key.pos can hold relative key position in available space

see r-spatial/stars#642

Author: edzer

NEWS.md

@@ -1,6 +1,8 @@
 # version 1.0-15
 
-* `[<-.sf` fixes the `agr` attribute if it is broken; #2211
+* `plot.sf()`: `key.width` is sensitive to pointsize graphics parameter, `key.pos` can hold a second value in [0, 1] determining the relative position of the key in the available space
+
+* `[<-.sf` fixes the `agr` attribute when it is broken; #2211
 
 * `sf` objects get a new attribute, `.sf_namespace`, which forces loading the `sf` namespace when it has not been loaded so far, e.g. for proper printing or plotting of an `sf` object; #2212 by Mike Mahoney
 

R/plot.R

@@ -11,7 +11,7 @@
 #' @param nbreaks number of colors breaks (ignored for \code{factor} or \code{character} variables)
 #' @param breaks either a numeric vector with the actual breaks, or a name of a method accepted by the \code{style} argument of \link[classInt]{classIntervals}
 #' @param max.plot integer; lower boundary to maximum number of attributes to plot; the default value (9) can be overriden by setting the global option \code{sf_max.plot}, e.g. \code{options(sf_max.plot=2)}
-#' @param key.pos integer; side to plot a color key: 1 bottom, 2 left, 3 top, 4 right; set to \code{NULL} to omit key completely, 0 to only not plot the key, or -1 to select automatically. If multiple columns are plotted in a single function call by default no key is plotted and every submap is stretched individually; if a key is requested (and \code{col} is missing) all maps are colored according to a single key. Auto select depends on plot size, map aspect, and, if set, parameter \code{asp}.
+#' @param key.pos numeric; side to plot a color key: 1 bottom, 2 left, 3 top, 4 right; set to \code{NULL} to omit key completely, 0 to only not plot the key, or -1 to select automatically. If multiple columns are plotted in a single function call by default no key is plotted and every submap is stretched individually; if a key is requested (and \code{col} is missing) all maps are colored according to a single key. Auto select depends on plot size, map aspect, and, if set, parameter \code{asp}. If it has lenght 2, the second value, ranging from 0 to 1, determines where the key is placed in the available space (default: 0.5, center).
 #' @param key.width amount of space reserved for the key (incl. labels), thickness/width of the scale bar
 #' @param key.length amount of space reserved for the key along its axis, length of the scale bar
 #' @param pch plotting symbol
@@ -72,7 +72,7 @@
 #' @export
 plot.sf <- function(x, y, ..., main, pal = NULL, nbreaks = 10, breaks = "pretty",
 		max.plot = if(is.null(n <- getOption("sf_max.plot"))) 9 else n,
-		key.pos = get_key_pos(x, ...), key.length = .618, key.width = lcm(1.8),
+		key.pos = get_key_pos(x, ...), key.length = .618, key.width = lcm(1.8 * par("ps")/12),
 		reset = TRUE, logz = FALSE, extent = x, xlim = st_bbox(extent)[c(1,3)],
 		ylim = st_bbox(extent)[c(2,4)]) {
 
@@ -89,8 +89,9 @@ plot.sf <- function(x, y, ..., main, pal = NULL, nbreaks = 10, breaks = "pretty"
 	opar = par()
 	if (ncol(x) > 2 && !isTRUE(dots$add)) { # multiple maps to plot...
 		cols = setdiff(names(x), attr(x, "sf_column"))
-		lt = .get_layout(st_bbox(x), min(max.plot, length(cols)), par("din"), key.pos, key.width)
-		key.pos = lt$key.pos
+		lt = .get_layout(st_bbox(x), min(max.plot, length(cols)), par("din"), key.pos[1], key.width)
+		if (key.pos.missing || key.pos == -1)
+			key.pos = lt$key.pos
 		layout(lt$m, widths = lt$widths, heights = lt$heights, respect = FALSE)
 
 		if (isTRUE(dots$axes))
@@ -140,7 +141,7 @@ plot.sf <- function(x, y, ..., main, pal = NULL, nbreaks = 10, breaks = "pretty"
 			plot.new()
 
 		# plot key?
-		if (!is.null(key.pos) && key.pos != 0 && col_missing) {
+		if (!is.null(key.pos) && key.pos[1] != 0 && col_missing) {
 			if (is.null(pal))
 				pal = function(n) sf.colors(n, categorical = is.factor(values))
 			colors = if (is.function(pal))
@@ -229,7 +230,7 @@ plot.sf <- function(x, y, ..., main, pal = NULL, nbreaks = 10, breaks = "pretty"
 					(is.factor(values) || length(unique(na.omit(values))) > 1 || breaks_numeric) && # 2065
 					length(col) > 1) { # plot key?
 
-				switch(key.pos,
+				switch(key.pos[1],
 					layout(matrix(c(2,1), nrow = 2, ncol = 1),
 						widths = 1, heights = c(1, key.width)), # 1 bottom
 					layout(matrix(c(1,2), nrow = 1, ncol = 2),
@@ -779,6 +780,24 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 	axis(side, at = at, labels = labels, ...)
 }
 
+# given range r = (a,b), return a value range that:
+#  * scales such that (b-a)/(y-x)=l
+#  * shifts linearly within [x,y] such that a==x if o==0, or b==y if o==1
+xy_from_r = function(r, l, o) {
+	stopifnot(length(r) == 2, l <= 1, l > 0, o >= 0, o <= 1)
+	a = r[1]
+	b = r[2]
+	if (o == 1) {
+		y = b
+		x = b - (b-a)/l
+	} else {
+		i = o / (o-1)
+		y = (a + (b-a)/l - i * b)/(1 - i)
+		x = i * (y - b) + a
+	}
+	c(x, y)
+}
+
 #' @name stars
 #' @export
 #' @param z ignore
@@ -801,6 +820,11 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 	zlim = range(z, na.rm = TRUE)
 	if (is.null(breaks))
 		breaks = seq(zlim[1], zlim[2], length.out = length(col) + 1)
+	offset = 0.5
+	if (length(key.pos) == 2) {
+		offset = key.pos[2]
+		key.pos = key.pos[1]
+	}
 	if (is.character(key.length)) {
 		kl = as.numeric(gsub(" cm", "", key.length))
 		sz = if (key.pos %in% c(1,3))
@@ -814,14 +838,13 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 		at = pretty(br)
 		at = at[at > br[1] & at < br[2]]
 	}
-	kl_lim = function(r, kl) { m = mean(r); (r - m)/kl + m }
 	if (key.pos %in% c(1,3)) {
 		ylim = c(0, 1)
-		xlim = kl_lim(range(breaks), key.length)
+		xlim = xy_from_r(range(breaks), key.length, offset)
 		mar = c(0, ifelse(axes, 2.1, 1), 0, 1)
 	}
 	if (key.pos %in% c(2,4)) {
-		ylim = kl_lim(range(breaks), key.length)
+		ylim = xy_from_r(range(breaks), key.length, offset)
 		xlim = c(0, 1)
 		mar = c(ifelse(axes, 2.1, 1), 0, 1.2, 0)
 	}
@@ -876,6 +899,11 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 	# TODO:
 	ksz = as.numeric(gsub(" cm", "", key.width)) * 2
 	breaks = (0:n) + 0.5
+	offset = 0.5
+	if (length(key.pos) == 2) {
+		offset = key.pos[2]
+		key.pos = key.pos[1]
+	}
 	if (is.character(key.length)) {
 		kl = as.numeric(gsub(" cm", "", key.length))
 		sz = if (key.pos %in% c(1,3))
@@ -884,17 +912,15 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 				dev.size("cm")[2]
 		key.length = kl/sz
 	}
-	kl_lim = function(r, kl) { m = mean(r); (r - m)/kl + m }
 	if (key.pos %in% c(1,3)) {
 		ylim = c(0, 1)
-		xlim = kl_lim(range(breaks), key.length)
+		xlim = xy_from_r(range(breaks), key.length, offset)
 		mar = c(0, ifelse(axes, 2.1, 1), 0, 1)
 		mar[key.pos] = 2.1
 	} else {
-		ylim = kl_lim(range(breaks), key.length)
+		ylim = xy_from_r(range(breaks), key.length, offset)
 		xlim = c(0, 1)
 		mar = c(ifelse(axes, 2.1, 1), 0, 1.2, 0)
-		#mar[key.pos] = 2.1
 		mar[key.pos] = max(ksz - 1.3, 0.0)
 	}
 	par(mar = mar)