tests/testthat/test-grid.R

In r-spatial/sf: Simple Features for R

test_that("point grob constructors work", {
	p1 <- st_point(c(0, 1))
	p2 <- st_point(c(2, 3))
	p3 <- st_multipoint(matrix(11:20, ncol = 2))
	p4 <- st_sfc(list(p1, p2, p3))
	g1 <- st_as_grob(p1)
	expect_s3_class(g1, c('points', 'grob'))
	g2 <- st_as_grob(p4, gp = grid::gpar(col = c('red', 'green', 'blue')))
	expect_s3_class(g2, c('points', 'grob'))
	expect_equal(as.numeric(g2$x), unname(rbind(p1, p2, p3)[,1]))
	expect_equal(g2$gp$col, rep(c('red', 'green', 'blue'), c(1, 1, 5)))
})

test_that("linestring grob construction work", {
	lines <- list(
		matrix(11:20, ncol = 2),
		matrix(21:30, ncol = 2),
		matrix(31:50, ncol = 2)
	)
	l1 <- st_linestring(lines[[1]])
	l2 <- st_multilinestring(lines[2:3])
	l3 <- st_sfc(list(l1, l2))
	g1 <- st_as_grob(l1)
	expect_s3_class(g1, c('lines', 'grob'))
	g2 <- st_as_grob(l3, gp = grid::gpar(lwd = c(2, 4)))
	expect_s3_class(g2, c('lines', 'grob'))
	expect_equal(as.numeric(g2$x), do.call(rbind, lines)[, 1])
	expect_equal(g2$gp$lwd, rep(c(2, 4), c(1, 2)))
	expect_equal(g2$id.lengths, c(5, 5, 10))
})

holed_rect <- function(x0, y0, width, height, hole) {
	outer <- cbind(
		c(x0 - width/2, x0 + width/2, x0 + width/2, x0 - width/2, x0 - width/2),
		c(y0 - height/2, y0 - height/2, y0 + height/2, y0 + height/2, y0 - height/2)
	)
	inner <- outer
	inner[,1] <- (inner[,1] - x0) * hole + x0
	inner[,2] <- (inner[,2] - y0) * hole + y0
	list(outer, inner)
}
test_that("polygon grob construction work", {
	polys <- list(
		holed_rect(0, 0, 1, 1, 0.5),
		holed_rect(10, 5, 5, 1, 0.25),
		holed_rect(-3, -10, 4, 10, 0.7)
	)
	p1 <- st_polygon(polys[[1]])
	p2 <- st_multipolygon(polys[2:3])
	p3 <- st_sfc(list(p1, p2))
	g1 <- st_as_grob(p1)
	expect_s3_class(g1, c('pathgrob', 'grob'))
	g2 <- st_as_grob(p3, gp = grid::gpar(fill = c('red', 'blue')))
	if (getRversion() <  as.numeric_version("3.6")) {
		expect_s3_class(g2, 'gList')
		expect_equal(g2[[1]]$gp$fill, 'red')
		expect_equal(g2[[2]]$gp$fill, 'blue')
	} else {
		expect_s3_class(g2, c('pathgrob', 'grob'))
		coords <- do.call(rbind, unlist(polys, recursive = FALSE))
		expect_equal(as.numeric(g2$x), coords[, 1])
		expect_equal(g2$id.lengths, rep(5, 6))
		expect_equal(g2$pathId.lengths, rep(10, 3))
		expect_equal(g2$gp$fill, c('red', 'blue', 'blue'))
	}
})

test_that("mixed sfc grob construction works", {
	p1 <- st_point(c(0, 1))
	p2 <- st_multipoint(matrix(11:20, ncol = 2))
	l1 <- st_linestring(matrix(21:30, ncol = 2))
	p3 <- st_polygon(holed_rect(0, 0, 1, 1, 0.5))
	sfc <- st_sfc(list(p1, p2, l1, p3))
	g1 <- st_as_grob(sfc, pch = 1:4, gp = grid::gpar(col = 'blue', fill = c('red', 'red', 'blue', 'green')))
	expect_s3_class(g1[[1]], c('points', 'grob'))
	expect_s3_class(g1[[2]], c('points', 'grob'))
	expect_s3_class(g1[[3]], c('lines', 'grob'))
	expect_s3_class(g1[[4]], c('pathgrob', 'grob'))
	expect_equal(g1[[1]]$pch, 1)
	expect_equal(g1[[2]]$pch, 2)
	expect_null(g1[[3]]$pch)
	expect_null(g1[[4]]$pch)
	expect_equal(g1[[1]]$gp$col, 'blue')
	expect_equal(g1[[2]]$gp$col, 'blue')
	expect_equal(g1[[3]]$gp$col, 'blue')
	expect_equal(g1[[4]]$gp$col, 'blue')
	expect_equal(g1[[1]]$gp$fill, 'red')
	expect_equal(g1[[2]]$gp$fill, 'red')
	expect_equal(g1[[3]]$gp$fill, 'blue')
	expect_equal(g1[[4]]$gp$fill, 'green')
})