Merge branch 'main' into pointx

Author: edzer

NAMESPACE

@@ -7,6 +7,7 @@ S3method("$",z_range)
 S3method("$<-",sf)
 S3method("[",sf)
 S3method("[",sfc)
+S3method("[<-",sf)
 S3method("[<-",sfc)
 S3method("[[",sfc)
 S3method("[[<-",sf)

NEWS.md

@@ -1,5 +1,21 @@
+# version 1.0-15
+
+* `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; keys with factor levels suggest a proper size if they won't fit.
+
+* `[<-.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
+
+* `distinct.sf` is type-safe for `sf` objects with zero rows; #2204
+
+* `summarise.sf` raises an error if `.by` is given but no `across()` on the geometry; #2207
+
+* `st_write()` matches fields on name first, than on position; this matters for formats that have pre-defined names, such as GPX; #2202 
+
 # version 1.0-14
 
+* fix `plot.sf()` when using a key for multiple factor variables; #2196, #2195
+
 * fix use of `as.numeric_version` in a test, for upcoming change in r-devel
 
 * code tidy-ing: fix many lintr suggestions, thanks to Michael Chirico (#2181 - #2191)

R/agr.R

@@ -80,7 +80,15 @@ st_agr.default = function(x = NA_character_, ...) {
 #' @name st_agr
 #' @export
 st_set_agr = function(x, value) { 
-	st_agr(x) = value
+	if (!missing(value))
+		st_agr(x) = value
+	else { # needs repair?
+		value = st_agr(x)
+		if (any(is.na(names(value))) && length(value) == length(x) - 1) {
+			names(value) = setdiff(names(x), attr(x, "sf_column"))
+			st_agr(x) = value
+		}
+	}
 	x
 }
 

R/cast_sfc.R

@@ -147,6 +147,15 @@ empty_sfg <- function(to) {
 	   )
 }
 
+has_curves = function(x) {
+	if (inherits(x, c("sfc_MULTICURVE", "sfc_COMPOUNDCURVE", "sfc_CURVEPOLYGON"))) # for which GEOS has no st_is_empty()
+		TRUE
+	else if(inherits(x, "sfc_GEOMETRY")) {
+		cls = sapply(x, class)
+		any(cls[2,] %in% c("MULTICURVE", "COMPOUNDCURVE", "CURVEPOLYGON"))
+	} else
+		FALSE
+}
 
 #' @name st_cast
 #' @param ids integer vector, denoting how geometries should be grouped (default: no grouping)
@@ -169,7 +178,7 @@ st_cast.sfc = function(x, to, ..., ids = seq_along(x), group_or_split = TRUE) {
 		return(st_cast_sfc_default(x))
 
 	e = rep(FALSE, length(x))
-	if (!inherits(x, c("sfc_MULTICURVE", "sfc_COMPOUNDCURVE", "sfc_CURVEPOLYGON"))) { # for which GEOS has no st_is_empty()
+	if (!has_curves(x)) { # for which GEOS has no st_is_empty()
 		e = st_is_empty(x)
 		if (all(e)) {
 			x[e] = empty_sfg(to)
@@ -248,7 +257,6 @@ st_cast.sfc = function(x, to, ..., ids = seq_along(x), group_or_split = TRUE) {
 #' @details the \code{st_cast} method for \code{sf} objects can only split geometries, e.g. cast \code{MULTIPOINT} into multiple \code{POINT} features.  In case of splitting, attributes are repeated and a warning is issued when non-constant attributes are assigned to sub-geometries. To merge feature geometries and attribute values, use \link[sf:aggregate.sf]{aggregate} or \link[sf:tidyverse]{summarise}.
 st_cast.sf = function(x, to, ..., warn = TRUE, do_split = TRUE) {
 	geom = st_cast(st_geometry(x), to, group_or_split = do_split)
-	crs = st_crs(x)
 	agr = st_agr(x)
 	all_const = all_constant(x)
 	sf_column = attr(x, "sf_column") # keep name

R/defunct.R

@@ -13,9 +13,8 @@
 #' it will try to cast all the character columns, which can be long for very wide
 #' tables.
 #' @inheritParams st_read
-#' @docType package
 #' @export  st_read_db st_write_db
-#' @aliases st_read_db, st_write_db
+#' @aliases sf-package st_read_db, st_write_db
 #' @section Details:
 #' \tabular{rl}{
 #'   \code{st_read_db} \tab now a synonym for \code{\link{st_read}}\cr

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))
@@ -113,9 +114,11 @@ plot.sf <- function(x, y, ..., main, pal = NULL, nbreaks = 10, breaks = "pretty"
 
 		if (!is.null(key.pos)) {
 			values = do.call(c, as.data.frame(x)[cols])
+			if (is.character(values))
+				values = as.factor(values)
 			if (logz)
 				values = log10(values)
-			if (is.character(breaks)) { # compute breaks from values:
+			if (is.character(breaks) && is.numeric(values)) { # compute breaks from values:
 				v0 = values[!is.na(values)]
 				n.unq = length(unique(v0))
 				breaks = if (! all(is.na(values)) && n.unq > 1)
@@ -138,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))
@@ -227,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),
@@ -778,6 +781,24 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 	axis(side, at = at, labels = labels, ...)
 }
 
+# find out where to place the legend key:
+# given range r = (a, b), key.length l, key offset o, return a value range that:
+#  * scales such that (b - a) / (y - x) = l
+#  * shifts linearly within [x, y] from a = x when o = 0 to b = y when 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
@@ -789,15 +810,22 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 #' @param logz ignore
 #' @param ... ignore
 #' @param lab ignore
+#' @param cex.axis see \link{par}
 .image_scale = function(z, col, breaks = NULL, key.pos, add.axis = TRUE,
-		at = NULL, ..., axes = FALSE, key.length, logz = FALSE, lab = "") {
+		at = NULL, ..., axes = FALSE, key.length, logz = FALSE, lab = "", 
+		cex.axis = par("cex.axis")) {
 	if (!is.null(breaks) && length(breaks) != (length(col) + 1))
 		stop("must have one more break than colour")
 	stopifnot(is.character(lab) || is.expression(lab))
 	lab_set = (is.character(lab) && lab != "") || is.expression(lab)
 	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))
@@ -811,14 +839,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)
 	}
@@ -860,19 +887,23 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 			TRUE
 
 	if (add.axis)
-		axis(key.pos, at = at, labels = labels)
+		axis(key.pos, at = at, labels = labels, cex.axis = cex.axis)
 }
 
 #' @name stars
 #' @export
 #' @param key.width ignore
 .image_scale_factor = function(z, col, key.pos, add.axis = TRUE,
-	..., axes = FALSE, key.width, key.length) {
+	..., axes = FALSE, key.width, key.length, cex.axis = par("cex.axis")) {
 
 	n = length(z)
-	# TODO:
-	ksz = as.numeric(gsub(" cm", "", key.width)) * 2
+	ksz = max(strwidth(z, "inches")) / par("cin")[1] # in "mar" lines
 	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))
@@ -881,26 +912,33 @@ 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)
+		mar[key.pos] = ksz
 	}
 	par(mar = mar)
 
 	poly = vector(mode="list", length(col))
 	for (i in seq(poly))
 		poly[[i]] = c(breaks[i], breaks[i+1], breaks[i+1], breaks[i])
-	plot(1, 1, t = "n", ylim = ylim, xlim = xlim, axes = FALSE,
-		xlab = "", ylab = "", xaxs = "i", yaxs = "i")
+
+	tryCatch({
+		plot(1, 1, t = "n", ylim = ylim, xlim = xlim, axes = FALSE,
+			xlab = "", ylab = "", xaxs = "i", yaxs = "i")
+		},
+		error = function(x) {
+			sz = max(strwidth(z, "inches")) * 2.54 * 1.1 + par("ps")/12 # cm
+			stop(paste0("key.width too small, try key.width = lcm(", signif(sz, 3), ")"), call. = FALSE)
+		}
+	)
+
 	for(i in seq_along(poly)) {
 		if (key.pos %in% c(1,3))
 			polygon(poly[[i]], c(0, 0, 1, 1), col = col[i], border = NA)
@@ -917,7 +955,7 @@ bb2merc = function(x, cls = "ggmap") { # return bbox in the appropriate "web mer
 
 	if (add.axis) {
 		opar = par(las = 1)
-		axis(key.pos, at = 1:n, labels = z)
+		axis(key.pos, at = 1:n, labels = z, cex.axis = cex.axis)
 		par(opar)
 	}
 }

R/sf.R

@@ -299,12 +299,17 @@ st_sf = function(..., agr = NA_agr_, row.names,
 	st_agr(df) = agr
 	if (! missing(crs))
 		st_crs(df) = crs
+	
+	attr(df, ".sf_namespace") <- .sf_namespace
+	
 	df
 }
 
+.sf_namespace <- function() NULL
+
 #' @name sf
 #' @param x object of class \code{sf}
-#' @param i record selection, see \link{[.data.frame}
+#' @param i record selection, see \link{[.data.frame}, or a \code{sf} object to work with the \code{op} argument
 #' @param j variable selection, see \link{[.data.frame}
 #' @param drop logical, default \code{FALSE}; if \code{TRUE} drop the geometry column and return a \code{data.frame}, else make the geometry sticky and return a \code{sf} object.
 #' @param op function; geometrical binary predicate function to apply when \code{i} is a simple feature object
@@ -374,6 +379,11 @@ st_sf = function(..., agr = NA_agr_, row.names,
 	}
 }
 
+#' @export
+"[<-.sf" = function(x, i, j, value) {
+	st_set_agr(NextMethod())
+}
+
 #' @export
 "[[<-.sf" = function(x, i, value) {
 	agr = st_agr(x)

R/spatstat.R

@@ -19,8 +19,8 @@ check_spatstat <- function(pkg, X = NULL) {
 	if (!requireNamespace(pkg, quietly = TRUE))
 		stop("package ", pkg, " required, please install it (or the full spatstat package) first", call. = FALSE)
 	spst_ver <- try(packageVersion("spatstat"), silent = TRUE)
-	if (!inherits(spst_ver, "try-error") && spst_ver < 2.0-0)
-		stop(wrp(paste("You have an old version of spatstat installed which is incompatible with ", pkg, 
+	if (!inherits(spst_ver, "try-error") && spst_ver < "2.0-0")
+		stop(wrp(paste0("You have an old version of spatstat installed that is incompatible with ", pkg, 
 			". Please update spatstat (or uninstall it).")), call. = FALSE)
 	if (!is.null(X))
 		check_spatstat_ll(X)
@@ -138,9 +138,9 @@ as.ppp.sfc = function(X, W = NULL, ..., check = TRUE) {
 	spatstat.geom::ppp(cc[,1], cc[,2], window = W, marks = NULL, check = check)
 }
 
-as.ppp.sf = function(X) {
+as.ppp.sf = function(X, ...) {
 	check_spatstat("spatstat.geom", X)
-	pp = spatstat.geom::as.ppp(st_geometry(X))
+	pp = spatstat.geom::as.ppp(st_geometry(X), ...)
 	if (st_dimension(X[1,]) == 2)
 		X = X[-1,]
 	st_geometry(X) = NULL # remove geometry column

R/tidyverse.R

@@ -244,10 +244,19 @@ rename_with.sf = function(.data, .fn, .cols, ...) {
 	if (!requireNamespace("rlang", quietly = TRUE))
 		stop("rlang required: install that first") # nocov
 	.fn = rlang::as_function(.fn)
+	
+	sf_column = attr(.data, "sf_column")
+	sf_column_loc = match(sf_column, names(.data))
+	
+	if (length(sf_column_loc) != 1 || is.na(sf_column_loc))
+		stop("internal error: can't find sf column") # nocov
+	
 	agr = st_agr(.data)
+	
 	ret = NextMethod()
 	names(agr) = .fn(names(agr))
 	st_agr(ret) = agr
+	st_geometry(ret) = names(ret)[sf_column_loc]
 	ret
 }
 
@@ -313,6 +322,8 @@ summarise.sf <- function(.data, ..., .dots, do_union = TRUE, is_coverage = FALSE
 					geom = list() #676 #nocov
 				do.call(st_sfc, c(geom, crs = list(crs), precision = precision))
 			} else { # single group:
+				if (nrow(ret) > 1)
+					stop(paste0("when using .by, also add across(", sf_column, ", st_union) as argument")) # https://github.com/r-spatial/sf/issues/2207
 				if (do_union)
 					st_union(geom, is_coverage = is_coverage)
 				else
@@ -336,6 +347,8 @@ distinct.sf <- function(.data, ..., .keep_all = FALSE) {
 	sf_column = attr(.data, "sf_column")
 	geom = st_geometry(.data)
 	eq = sapply(st_equals(.data), head, n = 1)
+	if (is.list(eq) && length(eq) == 0) # empty list: geometry was empty set
+		eq = integer(0)
 	empties = which(lengths(eq) == 0)
 	eq[ empties ] = empties[1] # first empty record
 	.data[[ sf_column ]] = unlist(eq)