gridtext/ 0000755 0001762 0000144 00000000000 15145524515 012113 5 ustar ligges users gridtext/tests/ 0000755 0001762 0000144 00000000000 15145415164 013254 5 ustar ligges users gridtext/tests/testthat/ 0000755 0001762 0000144 00000000000 15145524515 015115 5 ustar ligges users gridtext/tests/testthat/test-get_file.R 0000644 0001762 0000144 00000000655 15145415164 020000 0 ustar ligges users test_that("get_file works", {
# skip test on cran because the url could be broken in the future
skip_on_cran()
# get_file returns raw data if it's an url and a character path if it's
# a local path. That's why we test it with the function read_image that calls it
expect_identical(
read_image("https://upload.wikimedia.org/wikipedia/commons/6/62/Biedronka.drs.png"),
read_image("../figs/test_image.png")
)
})
gridtext/tests/testthat/test-text-details.R 0000644 0001762 0000144 00000003075 15145415164 020630 0 ustar ligges users test_that("text_details() calculates info correctly", {
# descent and space are independent of string
gp1 <- gpar(fontfamily = "Helvetica", fontface = "plain", fontsize = 10)
t1 <- text_details("abcd", gp = gp1)
t2 <- text_details("gjqp", gp = gp1)
expect_equal(t1$descent_pt, t2$descent_pt)
expect_equal(t1$space_pt, t2$space_pt)
# recalculating the same details gives same results (tests caching)
t2 <- text_details("abcd", gp = gp1)
expect_equal(t1$width_pt, t2$width_pt)
expect_equal(t1$ascent_pt, t2$ascent_pt)
expect_equal(t1$descent_pt, t2$descent_pt)
expect_equal(t1$space_pt, t2$space_pt)
# all parameters scale with font size
gp2 <- gpar(fontfamily = "Helvetica", fontface = "plain", fontsize = 20)
t2 <- text_details("abcd", gp = gp2)
expect_equal(2 * t1$width_pt, t2$width_pt)
expect_equal(2 * t1$ascent_pt, t2$ascent_pt)
expect_equal(2 * t1$descent_pt, t2$descent_pt)
expect_equal(2 * t1$space_pt, t2$space_pt)
# parameters change with font
gp2 <- gpar(fontfamily = "Times", fontface = "plain", fontsize = 10)
t2 <- text_details("abcd", gp = gp2)
expect_false(t1$width_pt == t2$width_pt)
expect_false(t1$ascent_pt == t2$ascent_pt)
expect_false(t1$descent_pt == t2$descent_pt)
expect_false(t1$space_pt == t2$space_pt)
# font details are identical to what we would get from an actual grob
g <- textGrob("Qbcd", gp = gp1)
t1 <- text_details("Qbcd", gp = gp1)
expect_equal(t1$ascent_pt, convertHeight(grobHeight(g), "pt", valueOnly = TRUE))
expect_equal(t1$width_pt, convertWidth(grobWidth(g), "pt", valueOnly = TRUE))
})
gridtext/tests/testthat/test-rect-box.R 0000644 0001762 0000144 00000015315 15145415164 017744 0 ustar ligges users test_that("alignment of content", {
nb <- bl_make_null_box()
cb <- bl_make_rect_box(nb, 20, 10, c(0, 0, 0, 0), c(0, 0, 0, 0), gp = gpar())
rb <- bl_make_rect_box(cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar())
bl_calc_layout(rb, 0, 0)
g <- bl_render(rb, 100, 200)
# placement of outer box depends on margins
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(400 - 2 - 8, "pt"))
expect_identical(outer$height, unit(600 - 1 - 4, "pt"))
# placement of inner box depends on margins, padding, justification, and inner size
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 600 - 1 - 16 - 10, "pt"))
rb <- bl_make_rect_box(cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
content_hjust = 1, content_vjust = 0)
bl_calc_layout(rb, 0, 0)
g <- bl_render(rb, 100, 200)
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 400 - 2 - 32 - 20, "pt"))
expect_identical(inner$y, unit(200 + 4 + 64, "pt"))
})
test_that("size policies", {
nb <- bl_make_null_box()
cb <- bl_make_rect_box(nb, 20, 10, c(0, 0, 0, 0), c(0, 0, 0, 0), gp = gpar())
rb <- bl_make_rect_box(
cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "expand", height_policy = "relative"
)
bl_calc_layout(rb, 100, 50)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(100 - 2 - 8, "pt"))
expect_identical(outer$height, unit(300 - 1 - 4, "pt"))
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 300 - 1 - 16 - 10, "pt"))
rb <- bl_make_rect_box(
cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "relative", height_policy = "expand"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(200 - 2 - 8, "pt"))
expect_identical(outer$height, unit(300 - 1 - 4, "pt"))
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 300 - 1 - 16 - 10, "pt"))
rb <- bl_make_rect_box(
cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "native", height_policy = "native"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
# native width/height now depends on padding, not on margin
expect_identical(outer$width, unit(20 + 32 + 128, "pt"))
expect_identical(outer$height, unit(10 + 16 + 64, "pt"))
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 4 + 64, "pt"))
rb <- bl_make_rect_box(
cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "native", height_policy = "relative"
)
bl_calc_layout(rb, 50, 50)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(20 + 32 + 128, "pt"))
expect_identical(outer$height, unit(300 - 1 - 4, "pt"))
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 300 - 1 - 16 - 10, "pt"))
rb <- bl_make_rect_box(
cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "native", height_policy = "expand"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(20 + 32 + 128, "pt"))
expect_identical(outer$height, unit(300 - 1 - 4, "pt"))
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 300 - 1 - 16 - 10, "pt"))
rb <- bl_make_rect_box(
cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "native", height_policy = "fixed"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(20 + 32 + 128, "pt"))
expect_identical(outer$height, unit(600 - 1 - 4, "pt"))
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 600 - 1 - 16 - 10, "pt"))
rb <- bl_make_rect_box(
cb, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "fixed", height_policy = "native"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(400 - 2 - 8, "pt"))
expect_identical(outer$height, unit(10 + 16 + 64, "pt"))
inner <- g[[2]]
expect_identical(inner$x, unit(100 + 8 + 128, "pt"))
expect_identical(inner$y, unit(200 + 4 + 64, "pt"))
# native size policies with no content
rb <- bl_make_rect_box(
NULL, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "native", height_policy = "native"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
# native width/height now depends only on padding, since content size is 0
expect_identical(outer$width, unit(32 + 128, "pt"))
expect_identical(outer$height, unit(16 + 64, "pt"))
rb <- bl_make_rect_box(
NULL, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "native", height_policy = "fixed"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(32 + 128, "pt"))
expect_identical(outer$height, unit(600 - 1 - 4, "pt"))
rb <- bl_make_rect_box(
NULL, 400, 600, c(1, 2, 4, 8), c(16, 32, 64, 128), gp = gpar(),
width_policy = "fixed", height_policy = "native"
)
bl_calc_layout(rb, 50, 300)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100 + 8, "pt"))
expect_identical(outer$y, unit(200 + 4, "pt"))
expect_identical(outer$width, unit(400 - 2 - 8, "pt"))
expect_identical(outer$height, unit(16 + 64, "pt"))
})
gridtext/tests/testthat/test-raster-box.R 0000644 0001762 0000144 00000012361 15145415164 020305 0 ustar ligges users test_that("image dimensions are used", {
logo_file <- system.file("extdata", "Rlogo.png", package = "gridtext")
logo <- png::readPNG(logo_file, native = FALSE)
# default size policy is native for both height and width
# dpi = 72.27 turns lengths in pixels to lengths in pt
rb <- bl_make_raster_box(logo, dpi = 72.27)
bl_calc_layout(rb, 100, 100)
bl_place(rb, 30, 5)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(40, "pt"))
expect_identical(img$y, unit(25, "pt"))
expect_equal(img$width, unit(ncol(logo), "pt"))
expect_equal(img$height, unit(nrow(logo), "pt"))
# test now with raster object
logo2 <- as.raster(logo)
rb <- bl_make_raster_box(logo2, dpi = 72.27)
bl_calc_layout(rb, 100, 100)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_equal(img$width, unit(ncol(logo), "pt"))
expect_equal(img$height, unit(nrow(logo), "pt"))
# test now with nativeRaster object
logo3 <- png::readPNG(logo_file, native = TRUE)
rb <- bl_make_raster_box(logo3, dpi = 72.27)
bl_calc_layout(rb, 100, 100)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_equal(img$width, unit(ncol(logo), "pt"))
expect_equal(img$height, unit(nrow(logo), "pt"))
# dimensions are reported correctly
expect_equal(bl_box_width(rb), ncol(logo))
expect_equal(bl_box_height(rb), nrow(logo))
expect_equal(bl_box_ascent(rb), nrow(logo))
expect_identical(bl_box_descent(rb), 0)
expect_identical(bl_box_voff(rb), 0)
m <- 1:10
dim(m) <- 10
expect_error(
bl_make_raster_box(m),
"Cannot extract image dimensions."
)
})
test_that("size policies, respect_aspect = FALSE", {
logo_file <- system.file("extdata", "Rlogo.png", package = "gridtext")
logo <- png::readPNG(logo_file, native = TRUE)
rb <- bl_make_raster_box(logo, width = 50, height = 80,
width_policy = "fixed", height_policy = "fixed",
respect_aspect = FALSE)
bl_calc_layout(rb, 200, 100)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_identical(img$width, unit(50, "pt"))
expect_identical(img$height, unit(80, "pt"))
rb <- bl_make_raster_box(logo, width = 50, height = 80,
width_policy = "relative", height_policy = "expand",
respect_aspect = FALSE)
bl_calc_layout(rb, 200, 100)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_identical(img$width, unit(100, "pt"))
expect_identical(img$height, unit(100, "pt"))
rb <- bl_make_raster_box(logo, width = 50, height = 80,
width_policy = "expand", height_policy = "relative",
respect_aspect = FALSE)
bl_calc_layout(rb, 200, 100)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_identical(img$width, unit(200, "pt"))
expect_identical(img$height, unit(80, "pt"))
rb <- bl_make_raster_box(logo, width = 50, height = 80,
width_policy = "fixed", height_policy = "native",
respect_aspect = FALSE)
bl_calc_layout(rb, 200, 100)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_identical(img$width, unit(50, "pt"))
expect_equal(img$height, unit(50*nrow(logo)/ncol(logo), "pt"))
rb <- bl_make_raster_box(logo, width = 50, height = 80,
width_policy = "native", height_policy = "fixed",
respect_aspect = FALSE)
bl_calc_layout(rb, 200, 100)
g <- bl_render(rb, 10, 20)
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_equal(img$width, unit(80*ncol(logo)/nrow(logo), "pt"))
expect_identical(img$height, unit(80, "pt"))
})
test_that("size policies, respect_aspect = TRUE", {
logo_file <- system.file("extdata", "Rlogo.png", package = "gridtext")
logo <- png::readPNG(logo_file, native = TRUE)
rb <- bl_make_raster_box(logo, width = 50, height = 80,
width_policy = "fixed", height_policy = "fixed")
bl_calc_layout(rb, 200, 100)
g <- bl_render(rb, 10, 20)
nr <- nrow(logo)
nc <- ncol(logo)
img_height <- 50*nr/nc
yoff <- (80 - img_height)/2
img <- g[[1]]
expect_identical(img$x, unit(10, "pt"))
expect_equal(img$y, unit(20 + yoff, "pt"))
expect_identical(img$width, unit(50, "pt"))
expect_equal(img$height, unit(img_height, "pt"))
rb <- bl_make_raster_box(logo, width = 80, height = 50,
width_policy = "fixed", height_policy = "fixed")
bl_calc_layout(rb, 200, 100)
g <- bl_render(rb, 10, 20)
nr <- nrow(logo)
nc <- ncol(logo)
img_width <- 50*nc/nr
xoff <- (80 - img_width)/2
img <- g[[1]]
expect_equal(img$x, unit(10 + xoff, "pt"))
expect_identical(img$y, unit(20, "pt"))
expect_equal(img$width, unit(img_width, "pt"))
expect_identical(img$height, unit(50, "pt"))
})
gridtext/tests/testthat/test-richtext-grob.R 0000644 0001762 0000144 00000016122 15145415164 020777 0 ustar ligges users context("richtext-grob")
test_that("grobheight and grobwidth work", {
# width is the same for textGrob and richtext_grob
g <- textGrob("test")
g2 <- richtext_grob("test")
w <- convertWidth(grobWidth(g), "pt", valueOnly = TRUE)
w2 <- convertWidth(grobWidth(g2), "pt", valueOnly = TRUE)
expect_equal(w, w2)
# height is slightly larger for richtext_grob, b/c descent is considered
h <- convertHeight(grobHeight(g), "pt", valueOnly = TRUE)
h2 <- convertHeight(grobHeight(g2), "pt", valueOnly = TRUE)
expect_lt(h, h2)
# width and height are flipped after rotating 90 degrees
g <- textGrob("test", rot = 90)
g2 <- richtext_grob("test", rot = 90)
w <- convertWidth(grobWidth(g), "pt", valueOnly = TRUE)
w2 <- convertWidth(grobWidth(g2), "pt", valueOnly = TRUE)
expect_lt(w, w2)
# height is slightly larger for richtext_grob, b/c descent is considered
h <- convertHeight(grobHeight(g), "pt", valueOnly = TRUE)
h2 <- convertHeight(grobHeight(g2), "pt", valueOnly = TRUE)
expect_equal(h, h2)
# position of multiple labels is taken into account
g <- textGrob("test", x = unit(0, "pt"), y = unit(80, "pt"))
g2 <- textGrob(c("test", "test"), x = unit(c(0, 50), "pt"), y = unit(c(80, 40), "pt"))
w <- convertWidth(grobWidth(g), "pt", valueOnly = TRUE)
w2 <- convertWidth(grobWidth(g2), "pt", valueOnly = TRUE)
expect_equal(w + 50, w2)
h <- convertHeight(grobHeight(g), "pt", valueOnly = TRUE)
h2 <- convertHeight(grobHeight(g2), "pt", valueOnly = TRUE)
expect_equal(h + 40, h2)
# multiple labels, w rotation
g <- textGrob("test", x = unit(0, "pt"), y = unit(80, "pt"), rot = 45)
g2 <- textGrob(c("test", "test"), x = unit(c(0, 50), "pt"), y = unit(c(80, 40), "pt"), rot = 45)
w <- convertWidth(grobWidth(g), "pt", valueOnly = TRUE)
w2 <- convertWidth(grobWidth(g2), "pt", valueOnly = TRUE)
expect_equal(w + 50, w2)
h <- convertHeight(grobHeight(g), "pt", valueOnly = TRUE)
h2 <- convertHeight(grobHeight(g2), "pt", valueOnly = TRUE)
expect_equal(h + 40, h2)
# grob height and width are identical with and without debug info
text <- c(
"Some text **in bold.**
(centered)", "Linebreaks
Linebreaks
Linebreaks",
"*x*2 + 5*x* + *C*i
*a* = 5"
)
x <- c(.4, .3, .8)
y <- c(.8, .5, .3)
rot <- c(0, -45, 45)
halign <- c(0.5, 0, 1)
valign <- c(0.5, 1, 0)
g1 <- richtext_grob(
text, x, y, halign = halign, valign = valign, rot = rot,
padding = unit(c(6, 6, 4, 6), "pt"),
r = unit(c(0, 4, 8), "pt"),
debug = FALSE
)
g2 <- richtext_grob(
text, x, y, halign = halign, valign = valign, rot = rot,
padding = unit(c(6, 6, 4, 6), "pt"),
r = unit(c(0, 4, 8), "pt"),
debug = TRUE
)
w1 <- convertWidth(grobWidth(g1), "pt", valueOnly = TRUE)
w2 <- convertWidth(grobWidth(g2), "pt", valueOnly = TRUE)
expect_equal(w1, w2)
h1 <- convertHeight(grobHeight(g1), "pt", valueOnly = TRUE)
h2 <- convertHeight(grobHeight(g2), "pt", valueOnly = TRUE)
expect_equal(h1, h2)
})
test_that("misc. tests", {
# empty strings work
expect_silent(richtext_grob(""))
expect_silent(richtext_grob(" "))
# NAs work
expect_silent(richtext_grob(c(" ", "abc", NA)))
})
test_that("visual tests", {
draw_labels <- function() {
function() {
text <- c(
"**Various text boxes in different stylings**",
"Some text **in bold.**
(centered)", "Linebreaks
Linebreaks
Linebreaks",
"*x*2 + 5*x* + *C*i
*a* = 5"
)
x <- c(0, .4, .3, .8)
y <- c(1, .8, .5, .3)
rot <- c(0, 0, -45, 45)
gp = gpar(col = c("black", "red"))
box_gp = gpar(col = "black", fill = c(NA, "cornsilk", NA, "lightblue1"), lty = c(0, 1, 1, 1))
hjust <- c(0, 0.5, 0, 1)
vjust <- c(1, 0.5, 1, 0)
g <- richtext_grob(
text, x, y, hjust = hjust, vjust = vjust, rot = rot,
padding = unit(c(6, 6, 4, 6), "pt"),
r = unit(c(0, 0, 4, 8), "pt"),
gp = gp, box_gp = box_gp
)
grid.draw(g)
grid.points(x, y, default.units = "npc", pch = 19, size = unit(5, "pt"))
invisible()
}
}
expect_doppelganger("Various text boxes", draw_labels())
draw_labels_debug <- function() {
function() {
text <- c(
"Some text **in bold.**
(centered)", "Linebreaks
Linebreaks
Linebreaks",
"*x*2 + 5*x* + *C*i
*a* = 5"
)
x <- c(.4, .3, .8)
y <- c(.8, .5, .3)
rot <- c(0, -45, 45)
gp = gpar(col = c("black", "red", "black"))
box_gp = gpar(col = "black", fill = c("cornsilk", NA, "lightblue1"), lty = c(1, 1, 1))
hjust <- c(0.5, 0, 1)
vjust <- c(0.5, 1, 0)
g <- richtext_grob(
text, x, y, hjust = hjust, vjust = vjust, rot = rot,
padding = unit(c(6, 6, 4, 6), "pt"),
r = unit(c(0, 4, 8), "pt"),
gp = gp, box_gp = box_gp,
debug = TRUE
)
grid.draw(g)
grid.points(x, y, default.units = "npc", pch = 19, size = unit(5, "pt"))
invisible()
}
}
expect_doppelganger("Various text boxes w/ debug", draw_labels_debug())
draw_aligned_heights <- function() {
function() {
text <- c(
"Some text **in bold.**
(centered)", "Linebreaks
Linebreaks
Linebreaks",
"*x*2 + 5*x* + *C*i
*a* = 5"
)
x <- c(.4, .3, .8)
y <- c(.8, .5, .3)
rot <- c(0, -45, 45)
gp = gpar()
box_gp = gpar(col = "black", fill = c("cornsilk", NA, "lightblue1"))
hjust <- c(0.5, 0, 1)
vjust <- c(0.5, 1, 0)
g <- richtext_grob(
text, x, y, halign = 0.5, valign = 0.5,
hjust = hjust, vjust = vjust, rot = rot,
align_heights = TRUE,
padding = unit(c(6, 6, 4, 6), "pt"),
r = unit(c(0, 4, 8), "pt"),
gp = gp, box_gp = box_gp
)
grid.draw(g)
grid.text("Box heights aligned, content centered", gp = gpar(fontface = "bold"), 0.02, 1, hjust = 0, vjust = 1.2)
grid.points(x, y, default.units = "npc", pch = 19, size = unit(5, "pt"))
invisible()
}
}
expect_doppelganger("Aligned heights", draw_aligned_heights())
draw_aligned_widths <- function() {
function() {
text <- c(
"Some text **in bold.**
(centered)", "Linebreaks
Linebreaks
Linebreaks",
"*x*2 + 5*x* + *C*i
*a* = 5"
)
x <- c(.4, .3, .8)
y <- c(.8, .5, .3)
rot <- c(0, -45, 45)
gp = gpar()
box_gp = gpar(col = "black", fill = c("cornsilk", NA, "lightblue1"))
hjust <- c(0.5, 0, 1)
vjust <- c(0.5, 1, 0)
g <- richtext_grob(
text, x, y, halign = 0.5, valign = 0.5,
hjust = hjust, vjust = vjust, rot = rot,
align_widths = TRUE,
padding = unit(c(6, 6, 4, 6), "pt"),
r = unit(c(0, 4, 8), "pt"),
gp = gp, box_gp = box_gp
)
grid.draw(g)
grid.text("Box widths aligned, content centered", gp = gpar(fontface = "bold"), 0.02, 1, hjust = 0, vjust = 1.2)
grid.points(x, y, default.units = "npc", pch = 19, size = unit(5, "pt"))
invisible()
}
}
expect_doppelganger("Aligned widths", draw_aligned_widths())
})
gridtext/tests/testthat/helper-vdiffr.R 0000644 0001762 0000144 00000000220 15145415164 017766 0 ustar ligges users expect_doppelganger <- function(title, fig, ...) {
testthat::skip_if_not_installed("vdiffr")
vdiffr::expect_doppelganger(title, fig, ...)
}
gridtext/tests/testthat/test-grid-renderer.R 0000644 0001762 0000144 00000007211 15145415164 020746 0 ustar ligges users context("grid-renderer")
test_that("basic functioning", {
r <- grid_renderer()
g <- grid_renderer_collect_grobs(r)
# without any grobs rendered, we get an empty list of class gList
expect_equal(length(g), 0)
expect_true(inherits(g, "gList"))
# grobs get added in order
grid_renderer_text(r, "abcd", 100, 100, gpar())
grid_renderer_rect(r, 100, 100, 200, 200, gpar())
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 2)
expect_true(inherits(g, "gList"))
expect_true(inherits(g[[1]], "text"))
expect_true(inherits(g[[2]], "rect"))
# internal state gets reset after calling collect_grobs()
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 0)
expect_true(inherits(g, "gList"))
})
test_that("smart rendering of rects", {
r <- grid_renderer()
# add normal rect
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar())
# add rect with rounded corners
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(), r = 5)
# add rect that is invisible, gets removed automatically
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(col = NA))
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 2)
expect_true(inherits(g, "gList"))
expect_true(inherits(g[[1]], "rect"))
expect_true(inherits(g[[2]], "roundrect"))
# more extensive testing variations for dropping unneeded rects
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(lty = 0))
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 0)
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(col = NA, lty = 1))
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 0)
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(col = "black", lty = 0))
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 0)
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(fill = NA, lty = 0))
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 0)
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(fill = NA, col = "black", lty = 0))
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 0)
grid_renderer_rect(r, 100, 100, 200, 200, gp = gpar(fill = NA, col = NA, lty = 1))
g <- grid_renderer_collect_grobs(r)
expect_equal(length(g), 0)
})
test_that("visual tests", {
draw_grob <- function(g) {
function() {
grid.newpage()
grid.draw(g)
invisible()
}
}
r <- grid_renderer()
grid_renderer_text(r, "blue", 10, 400, gp = gpar(col = "blue", fontsize = 12))
grid_renderer_text(r, "red bold", 20, 380, gp = gpar(col = "red", fontsize = 12, fontface = "bold"))
grid_renderer_text(r, "roman", 30, 360, gp = gpar(fontsize = 12, fontfamily = "Times"))
g <- grid_renderer_collect_grobs(r)
expect_doppelganger("Text in different stylings", draw_grob(g))
grid_renderer_rect(r, 100, 400, 200, 20, gp = gpar(col = "blue"))
grid_renderer_rect(r, 100, 200, 300, 30, gp = gpar(fill = "cornsilk"), r = 8)
grid_renderer_text(r, "text 1, square box blue", 100, 400, gp = gpar(fontsize = 20))
grid_renderer_text(r, "text 2, rounded box filled", 100, 200, gp = gpar(fontsize = 20))
g <- grid_renderer_collect_grobs(r)
expect_doppelganger("Mixing text and boxes", draw_grob(g))
logo_file <- system.file("extdata", "Rlogo.png", package = "gridtext")
logo <- png::readPNG(logo_file, native = TRUE)
width <- ncol(logo)
height <- nrow(logo)
grid_renderer_raster(r, logo, 10, 10, width, height)
g <- grid_renderer_collect_grobs(r)
expect_doppelganger("Rendering raster data", draw_grob(g))
})
test_that("text details are calculated correctly", {
gp = gpar(fontsize = 20)
td <- text_details("abcd", gp)
td2 <- grid_renderer_text_details("abcd", gp)
expect_identical(td, td2)
})
gridtext/tests/testthat/test-vbox.R 0000644 0001762 0000144 00000006761 15145415164 017204 0 ustar ligges users test_that("vertical stacking works", {
nb <- bl_make_null_box()
rb1 <- bl_make_rect_box(nb, 100, 100, rep(0, 4), rep(0, 4), gp = gpar())
rb2 <- bl_make_rect_box(nb, 50, 50, rep(10, 4), rep(0, 4), gp = gpar())
rb3 <- bl_make_rect_box(nb, 50, 10, rep(0, 4), rep(0, 4), gp = gpar(), width_policy = "expand")
vb <- bl_make_vbox(list(rb1, rb2, rb3), width = 200, hjust = 0, vjust = 0, width_policy = "fixed")
bl_calc_layout(vb, 0, 0)
bl_place(vb, 0, 0)
expect_identical(bl_box_width(vb), 200)
expect_identical(bl_box_height(vb), 160)
expect_identical(bl_box_voff(vb), 0)
g <- bl_render(vb, 200, 100)
out1 <- g[[1]]
expect_identical(out1$x, unit(200, "pt"))
expect_identical(out1$y, unit(100 + 10 + 50, "pt"))
out2 <- g[[2]]
expect_identical(out2$x, unit(210, "pt"))
expect_identical(out2$y, unit(100 + 10 + 10, "pt"))
out3 <- g[[3]]
expect_identical(out3$x, unit(200, "pt"))
expect_identical(out3$y, unit(100, "pt"))
expect_identical(out3$width, unit(200, "pt"))
# alternatve hjust, vjust, x, y
vb <- bl_make_vbox(list(rb1, rb2, rb3), width = 200, hjust = 1, vjust = 1, width_policy = "fixed")
bl_calc_layout(vb, 0, 0)
bl_place(vb, 15, 27)
expect_identical(bl_box_width(vb), 200)
expect_identical(bl_box_height(vb), 160)
g <- bl_render(vb, 200, 100)
out1 <- g[[1]]
expect_identical(out1$x, unit(15 + 0, "pt"))
expect_identical(out1$y, unit(27 - 60 + 10 + 50, "pt"))
out2 <- g[[2]]
expect_identical(out2$x, unit(15 + 10, "pt"))
expect_identical(out2$y, unit(27 - 60 + 10 + 10, "pt"))
out3 <- g[[3]]
expect_identical(out3$x, unit(15 + 0, "pt"))
expect_identical(out3$y, unit(27 - 60, "pt"))
expect_identical(out3$width, unit(200, "pt"))
})
test_that("size policies", {
nb <- bl_make_null_box()
rb1 <- bl_make_rect_box(nb, 100, 100, rep(0, 4), rep(0, 4), gp = gpar())
rb2 <- bl_make_rect_box(nb, 50, 50, rep(10, 4), rep(0, 4), gp = gpar())
vb <- bl_make_vbox(list(rb1, rb2), width = 200, hjust = 0.5, vjust = 0.5, width_policy = "native")
bl_calc_layout(vb, 0, 0)
expect_identical(bl_box_width(vb), 100)
expect_identical(bl_box_height(vb), 150)
vb <- bl_make_vbox(list(rb1, rb2), width = 200, hjust = 0.5, vjust = 0.5, width_policy = "relative")
bl_calc_layout(vb, 70, 0)
expect_identical(bl_box_width(vb), 140)
expect_identical(bl_box_height(vb), 150)
vb <- bl_make_vbox(list(rb1, rb2), width = 200, hjust = 0.5, vjust = 0.5, width_policy = "expand")
bl_calc_layout(vb, 300, 0)
expect_identical(bl_box_width(vb), 300)
expect_identical(bl_box_height(vb), 150)
})
test_that("vertical offset is ignored in vertical stacking", {
tb1 <- bl_make_text_box("string1", gp = gpar(fontsize = 10))
tb2 <- bl_make_text_box("string2", gp = gpar(fontsize = 20), voff = -10)
tb3 <- bl_make_text_box("string2", gp = gpar(fontsize = 20), voff = 0)
tb4 <- bl_make_text_box("string3", gp = gpar(fontsize = 15))
vb1 <- bl_make_vbox(list(tb1, tb2, tb4), hjust = 0, vjust = 0)
bl_calc_layout(vb1, 100, 100)
bl_place(vb1, 17, 24)
vb2 <- bl_make_vbox(list(tb1, tb3, tb4), hjust = 0, vjust = 0)
bl_calc_layout(vb2, 100, 100)
bl_place(vb2, 17, 24)
g1 <- bl_render(vb1, 0, 0)
g2 <- bl_render(vb2, 0, 0)
extract <- function(x, name) {x[[name]]}
expect_identical(
lapply(g1, extract, name = "x"),
lapply(g2, extract, name = "x")
)
expect_identical(
lapply(g1, extract, name = "y"),
lapply(g2, extract, name = "y")
)
expect_identical(
lapply(g1, extract, name = "label"),
lapply(g2, extract, name = "label")
)
})
gridtext/tests/testthat/_snaps/ 0000755 0001762 0000144 00000000000 15145415164 016377 5 ustar ligges users gridtext/tests/testthat/_snaps/textbox-grob/ 0000755 0001762 0000144 00000000000 15145415164 021023 5 ustar ligges users gridtext/tests/testthat/_snaps/textbox-grob/rotation-around-fixed-point.svg 0000644 0001762 0000144 00000016707 15145415164 027130 0 ustar ligges users
gridtext/tests/testthat/_snaps/textbox-grob/multiple-boxes-internal-alignment.svg 0000644 0001762 0000144 00000014121 15145415164 030302 0 ustar ligges users
gridtext/tests/testthat/_snaps/textbox-grob/multiple-boxes-inverted-internal-alignment.svg 0000644 0001762 0000144 00000017354 15145415164 032133 0 ustar ligges users
gridtext/tests/testthat/_snaps/textbox-grob/multiple-boxes-right-rotated-internal-alignment.svg 0000644 0001762 0000144 00000017226 15145415164 033066 0 ustar ligges users
gridtext/tests/testthat/_snaps/textbox-grob/multiple-boxes-left-rotated-internal-alignment.svg 0000644 0001762 0000144 00000017323 15145415164 032701 0 ustar ligges users
gridtext/tests/testthat/_snaps/textbox-grob/box-spanning-entire-viewport-with-margins.svg 0000644 0001762 0000144 00000015656 15145415164 031734 0 ustar ligges users
gridtext/tests/testthat/_snaps/grid-renderer/ 0000755 0001762 0000144 00000000000 15145415164 021130 5 ustar ligges users gridtext/tests/testthat/_snaps/grid-renderer/mixing-text-and-boxes.svg 0000644 0001762 0000144 00000003761 15145415164 026013 0 ustar ligges users
gridtext/tests/testthat/_snaps/grid-renderer/text-in-different-stylings.svg 0000644 0001762 0000144 00000002412 15145415164 027056 0 ustar ligges users
gridtext/tests/testthat/_snaps/grid-renderer/rendering-raster-data.svg 0000644 0001762 0000144 00000046133 15145415164 026042 0 ustar ligges users
gridtext/tests/testthat/_snaps/richtext-grob/ 0000755 0001762 0000144 00000000000 15145415164 021160 5 ustar ligges users gridtext/tests/testthat/_snaps/richtext-grob/aligned-heights.svg 0000644 0001762 0000144 00000013652 15145415164 024744 0 ustar ligges users
gridtext/tests/testthat/_snaps/richtext-grob/aligned-widths.svg 0000644 0001762 0000144 00000013651 15145415164 024612 0 ustar ligges users
gridtext/tests/testthat/_snaps/richtext-grob/various-text-boxes.svg 0000644 0001762 0000144 00000015751 15145415164 025502 0 ustar ligges users
gridtext/tests/testthat/_snaps/richtext-grob/various-text-boxes-w-debug.svg 0000644 0001762 0000144 00000014331 15145415164 027023 0 ustar ligges users
gridtext/tests/testthat/test-textbox-grob.R 0000644 0001762 0000144 00000023635 15145415164 020651 0 ustar ligges users context("textbox-grob")
test_that("misc. tests", {
# empty strings work
expect_silent(textbox_grob(""))
expect_silent(textbox_grob(" "))
# NAs work
expect_silent(textbox_grob(NA))
})
test_that("visual tests", {
draw_box <- function() {
function() {
g <- textbox_grob(
"**The quick brown fox jumps over the lazy dog.**
The quick brown fox jumps over the lazy dog.
The **quick brown fox** jumps over the lazy dog.
The quick brown fox jumps over the lazy dog.",
y = unit(0.9, "npc"), vjust = 1,
gp = gpar(fontsize = 15),
box_gp = gpar(col = "black", fill = "lightcyan1"),
r = unit(5, "pt"),
padding = unit(c(10, 10, 10, 10), "pt"),
margin = unit(c(0, 10, 0, 10), "pt")
)
grid.draw(g)
grid.text(" Box spanning entire viewport, with margins", 0, 1, hjust = 0, vjust = 1.2)
grid.points(0.5, 0.9, default.units = "npc", pch = 19, size = unit(5, "pt"))
invisible()
}
}
expect_doppelganger("Box spanning entire viewport, with margins", draw_box())
draw_align_upright <- function() {
function() {
g1 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1, valign = 1, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g2 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 1, valign = 0.5, halign = 0.5,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g3 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 0, valign = 1, halign = 1,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g4 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 0, valign = 0, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
grid.draw(g1)
grid.draw(g2)
grid.draw(g3)
grid.draw(g4)
invisible()
}
}
expect_doppelganger("Multiple boxes, internal alignment", draw_align_upright())
draw_align_left_rotated <- function() {
function() {
g1 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1, valign = 1, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "left-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g2 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 1, valign = 0.5, halign = 0.5,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "left-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g3 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 0, valign = 1, halign = 1,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "left-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g4 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 0, valign = 0, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "left-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
grid.draw(g1)
grid.draw(g2)
grid.draw(g3)
grid.draw(g4)
invisible()
}
}
expect_doppelganger("Multiple boxes left rotated, internal alignment", draw_align_left_rotated())
draw_align_right_rotated <- function() {
function() {
g1 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1, valign = 1, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "right-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g2 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 1, valign = 0.5, halign = 0.5,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "right-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g3 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 0, valign = 1, halign = 1,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "right-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g4 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 0, valign = 0, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "right-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
grid.draw(g1)
grid.draw(g2)
grid.draw(g3)
grid.draw(g4)
invisible()
}
}
expect_doppelganger("Multiple boxes right rotated, internal alignment", draw_align_right_rotated())
draw_align_inverted <- function() {
function() {
g1 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1, valign = 1, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "inverted",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g2 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 1, valign = 0.5, halign = 0.5,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "inverted",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g3 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 0, valign = 1, halign = 1,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "inverted",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
g4 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 1, vjust = 0, valign = 0, halign = 0,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "inverted",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 5, 5, 5), "pt")
)
grid.draw(g1)
grid.draw(g2)
grid.draw(g3)
grid.draw(g4)
invisible()
}
}
expect_doppelganger("Multiple boxes inverted, internal alignment", draw_align_inverted())
draw_rotated_fixedpoint <- function() {
function() {
g1 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1,
x = 0.4, y = 0.6,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "upright",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 0, 5, 0), "pt")
)
g2 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1,
x = 0.4, y = 0.6,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "left-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 0, 5, 0), "pt")
)
g3 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1,
x = 0.4, y = 0.6,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "right-rotated",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 0, 5, 0), "pt")
)
g4 <- textbox_grob(
"The quick brown fox jumps over the lazy dog.",
hjust = 0, vjust = 1,
x = 0.4, y = 0.6,
width = unit(1.5, "inch"), height = unit(1.5, "inch"),
orientation = "inverted",
box_gp = gpar(col = "black", fill = "cornsilk"),
padding = unit(c(2, 2, 2, 2), "pt"),
margin = unit(c(5, 0, 5, 0), "pt")
)
grid.draw(g1)
grid.draw(g2)
grid.draw(g3)
grid.draw(g4)
grid.points(0.4, 0.6, default.units = "npc", pch = 19, size = unit(5, "pt"))
invisible()
}
}
expect_doppelganger("Rotation around fixed point", draw_rotated_fixedpoint())
})
gridtext/tests/testthat/test-null-box.R 0000644 0001762 0000144 00000002227 15145415164 017757 0 ustar ligges users test_that("basic features", {
# null box with no extent
nb <- bl_make_null_box()
expect_identical(bl_box_width(nb), 0)
expect_identical(bl_box_height(nb), 0)
expect_identical(bl_box_ascent(nb), 0)
expect_identical(bl_box_descent(nb), 0)
expect_identical(bl_box_voff(nb), 0)
g <- bl_render(nb, 100, 200)
expect_identical(length(g), 0L)
# null box with defined extent
nb <- bl_make_null_box(100, 200)
expect_identical(bl_box_width(nb), 100)
expect_identical(bl_box_height(nb), 200)
expect_identical(bl_box_ascent(nb), 200)
expect_identical(bl_box_descent(nb), 0)
expect_identical(bl_box_voff(nb), 0)
g <- bl_render(nb, 100, 200)
expect_identical(length(g), 0L)
# null box transmits its extent to enclosing rect box
rb <- bl_make_rect_box(
nb, 0, 0, margin = rep(0, 4), padding = rep(0, 4),
gp = gpar(), width_policy = "native", height_policy = "native"
)
bl_calc_layout(rb, 0, 0)
g <- bl_render(rb, 100, 200)
outer <- g[[1]]
expect_identical(outer$x, unit(100, "pt"))
expect_identical(outer$y, unit(200, "pt"))
expect_identical(outer$width, unit(100, "pt"))
expect_identical(outer$height, unit(200, "pt"))
})
gridtext/tests/testthat/test-grid-constructors.R 0000644 0001762 0000144 00000012272 15145415164 021713 0 ustar ligges users test_that("unit_pt", {
expect_equal(
unit_pt(10),
grid::unit(10, "pt")
)
expect_identical(
unit_pt(1:10),
grid::unit(1:10, "pt")
)
})
test_that("gpar_empty", {
expect_identical(
gpar_empty(),
grid::gpar()
)
})
test_that("text_grob", {
# basic functionality, gp is set to gpar() if not provided
expect_identical(
text_grob("test", 10, 20, name = "abc"),
textGrob(
"test",
x = unit(10, "pt"), y = unit(20, "pt"),
hjust = 0, vjust = 0,
gp = gpar(),
name = "abc"
)
)
# basic functionality, x and y are set to 0 if not provided
expect_identical(
text_grob("test", name = "abc"),
textGrob(
"test",
x = unit(0, "pt"), y = unit(0, "pt"),
hjust = 0, vjust = 0,
gp = gpar(),
name = "abc"
)
)
# gp is set as requested
gp <- gpar(col = "blue", fill = "red")
expect_identical(
text_grob("test", 10, 20, gp = gp, name = "abc"),
textGrob(
"test",
x = unit(10, "pt"), y = unit(20, "pt"),
hjust = 0, vjust = 0,
gp = gp,
name = "abc"
)
)
# if no name is provided, different names are assigned
g1 <- text_grob("test")
g2 <- text_grob("test")
expect_false(identical(g1$name, g2$name))
# function is not vectorized
expect_error(
text_grob(c("test", "test"), 10, 20),
"not vectorized"
)
expect_error(
text_grob("test", 1:5, 20),
"not vectorized"
)
expect_error(
text_grob("test", 10, 1:5),
"not vectorized"
)
# arguments of length 0 are also disallowed
expect_error(
text_grob("test", numeric(0), 5),
"not vectorized"
)
})
test_that("raster_grob", {
# basic functionality
image <- matrix(0:1, ncol = 5, nrow = 4)
expect_identical(
raster_grob(image, 10, 20, 50, 40, gp = gpar(), name = "abc"),
rasterGrob(
image,
x = unit(10, "pt"), y = unit(20, "pt"),
width = unit(50, "pt"), height = unit(40, "pt"),
hjust = 0, vjust = 0,
interpolate = TRUE,
gp = gpar(),
name = "abc"
)
)
# interpolate is set as requested, gp default is NULL
expect_identical(
raster_grob(image, 10, 20, 50, 40, interpolate = FALSE, name = "abc"),
rasterGrob(
image,
x = unit(10, "pt"), y = unit(20, "pt"),
width = unit(50, "pt"), height = unit(40, "pt"),
hjust = 0, vjust = 0,
interpolate = FALSE,
gp = NULL,
name = "abc"
)
)
# if no name is provided, different names are assigned
g1 <- raster_grob(image)
g2 <- raster_grob(image)
expect_false(identical(g1$name, g2$name))
# function is not vectorized
expect_error(
raster_grob(image, c(10, 20), 20, 100, 140),
"not vectorized"
)
expect_error(
raster_grob(image, 10, numeric(0), 100, 140),
"not vectorized"
)
})
test_that("rect_grob", {
# basic functionality, gp is set to gpar() if not provided
expect_identical(
rect_grob(10, 20, 100, 140, name = "abc"),
rectGrob(
x = unit(10, "pt"), y = unit(20, "pt"),
width = unit(100, "pt"), height = unit(140, "pt"),
hjust = 0, vjust = 0,
gp = gpar(),
name = "abc"
)
)
# gp is set as requested
gp <- gpar(col = "blue", fill = "red")
expect_identical(
rect_grob(10, 20, 100, 140, gp = gp, name = "abc"),
rectGrob(
x = unit(10, "pt"), y = unit(20, "pt"),
width = unit(100, "pt"), height = unit(140, "pt"),
hjust = 0, vjust = 0,
gp = gp,
name = "abc"
)
)
# if no name is provided, different names are assigned
g1 <- rect_grob()
g2 <- rect_grob()
expect_false(identical(g1$name, g2$name))
# function is not vectorized
expect_error(
rect_grob(c(10, 20), 20, 100, 140),
"not vectorized"
)
expect_error(
rect_grob(10, numeric(0), 100, 140),
"not vectorized"
)
})
test_that("roundrect_grob", {
# basic functionality, gp is set to gpar() if not provided
expect_identical(
roundrect_grob(10, 20, 100, 140, 10, name = "abc"),
roundrectGrob(
x = unit(10, "pt"), y = unit(20, "pt"),
width = unit(100, "pt"), height = unit(140, "pt"),
r = unit(10, "pt"),
just = c(0, 0),
gp = gpar(),
name = "abc"
)
)
# gp is set as requested
gp <- gpar(col = "blue", fill = "red")
expect_identical(
roundrect_grob(10, 20, 100, 140, 20, gp = gp, name = "abc"),
roundrectGrob(
x = unit(10, "pt"), y = unit(20, "pt"),
width = unit(100, "pt"), height = unit(140, "pt"),
r = unit(20, "pt"),
just = c(0, 0),
gp = gp,
name = "abc"
)
)
# if no name is provided, different names are assigned
g1 <- roundrect_grob()
g2 <- roundrect_grob()
expect_false(identical(g1$name, g2$name))
# function is not vectorized
expect_error(
roundrect_grob(c(10, 20), 20, 100, 140, 20),
"not vectorized"
)
expect_error(
roundrect_grob(10, numeric(0), 100, 140, 20),
"not vectorized"
)
})
test_that("set_grob_coords", {
g <- list(x = 0, y = 0)
# setting coords as numbers
expect_identical(
set_grob_coords(g, x = 20, y = 40),
list(x = 20, y = 40)
)
# setting coords as units
expect_identical(
set_grob_coords(g, x = unit_pt(20), y = unit_pt(40)),
list(x = unit_pt(20), y = unit_pt(40))
)
})
gridtext/tests/testthat.R 0000644 0001762 0000144 00000000112 15145415164 015231 0 ustar ligges users library(testthat)
library(grid)
library(gridtext)
test_check("gridtext")
gridtext/tests/figs/ 0000755 0001762 0000144 00000000000 15145415164 014204 5 ustar ligges users gridtext/tests/figs/test_image.png 0000644 0001762 0000144 00000452717 15145415164 017053 0 ustar ligges users PNG
IHDR u , UIDATx^Li%[y'Vu5nHd& (AC_A2
dM7Fzdv͛y"9wu1GX{[_}\ѻks
cξ/cHnt݇K!PVo)Zsk\>^k}Tx?۱9t5gqιZkJk-z>~[TN1%5*qV]c:>FB?{ō]\qt~h;#w
.fg곮݊~P^>;Ӈ'q.9B.u9?K)ǒg΅Fikӧ)<έ#1r9vkbczǽ~e}|L15n˻}n>1}Z12[?Yդ3Ys#9;vsCpι֎>>\cM>Gw۵rRܹ:mhlOCp1}3bQ߮Ft\UǜvJ)1~qOvaf}Fnm-wE2z<_sܙϬ#,hlQp)6y%2vcMi
7\+c})FNaq1Q:;+sEOCM~'?RѻI(i>cd~$_XQ3ډGh>Xqǒvs1cvK1p{is}>&܈
a 1y!v>c\1:Y{=>qTܞۍԹNM=wB\vTlff_#8yǸ{~J
PҚѻFysXs$b8ۯƎ.tŅw :O}c4)}.K>jH)9V 0-
圷sS$,B&SL5sDwIsZ<6:jꩆz+:s![=!ʯ\p8oGЩ_?@p;k9Nxc99>^sKaZZYs}ȫq~|Ҟ>g:·]|s6*)c@혂[a>}ͱcؽmYV_bLs6XO>,Xy/ Tq"Y|h(rɅ8V;Yܫr@qlm}wr9^`0fIOuB#E )2s-b Q[5;U?cx?rkH)fSe)-Z_Q
L5cwiy[\29I=:'B1"ŖRiUj\fZ1]pp:Á,s~ű".cx|8;+S>.7r̜ʹCQcFYى
ᣄp;o?rc$TKs\YVJaTcC+-XË݈ӡ#̋MJSؾʥFּ8\9\;G.9n9wicYkϘ?F[Ź'uDK:\+l7,quy,;ܣxmp`B+b4BQ7c)_91b
6BKk>3/}&ƴ8}i8,!91Pa{`Zc
9Dйp+݂w%u#`5-5!D [܂0 M1ArJ<4bs9DcqS̖Ktǜ&`Ccd{;i]lbpI
_XH
je PhӴE¢$(,i\D{֑^ns3]nϵI"Y7>JȞȊ;]gvrB30^sZr ZH_軇r%5{;3 l.p#am{~zC]!GƜ[,XA%T;,pCg\)1DT9vR~1Dmi̐l!_>
~7*[Y rjY{}l=$A
ɘgX͈4ޥ֯Lmx`3E SV9!%6`)0ھt2ͦ^\z
B8'#"Ӆ#~Bc.Ԍi(W4-z99o"ِJd*$3YF29"sl1ūy]$ F)sc9x YP9\H3˩>^pR,ijF1xJ1Zϔb
i_kac$D] 2U\]v_^1XDNaXk1{zpŚ)х1/Җxsm!BfK6OvWvOȼbڢ6\P_Gg>ȁ1w2%"F6!E?Pfsj:MSqUws;iy漘bHsx|[9 `"~S!֮RcVmv#
.][71"]בVK|7rfR|qkSJ*1f%q%o6-'lZVT:@zNq$f B_{B_1z~r-~0#0Ea+EVѧ$f
Q>#az7Ylbgd*S__ N ~nCQ$0Ǟ0s:O2`X[{w6F[c?XvEr1nxrI%s-s߯7)9$fAbAC=0&gg-*K
q{" H!?GA)&}LuQU[m#E>e3>,Q~qiyqJIsd<5T1^"neiYk>p2v\.̉!;#'oKU1z\DcÊ)fv3D-D2U1Ƃ]kȄxOawk>K8>3
Bޯ|I X!1u|Dj|{00[qpJFG2x&ii~G^CZӽ>/ZHak{$P{2t韃M"@)%P: BÝŊR$Cڟ|Ȓ;8v
m1y:GǖSkZ