tests/testthat/test-utilities.R
In dbosak01/rptr: Creates Statistical Reports
context("Utilities Tests")
test_that("utils1: gen_groups() works as expected.", {
expect_equal(gen_groups(10, 3),
c(1, 1, 1, 2, 2, 2, 3, 3, 3, 4))
expect_equal(gen_groups(12, c(3, 2, 5, 2)),
c(1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 4, 4))
expect_equal(gen_groups(10, 3, last_indices = TRUE),
c(3, 6, 9, 10))
expect_equal(gen_groups(12, c(3, 2, 5, 2), last_indices = TRUE),
c(3, 5, 10, 12))
})
test_that("utils2: get_font_family() works as expected.", {
expect_equal(get_font_family("Arial"), "sans")
expect_error(get_font_family("Calibri"))
expect_equal(get_font_family("Courier"), "mono")
expect_equal(get_font_family("Times"), "serif")
expect_error(get_font_family("Wingdings"))
})
test_that("utils3: get_page_size() works as expected.", {
ret <- get_page_size("letter", "inches")
expect_equal(ret[1], 8.5)
expect_equal(ret[2], 11)
ret <- get_page_size("A4", "cm")
expect_equal(ret[1], 21)
expect_equal(ret[2], 29.7)
})
test_that("utils4: add_blank_rows() works as expected.", {
tdat <- iris[order(iris$Species, decreasing = TRUE), ]
tdat$cat <- c(rep("A", 25), rep("B", 25))
res <- add_blank_rows(tdat, location = "both", vars = c("cat", "Species"))
expect_equal(nrow(res), nrow(iris) + 12)
expect_equal("..blank" %in% names(res), TRUE)
res2 <- add_blank_rows(tdat, location = "below", vars = c("Species"))
expect_equal(nrow(res2), nrow(iris) + 3)
res3 <- add_blank_rows(iris, location = "above")
expect_equal(nrow(res3), nrow(iris) + 1)
})
test_that("utils5: split_cells works as expected.", {
a1 <- c("one", "two", "three")
b1 <- c("here is a\n long value", "Some sort of value",
"Another value that goes on and on")
c1 <- c("here is a longer value", "Really", "Medium value")
..blank <- ""
..page <- NA
..row <- NA
df <- data.frame(a1, b1, c1, ..blank, ..page, ..row, stringsAsFactors = FALSE)
df
w <- c(a1 = .5, b1 = 1.5, c1 = 1.25)
conversion_factor <- .083333
wc <- floor(w / conversion_factor)
res1 <- split_cells(df, wc)
res1
expect_equal(nrow(res1), 5)
})
test_that("utils6: align_cells works as expected.", {
x <- list(a1 = c("a", "b", "c"),
b1 = c("a"),
c1 = c("a", "b", "c", "d", "e"))
g <- align_cells(x, 5)
expect_equal(nrow(g), 5)
})
test_that("utils7: clear_missing works as expected.", {
df <- data.frame(a = c(1, 2, 3), b = c("A", "B", "C"),
stringsAsFactors = FALSE)
df2 <- clear_missing(df)
expect_equal(class(df2$a), "character")
expect_equal(sum(is.na(df2$a)), 0)
})
test_that("utils8: push_down works as expected.", {
x <- data.frame(a1 = c("a", "b", "c", "", ""),
b1 = c("a", rep("", 4)),
c1 = c("a", "b", "c", "d", "e"), stringsAsFactors = FALSE)
res2 <- push_down(x)
expect_equal(res2$a1, c("", "", "a", "b", "c"))
expect_equal(res2$b1, c("", "", "", "", "a"))
expect_equal(res2$c1, c("a", "b", "c", "d", "e"))
})
test_that("utils9: create_stub works as expected.", {
x <- data.frame(a1 = c("a", "a", "a", "a", "a", "a"),
b1 = c(NA, "b", "b", NA, "b", "b"),
c1 = c(NA, NA, "c", NA, NA, "c"),
d1 = c("Here", "is", "some", "stuff", "shouldn't", "touch"),
stringsAsFactors = FALSE)
x
tbl <- create_table(x) %>% stub(c("a1", "b1", "c1"))
d <- create_stub(x, tbl)
expect_equal(d$stub, c("a", "b", "c", "a", "b", "c"))
})
test_that("utils10: quote_names function works as expected.", {
expect_equal(quote_names(c("fork")), c("fork"))
expect_equal(quote_names(c(fork)), c("fork"))
expect_equal(quote_names("fork"), c("fork"))
expect_equal(quote_names("fork"), c("fork"))
expect_equal(quote_names(c("fork", "bork")), c("fork", "bork"))
expect_equal(quote_names(c(fork, bork)), c("fork", "bork"))
})
test_that("utils11: set_column_defaults function works as expected.", {
tbl <- create_table(mtcars)
tbl <- column_defaults(tbl, c(mpg, cyl, disp), width = 2, format = "%.1f")
tbl <- define(tbl, mpg, width = 3, format = "%.2f")
res <- set_column_defaults(tbl, names(mtcars))
expect_equal(length(res), 3)
expect_equal(res[["mpg"]]$width, 3)
expect_equal(res[["mpg"]]$format, "%.2f")
expect_equal(res[["cyl"]]$width, 2)
expect_equal(res[["cyl"]]$format, "%.1f")
expect_equal(res[["disp"]]$width, 2)
expect_equal(res[["disp"]]$format, "%.1f")
})
test_that("utils12: set_column_defaults function with range works as expected.", {
tbl <- create_table(mtcars)
tbl <- column_defaults(tbl, from = mpg, to = drat, width = 2, format = "%.1f")
tbl <- define(tbl, mpg, width = 3, format = "%.2f")
res <- set_column_defaults(tbl, names(mtcars))
expect_equal(length(res), 5)
expect_equal(res[["mpg"]]$width, 3)
expect_equal(res[["mpg"]]$format, "%.2f")
expect_equal(res[["cyl"]]$width, 2)
expect_equal(res[["cyl"]]$format, "%.1f")
expect_equal(is.null(res[["vs"]]$width), TRUE)
expect_equal(is.null(res[["vs"]]$format), TRUE)
})
test_that("utils13: set_column_defaults function all cols works as expected.", {
tbl <- create_table(mtcars)
tbl <- column_defaults(tbl, width = 2, format = "%.1f")
tbl <- define(tbl, mpg, width = 3, format = "%.2f")
res <- set_column_defaults(tbl, names(mtcars))
expect_equal(length(res), 11)
expect_equal(res[["mpg"]]$width, 3)
expect_equal(res[["mpg"]]$format, "%.2f")
expect_equal(res[["cyl"]]$width, 2)
expect_equal(res[["cyl"]]$format, "%.1f")
expect_equal(res[["vs"]]$width, 2)
expect_equal(res[["vs"]]$format, "%.1f")
})
# Commented out this test because the dm_final.rds file creates a dependency
# on higher level of R > 3.5.
test_that("utils14: data with extra names on variables doesn't crash labels function.", {
# fp <- file.path(base_path, "user/user8.out")
#
# dat <- readRDS(file.path(base_path, "./data/dm_final.rds"))
#
# #names(dat)
#
# #dat1 <- mtcars
#
# #names(dat1$cyl) <- c("fork", "bork", "spork")
#
# names(dat$statistic)
# tbl <- create_table(dat)
#
# labels <- get_labels(dat, tbl)
#
# names(labels)
# length(labels)
#
# ncol(dat)
#
# names(dat)
#
# labels[names(dat)]
expect_equal(TRUE, TRUE)
})
test_that("utils15: split_cells_variable works as expected.", {
# split_cells_variable <- function(x, col_widths, font, font_size, units)
df <- data.frame(car = c("Dart", "Bart", "Here is another car name"),
cyl = c(8, 3, 4),
disp = c("My lovely disp and it gets longer",
"Here is a big long string value to exceed 2 inches",
"Short"), stringsAsFactors = FALSE)
tbl <- create_table(df) %>%
define(car, label = "Cars", width = 1) %>%
define(cyl, width = 1.5) %>%
define(disp, width = 2)
lbls <- get_labels(df, tbl)
cw <- get_col_widths_variable(df, tbl, lbls, "Arial", 12, "inches", .2)
cw
res <- split_cells_variable(df, cw, "Arial", 12, "inches", "RTF")
res$widths
expect_equal(any(class(res$data) == "data.frame"), TRUE)
expect_equal(res$data[1, "..row"], 2)
expect_equal(res$data[3, "..row"], 3)
})
test_that("utils16: get_width function works as expected.", {
res1 <- get_text_width("This is cool.", "Arial", 12)
res1
res2 <- get_text_width("This is cool.", "Arial", 10)
res2
expect_equal(res1 > res2, TRUE)
res3 <- get_text_width("This is cool.", "Courier", 10)
res3
expect_equal(res2 < res3, TRUE)
res4 <- get_text_width("This is cool.", "Courier", 10, units = "cm")
res4
expect_equal(res3 == cin(res4), TRUE)
# get_text_width("This is cool and this is cooler and more an more.",
# "Courier", 10, multiplier = .5)
})
test_that("utils17: has_bottom_footnotes works as expected.", {
rpt <- create_report("")
expect_equal(has_bottom_footnotes(rpt), FALSE)
rpt2 <- rpt %>%
footnotes("Hello")
expect_equal(has_bottom_footnotes(rpt2), TRUE)
rpt3 <- rpt %>%
footnotes("Hello", valign = "top")
expect_equal(has_bottom_footnotes(rpt3), FALSE)
})
test_that("utils18: has_top_footnotes works as expected.", {
rpt <- create_report("")
expect_equal(has_top_footnotes(rpt), FALSE)
rpt2 <- rpt %>%
footnotes("Hello")
expect_equal(has_top_footnotes(rpt2), FALSE)
rpt3 <- rpt %>%
footnotes("Hello", valign = "top")
expect_equal(has_top_footnotes(rpt3), TRUE)
})
test_that("utils19: get_spanning_info works as expected.", {
fp <- ""
dat <- mtcars[1:15, ]
tbl <- create_table(dat, borders = "none") %>%
spanning_header(mpg, disp, "Span 1") %>%
spanning_header(hp, wt, "Span 2") %>%
spanning_header(qsec, vs, "Span 3") %>%
spanning_header(drat, gear, "Super span", level = 2)
rpt <- create_report(fp, output_type = "RTF", font = "fixed",
font_size = 10, orientation = "landscape") %>%
set_margins(top = 1, bottom = 1) %>%
page_header("Left", c("Right1", "Right2", "Right3"), blank_row = "below") %>%
titles("Table 1.0", "My Nice Table") %>%
add_content(tbl) %>%
footnotes("My footnote 1", "My footnote 2") %>%
page_footer("Left1", "Center1", "Right1")
rpt <- page_setup(rpt)
cols <- rep(.6, ncol(dat))
names(cols) <- names(dat)
pi <- list(keys = names(dat), col_width = cols)
w <- round(pi$col_width / rpt$char_width) - 1
res <- get_spanning_info(rpt, tbl, pi, w)
res
expect_equal(length(res), 2)
expect_equal(nrow(res[[1]]), 6)
})
test_that("utils20: get_lines_rtf works as expected.", {
expect_equal(get_lines_rtf("Here There", 3, "Arial", 10), 1)
expect_equal(get_lines_rtf("Here\nThere", 3, "Arial", 10), 2)
expect_equal(get_lines_rtf("Here\nThere now here is something else\nanother split",
2, "Arial", 12), 4)
cnt <- paste0("Lorem ipsum dolor sit amet, consectetur adipiscing elit, ",
"sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. ",
"Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris ",
"nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in ",
"reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla ",
"pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa ",
"qui officia deserunt mollit anim id est laborum.")
expect_equal(get_lines_rtf(cnt, 9, "Arial", 10), 3)
})
test_that("utils21: split_string_rtf() works as expected.", {
cnt <- paste0("Lorem ipsum dolor sit amet, consectetur adipiscing elit, ",
"sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. ",
"Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris ",
"nisi ut aliquip ex ea commodo consequat.\n Duis aute irure dolor in ",
"reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla ",
"pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa ",
"qui officia deserunt mollit anim id est laborum.")
pdf(NULL)
par(family = "sans", ps = 10)
res <- split_string_rtf(cnt, 4, "inches")
res
expect_equal(length(res$rtf), 1)
expect_equal(res$line, 8)
res2 <- split_string_rtf(NA, 4, "inches")
res2
expect_equal(length(res2$rtf), 1)
expect_equal(res2$lines, 1)
res3 <- split_string_rtf("hereisareallylongstringlongerthanoneinch",
1, "inches")
res3
expect_equal(length(res3$rtf), 1)
expect_equal(res3$lines, 1)
res4 <- split_string_rtf("here is areallylongstringlongerthan one inch",
1, "inches")
res4
expect_equal(length(res4$rtf), 1)
expect_equal(res4$lines, 3)
res5 <- split_string_rtf("here is areally long string longer than 3 cm",
3, "cm")
res5
expect_equal(length(res4$rtf), 1)
expect_equal(res4$lines, 3)
res6 <- split_string_rtf("here \nis a\nreally \nlong string\n longer than 3 cm",
3, "cm")
res6
expect_equal(length(res6$rtf), 1)
expect_equal(res6$lines, 5)
dev.off()
})
test_that("utils22: split_cells_variable() works as expected.", {
dat <- data.frame(col1 = c("hello", "there", "here is a big long\nline to wrap and wrap"),
col2 = c(1, 2, 3),
col3 = c("my big string I want to wrap", "fork", "bork"),
..row = c(NA, NA, NA), stringsAsFactors = FALSE)
res <- split_cells_variable(dat, c(col1 = 1, col2 = 1, col3 = 1),
"Arial", 12, "inches", "RTF")
res
expect_equal(nrow(res$data), 3)
expect_equal(ncol(res$data), 4)
expect_equal(res$data$..row, c(3, 1, 4))
expect_equal(length(res), 2)
expect_equal(length(res$widths), 3)
expect_equal(length(res$widths[[3]]$col1), 4)
expect_equal(all(res$widths[[3]]$col1 < 1), TRUE)
})
test_that("utils23: get_image_html works as expected.", {
tmp <- tempfile(fileext = ".jpg")
tmp2 <- tempfile(fileext = ".html")
plt <- list(height = 4, width = 8)
res <- get_image_html(tmp, tmp2, plt, "inches")
res
expect_equal(length(res), 1)
expect_equal(substr(res, 1, 4), "<img")
})
test_that("utils24: get_outer_borders works as expected.", {
expect_equal(is.null(get_outer_borders("none")), TRUE)
expect_equal(get_outer_borders("all"), c("top", "bottom", "left", "right"))
expect_equal(get_outer_borders(c("top", "bottom")), c("top", "bottom"))
expect_equal(get_outer_borders(c("outside", "inside")),
c("top", "bottom", "left", "right"))
})
test_that("utils25: split_strings() works as expected.", {
pdf(NULL)
par(family = "sans", ps = 10)
res <- split_strings("Here is a big long string that will not fit in one inch",
1, "inches")
dev.off()
res
expect_equal(length(res$text), 4)
expect_equal(length(res$widths), 4)
})
test_that("utils26: split_string_text() works as expected.", {
pdf(NULL)
par(family = "sans", ps = 10)
res <- split_string_text("Here is a big long string that will not fit in one inch",
1, "inches")
dev.off()
res
expect_equal(length(res$text), 4)
expect_equal(res$lines, 4)
expect_equal(length(res$widths), 4)
})
test_that("utils27: get_points_* functions work as expected.", {
w <- c(1, .8, .5)
res1 <- get_points_left(1, 4, w, "inches")
res1
expect_equal(res1, c(75, 75, 75))
res2 <- get_points_right(1, 2, w, "inches")
res2
expect_equal(res2, c(72, 86.4, 108))
res3 <- get_points_center(1, 2, w, "inches")
res3
expect_equal(res3, c(73, 80.2, 91))
})
test_that("utils28: apply_widths works as expected.", {
df1 <- data.frame(col1 = c("here is a something", "fork", "bork"),
col2 = c("", 3, 43),
col3 = c("", "B", "C"), stringsAsFactors = FALSE,
"..blank" = c("L", "", ""))
wdth <- c(col1 = 4, col2 = 3, col3 = 5)
jst <- c(col1 = "left", col2 = "right", col3 = "center")
res1 <- apply_widths(df1, wdth, jst)
res1$col1
res1$col2
res1$col3
expect_equal(res1$col1[2], "fork")
expect_equal(nchar(res1$col2[1]), 0)
expect_equal(nchar(res1$col3[1]), 0)
})
test_that("utils29: invisible functions work as expected.", {
lst <- c("A", "B", "..blank", "..x.C")
expect_equal(has_invisible(lst), TRUE)
expect_equal(is.invisible("..x.C"), TRUE)
expect_equal(is.invisible("..blank"), FALSE)
expect_equal(is.invisiblev(lst), c(A = FALSE, B = FALSE,
..blank = FALSE, ..x.C = TRUE))
expect_equal(translate_invisible("C", lst), "..x.C")
expect_equal(translate_invisible("D", lst), "D")
})
test_that("utils30: gluev() works as expected.", {
library(common)
v1 <- c("here{supsc('1')}", "there{subsc('a')}")
res <- gluev(v1)
res
expect_equal(res, c("here\U00B9", "there\U2090"))
res2 <- gluev(NULL)
expect_equal(is.null(res2), TRUE)
})
test_that("utils30: has_glue() works as expected.", {
res1 <- has_glue()
expect_equal(res1, TRUE)
options("reporter.glue" = FALSE)
res2 <- has_glue()
expect_equal(res2, FALSE)
options("reporter.glue" = NULL)
res3 <- has_glue()
expect_equal(res3, TRUE)
})
test_that("utils31: strwdth() works as expected.", {
strngs <- c("hello", "goodbye", paste0("here is something", supsc('6')))
# pdf(NULL)
# par(family = 'mono', ps = 10)
#
# res <- strwidth(strngs, un = "inches")
#
# dev.off()
res <- c(0.4166667, 0.5833333, 1.5000000)
pdf(NULL)
par(family = 'mono', ps = 10)
res1 <- strwdth(strngs, un = "inches")
dev.off()
res1
expect_equal(res[1] == round(res1[1], 7), TRUE)
expect_equal(res[2] == round(res1[2], 7), TRUE)
# pdf(NULL)
# par(family = 'sans', ps = 10)
#
# res3 <- strwidth(strngs, un = "inches")
#
# dev.off()
res3 <- c(0.2933333, 0.5272222, 1.1733333)
pdf(NULL)
par(family = 'sans', ps = 10)
res4 <- strwdth(strngs, un = "inches")
dev.off()
res4
# print(res1)
# print(res2)
expect_equal(all(res != res4), TRUE)
expect_equal(res3[1] == round(res4[1], 7), TRUE)
expect_equal(res3[2] == round(res4[2], 7), TRUE)
})
dbosak01/rptr documentation built on March 21, 2024, 12:54 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
context("Utilities Tests")
test_that("utils1: gen_groups() works as expected.", {
expect_equal(gen_groups(10, 3),
c(1, 1, 1, 2, 2, 2, 3, 3, 3, 4))
expect_equal(gen_groups(12, c(3, 2, 5, 2)),
c(1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 4, 4))
expect_equal(gen_groups(10, 3, last_indices = TRUE),
c(3, 6, 9, 10))
expect_equal(gen_groups(12, c(3, 2, 5, 2), last_indices = TRUE),
c(3, 5, 10, 12))
})
test_that("utils2: get_font_family() works as expected.", {
expect_equal(get_font_family("Arial"), "sans")
expect_error(get_font_family("Calibri"))
expect_equal(get_font_family("Courier"), "mono")
expect_equal(get_font_family("Times"), "serif")
expect_error(get_font_family("Wingdings"))
})
test_that("utils3: get_page_size() works as expected.", {
ret <- get_page_size("letter", "inches")
expect_equal(ret[1], 8.5)
expect_equal(ret[2], 11)
ret <- get_page_size("A4", "cm")
expect_equal(ret[1], 21)
expect_equal(ret[2], 29.7)
})
test_that("utils4: add_blank_rows() works as expected.", {
tdat <- iris[order(iris$Species, decreasing = TRUE), ]
tdat$cat <- c(rep("A", 25), rep("B", 25))
res <- add_blank_rows(tdat, location = "both", vars = c("cat", "Species"))
expect_equal(nrow(res), nrow(iris) + 12)
expect_equal("..blank" %in% names(res), TRUE)
res2 <- add_blank_rows(tdat, location = "below", vars = c("Species"))
expect_equal(nrow(res2), nrow(iris) + 3)
res3 <- add_blank_rows(iris, location = "above")
expect_equal(nrow(res3), nrow(iris) + 1)
})
test_that("utils5: split_cells works as expected.", {
a1 <- c("one", "two", "three")
b1 <- c("here is a\n long value", "Some sort of value",
"Another value that goes on and on")
c1 <- c("here is a longer value", "Really", "Medium value")
..blank <- ""
..page <- NA
..row <- NA
df <- data.frame(a1, b1, c1, ..blank, ..page, ..row, stringsAsFactors = FALSE)
df
w <- c(a1 = .5, b1 = 1.5, c1 = 1.25)
conversion_factor <- .083333
wc <- floor(w / conversion_factor)
res1 <- split_cells(df, wc)
res1
expect_equal(nrow(res1), 5)
})
test_that("utils6: align_cells works as expected.", {
x <- list(a1 = c("a", "b", "c"),
b1 = c("a"),
c1 = c("a", "b", "c", "d", "e"))
g <- align_cells(x, 5)
expect_equal(nrow(g), 5)
})
test_that("utils7: clear_missing works as expected.", {
df <- data.frame(a = c(1, 2, 3), b = c("A", "B", "C"),
stringsAsFactors = FALSE)
df2 <- clear_missing(df)
expect_equal(class(df2$a), "character")
expect_equal(sum(is.na(df2$a)), 0)
})
test_that("utils8: push_down works as expected.", {
x <- data.frame(a1 = c("a", "b", "c", "", ""),
b1 = c("a", rep("", 4)),
c1 = c("a", "b", "c", "d", "e"), stringsAsFactors = FALSE)
res2 <- push_down(x)
expect_equal(res2$a1, c("", "", "a", "b", "c"))
expect_equal(res2$b1, c("", "", "", "", "a"))
expect_equal(res2$c1, c("a", "b", "c", "d", "e"))
})
test_that("utils9: create_stub works as expected.", {
x <- data.frame(a1 = c("a", "a", "a", "a", "a", "a"),
b1 = c(NA, "b", "b", NA, "b", "b"),
c1 = c(NA, NA, "c", NA, NA, "c"),
d1 = c("Here", "is", "some", "stuff", "shouldn't", "touch"),
stringsAsFactors = FALSE)
x
tbl <- create_table(x) %>% stub(c("a1", "b1", "c1"))
d <- create_stub(x, tbl)
expect_equal(d$stub, c("a", "b", "c", "a", "b", "c"))
})
test_that("utils10: quote_names function works as expected.", {
expect_equal(quote_names(c("fork")), c("fork"))
expect_equal(quote_names(c(fork)), c("fork"))
expect_equal(quote_names("fork"), c("fork"))
expect_equal(quote_names("fork"), c("fork"))
expect_equal(quote_names(c("fork", "bork")), c("fork", "bork"))
expect_equal(quote_names(c(fork, bork)), c("fork", "bork"))
})
test_that("utils11: set_column_defaults function works as expected.", {
tbl <- create_table(mtcars)
tbl <- column_defaults(tbl, c(mpg, cyl, disp), width = 2, format = "%.1f")
tbl <- define(tbl, mpg, width = 3, format = "%.2f")
res <- set_column_defaults(tbl, names(mtcars))
expect_equal(length(res), 3)
expect_equal(res[["mpg"]]$width, 3)
expect_equal(res[["mpg"]]$format, "%.2f")
expect_equal(res[["cyl"]]$width, 2)
expect_equal(res[["cyl"]]$format, "%.1f")
expect_equal(res[["disp"]]$width, 2)
expect_equal(res[["disp"]]$format, "%.1f")
})
test_that("utils12: set_column_defaults function with range works as expected.", {
tbl <- create_table(mtcars)
tbl <- column_defaults(tbl, from = mpg, to = drat, width = 2, format = "%.1f")
tbl <- define(tbl, mpg, width = 3, format = "%.2f")
res <- set_column_defaults(tbl, names(mtcars))
expect_equal(length(res), 5)
expect_equal(res[["mpg"]]$width, 3)
expect_equal(res[["mpg"]]$format, "%.2f")
expect_equal(res[["cyl"]]$width, 2)
expect_equal(res[["cyl"]]$format, "%.1f")
expect_equal(is.null(res[["vs"]]$width), TRUE)
expect_equal(is.null(res[["vs"]]$format), TRUE)
})
test_that("utils13: set_column_defaults function all cols works as expected.", {
tbl <- create_table(mtcars)
tbl <- column_defaults(tbl, width = 2, format = "%.1f")
tbl <- define(tbl, mpg, width = 3, format = "%.2f")
res <- set_column_defaults(tbl, names(mtcars))
expect_equal(length(res), 11)
expect_equal(res[["mpg"]]$width, 3)
expect_equal(res[["mpg"]]$format, "%.2f")
expect_equal(res[["cyl"]]$width, 2)
expect_equal(res[["cyl"]]$format, "%.1f")
expect_equal(res[["vs"]]$width, 2)
expect_equal(res[["vs"]]$format, "%.1f")
})
# Commented out this test because the dm_final.rds file creates a dependency
# on higher level of R > 3.5.
test_that("utils14: data with extra names on variables doesn't crash labels function.", {
# fp <- file.path(base_path, "user/user8.out")
#
# dat <- readRDS(file.path(base_path, "./data/dm_final.rds"))
#
# #names(dat)
#
# #dat1 <- mtcars
#
# #names(dat1$cyl) <- c("fork", "bork", "spork")
#
# names(dat$statistic)
# tbl <- create_table(dat)
#
# labels <- get_labels(dat, tbl)
#
# names(labels)
# length(labels)
#
# ncol(dat)
#
# names(dat)
#
# labels[names(dat)]
expect_equal(TRUE, TRUE)
})
test_that("utils15: split_cells_variable works as expected.", {
# split_cells_variable <- function(x, col_widths, font, font_size, units)
df <- data.frame(car = c("Dart", "Bart", "Here is another car name"),
cyl = c(8, 3, 4),
disp = c("My lovely disp and it gets longer",
"Here is a big long string value to exceed 2 inches",
"Short"), stringsAsFactors = FALSE)
tbl <- create_table(df) %>%
define(car, label = "Cars", width = 1) %>%
define(cyl, width = 1.5) %>%
define(disp, width = 2)
lbls <- get_labels(df, tbl)
cw <- get_col_widths_variable(df, tbl, lbls, "Arial", 12, "inches", .2)
cw
res <- split_cells_variable(df, cw, "Arial", 12, "inches", "RTF")
res$widths
expect_equal(any(class(res$data) == "data.frame"), TRUE)
expect_equal(res$data[1, "..row"], 2)
expect_equal(res$data[3, "..row"], 3)
})
test_that("utils16: get_width function works as expected.", {
res1 <- get_text_width("This is cool.", "Arial", 12)
res1
res2 <- get_text_width("This is cool.", "Arial", 10)
res2
expect_equal(res1 > res2, TRUE)
res3 <- get_text_width("This is cool.", "Courier", 10)
res3
expect_equal(res2 < res3, TRUE)
res4 <- get_text_width("This is cool.", "Courier", 10, units = "cm")
res4
expect_equal(res3 == cin(res4), TRUE)
# get_text_width("This is cool and this is cooler and more an more.",
# "Courier", 10, multiplier = .5)
})
test_that("utils17: has_bottom_footnotes works as expected.", {
rpt <- create_report("")
expect_equal(has_bottom_footnotes(rpt), FALSE)
rpt2 <- rpt %>%
footnotes("Hello")
expect_equal(has_bottom_footnotes(rpt2), TRUE)
rpt3 <- rpt %>%
footnotes("Hello", valign = "top")
expect_equal(has_bottom_footnotes(rpt3), FALSE)
})
test_that("utils18: has_top_footnotes works as expected.", {
rpt <- create_report("")
expect_equal(has_top_footnotes(rpt), FALSE)
rpt2 <- rpt %>%
footnotes("Hello")
expect_equal(has_top_footnotes(rpt2), FALSE)
rpt3 <- rpt %>%
footnotes("Hello", valign = "top")
expect_equal(has_top_footnotes(rpt3), TRUE)
})
test_that("utils19: get_spanning_info works as expected.", {
fp <- ""
dat <- mtcars[1:15, ]
tbl <- create_table(dat, borders = "none") %>%
spanning_header(mpg, disp, "Span 1") %>%
spanning_header(hp, wt, "Span 2") %>%
spanning_header(qsec, vs, "Span 3") %>%
spanning_header(drat, gear, "Super span", level = 2)
rpt <- create_report(fp, output_type = "RTF", font = "fixed",
font_size = 10, orientation = "landscape") %>%
set_margins(top = 1, bottom = 1) %>%
page_header("Left", c("Right1", "Right2", "Right3"), blank_row = "below") %>%
titles("Table 1.0", "My Nice Table") %>%
add_content(tbl) %>%
footnotes("My footnote 1", "My footnote 2") %>%
page_footer("Left1", "Center1", "Right1")
rpt <- page_setup(rpt)
cols <- rep(.6, ncol(dat))
names(cols) <- names(dat)
pi <- list(keys = names(dat), col_width = cols)
w <- round(pi$col_width / rpt$char_width) - 1
res <- get_spanning_info(rpt, tbl, pi, w)
res
expect_equal(length(res), 2)
expect_equal(nrow(res[[1]]), 6)
})
test_that("utils20: get_lines_rtf works as expected.", {
expect_equal(get_lines_rtf("Here There", 3, "Arial", 10), 1)
expect_equal(get_lines_rtf("Here\nThere", 3, "Arial", 10), 2)
expect_equal(get_lines_rtf("Here\nThere now here is something else\nanother split",
2, "Arial", 12), 4)
cnt <- paste0("Lorem ipsum dolor sit amet, consectetur adipiscing elit, ",
"sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. ",
"Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris ",
"nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in ",
"reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla ",
"pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa ",
"qui officia deserunt mollit anim id est laborum.")
expect_equal(get_lines_rtf(cnt, 9, "Arial", 10), 3)
})
test_that("utils21: split_string_rtf() works as expected.", {
cnt <- paste0("Lorem ipsum dolor sit amet, consectetur adipiscing elit, ",
"sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. ",
"Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris ",
"nisi ut aliquip ex ea commodo consequat.\n Duis aute irure dolor in ",
"reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla ",
"pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa ",
"qui officia deserunt mollit anim id est laborum.")
pdf(NULL)
par(family = "sans", ps = 10)
res <- split_string_rtf(cnt, 4, "inches")
res
expect_equal(length(res$rtf), 1)
expect_equal(res$line, 8)
res2 <- split_string_rtf(NA, 4, "inches")
res2
expect_equal(length(res2$rtf), 1)
expect_equal(res2$lines, 1)
res3 <- split_string_rtf("hereisareallylongstringlongerthanoneinch",
1, "inches")
res3
expect_equal(length(res3$rtf), 1)
expect_equal(res3$lines, 1)
res4 <- split_string_rtf("here is areallylongstringlongerthan one inch",
1, "inches")
res4
expect_equal(length(res4$rtf), 1)
expect_equal(res4$lines, 3)
res5 <- split_string_rtf("here is areally long string longer than 3 cm",
3, "cm")
res5
expect_equal(length(res4$rtf), 1)
expect_equal(res4$lines, 3)
res6 <- split_string_rtf("here \nis a\nreally \nlong string\n longer than 3 cm",
3, "cm")
res6
expect_equal(length(res6$rtf), 1)
expect_equal(res6$lines, 5)
dev.off()
})
test_that("utils22: split_cells_variable() works as expected.", {
dat <- data.frame(col1 = c("hello", "there", "here is a big long\nline to wrap and wrap"),
col2 = c(1, 2, 3),
col3 = c("my big string I want to wrap", "fork", "bork"),
..row = c(NA, NA, NA), stringsAsFactors = FALSE)
res <- split_cells_variable(dat, c(col1 = 1, col2 = 1, col3 = 1),
"Arial", 12, "inches", "RTF")
res
expect_equal(nrow(res$data), 3)
expect_equal(ncol(res$data), 4)
expect_equal(res$data$..row, c(3, 1, 4))
expect_equal(length(res), 2)
expect_equal(length(res$widths), 3)
expect_equal(length(res$widths[[3]]$col1), 4)
expect_equal(all(res$widths[[3]]$col1 < 1), TRUE)
})
test_that("utils23: get_image_html works as expected.", {
tmp <- tempfile(fileext = ".jpg")
tmp2 <- tempfile(fileext = ".html")
plt <- list(height = 4, width = 8)
res <- get_image_html(tmp, tmp2, plt, "inches")
res
expect_equal(length(res), 1)
expect_equal(substr(res, 1, 4), "<img")
})
test_that("utils24: get_outer_borders works as expected.", {
expect_equal(is.null(get_outer_borders("none")), TRUE)
expect_equal(get_outer_borders("all"), c("top", "bottom", "left", "right"))
expect_equal(get_outer_borders(c("top", "bottom")), c("top", "bottom"))
expect_equal(get_outer_borders(c("outside", "inside")),
c("top", "bottom", "left", "right"))
})
test_that("utils25: split_strings() works as expected.", {
pdf(NULL)
par(family = "sans", ps = 10)
res <- split_strings("Here is a big long string that will not fit in one inch",
1, "inches")
dev.off()
res
expect_equal(length(res$text), 4)
expect_equal(length(res$widths), 4)
})
test_that("utils26: split_string_text() works as expected.", {
pdf(NULL)
par(family = "sans", ps = 10)
res <- split_string_text("Here is a big long string that will not fit in one inch",
1, "inches")
dev.off()
res
expect_equal(length(res$text), 4)
expect_equal(res$lines, 4)
expect_equal(length(res$widths), 4)
})
test_that("utils27: get_points_* functions work as expected.", {
w <- c(1, .8, .5)
res1 <- get_points_left(1, 4, w, "inches")
res1
expect_equal(res1, c(75, 75, 75))
res2 <- get_points_right(1, 2, w, "inches")
res2
expect_equal(res2, c(72, 86.4, 108))
res3 <- get_points_center(1, 2, w, "inches")
res3
expect_equal(res3, c(73, 80.2, 91))
})
test_that("utils28: apply_widths works as expected.", {
df1 <- data.frame(col1 = c("here is a something", "fork", "bork"),
col2 = c("", 3, 43),
col3 = c("", "B", "C"), stringsAsFactors = FALSE,
"..blank" = c("L", "", ""))
wdth <- c(col1 = 4, col2 = 3, col3 = 5)
jst <- c(col1 = "left", col2 = "right", col3 = "center")
res1 <- apply_widths(df1, wdth, jst)
res1$col1
res1$col2
res1$col3
expect_equal(res1$col1[2], "fork")
expect_equal(nchar(res1$col2[1]), 0)
expect_equal(nchar(res1$col3[1]), 0)
})
test_that("utils29: invisible functions work as expected.", {
lst <- c("A", "B", "..blank", "..x.C")
expect_equal(has_invisible(lst), TRUE)
expect_equal(is.invisible("..x.C"), TRUE)
expect_equal(is.invisible("..blank"), FALSE)
expect_equal(is.invisiblev(lst), c(A = FALSE, B = FALSE,
..blank = FALSE, ..x.C = TRUE))
expect_equal(translate_invisible("C", lst), "..x.C")
expect_equal(translate_invisible("D", lst), "D")
})
test_that("utils30: gluev() works as expected.", {
library(common)
v1 <- c("here{supsc('1')}", "there{subsc('a')}")
res <- gluev(v1)
res
expect_equal(res, c("here\U00B9", "there\U2090"))
res2 <- gluev(NULL)
expect_equal(is.null(res2), TRUE)
})
test_that("utils30: has_glue() works as expected.", {
res1 <- has_glue()
expect_equal(res1, TRUE)
options("reporter.glue" = FALSE)
res2 <- has_glue()
expect_equal(res2, FALSE)
options("reporter.glue" = NULL)
res3 <- has_glue()
expect_equal(res3, TRUE)
})
test_that("utils31: strwdth() works as expected.", {
strngs <- c("hello", "goodbye", paste0("here is something", supsc('6')))
# pdf(NULL)
# par(family = 'mono', ps = 10)
#
# res <- strwidth(strngs, un = "inches")
#
# dev.off()
res <- c(0.4166667, 0.5833333, 1.5000000)
pdf(NULL)
par(family = 'mono', ps = 10)
res1 <- strwdth(strngs, un = "inches")
dev.off()
res1
expect_equal(res[1] == round(res1[1], 7), TRUE)
expect_equal(res[2] == round(res1[2], 7), TRUE)
# pdf(NULL)
# par(family = 'sans', ps = 10)
#
# res3 <- strwidth(strngs, un = "inches")
#
# dev.off()
res3 <- c(0.2933333, 0.5272222, 1.1733333)
pdf(NULL)
par(family = 'sans', ps = 10)
res4 <- strwdth(strngs, un = "inches")
dev.off()
res4
# print(res1)
# print(res2)
expect_equal(all(res != res4), TRUE)
expect_equal(res3[1] == round(res4[1], 7), TRUE)
expect_equal(res3[2] == round(res4[2], 7), TRUE)
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.