Avoid side effects on PROJ_LIB when loading sf

DESCRIPTION

@@ -145,3 +145,4 @@ Collate:
     'deprecated.R'
     'z_range.R'
     'm_range.R'
+    'setprojpath.R'

NAMESPACE

@@ -334,6 +334,7 @@ export(get_key_pos)
 export(plot_sf)
 export(rawToHex)
 export(read_sf)
+export(setprojpath)
 export(sf.colors)
 export(sf_as_sfc.pq_geometry)
 export(sf_extSoftVersion)

R/crs.R

@@ -43,11 +43,14 @@ Ops.crs <- function(e1, e2) {
 #' @details The *crs functions create, get, set or replace the \code{crs} attribute of a simple feature geometry
 #' list-column. This attribute is of class \code{crs}, and is a list consisting of \code{epsg} (integer EPSG
 #' code) and \code{proj4string} (character).
-#' Comparison of two objects of class \code{crs} uses the GDAL function 
+#' Comparison of two objects of class \code{crs} uses the GDAL function
 #' \code{OGRSpatialReference::IsSame}.
 #' @return Object of class \code{crs}, which is a list with elements \code{epsg} (length-1 integer) and
 #' \code{proj4string} (length-1 character).
-st_crs = function(x, ...) UseMethod("st_crs")
+st_crs = function(x, ...) {
+	setprojpath()
+	UseMethod("st_crs")
+}
 
 #' @name st_crs
 #' @export
@@ -216,7 +219,7 @@ st_is_longlat = function(x) {
 			bb = st_bbox(x)
 			# check for potentially meaningless value range:
 			eps = sqrt(.Machine$double.eps)
-			if (all(!is.na(unclass(bb))) && 
+			if (all(!is.na(unclass(bb))) &&
 					(bb["xmin"] < (-180-eps) || bb["xmax"] > (360+eps) || bb["ymin"] < (-90-eps) || bb["ymax"] > (90+eps)))
 				warning("bounding box has potentially an invalid value range for longlat data")
 		}
@@ -253,7 +256,7 @@ udunits_from_proj = list(
 crs_parameters = function(x) {
 	stopifnot(!is.na(x))
 	ret = structure(CPL_crs_parameters(x$proj4string),
-		names = c("SemiMajor", "SemiMinor", "InvFlattening", "units_gdal", 
+		names = c("SemiMajor", "SemiMinor", "InvFlattening", "units_gdal",
 			"IsVertical", "WktPretty", "Wkt"))
 	units(ret$SemiMajor) = as_units("m")
 	units(ret$SemiMinor) = as_units("m")

R/init.R

@@ -69,15 +69,15 @@ sf_extSoftVersion = function() {
 load_gdal <- function() {
 	if (file.exists(system.file("proj/nad.lst", package = "sf")[1])) {
 		# nocov start
-		prj = system.file("proj", package = "sf")[1]
-		if (! CPL_set_data_dir(prj)) { # if TRUE, uses C API to set path, leaving PROJ_LIB alone
-			assign(".sf.PROJ_LIB", Sys.getenv("PROJ_LIB"), envir=.sf_cache)
-			Sys.setenv("PROJ_LIB" = prj)
-		}
+		# prj = system.file("proj", package = "sf")[1]
+		# if (! CPL_set_data_dir(prj)) { # if TRUE, uses C API to set path, leaving PROJ_LIB alone
+		# 	assign(".sf.PROJ_LIB", Sys.getenv("PROJ_LIB"), envir=.sf_cache)
+		# 	# Sys.setenv("PROJ_LIB" = system.file("proj", package = "sf")[1])
+		# }
 		CPL_use_proj4_init_rules(1L)
-		assign(".sf.GDAL_DATA", Sys.getenv("GDAL_DATA"), envir=.sf_cache)
-		gdl = system.file("gdal", package = "sf")[1]
-		Sys.setenv("GDAL_DATA" = gdl)
+		# assign(".sf.GDAL_DATA", Sys.getenv("GDAL_DATA"), envir=.sf_cache)
+		# gdl = system.file("gdal", package = "sf")[1]
+		# Sys.setenv("GDAL_DATA" = gdl)
 		# nocov end
 	}
 	CPL_gdal_init()
@@ -96,14 +96,14 @@ load_gdal <- function() {
 
 unload_gdal <- function() {
 	CPL_gdal_cleanup_all()
-	if (file.exists(system.file("proj/nad.lst", package = "sf")[1])) {
-		# nocov start
-		if (! CPL_set_data_dir(system.file("proj", package = "sf")[1])) # set back:
-			Sys.setenv("PROJ_LIB"=get(".sf.PROJ_LIB", envir=.sf_cache))
-
-		Sys.setenv("GDAL_DATA"=get(".sf.GDAL_DATA", envir=.sf_cache))
-		# nocov end
-	}
+	# if (file.exists(system.file("proj/nad.lst", package = "sf")[1])) {
+	# 	# nocov start
+	# 	if (! CPL_set_data_dir(system.file("proj", package = "sf")[1])) # set back:
+	# 		Sys.setenv("PROJ_LIB"=get(".sf.PROJ_LIB", envir=.sf_cache))
+	#
+	# 	Sys.setenv("GDAL_DATA"=get(".sf.GDAL_DATA", envir=.sf_cache))
+	# 	# nocov end
+	# }
 	units::remove_symbolic_unit("link")
 	units::remove_symbolic_unit("us_in")
 	units::remove_symbolic_unit("ind_yd")

R/read.R

@@ -29,7 +29,7 @@ set_utf8 = function(x) {
 #' @param ... parameter(s) passed on to \link{st_as_sf}
 #' @param options character; driver dependent dataset open options, multiple
 #'   options supported. For possible values, see the "Open options" section
-#'   of the GDAL documentation of the corresponding driver, and 
+#'   of the GDAL documentation of the corresponding driver, and
 #'   https://github.com/r-spatial/sf/issues/1157 for an example.
 #' @param quiet logical; suppress info on name, driver, size and spatial
 #'   reference, or signaling no or multiple layers
@@ -44,8 +44,8 @@ set_utf8 = function(x) {
 #'   of LineString and MultiLineString, or of Polygon and MultiPolygon, convert
 #'   all to the Multi variety; defaults to \code{TRUE}
 #' @param stringsAsFactors logical; logical: should character vectors be
-#'   converted to factors?  The `factory-fresh' default is \code{TRUE} for 
-#'   \code{st_read} and \code{FALSE} for \code{read_sf}, but this can be changed 
+#'   converted to factors?  The `factory-fresh' default is \code{TRUE} for
+#'   \code{st_read} and \code{FALSE} for \code{read_sf}, but this can be changed
 #'   globally by e.g. the R command \code{options(stringsAsFactors = FALSE)}.
 #' @param int64_as_string logical; if TRUE, Int64 attributes are returned as
 #'   string; if FALSE, they are returned as double and a warning is given when
@@ -112,11 +112,14 @@ set_utf8 = function(x) {
 #'    query = sprintf("SELECT NAME, SID74, FIPS, geom  FROM \"%s\" WHERE BIR74 > 20000", layer))
 #' }
 #' # spatial filter, as wkt:
-#' wkt = st_as_text(st_geometry(nc[1,])) 
+#' wkt = st_as_text(st_geometry(nc[1,]))
 #' # filter by (bbox overlaps of) first feature geometry:
 #' read_sf(system.file("gpkg/nc.gpkg", package="sf"), wkt_filter = wkt)
 #' @export
-st_read = function(dsn, layer, ...) UseMethod("st_read")
+st_read = function(dsn, layer, ...) {
+	setprojpath()
+	UseMethod("st_read")
+}
 
 #' @export
 st_read.default = function(dsn, layer, ...) {
@@ -218,7 +221,6 @@ st_read.character = function(dsn, layer, ..., query = NA, options = NULL, quiet
 
 	if (length(promote_to_multi) > 1)
 		stop("`promote_to_multi' should have length one, and applies to all geometry columns")
-
 	x = CPL_read_ogr(dsn, layer, query, as.character(options), quiet, type, fid_column_name,
 		drivers, wkt_filter, promote_to_multi, int64_as_string, dsn_exists, dsn_isdb)
 	process_cpl_read_ogr(x, quiet, check_ring_dir = check_ring_dir,
@@ -311,38 +313,38 @@ abbreviate_shapefile_names = function(x) {
 #' are found at \url{http://www.gdal.org/ogr_formats.html}.
 #' @param ... other arguments passed to \link{dbWriteTable} when \code{dsn} is a
 #' Database Connection
-#' @param dataset_options character; driver dependent dataset creation options; 
+#' @param dataset_options character; driver dependent dataset creation options;
 #' multiple options supported.
-#' @param layer_options character; driver dependent layer creation options; 
+#' @param layer_options character; driver dependent layer creation options;
 #' multiple options supported.
 #' @param quiet logical; suppress info on name, driver, size and spatial reference
-#' @param factorsAsCharacter logical; convert \code{factor} objects into 
+#' @param factorsAsCharacter logical; convert \code{factor} objects into
 #' character strings (default), else into numbers by \code{as.numeric}.
-#' @param update logical; \code{FALSE} by default for single-layer drivers but 
+#' @param update logical; \code{FALSE} by default for single-layer drivers but
 #' \code{TRUE} by default for database drivers as defined by \code{db_drivers}.
-#' For database-type drivers (e.g. GPKG) \code{TRUE} values will make 
+#' For database-type drivers (e.g. GPKG) \code{TRUE} values will make
 #' \code{GDAL} try to update (append to) the existing data source, e.g. adding
 #' a table to an existing database, or adding records to a layer. See also the
 #' next two arguments and Details.
-#' @param delete_dsn logical; delete data source \code{dsn} before attempting 
+#' @param delete_dsn logical; delete data source \code{dsn} before attempting
 #' to write?
 #' @param delete_layer logical; delete layer \code{layer} before attempting to
 #' write?
 #' @param fid_column_name character, name of column with feature IDs; if
 #' specified, this column is no longer written as feature attribute.
-#' @details 
-#' Columns (variables) of a class not supported are dropped with a warning. 
-#' 
+#' @details
+#' Columns (variables) of a class not supported are dropped with a warning.
+#'
 #' When updating an existing layer, records are appended to it if the updating
-#' object has the right variable names and types. If names don't match an 
+#' object has the right variable names and types. If names don't match an
 #' error is raised. If types don't match, behaviour is undefined: GDAL may
 #' raise warnings or errors or fail silently.
-#' 
-#' When deleting layers or data sources is not successful, no error is emitted. 
+#'
+#' When deleting layers or data sources is not successful, no error is emitted.
 #' \code{delete_dsn} and \code{delete_layer} should be
 #' handled with care; the former may erase complete directories or databases.
 #' @seealso \link{st_drivers}
-#' @return \code{obj}, invisibly; in case \code{obj} is of class \code{sfc}, 
+#' @return \code{obj}, invisibly; in case \code{obj} is of class \code{sfc},
 #' it is returned as an \code{sf} object.
 #' @examples
 #' nc = st_read(system.file("shape/nc.shp", package="sf"))
@@ -351,7 +353,7 @@ abbreviate_shapefile_names = function(x) {
 #' data(meuse, package = "sp") # loads data.frame from sp
 #' meuse_sf = st_as_sf(meuse, coords = c("x", "y"), crs = 28992)
 #' # writes X and Y as columns:
-#' st_write(meuse_sf, paste0(tempdir(), "/", "meuse.csv"), layer_options = "GEOMETRY=AS_XY") 
+#' st_write(meuse_sf, paste0(tempdir(), "/", "meuse.csv"), layer_options = "GEOMETRY=AS_XY")
 #' st_write(meuse_sf, paste0(tempdir(), "/", "meuse.csv"), layer_options = "GEOMETRY=AS_WKT",
 #'   delete_dsn=TRUE) # overwrites
 #' \dontrun{

R/setprojpath.R

@@ -0,0 +1,22 @@
+#' Set the PROJ_LIB path to the 'proj' subfolder of `sf` installation
+#' folder on windows () and the GDAL_DATA folder to the 'GDAL_DATA' folder
+#' of `sf` and autoatically restore the previous (system) value upon
+#' exiting from the caller function. This avoids the need of modifying
+#' values of the two variables on load.
+#' @name setprojpath
+setprojpath <- function() {
+	if (file.exists(system.file("proj/nad.lst", package = "sf")[1])) {
+		prj = system.file("proj", package = "sf")[1]
+		curprojpath <- Sys.getenv("PROJ_LIB")
+		if (! CPL_set_data_dir(prj)) {
+			Sys.setenv("PROJ_LIB" = prj)
+		}
+		curgdalpath <- Sys.getenv("GDAL_DATA")
+		Sys.setenv("GDAL_DATA" = system.file("gdal", package = "sf")[1])
+		do.call(on.exit,
+				list(substitute(Sys.setenv("PROJ_LIB"  = curprojpath,
+										   "GDAL_DATA" = curgdalpath))),
+				envir = parent.frame()
+		)
+	}
+}

R/transform.R

@@ -20,8 +20,10 @@
 #' sfc
 #' st_transform(sfc, 3857)
 #' @export
-st_transform = function(x, crs, ...) UseMethod("st_transform")
-
+st_transform = function(x, crs, ...) {
+	setprojpath()
+	UseMethod("st_transform")
+}
 chk_pol = function(x, dim = class(x)[1]) {
 	PolClose = function(y) {
 		if (any(head(y[[1]], 1) != tail(y[[1]], 1))) # close
@@ -39,24 +41,24 @@ chk_pol = function(x, dim = class(x)[1]) {
 chk_mpol = function(x) {
 	cln = lapply(x, function(y) unclass(chk_pol(y, class(x)[1])))
 	empty = if (length(cln))
-			lengths(cln) == 0
-		else
-			TRUE
+		lengths(cln) == 0
+	else
+		TRUE
 	# print(empty)
 	st_multipolygon(cln[!empty], dim = class(x)[1])
 }
 
 sanity_check = function(x) {
-    d = st_dimension(x) # flags empty geoms as NA
-    if (any(d == 2, na.rm = TRUE)) { # the polygon stuff
+	d = st_dimension(x) # flags empty geoms as NA
+	if (any(d == 2, na.rm = TRUE)) { # the polygon stuff
 		if (inherits(x, "sfc_POLYGON"))
-        	st_sfc(lapply(x, chk_pol), crs = st_crs(x))
+			st_sfc(lapply(x, chk_pol), crs = st_crs(x))
 		else if (inherits(x, "sfc_MULTIPOLYGON"))
-        	st_sfc(lapply(x, chk_mpol), crs = st_crs(x))
+			st_sfc(lapply(x, chk_mpol), crs = st_crs(x))
 		else
 			stop(paste("no check implemented for", class(x)[1]))
-    } else
-        x # nocov
+	} else
+		x # nocov
 }
 
 #' @name st_transform
@@ -71,7 +73,7 @@ st_transform.sfc = function(x, crs, ..., partial = TRUE, check = FALSE, use_gdal
 
 	if (! use_gdal)
 		.Deprecated("lwgeom::st_transform_proj", "lwgeom",
-			'install with devtools::install_github("r-spatial/lwgeom")')
+					'install with devtools::install_github("r-spatial/lwgeom")')
 
 	crs = make_crs(crs)
 
@@ -87,7 +89,7 @@ st_transform.sfc = function(x, crs, ..., partial = TRUE, check = FALSE, use_gdal
 
 	if (crs != st_crs(x)) { # transform:
 		ret = structure(CPL_transform(x, crs$proj4string),
-			single_type = NULL, crs = crs)
+						single_type = NULL, crs = crs)
 		ret = st_sfc(ret)
 		if (check)
 			sanity_check(ret)
@@ -137,15 +139,15 @@ st_proj_info = function(type = "proj") {
 	if (type == "have_datum_files")
 		return(CPL_have_datum_files(0))
 
-    opts <- c("proj", "ellps", "datum", "units", "prime_meridians")
-    if (!(type %in% opts))
+	opts <- c("proj", "ellps", "datum", "units", "prime_meridians")
+	if (!(type %in% opts))
 		stop("unknown type") # nocov
-    t <- as.integer(match(type[1], opts) - 1)
+	t <- as.integer(match(type[1], opts) - 1)
 	res = CPL_proj_info(as.integer(t))
-    if (type == "proj")
+	if (type == "proj")
 		res$description <- sapply(strsplit(as.character(res$description), "\n"),
-			function(x) x[1])
-    data.frame(res)
+								  function(x) x[1])
+	data.frame(res)
 }
 
 #' @name st_transform