Skip to content

Commit 87102c0

Browse files
rhijmansrhijmans
committed
fixes #1956 
1 parent a07673b commit 87102c0

File tree

4 files changed

+96
-10
lines changed

4 files changed

+96
-10
lines changed

‎R/plot_axes.R‎

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,51 @@
11

2+
zebra <- function(cex=1, x=NULL, y=NULL, width=NULL) {
3+
4+
clip <- terra:::get.clip()
5+
axs <- unlist(clip)[1:4]
6+
if (is.null(width)) {
7+
width <- rep(min(axs[2]-axs[1], axs[4]-axs[3]) / 100, 2) * cex
8+
if (clip$geo) {
9+
asp <- 1/cos((mean(axs[3:4]) * pi)/180)
10+
width[2] <- width[2] / asp
11+
}
12+
} else {
13+
width <- rep(width, length.out=2)
14+
}
15+
16+
if (is.null(x)) {
17+
x = graphics:::.grid.at(1L, NULL, log=FALSE, equilogs=TRUE, axp=par("xaxp"), usr2=par("usr")[1:2])
18+
}
19+
if (is.null(y)) {
20+
y = graphics:::.grid.at(2L, NULL, log=FALSE, equilogs=TRUE, axp=par("yaxp"), usr2=par("usr")[1:2])
21+
}
22+
23+
x <- sort(unique(c(axs[1:2], x)))
24+
x <- x[x >= axs[1] & x <= axs[2]]
25+
y <- sort(unique(c(axs[3:4], y)))
26+
y <- y[y >= axs[3] & y <= axs[4]]
27+
28+
v1 <- vect(lapply(1:(length(y)-1), function(i) {
29+
as.polygons(ext(axs[1], axs[1]+width[1], y[i], y[i+1]))
30+
}))
31+
v1$col <- rep(c("black", "white"), length.out=nrow(v1))
32+
v2 <- shift(v1, axs[2]-axs[1]-width[1], 0)
33+
34+
h1 <- vect(lapply(1:(length(x)-1), function(i) {
35+
as.polygons(ext(x[i], x[i+1], axs[3], axs[3]+width[2]))
36+
}))
37+
h1$col <- rep(c("black", "white"), length.out=nrow(v1))
38+
h2 <- shift(h1, 0, axs[4]-axs[3]-width[2])
39+
40+
z <- rbind(v1, v2, h1, h2)
41+
polys(z, col=z$col, border=NA, xpd=TRUE)
42+
e <- c(axs[1] + width[1], axs[2] - width[1], axs[3] + width[2], axs[4] - width[2])
43+
lines(ext(e), xpd=TRUE)
44+
lines(ext(axs), xpd=TRUE)
45+
try(terra:::set.clip(e, clip$geo))
46+
}
47+
48+
249
retro_labels <- function(x, lat=TRUE) {
350
if ((is.null(x)) || (!is.numeric(x))) {
451
return(x)
@@ -220,6 +267,8 @@ retro_labels <- function(x, lat=TRUE) {
220267
}
221268
}
222269

270+
x$axs$xat <- xat
271+
x$axs$yat <- yat
223272
x
224273
}
225274

‎R/plot_raster.R‎

Lines changed: 23 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -374,6 +374,17 @@
374374
old.mar <- graphics::par()$mar
375375
if (!any(is.na(x$mar))) { graphics::par(mar=x$mar) }
376376
if (x$reset) on.exit(graphics::par(mar=old.mar))
377+
378+
if (x$zebra) {
379+
width <- rep(min(diff(x$lim[1:2]), diff(x$lim[3:4])) / 100, 2) * x$zebra.cex
380+
if (x$lonlat) {
381+
asp <- 1/cos((mean(x$lim[3:4]) * pi)/180)
382+
width[2] <- width[2] / asp
383+
}
384+
x$lim[1:2] <- x$lim[1:2] + c(-width[1], width[1])
385+
x$lim[3:4] <- x$lim[3:4] + c(-width[2], width[2])
386+
}
387+
377388
arglist <- c(list(x=x$lim[1:2], y=x$lim[3:4], type="n", xlab="", ylab="", asp=x$asp, xaxs=x$xaxs, yaxs=x$yaxs, axes=FALSE), x$dots)
378389
do.call(plot, arglist)
379390
if (!is.null(x$background)) {
@@ -387,6 +398,12 @@
387398
if (!x$legend_only) {
388399
graphics::rasterImage(x$r, x$ext[1], x$ext[3], x$ext[2], x$ext[4], angle = 0, interpolate = x$interpolate)
389400
x <- .plot.axes(x)
401+
if (x$zebra) {
402+
try(set.clip(x$lim, x$lonlat))
403+
zebra(width=width, x=x$axs$xat, y=x$axs$yat)
404+
x$lim[1:2] <- x$lim[1:2] + c(width[1], -width[1])
405+
x$lim[3:4] <- x$lim[3:4] + c(width[2], -width[2])
406+
}
390407
}
391408

392409
if (x$legend_draw) {
@@ -442,7 +459,7 @@
442459
xlab="", ylab="", cex.lab=0.8, line.lab=1.5, asp=NULL, yaxs="i", xaxs="i",
443460
main="", cex.main=1.2, line.main=0.5, font.main=graphics::par()$font.main, col.main = graphics::par()$col.main, loc.main=NULL,
444461
sub = "", font.sub=1, cex.sub=0.8*cex.main, line.sub =1.75, col.sub=col.main, loc.sub=NULL,
445-
halo=FALSE, hc="white", hw=0.1, axes=TRUE, box=TRUE, maxcell=500000, buffer=FALSE, clip=TRUE,
462+
halo=FALSE, hc="white", hw=0.1, axes=TRUE, box=TRUE, zebra=FALSE, zebra.cex=1, maxcell=500000, buffer=FALSE, clip=TRUE,
446463
# for rgb
447464
stretch=NULL, scale=NULL, bgalpha=NULL, zlim=NULL, zcol=NULL, overview=NULL,
448465
#catch and kill
@@ -610,6 +627,8 @@
610627
}
611628
out$leg$reverse <- isTRUE(reverse)
612629
out$box <- isTRUE(box)
630+
out$zebra <- isTRUE(zebra)
631+
out$zebra.cex <- zebra.cex
613632

614633
# if (!is.null(out$leg$loc)) {
615634
# out$leg$x <- out$leg$loc
@@ -674,7 +693,7 @@
674693

675694

676695
setMethod("plot", signature(x="SpatRaster", y="numeric"),
677-
function(x, y=1, col, type=NULL, mar=NULL, legend=TRUE, axes=!add, plg=list(), pax=list(), maxcell=500000, smooth=FALSE, range=NULL, fill_range=FALSE, levels=NULL, all_levels=FALSE, breaks=NULL, breakby="eqint", fun=NULL, colNA=NULL, alpha=NULL, sort=FALSE, reverse=FALSE, grid=FALSE, ext=NULL, reset=FALSE, add=FALSE, buffer=FALSE, background=NULL, box=axes, clip=TRUE, overview=NULL, ...) {
696+
function(x, y=1, col, type=NULL, mar=NULL, legend=TRUE, axes=!add, plg=list(), pax=list(), maxcell=500000, smooth=FALSE, range=NULL, fill_range=FALSE, levels=NULL, all_levels=FALSE, breaks=NULL, breakby="eqint", fun=NULL, colNA=NULL, alpha=NULL, sort=FALSE, reverse=FALSE, grid=FALSE, zebra=FALSE, ext=NULL, reset=FALSE, add=FALSE, buffer=FALSE, background=NULL, box=axes, clip=TRUE, overview=NULL, ...) {
678697

679698
old.mar <- graphics::par()$mar
680699
on.exit(graphics::par(mar=old.mar))
@@ -703,7 +722,7 @@ setMethod("plot", signature(x="SpatRaster", y="numeric"),
703722
alpha <- alpha[[y]]
704723
}
705724
}
706-
plot(x, col=col, type=type, mar=mar, legend=legend, axes=axes, plg=plg, pax=pax, maxcell=2*maxcell/length(y), smooth=smooth, range=range, fill_range=fill_range, levels=levels, all_levels=all_levels, breaks=breaks, breakby=breakby, fun=fun, colNA=colNA, alpha=alpha, grid=grid, sort=sort, reverse=reverse, ext=ext, reset=reset, add=add, buffer=buffer, background=background, box=box, clip=clip, overview=overview, ...)
725+
plot(x, col=col, type=type, mar=mar, legend=legend, axes=axes, plg=plg, pax=pax, maxcell=2*maxcell/length(y), smooth=smooth, range=range, fill_range=fill_range, levels=levels, all_levels=all_levels, breaks=breaks, breakby=breakby, fun=fun, colNA=colNA, alpha=alpha, zebra=zebra, grid=grid, sort=sort, reverse=reverse, ext=ext, reset=reset, add=add, buffer=buffer, background=background, box=box, clip=clip, overview=overview, ...)
707726
return(invisible())
708727
} else {
709728
x <- x[[y]]
@@ -779,7 +798,7 @@ setMethod("plot", signature(x="SpatRaster", y="numeric"),
779798
}
780799
}
781800

782-
x <- .prep.plot.data(x, type=type, cols=col, mar=mar, draw=TRUE, plg=plg, pax=pax, legend=isTRUE(legend), axes=isTRUE(axes), coltab=coltab, cats=cats, interpolate=smooth, levels=levels, range=range, fill_range=fill_range, colNA=colNA, alpha=alpha, reset=reset, grid=grid, sort=sort, reverse=reverse, ext=ext, all_levels=all_levels, breaks=breaks, breakby=breakby, add=add, buffer=buffer, background=background, box=box, maxcell=maxcell, clip=clip, overview=overview, ...)
801+
x <- .prep.plot.data(x, type=type, cols=col, mar=mar, draw=TRUE, plg=plg, pax=pax, legend=isTRUE(legend), axes=isTRUE(axes), coltab=coltab, cats=cats, interpolate=smooth, levels=levels, range=range, fill_range=fill_range, colNA=colNA, alpha=alpha, reset=reset, grid=grid, zebra=zebra, sort=sort, reverse=reverse, ext=ext, all_levels=all_levels, breaks=breaks, breakby=breakby, add=add, buffer=buffer, background=background, box=box, maxcell=maxcell, clip=clip, overview=overview, ...)
783802

784803
add_more(fun, y)
785804

‎R/plot_vector.R‎

Lines changed: 20 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -337,6 +337,15 @@ setMethod("dots", signature(x="SpatVector"),
337337
.plot.vect.map <- function(x, out, ...) {
338338

339339
if ((!out$add) & (!out$legend_only)) {
340+
if (out$zebra) {
341+
width <- rep(min(diff(out$lim[1:2]), diff(out$lim[3:4])) / 100, 2) * out$zebra.cex
342+
if (out$lonlat) {
343+
asp <- 1/cos((mean(out$lim[3:4]) * pi)/180)
344+
width[2] <- width[2] / asp
345+
}
346+
out$lim[1:2] <- out$lim[1:2] + c(-width[1], width[1])
347+
out$lim[3:4] <- out$lim[3:4] + c(-width[2], width[2])
348+
}
340349
if (!any(is.na(out$mar))) { graphics::par(mar=out$mar) }
341350
plot(out$lim[1:2], out$lim[3:4], type="n", xlab="", ylab="", asp=out$asp, xaxs="i", yaxs="i", axes=FALSE, main="")
342351
if (!is.null(out$background)) {
@@ -383,6 +392,11 @@ setMethod("dots", signature(x="SpatVector"),
383392
}
384393

385394
out <- .plot.axes(out)
395+
if (out$zebra) {
396+
zebra(width=width, x=out$axs$xat, y=out$axs$yat)
397+
out$lim[1:2] <- out$lim[1:2] + c(width[1], -width[1])
398+
out$lim[3:4] <- out$lim[3:4] + c(width[2], -width[2])
399+
}
386400

387401
if (out$legend_draw) {
388402
if (out$legend_type == "continuous") {
@@ -433,7 +447,7 @@ setMethod("dots", signature(x="SpatVector"),
433447
.prep.vect.data <- function(x, y, type=NULL, cols=NULL, mar=NULL, legend=TRUE,
434448
legend.only=FALSE, levels=NULL, add=FALSE, range=NULL, fill_range=FALSE, breaks=NULL, breakby="eqint",
435449
xlim=NULL, ylim=NULL, colNA=NA, alpha=NULL, axes=TRUE, buffer=TRUE, background=NULL,
436-
pax=list(), plg=list(), ext=NULL, grid=FALSE, las=0, sort=TRUE, reverse=FALSE, values=NULL,
450+
pax=list(), plg=list(), ext=NULL, grid=FALSE, zebra=FALSE, zebra.cex=1, las=0, sort=TRUE, reverse=FALSE, values=NULL,
437451
box=TRUE, xlab="", ylab="", cex.lab=0.8, line.lab=1.5, yaxs="i", xaxs="i",
438452
main="", cex.main=1.2, line.main=0.5, font.main=graphics::par()$font.main, col.main = graphics::par()$col.main, loc.main=NULL,
439453
sub = "", font.sub=1, cex.sub=0.8*cex.main, line.sub =1.75, col.sub=col.main, loc.sub=NULL,
@@ -526,6 +540,9 @@ setMethod("dots", signature(x="SpatVector"),
526540
out$dig.lab <- dig.lab
527541

528542
out$box <- isTRUE(box)
543+
out$zebra <- isTRUE(zebra)
544+
out$zebra.cex <- zebra.cex
545+
529546
out$add <- isTRUE(add)
530547
out$axes <- isTRUE(axes)
531548
out$xlab <- xlab
@@ -682,7 +699,7 @@ setMethod("dots", signature(x="SpatVector"),
682699

683700
setMethod("plot", signature(x="SpatVector", y="character"),
684701
function(x, y, col=NULL, type=NULL, mar=NULL, legend=TRUE, axes=!add, plg=list(), pax=list(),
685-
main="", grid=FALSE, ext=NULL, sort=TRUE, reverse=FALSE, fun=NULL,
702+
main="", grid=FALSE, zebra=FALSE, ext=NULL, sort=TRUE, reverse=FALSE, fun=NULL,
686703
colNA=NA, alpha=NULL, nr, nc, add=FALSE, buffer=TRUE, background=NULL,
687704
box=axes, clip=TRUE, ...) {
688705

@@ -738,7 +755,7 @@ setMethod("plot", signature(x="SpatVector", y="character"),
738755

739756
if (missing(col)) col <- NULL
740757

741-
out <- .prep.vect.data(x, y[i], type=type, cols=col, mar=mar, plg=plg, pax=pax, legend=isTRUE(legend), add=add, axes=axes, main=main[i], buffer=buffer, background=background, grid=grid, ext=ext, sort=sort, reverse=reverse, colNA=colNA, alpha=alpha, box=box, clip=clip, leg_i=i, ...)
758+
out <- .prep.vect.data(x, y[i], type=type, cols=col, mar=mar, plg=plg, pax=pax, legend=isTRUE(legend), add=add, axes=axes, main=main[i], buffer=buffer, background=background, grid=grid, zebra=zebra, ext=ext, sort=sort, reverse=reverse, colNA=colNA, alpha=alpha, box=box, clip=clip, leg_i=i, ...)
742759

743760
add_more(fun, i)
744761

‎man/plot.Rd‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,8 @@ There is a separate help file for plotting a \code{\link[=plot,SpatGraticule,mis
2828
\usage{
2929
\S4method{plot}{SpatRaster,numeric}(x, y=1, col, type=NULL, mar=NULL, legend=TRUE, axes=!add, plg=list(), pax=list(),
3030
maxcell=500000, smooth=FALSE, range=NULL, fill_range=FALSE, levels=NULL,
31-
all_levels=FALSE, breaks=NULL, breakby="eqint", fun=NULL, colNA=NULL,
32-
alpha=NULL, sort=FALSE, reverse=FALSE, grid=FALSE, ext=NULL, reset=FALSE,
31+
all_levels=FALSE, breaks=NULL, breakby="eqint", fun=NULL, colNA=NULL, alpha=NULL,
32+
sort=FALSE, reverse=FALSE, grid=FALSE, zebra=FALSE, ext=NULL, reset=FALSE,
3333
add=FALSE, buffer=FALSE, background=NULL, box=axes, clip=TRUE, overview=NULL, ...)
3434

3535
\S4method{plot}{SpatRaster,missing}(x, y, main, mar=NULL, nc, nr, maxnl=16, maxcell=500000, add=FALSE,
@@ -38,7 +38,7 @@ There is a separate help file for plotting a \code{\link[=plot,SpatGraticule,mis
3838
\S4method{plot}{SpatRaster,character}(x, y, ...)
3939

4040
\S4method{plot}{SpatVector,character}(x, y, col=NULL, type=NULL, mar=NULL, legend=TRUE, axes=!add, plg=list(), pax=list(),
41-
main="", grid=FALSE, ext=NULL, sort=TRUE, reverse=FALSE, fun=NULL,
41+
main="", grid=FALSE, zebra=FALSE, ext=NULL, sort=TRUE, reverse=FALSE, fun=NULL,
4242
colNA=NA, alpha=NULL, nr, nc, add=FALSE, buffer=TRUE, background=NULL,
4343
box=axes, clip=TRUE, ...)
4444

@@ -107,6 +107,7 @@ There is a separate help file for plotting a \code{\link[=plot,SpatGraticule,mis
107107
\item{sort}{logical. If \code{TRUE} legends with categorical values are sorted. If \code{x} is a \code{SpatVector} you can also supply a vector of the unique values, in the order in which you want them to appear in the legend}
108108
\item{reverse}{logical. If \code{TRUE}, the legend order is reversed}
109109
\item{grid}{logical. If \code{TRUE} grid lines are drawn. Their properties such as type and color can be set with the \code{pax} argument}
110+
\item{zebra}{logical. If \code{TRUE}, a "zebra-box" is added to the axes. The width of the zebra-box can be set with additional argument \code{zebra.cex}}
110111
\item{nc}{positive integer. Optional. The number of columns to divide the plotting device in (when plotting multiple layers)}
111112
\item{nr}{positive integer. Optional. The number of rows to divide the plotting device in (when plotting multiple layers)}
112113
\item{main}{character. Main plot titles (one for each layer to be plotted). You can use arguments \code{cex.main}, \code{font.main}, \code{col.main} to change the appearance; and \code{loc.main} to change the location of the main title (either two coordinates, or a character value such as "topleft"). You can also use \code{sub=""} for a subtitle. See \code{\link{title}}}

0 commit comments

Comments
 (0)