Last updated on 2020-02-19 10:48:54 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 0.1.1 | 53.44 | 218.87 | 272.31 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 0.1.1 | 38.35 | 164.63 | 202.98 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 0.1.1 | 327.44 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 0.1.1 | 316.57 | ERROR | |||
| r-devel-windows-ix86+x86_64 | 0.1.1 | 102.00 | 303.00 | 405.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 0.1.1 | 143.00 | 405.00 | 548.00 | OK | |
| r-patched-linux-x86_64 | 0.1.1 | 43.16 | 182.83 | 225.99 | OK | |
| r-patched-solaris-x86 | 0.1.1 | 391.50 | OK | |||
| r-release-linux-x86_64 | 0.1.1 | 39.77 | 181.38 | 221.15 | OK | |
| r-release-windows-ix86+x86_64 | 0.1.1 | 102.00 | 275.00 | 377.00 | OK | |
| r-release-osx-x86_64 | 0.1.1 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 0.1.1 | 98.00 | 258.00 | 356.00 | ERROR | |
| r-oldrel-osx-x86_64 | 0.1.1 | ERROR |
Version: 0.1.1
Check: tests
Result: ERROR
Running 'testthat.R' [30s/32s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
> library(testthat)
> library(checkmate)
> library(raster)
Loading required package: sp
> library(sp)
> library(sf)
Linking to GEOS 3.8.0, GDAL 3.0.4, PROJ 6.3.0
>
> test_check("geometr")
Loading required package: geometr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(template$obj)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
--- R stacktrace ---
where 1: visualise(template$obj)
where 2 at testthat/test_gt_sketch.R#15: gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test_gt_sketch.R#14: test_that("sketch a point geometry from a matrix", {
output <- gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
expect_class(x = output, classes = "geom")
expect_true(object = output@type == "point")
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x11c23868>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
-- 1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15) -----
the condition has length > 1
Backtrace:
1. geometr::gt_sketch(...)
2. geometr::visualise(template$obj)
Reading layer `nc' from data source `/home/hornik/tmp/R.check/r-devel-clang/Work/build/Packages/sf/shape/nc.shp' using driver `ESRI Shapefile'
Simple feature collection with 100 features and 14 fields
geometry type: MULTIPOLYGON
dimension: XY
bbox: xmin: -84.32385 ymin: 33.88199 xmax: -75.45698 ymax: 36.58965
epsg (SRID): 4267
proj4string: +proj=longlat +datum=NAD27 +no_defs
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(`my matrix` = aMatrix)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
} else {
theName <- names(objs)[i]
}
--- R stacktrace ---
where 1 at testthat/test_visualise.R#21: visualise(`my matrix` = aMatrix)
where 2: eval(code, test_env)
where 3: eval(code, test_env)
where 4: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 5: doTryCatch(return(expr), name, parentenv, handler)
where 6: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 7: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 12: test_code(desc, code, env = parent.frame())
where 13 at testthat/test_visualise.R#18: test_that("visualise a matrix", {
aMatrix <<- raster::as.matrix(gtRasters$continuous)
output <- visualise(`my matrix` = aMatrix)
expect_class(output, "recordedplot")
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 40: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 41: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x11c23868>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
-- 2. Error: visualise a matrix (@test_visualise.R#21) ------------------------
the condition has length > 1
Backtrace:
1. geometr::visualise(`my matrix` = aMatrix)
== testthat results ===========================================================
[ OK: 693 | SKIPPED: 0 | WARNINGS: 8 | FAILED: 2 ]
1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15)
2. Error: visualise a matrix (@test_visualise.R#21)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 0.1.1
Check: tests
Result: ERROR
Running ‘testthat.R’ [22s/32s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(checkmate)
> library(raster)
Loading required package: sp
> library(sp)
> library(sf)
Linking to GEOS 3.8.0, GDAL 3.0.4, PROJ 6.3.0
>
> test_check("geometr")
Loading required package: geometr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(template$obj)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
--- R stacktrace ---
where 1: visualise(template$obj)
where 2 at testthat/test_gt_sketch.R#15: gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test_gt_sketch.R#14: test_that("sketch a point geometry from a matrix", {
output <- gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
expect_class(x = output, classes = "geom")
expect_true(object = output@type == "point")
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x55a05b56ae70>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
── 1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15) ─────
the condition has length > 1
Backtrace:
1. geometr::gt_sketch(...)
2. geometr::visualise(template$obj)
Reading layer `nc' from data source `/home/hornik/tmp/R.check/r-devel-gcc/Work/build/Packages/sf/shape/nc.shp' using driver `ESRI Shapefile'
Simple feature collection with 100 features and 14 fields
geometry type: MULTIPOLYGON
dimension: XY
bbox: xmin: -84.32385 ymin: 33.88199 xmax: -75.45698 ymax: 36.58965
epsg (SRID): 4267
proj4string: +proj=longlat +datum=NAD27 +no_defs
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(`my matrix` = aMatrix)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
} else {
theName <- names(objs)[i]
}
--- R stacktrace ---
where 1 at testthat/test_visualise.R#21: visualise(`my matrix` = aMatrix)
where 2: eval(code, test_env)
where 3: eval(code, test_env)
where 4: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 5: doTryCatch(return(expr), name, parentenv, handler)
where 6: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 7: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 12: test_code(desc, code, env = parent.frame())
where 13 at testthat/test_visualise.R#18: test_that("visualise a matrix", {
aMatrix <<- raster::as.matrix(gtRasters$continuous)
output <- visualise(`my matrix` = aMatrix)
expect_class(output, "recordedplot")
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 40: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 41: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x55a05b56ae70>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
── 2. Error: visualise a matrix (@test_visualise.R#21) ────────────────────────
the condition has length > 1
Backtrace:
1. geometr::visualise(`my matrix` = aMatrix)
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 693 | SKIPPED: 0 | WARNINGS: 8 | FAILED: 2 ]
1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15)
2. Error: visualise a matrix (@test_visualise.R#21)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 0.1.1
Check: tests
Result: ERROR
Running ‘testthat.R’ [34s/37s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(checkmate)
> library(raster)
Loading required package: sp
> library(sp)
> library(sf)
Linking to GEOS 3.7.1, GDAL 2.3.2, PROJ 5.2.0
>
> test_check("geometr")
Loading required package: geometr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(template$obj)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
--- R stacktrace ---
where 1: visualise(template$obj)
where 2 at testthat/test_gt_sketch.R#15: gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test_gt_sketch.R#14: test_that("sketch a point geometry from a matrix", {
output <- gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
expect_class(x = output, classes = "geom")
expect_true(object = output@type == "point")
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x11eff168>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
── 1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15) ─────
the condition has length > 1
Backtrace:
1. geometr::gt_sketch(...)
2. geometr::visualise(template$obj)
Reading layer `nc' from data source `/data/gannet/ripley/R/test-clang/sf/shape/nc.shp' using driver `ESRI Shapefile'
Simple feature collection with 100 features and 14 fields
geometry type: MULTIPOLYGON
dimension: XY
bbox: xmin: -84.32385 ymin: 33.88199 xmax: -75.45698 ymax: 36.58965
epsg (SRID): 4267
proj4string: +proj=longlat +datum=NAD27 +no_defs
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(`my matrix` = aMatrix)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
} else {
theName <- names(objs)[i]
}
--- R stacktrace ---
where 1 at testthat/test_visualise.R#21: visualise(`my matrix` = aMatrix)
where 2: eval(code, test_env)
where 3: eval(code, test_env)
where 4: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 5: doTryCatch(return(expr), name, parentenv, handler)
where 6: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 7: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 12: test_code(desc, code, env = parent.frame())
where 13 at testthat/test_visualise.R#18: test_that("visualise a matrix", {
aMatrix <<- raster::as.matrix(gtRasters$continuous)
output <- visualise(`my matrix` = aMatrix)
expect_class(output, "recordedplot")
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 40: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 41: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x11eff168>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
── 2. Error: visualise a matrix (@test_visualise.R#21) ────────────────────────
the condition has length > 1
Backtrace:
1. geometr::visualise(`my matrix` = aMatrix)
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 693 | SKIPPED: 0 | WARNINGS: 8 | FAILED: 2 ]
1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15)
2. Error: visualise a matrix (@test_visualise.R#21)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 0.1.1
Check: tests
Result: ERROR
Running ‘testthat.R’ [31s/33s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(checkmate)
> library(raster)
Loading required package: sp
> library(sp)
> library(sf)
Linking to GEOS 3.7.1, GDAL 2.3.2, PROJ 5.2.0
>
> test_check("geometr")
Loading required package: geometr
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(template$obj)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
--- R stacktrace ---
where 1: visualise(template$obj)
where 2 at testthat/test_gt_sketch.R#15: gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test_gt_sketch.R#14: test_that("sketch a point geometry from a matrix", {
output <- gt_sketch(template = raster::as.matrix(gtRasters$categorical),
shape = "point")
expect_class(x = output, classes = "geom")
expect_true(object = output@type == "point")
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x12b1f970>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
── 1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15) ─────
the condition has length > 1
Backtrace:
1. geometr::gt_sketch(...)
2. geometr::visualise(template$obj)
Reading layer `nc' from data source `/data/gannet/ripley/R/test-4.0/sf/shape/nc.shp' using driver `ESRI Shapefile'
Simple feature collection with 100 features and 14 fields
geometry type: MULTIPOLYGON
dimension: XY
bbox: xmin: -84.32385 ymin: 33.88199 xmax: -75.45698 ymax: 36.58965
epsg (SRID): 4267
proj4string: +proj=longlat +datum=NAD27 +no_defs
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
geometr
--- call from context ---
visualise(`my matrix` = aMatrix)
--- call from argument ---
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
} else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
} else {
theName <- names(objs)[i]
}
--- R stacktrace ---
where 1 at testthat/test_visualise.R#21: visualise(`my matrix` = aMatrix)
where 2: eval(code, test_env)
where 3: eval(code, test_env)
where 4: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 5: doTryCatch(return(expr), name, parentenv, handler)
where 6: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 7: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 12: test_code(desc, code, env = parent.frame())
where 13 at testthat/test_visualise.R#18: test_that("visualise a matrix", {
aMatrix <<- raster::as.matrix(gtRasters$continuous)
output <- visualise(`my matrix` = aMatrix)
expect_class(output, "recordedplot")
})
where 14: eval(code, test_env)
where 15: eval(code, test_env)
where 16: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 17: doTryCatch(return(expr), name, parentenv, handler)
where 18: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 19: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 20: doTryCatch(return(expr), name, parentenv, handler)
where 21: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 22: tryCatchList(expr, classes, parentenv, handlers)
where 23: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 24: test_code(NULL, exprs, env)
where 25: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 26: force(code)
where 27: doWithOneRestart(return(expr), restart)
where 28: withOneRestart(expr, restarts[[1L]])
where 29: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 30: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 31: FUN(X[[i]], ...)
where 32: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 38: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 39: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 40: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 41: test_check("geometr")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (..., window = NULL, theme = gtTheme, trace = FALSE,
image = FALSE, new = TRUE, clip = TRUE)
{
window <- .testWindow(x = window, ...)
assertDataFrame(x = window, nrows = 5, min.cols = 2, null.ok = TRUE)
assertClass(x = theme, classes = "gtTheme", null.ok = TRUE)
assertLogical(x = trace, len = 1, any.missing = FALSE)
assertLogical(x = image, len = 1, any.missing = FALSE)
assertLogical(x = new, len = 1, any.missing = FALSE)
assertLogical(x = clip, len = 1, any.missing = FALSE)
objs <- rlang::enquos(...)
names <- NULL
objects <- list()
for (i in seq_along(objs)) {
theObject <- theName <- NULL
if (is.null(names(objs)[i]) || names(objs)[i] == "") {
theObject <- eval_tidy(expr = objs[[i]])
if (is.null(names(theObject))) {
theName <- NA
}
else if (image) {
theName <- "an image"
}
else {
theName <- names(theObject)
}
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
temp <- lapply(1:dim(theObject)[3], function(x) {
theObject[[x]]
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
}
}
else {
if (!names(objs)[i] %in% names(theme@vector)) {
theObject <- eval_tidy(expr = objs[[i]])
if ((class(theObject) == "RasterBrick" | class(theObject) ==
"RasterStack") & !image) {
theName <- paste(names(objs)[i], 1:dim(theObject)[3])
temp <- lapply(1:dim(theObject)[3], function(x) {
t <- theObject[[x]]
if (length(theObject@history) != 0) {
t@history <- theObject@history
}
return(t)
})
theObject <- temp
}
else if (class(theObject) == "matrix") {
theObject <- list(theObject)
theName <- "a matrix"
}
else {
theName <- names(objs)[i]
}
}
}
objects <- c(objects, theObject)
names <- c(names, theName)
}
if (!is.null(dev.list()) & !new) {
objViewports <- grid.ls(viewports = TRUE, grobs = FALSE,
print = FALSE)
newPlot <- ifelse(any(objViewports$name == "geometr"),
FALSE, TRUE)
panelNames <- objViewports$name[objViewports$vpDepth ==
2 & objViewports$name != "1"]
panelNames <- panelNames[!duplicated(panelNames)]
panels <- length(panelNames)
}
else {
newPlot <- TRUE
panels <- length(objects)
}
objects <- rep(x = objects, length.out = panels)
names <- rep(x = names, length.out = panels)
if (panels > 15) {
question <- readline(paste0(" -> this will produce ",
panels, " plots, do you wish to continue? [yes/no]: "))
question <- match.arg(question, c("yes", "no"))
if (question == "no") {
return(invisible(0))
}
}
if (panels > 1) {
ncol <- ceiling(sqrt(panels))
}
else {
ncol <- 1
}
nrow <- ceiling(panels/ncol)
panelPosY <- rep(rev(seq(from = 1, to = nrow)), each = ncol)
panelPosX <- rep(seq(from = 1, to = ncol), times = nrow)
if (newPlot) {
grid.newpage()
pushViewport(viewport(name = "geometr"))
}
for (i in 1:panels) {
if (!newPlot) {
prev <- grid.get(gPath("extentGrob"), global = TRUE)
window <- .testWindow(x = tibble(x = c(as.numeric(prev$x),
as.numeric(prev$x) + as.numeric(prev$width)),
y = c(as.numeric(prev$y), as.numeric(prev$y) +
as.numeric(prev$height))))
}
obj <- makeObject(x = objects[[i]], window = window,
image = image, theme = theme, ...)
pnl <- makeLayout(x = obj, theme = theme)
if (!is.na(names[[i]]) & !is.null(names[[i]])) {
plotName <- names[[i]]
}
else {
plotName <- obj$name
}
if (newPlot | (!newPlot & obj$type == "raster")) {
pushViewport(viewport(x = (panelPosX[i]/ncol) - (1/ncol/2),
y = (panelPosY[i]/nrow) - (1/nrow/2), width = 1/ncol,
height = 1/nrow, name = plotName))
grid.rect(width = convertX(unit(1, "npc"), "native"),
gp = gpar(col = NA, fill = NA), name = "panelGrob")
grid.rect(height = pnl$yMargin, width = pnl$xMargin,
gp = gpar(fill = NA, col = NA), name = "marginGrob")
grid.rect(x = unit(pnl$minPlotX, "points"), y = unit(pnl$minPlotY,
"points"), height = unit(pnl$maxPlotY - pnl$minPlotY,
"points"), width = unit(pnl$maxPlotX - pnl$minPlotX,
"points"), gp = gpar(fill = NA, col = NA), name = "extentGrob")
pushViewport(viewport(x = unit(0.5, "npc") + unit(pnl$xOffset,
"points"), y = unit(0.5, "npc") + unit(pnl$yOffset,
"points"), height = min(pnl$gridH, pnl$gridHr),
width = min(pnl$gridW, pnl$gridWr), name = "plot"))
if (theme@title$plot) {
pushViewport(viewport(name = "title"))
grid.text(just = "top", y = unit(1, "npc") -
unit(3, "points") + pnl$titleH, label = plotName,
gp = gpar(fontsize = theme@title$fontsize,
col = theme@title$colour))
upViewport()
}
if (theme@yAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "yAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "right", x = unit(0, "npc") -
unit(2, "points") - pnl$yAxisTicksW, label = theme@yAxis$label$title,
rot = theme@yAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@yAxis$label$fontsize,
col = theme@yAxis$label$colour))
}
if (theme@yAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$yMajGrid,
theme@yAxis$ticks$digits)), just = "right",
x = unit(-0.005, "npc"), y = unit(pnl$yMajGrid,
"native"), name = "ticks", gp = gpar(fontsize = theme@yAxis$ticks$fontsize,
col = theme@yAxis$ticks$colour))
}
upViewport()
}
if (theme@xAxis$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "xAxis"))
if (theme@yAxis$label$plot) {
grid.text(just = "bottom", y = unit(0, "npc") -
unit(2, "points") - pnl$xAxisTitleH, label = theme@xAxis$label$title,
rot = theme@xAxis$label$rotation, name = "title",
gp = gpar(fontsize = theme@xAxis$label$fontsize,
col = theme@xAxis$label$colour))
}
if (theme@xAxis$ticks$plot) {
grid.text(label = as.character(round(pnl$xMajGrid,
theme@xAxis$ticks$digits)), just = "top",
x = unit(pnl$xMajGrid, "native"), y = unit(-0.005,
"npc"), name = "ticks", gp = gpar(fontsize = theme@xAxis$ticks$fontsize,
col = theme@xAxis$ticks$colour))
}
upViewport()
}
if (theme@legend$plot & obj$hasLegend) {
pushViewport(viewport(name = "legend"))
for (j in seq_along(obj$legend)) {
theParam <- names(obj$legend)[j]
theLegend <- obj$legend[[j]]
legendName <- names(theLegend[, 1])
if (length(theLegend$pos) == 1) {
maxYScale <- theLegend$pos[length(theLegend$pos)] +
1e-05
}
else {
maxYScale <- unit(as.numeric(theLegend$pos[which.max(theLegend$pos)]) +
1, "native")
}
pushViewport(viewport(height = unit(1, "npc") *
theme@legend$sizeRatio, yscale = c(1, maxYScale),
name = legendName))
theValues <- unlist(obj$params[legendName],
use.names = FALSE)
grid.text(label = theValues, name = "legend_values",
gp = gpar(col = NA))
if (theParam %in% c("linecol", "fillcol")) {
temp <- unlist(obj$params[legendName], use.names = FALSE)
theColours <- unique(unlist(obj$params[order(temp),
][theParam], use.names = FALSE))
grid.raster(x = unit(1, "npc") + pnl$legendX[j],
width = unit(10, "points"), height = unit(1,
"npc"), just = "left", name = "legend_items",
image = rev(theColours), interpolate = FALSE)
if (theme@legend$box$plot) {
grid.rect(x = unit(1, "npc") + pnl$legendX[j],
just = "left", width = unit(10, "points"),
name = "legend_box", gp = gpar(col = theme@legend$box$colour,
fill = NA, lty = theme@legend$box$linetype,
lwd = theme@legend$box$linewidth))
}
}
else if (theParam %in% "pointsize") {
theSizes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
times = length(theLegend$pos)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theme@vector$pointsymbol[1],
size = unit(theSizes, "char"), name = "legend_items")
}
else if (theParam %in% "pointsymbol") {
theSymbols <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.points(x = rep(unit(1, "npc") + pnl$legendX[j],
length(theSymbols)), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), pch = theSymbols,
size = unit(max(theme@vector$pointsize),
"char"), name = "legend_items")
}
else if (theParam %in% c("linewidth")) {
theWidths <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = theWidths, lty = theme@vector$linetype[1]))
}
else if (theParam %in% c("linetype")) {
theTypes <- sort(unique(unlist(obj$params[theParam],
use.names = FALSE)))[theLegend$pos]
grid.polyline(x = rep(unit(c(1, 1), "npc") +
unit.c(pnl$legendX[j], pnl$legendX[j] +
unit(10, "points")), times = length(theLegend$pos)),
y = unit(rep(theLegend$pos, each = 2),
"native") - unit(0.5, "native"), id = rep(theLegend$pos,
each = 2), name = "legend_items", gp = gpar(col = theme@vector$linecol[1],
lwd = max(theme@vector$linewidth), lty = theTypes))
}
if (theme@legend$label$plot) {
grid.text(label = unlist(theLegend[legendName],
use.names = FALSE), x = unit(1, "npc") +
pnl$legendX[j] + unit(15, "points"), y = unit(theLegend$pos,
"native") - unit(0.5, "native"), name = "legend_labels",
just = c("left"), gp = gpar(fontsize = theme@legend$label$fontsize,
col = theme@legend$label$colour))
}
upViewport()
}
upViewport()
}
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "gridGrob")
if (theme@grid$plot) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "majorGrid"))
grid.grill(h = unit(pnl$yMajGrid, "native"),
v = unit(pnl$xMajGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth, lty = theme@grid$linetype))
upViewport()
if (theme@grid$minor) {
pushViewport(viewport(xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin),
yscale = c(pnl$minPlotY - pnl$yMargin, pnl$maxPlotY +
pnl$yMargin), name = "minorGrid"))
grid.grill(h = unit(pnl$yMinGrid, "native"),
v = unit(pnl$xMinGrid, "native"), gp = gpar(col = theme@grid$colour,
lwd = theme@grid$linewidth/2, lty = theme@grid$linetype))
upViewport()
}
}
if (theme@box$plot) {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native"), height = unit(1,
"npc") - unit(2 * pnl$yMargin, "native"), name = "box"))
grid.rect(gp = gpar(fill = NA, col = theme@box$colour,
lwd = theme@box$linewidth, lty = theme@box$linetype),
name = "theBox")
upViewport()
}
upViewport()
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "object"))
grid.rect(gp = gpar(col = NA, fill = NA), name = "objectGrob")
if (obj$type == "raster") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "raster"))
grid.clip(width = unit(1, "npc"), height = unit(1,
"npc"))
grid.raster(x = unit(0, "npc") - unit(pnl$xWindowOffset,
"npc") * pnl$xFactor, y = unit(0, "npc") -
unit(pnl$yWindowOffset, "npc") * pnl$yFactor,
width = unit(pnl$xFactor, "npc"), height = unit(pnl$yFactor,
"npc"), hjust = 0, vjust = 0, image = matrix(data = obj$array,
nrow = obj$rows, ncol = obj$cols, byrow = TRUE),
name = "theRaster", interpolate = FALSE)
}
else if (obj$type == "vector") {
pushViewport(viewport(width = unit(1, "npc") -
unit(2 * pnl$xMargin, "native") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") - unit(2 *
pnl$yMargin, "native") + unit(theme@box$linewidth,
"points"), xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "vector"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
}
upViewport()
upViewport(3)
}
else {
downViewport(panelNames[i])
downViewport("plot")
pushViewport(viewport(xscale = c(pnl$minPlotX - pnl$xMargin,
pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "grid"))
pushViewport(viewport(width = unit(1, "npc") - unit(2 *
pnl$xMargin, "native"), height = unit(1, "npc") -
unit(2 * pnl$yMargin, "native"), xscale = c(pnl$minPlotX -
pnl$xMargin, pnl$maxPlotX + pnl$xMargin), yscale = c(pnl$minPlotY -
pnl$yMargin, pnl$maxPlotY + pnl$yMargin), name = "geom"))
if (clip) {
grid.clip(width = unit(1, "npc") + unit(theme@box$linewidth,
"points"), height = unit(1, "npc") + unit(theme@box$linewidth,
"points"))
}
grid.draw(obj$out)
upViewport(4)
}
}
upViewport()
if (trace) {
plotHistory <- FALSE
for (i in seq_along(objects)) {
hasHistory <- ifelse(!is.null(tryCatch(expr = objects[[i]]@history,
error = function(x) NULL)), TRUE, FALSE)
if (hasHistory) {
theHistory <- unlist(objects[[i]]@history)
if (!is.null(theHistory)) {
histMsg <- paste0("this object has the following history:\n -> ",
paste0(theHistory, collapse = "\n -> "))
plotHistory <- TRUE
}
}
}
if (plotHistory) {
message(paste0(histMsg, collapse = "\n"))
}
else {
message(paste0("this object has the following history:\n -> object loaded from memory"))
}
}
invisible(recordPlot(attach = "geometr"))
}
<bytecode: 0x12b1f970>
<environment: namespace:geometr>
--- function search by body ---
Function visualise in namespace geometr has this body.
----------- END OF FAILURE REPORT --------------
── 2. Error: visualise a matrix (@test_visualise.R#21) ────────────────────────
the condition has length > 1
Backtrace:
1. geometr::visualise(`my matrix` = aMatrix)
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 693 | SKIPPED: 0 | WARNINGS: 8 | FAILED: 2 ]
1. Error: sketch a point geometry from a matrix (@test_gt_sketch.R#15)
2. Error: visualise a matrix (@test_visualise.R#21)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc
Version: 0.1.1
Check: running tests for arch ‘i386’
Result: ERROR
Running 'testthat.R' [20s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
> library(testthat)
> library(checkmate)
> library(raster)
Loading required package: sp
> library(sp)
> library(sf)
Linking to GEOS 3.6.1, GDAL 2.2.3, PROJ 4.9.3
>
> test_check("geometr")
Loading required package: geometr
-- 1. Failure: transform from geom to grob (@test_gc_grob.R#25) ---------------
Check on names(polyGrob[[1]]) isn't true.
Must be a permutation of set {x,y,id,id.lengths,pathId,pathId.lengths,rule,name,gp,vp}
Reading layer `nc' from data source `D:\temp\Rtmp0YNYTw\RLIBS_4f6c42154e66\sf\shape\nc.shp' using driver `ESRI Shapefile'
Simple feature collection with 100 features and 14 fields
geometry type: MULTIPOLYGON
dimension: XY
bbox: xmin: -84.32385 ymin: 33.88199 xmax: -75.45698 ymax: 36.58965
epsg (SRID): 4267
proj4string: +proj=longlat +datum=NAD27 +no_defs
== testthat results ===========================================================
[ OK: 695 | SKIPPED: 0 | WARNINGS: 8 | FAILED: 1 ]
1. Failure: transform from geom to grob (@test_gc_grob.R#25)
Error: testthat unit tests failed
Execution halted
Flavor: r-oldrel-windows-ix86+x86_64
Version: 0.1.1
Check: running tests for arch ‘x64’
Result: ERROR
Running 'testthat.R' [22s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
> library(testthat)
> library(checkmate)
> library(raster)
Loading required package: sp
> library(sp)
> library(sf)
Linking to GEOS 3.6.1, GDAL 2.2.3, PROJ 4.9.3
>
> test_check("geometr")
Loading required package: geometr
-- 1. Failure: transform from geom to grob (@test_gc_grob.R#25) ---------------
Check on names(polyGrob[[1]]) isn't true.
Must be a permutation of set {x,y,id,id.lengths,pathId,pathId.lengths,rule,name,gp,vp}
Reading layer `nc' from data source `D:\temp\Rtmp0YNYTw\RLIBS_4f6c42154e66\sf\shape\nc.shp' using driver `ESRI Shapefile'
Simple feature collection with 100 features and 14 fields
geometry type: MULTIPOLYGON
dimension: XY
bbox: xmin: -84.32385 ymin: 33.88199 xmax: -75.45698 ymax: 36.58965
epsg (SRID): 4267
proj4string: +proj=longlat +datum=NAD27 +no_defs
== testthat results ===========================================================
[ OK: 695 | SKIPPED: 0 | WARNINGS: 8 | FAILED: 1 ]
1. Failure: transform from geom to grob (@test_gc_grob.R#25)
Error: testthat unit tests failed
Execution halted
Flavor: r-oldrel-windows-ix86+x86_64
Version: 0.1.1
Check: tests
Result: ERROR
Running ‘testthat.R’ [18s/18s]
Running the tests in ‘tests/testthat.R’ failed.
Last 13 lines of output:
Must be a permutation of set {x,y,id,id.lengths,pathId,pathId.lengths,rule,name,gp,vp}
Reading layer `nc' from data source `/Volumes/SSD-Data/Builds/R-dev-web/QA/Simon/packages/el-capitan-x86_64/Rlib/3.5/sf/shape/nc.shp' using driver `ESRI Shapefile'
Simple feature collection with 100 features and 14 fields
geometry type: MULTIPOLYGON
dimension: XY
bbox: xmin: -84.32385 ymin: 33.88199 xmax: -75.45698 ymax: 36.58965
epsg (SRID): 4267
proj4string: +proj=longlat +datum=NAD27 +no_defs
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 695 | SKIPPED: 0 | WARNINGS: 8 | FAILED: 1 ]
1. Failure: transform from geom to grob (@test_gc_grob.R#25)
Error: testthat unit tests failed
Execution halted
Flavor: r-oldrel-osx-x86_64