Skip to content

Commit 8ffd7f1

Browse files
rhijmansrhijmans
committed
r
1 parent 6573288 commit 8ffd7f1

File tree

1 file changed

+64
-38
lines changed

1 file changed

+64
-38
lines changed

‎R/plot_scale.R‎

Lines changed: 64 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -168,8 +168,29 @@ north <- function(xy=NULL, type=1, label="N", angle=0, d, head=0.1, xpd=TRUE, ..
168168
}
169169
}
170170

171+
draw_box <- function(xy, d, below, labels, box.col, cex=1, ...){
172+
h <- strheight("A", cex=cex)
173+
w <- c(strwidth(labels[1], cex=cex), strwidth(labels[length(labels)], cex=cex))
174+
box.col <- rep(box.col, length.out=2)
175+
b <- ifelse(isTRUE(nchar(below) > 1), 3.5, 1.5)
176+
e <- c(xy[1]-1.5*w[1], xy[1]+d+w[2], xy[2]-b*h, xy[2]+3*h)
177+
polys(vect(ext(e)), col=box.col[1], border=box.col[2], xpd=TRUE)
178+
}
179+
180+
181+
add_text <- function(halo=FALSE, ...) {
182+
if (halo) {
183+
halo(...)
184+
} else {
185+
text(...)
186+
}
187+
}
188+
189+
190+
sbar <- function(d, xy=NULL, type="line", divs=2, below="", lonlat=NULL, labels, adj=c(0.5, -1), lwd=2, xpd=TRUE, ticks=FALSE, scaleby=1, halo=TRUE, col="black", fill=c("black", "white"), border="black", ...){
171191

172-
sbar <- function(d, xy=NULL, type="line", divs=2, below="", lonlat=NULL, labels, adj=c(0.5, -1), lwd=2, xpd=TRUE, ticks=FALSE, scaleby=1, halo=TRUE, ...){
192+
box=FALSE
193+
box.col=c("white", "black")
173194

174195
stopifnot(type %in% c("line", "bar"))
175196
pr <- graphics::par()
@@ -178,6 +199,8 @@ sbar <- function(d, xy=NULL, type="line", divs=2, below="", lonlat=NULL, labels,
178199
if (is.null(lonlat)) {
179200
lonlat <- isTRUE(clp[[5]])
180201
}
202+
fill <- rep(fill, length.out=2)
203+
181204

182205
if (missing(d)) {
183206
labels <- NULL
@@ -190,11 +213,6 @@ sbar <- function(d, xy=NULL, type="line", divs=2, below="", lonlat=NULL, labels,
190213
xy <- .get_xy(xy, dd, 0, pr, "bottomleft", caller="sbar")
191214

192215
if (type == "line") {
193-
if (halo) {
194-
lines(matrix(c(xy[1], xy[2], xy[1]+dd, xy[2]), byrow=T, nrow=2), lwd=lwd+1, xpd=xpd, col="white")
195-
}
196-
lines(matrix(c(xy[1], xy[2], xy[1]+dd, xy[2]), byrow=T, nrow=2), lwd=lwd, xpd=xpd, ...)
197-
198216
if (missing(labels) || is.null(labels)) {
199217
ds <- d / scaleby
200218
if (divs > 2) {
@@ -203,6 +221,14 @@ sbar <- function(d, xy=NULL, type="line", divs=2, below="", lonlat=NULL, labels,
203221
labels <- paste(ds)
204222
}
205223
}
224+
if (box) draw_box(xy, dd, below, labels, box.col, ...)
225+
226+
227+
if (halo) {
228+
lines(matrix(c(xy[1], xy[2], xy[1]+dd, xy[2]), byrow=T, nrow=2), lwd=lwd+1, xpd=xpd, col="white")
229+
}
230+
lines(matrix(c(xy[1], xy[2], xy[1]+dd, xy[2]), byrow=T, nrow=2), lwd=lwd, xpd=xpd, col=fill[1], ...)
231+
206232
if (missing(adj)) {
207233
adj <- c(0.5, -0.2-lwd/20 )
208234
}
@@ -219,63 +245,63 @@ sbar <- function(d, xy=NULL, type="line", divs=2, below="", lonlat=NULL, labels,
219245
xtick <- c(xy[1], xy[1]+dd/2, xy[1]+dd)
220246
}
221247
for (i in 1:length(xtick)) {
222-
lines(rbind(c(xtick[i], xy[2]), c(xtick[i], xy[2]+tadd)), lwd=ceiling(lwd/2), ...)
248+
lines(rbind(c(xtick[i], xy[2]), c(xtick[i], xy[2]+tadd)), lwd=ceiling(lwd/2), xpd=TRUE, ...)
223249
}
224250
}
225-
tadd <- max(0, tadd)
251+
tadd <- max(strheight("0", cex=1)/5, tadd)
226252
if (length(labels) == 1) labels =c("", labels, "")
227-
if (halo) {
228-
.halo(xy[1], xy[2]+tadd,labels=labels[1], xpd=xpd, adj=adj, ...)
229-
.halo(xy[1]+0.5*dd, xy[2]+tadd,labels=labels[2], xpd=xpd, adj=adj,...)
230-
.halo(xy[1]+dd, xy[2]+tadd,labels=labels[3], xpd=xpd, adj=adj,...)
231-
} else {
232-
text(xy[1], xy[2]+tadd,labels=labels[1], xpd=xpd, adj=adj, ...)
233-
text(xy[1]+0.5*dd, xy[2]+tadd,labels=labels[2], xpd=xpd, adj=adj,...)
234-
text(xy[1]+dd, xy[2]+tadd,labels=labels[3], xpd=xpd, adj=adj,...)
235-
}
236-
xy[2] <- xy[2] - dd/10
253+
add_text(xy[1]+c(0,dd/2,dd),xy[2]+tadd, labels=labels, xpd=xpd, adj=adj, halo=halo, col=col, ...)
237254

238255
} else if (type == "bar") {
239256
stopifnot(divs > 0)
240257

258+
241259
if (missing(adj)) {
242-
adj <- c(0.5, -1 )
260+
adj <- c(0.5, -1)
243261
}
244262
lwd <- dd / 25
245263

246264
if (divs==2) {
247-
half <- xy[1] + dd / 2
248-
graphics::polygon(c(xy[1], xy[1], half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col="white", xpd=xpd)
249-
graphics::polygon(c(half, half, xy[1]+dd, xy[1]+dd ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col="black", xpd=xpd)
250265
if (missing(labels) || is.null(labels)) {
251266
labels <- c("0", "", d/scaleby)
252267
}
268+
if (box) draw_box(xy, dd, below, labels, box.col, ...)
253269

254-
text(xy[1], xy[2],labels=labels[1], xpd=xpd, adj=adj,...)
255-
text(xy[1]+0.5*dd, xy[2],labels=labels[2], xpd=xpd, adj=adj,...)
256-
text(xy[1]+dd, xy[2],labels=labels[3], xpd=xpd, adj=adj,...)
257-
} else {
258-
q1 <- xy[1] + dd / 4
259270
half <- xy[1] + dd / 2
260-
q3 <- xy[1] + 3 * dd / 4
261-
end <- xy[1] + dd
262-
graphics::polygon(c(xy[1], xy[1], q1, q1), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col="white", xpd=xpd)
263-
graphics::polygon(c(q1, q1, half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col="black", xpd=xpd)
264-
graphics::polygon(c(half, half, q3, q3 ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col="white", xpd=xpd)
265-
graphics::polygon(c(q3, q3, end, end), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col="black", xpd=xpd)
271+
graphics::polygon(c(xy[1], xy[1], half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col=fill[1], xpd=xpd, border=border)
272+
graphics::polygon(c(half, half, xy[1]+dd, xy[1]+dd ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col=fill[2], xpd=xpd, border=border)
273+
274+
add_text(xy[1], xy[2], labels=labels[1], xpd=xpd, adj=adj, halo=halo, col=col, ...)
275+
add_text(xy[1]+0.5*dd, xy[2], labels=labels[2], xpd=xpd, adj=adj, halo=halo, col=col,...)
276+
add_text(xy[1]+dd, xy[2], labels=labels[3], xpd=xpd, adj=adj, halo=halo, col=col,...)
277+
} else {
266278
if (missing(labels) || is.null(labels)) {
267279
ds <- d / scaleby
268280
labels <- c("0", round(0.5*ds), ds)
269281
}
270-
text(xy[1], xy[2], labels=labels[1], xpd=xpd, adj=adj, ...)
271-
text(half, xy[2], labels=labels[2], xpd=xpd, adj=adj,...)
272-
text(end, xy[2],labels=labels[3], xpd=xpd, adj=adj,...)
282+
if (box) draw_box(xy, dd, below, labels, box.col, ...)
283+
284+
q1 <- xy[1] + dd / 4
285+
half <- xy[1] + dd / 2
286+
q3 <- xy[1] + 3 * dd / 4
287+
end <- xy[1] + dd
288+
graphics::polygon(c(xy[1], xy[1], q1, q1), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col=fill[1], xpd=xpd, border=border)
289+
graphics::polygon(c(q1, q1, half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col=fill[2], xpd=xpd, border=border)
290+
graphics::polygon(c(half, half, q3, q3 ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col=fill[1], xpd=xpd, border=border)
291+
graphics::polygon(c(q3, q3, end, end), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col=fill[2], xpd=xpd, border=border)
292+
add_text(xy[1], xy[2], labels=labels[1], xpd=xpd, adj=adj, halo=halo, col=col, ...)
293+
add_text(half, xy[2], labels=labels[2], xpd=xpd, adj=adj, halo=halo, col=col,...)
294+
add_text(end, xy[2],labels=labels[3], xpd=xpd, adj=adj, halo=halo, col=col,...)
273295
}
274296
}
275297
if (below != "") {
276298
adj[2] <- -adj[2]
277-
text(xy[1]+(0.5*dd), xy[2], xpd=xpd, labels=below, adj=adj,...)
299+
if (type == "line") {
300+
xy[2] <- xy[2] - strheight("1")/1.5
301+
} else {
302+
xy[2] <- xy[2] - strheight("1")/4
303+
}
304+
add_text(xy[1]+(dd/2), xy[2], xpd=xpd, labels=below, adj=adj, halo=halo, col=col, ...)
278305
}
279306
}
280307

281-

0 commit comments

Comments
 (0)