R/read.R

Defines functions is_driver_can is_driver_available guess_driver_can_write is_db_driver guess_driver st_layers print.sf_layers st_drivers write_sf st_write.data.frame st_write.sf st_write.sfc st_write abbreviate_shapefile_names clean_columns read_sf st_read.character process_cpl_read_ogr st_read.default st_read set_utf8

Documented in is_driver_available is_driver_can read_sf st_drivers st_layers st_read st_read.character st_write st_write.data.frame st_write.sf st_write.sfc write_sf

set_utf8 = function(x) {
	n = names(x)
	Encoding(n) = "UTF-8"
	to_utf8 = function(x) {
		if (is.character(x))
			Encoding(x) = "UTF-8"
		x
	}
	structure(lapply(x, to_utf8), names = n)
}

#' Read simple features or layers from file or database
#'
#' Read simple features from file or database, or retrieve layer names and their
#' geometry type(s)
#' @param dsn data source name (interpretation varies by driver - for some
#'   drivers, \code{dsn} is a file name, but may also be a folder, or contain
#'   the name and access credentials of a database); in case of GeoJSON,
#'   \code{dsn} may be the character string holding the geojson data. It can
#'   also be an open database connection.
#' @param layer layer name (varies by driver, may be a file name without
#'   extension); in case \code{layer} is missing, \code{st_read} will read the
#'   first layer of \code{dsn}, give a warning and (unless \code{quiet = TRUE})
#'   print a message when there are multiple layers, or give an error if there
#'   are no layers in \code{dsn}. If \code{dsn} is a database connection, then
#'   \code{layer} can be a table name or a database identifier (see
#'   \code{\link[DBI]{Id}}). It is also possible to omit \code{layer} and rather
#'   use the \code{query} argument.
#' @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 
#'   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
#' @param geometry_column integer or character; in case of multiple geometry
#'   fields, which one to take?
#' @param type integer; ISO number of desired simple feature type; see details.
#'   If left zero, and \code{promote_to_multi} is \code{TRUE}, in case of mixed
#'   feature geometry types, conversion to the highest numeric type value found
#'   will be attempted. A vector with different values for each geometry column
#'   can be given.
#' @param promote_to_multi logical; in case of a mix of Point and MultiPoint, or
#'   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 
#'   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
#'   precision is lost (i.e., values are larger than 2^53).
#' @param check_ring_dir logical; if TRUE, polygon ring directions are checked
#'   and if necessary corrected (when seen from above: exterior ring counter
#'   clockwise, holes clockwise)
#' @details for \code{geometry_column}, see also
#' \url{https://trac.osgeo.org/gdal/wiki/rfc41_multiple_geometry_fields}
#'
#' for values for \code{type} see
#' \url{https://en.wikipedia.org/wiki/Well-known_text#Well-known_binary}, but
#' note that not every target value may lead to successful conversion. The
#' typical conversion from POLYGON (3) to MULTIPOLYGON (6) should work; the
#' other way around (type=3), secondary rings from MULTIPOLYGONS may be dropped
#' without warnings. \code{promote_to_multi} is handled on a per-geometry column
#' basis; \code{type} may be specified for each geometry column.
#'
#' Note that stray files in data source directories (such as \code{*.dbf}) may
#' lead to spurious errors that accompanying \code{*.shp} are missing.
#'
#' In case of problems reading shapefiles from USB drives on OSX, please see
#' \url{https://github.com/r-spatial/sf/issues/252}.
#'
#' For \code{query} with a character \code{dsn} the query text is handed to
#' 'ExecuteSQL' on the GDAL/OGR data set and will result in the creation of a
#' new layer (and \code{layer} is ignored). See 'OGRSQL'
#' \url{https://gdal.org/user/ogr_sql_dialect.html} for details. Please note that the
#' 'FID' special field is driver-dependent, and may be either 0-based (e.g. ESRI
#' Shapefile), 1-based (e.g. MapInfo) or arbitrary (e.g. OSM). Other features of
#' OGRSQL are also likely to be driver dependent. The available layer names may
#' be obtained with
#' \link{st_layers}. Care will be required to properly escape the use of some layer names.
#'
#' @return object of class \link{sf} when a layer was successfully read; in case
#'   argument \code{layer} is missing and data source \code{dsn} does not
#'   contain a single layer, an object of class \code{sf_layers} is returned
#'   with the layer names, each with their geometry type(s). Note that the
#'   number of layers may also be zero.
#' @seealso \link{st_layers}, \link{st_drivers}
#' @examples
#' nc = st_read(system.file("shape/nc.shp", package="sf"))
#' summary(nc) # note that AREA was computed using Euclidian area on lon/lat degrees
#'
#' ## only three fields by select clause
#' ## only two features by where clause
#' nc_sql = st_read(system.file("shape/nc.shp", package="sf"),
#'                      query = "SELECT NAME, SID74, FIPS FROM \"nc\" WHERE BIR74 > 20000")
#' \dontrun{
#'   library(sp)
#'   example(meuse, ask = FALSE, echo = FALSE)
#'   try(st_write(st_as_sf(meuse), "PG:dbname=postgis", "meuse",
#'        layer_options = "OVERWRITE=true"))
#'   try(st_meuse <- st_read("PG:dbname=postgis", "meuse"))
#'   if (exists("st_meuse"))
#'     summary(st_meuse)
#' }
#'
#' \dontrun{
#' ## note that we need special escaping of layer  within single quotes (nc.gpkg)
#' ## and that geom needs to be included in the select, otherwise we don't detect it
#' layer <- st_layers(system.file("gpkg/nc.gpkg", package = "sf"))$name[1]
#' nc_gpkg_sql = st_read(system.file("gpkg/nc.gpkg", package = "sf"),
#'    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,])) 
#' # 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")

#' @export
st_read.default = function(dsn, layer, ...) {
	if (missing(dsn))
		stop("dsn should specify a data source or filename")
	else {
		dsn_is_null = is.null(dsn)
		class_dsn = class(dsn)
		tr <- try(dsn <- as.character(dsn))
		if (dsn_is_null || inherits(tr, "try-error"))
			stop(paste("no st_read method available for objects of class", paste(class_dsn, collapse = ", ")))
		else
			st_read.character(dsn, layer, ...)
	}
}

process_cpl_read_ogr = function(x, quiet = FALSE, ..., check_ring_dir = FALSE,
		stringsAsFactors = ifelse(as_tibble, FALSE, default.stringsAsFactors()), geometry_column = 1, as_tibble = FALSE) {

	which.geom = which(vapply(x, function(f) inherits(f, "sfc"), TRUE))

	if (as_tibble && !requireNamespace("tibble", quietly = TRUE))
		stop("package tibble not available: install first?")

	# in case no geometry is present:
	if (length(which.geom) == 0) {
		warning("no simple feature geometries present: returning a data.frame or tbl_df",
			call. = FALSE)
		x = if (!as_tibble) {
				if (any(sapply(x, is.list)))
					warning("list-column(s) present: in case of failure, try read_sf or as_tibble=TRUE") # nocov
				as.data.frame(x , stringsAsFactors = stringsAsFactors)
			} else
				tibble::as_tibble(x)
		return(x)
	}

	nm = names(x)[which.geom]
	Encoding(nm) = "UTF-8"
	geom = x[which.geom]

	lc.other = setdiff(which(vapply(x, is.list, TRUE)), which.geom) # non-sfc list-columns
	list.cols = x[lc.other]
	nm.lc = names(x)[lc.other]

	if (length(x) == length(geom)) { # ONLY geometry column(s)
		if (as_tibble)
			x <- tibble::tibble(row.names = seq_along(geom[[1]]))[-1]
		else
			x <- data.frame(row.names = seq_along(geom[[1]]))
	} else {
		x <- as.data.frame(set_utf8(x[-c(lc.other, which.geom)]), stringsAsFactors = stringsAsFactors)
		if (as_tibble) {
			# "sf" class is added later by `st_as_sf` (and sets all the attributes)
			x <- tibble::new_tibble(x, nrow = nrow(x))
		}
	}

	for (i in seq_along(lc.other))
		x[[ nm.lc[i] ]] = list.cols[[i]]

	for (i in seq_along(geom))
		x[[ nm[i] ]] = st_sfc(geom[[i]], crs = attr(geom[[i]], "crs")) # computes bbox

	x = st_as_sf(x, ...,
		sf_column_name = if (is.character(geometry_column)) geometry_column else nm[geometry_column],
		check_ring_dir = check_ring_dir)
	if (! quiet)
		print(x, n = 0)
	else
		x
}

#' @name st_read
#' @param fid_column_name character; name of column to write feature IDs to; defaults to not doing this
#' @param drivers character; limited set of driver short names to be tried (default: try all)
#' @param wkt_filter character; WKT representation of a spatial filter (may be used as bounding box, selecting overlapping geometries); see examples
#' @note The use of \code{system.file} in examples make sure that examples run regardless where R is installed:
#' typical users will not use \code{system.file} but give the file name directly, either with full path or relative
#' to the current working directory (see \link{getwd}). "Shapefiles" consist of several files with the same basename
#' that reside in the same directory, only one of them having extension \code{.shp}.
#' @export
st_read.character = function(dsn, layer, ..., query = NA, options = NULL, quiet = FALSE, geometry_column = 1L, type = 0,
		promote_to_multi = TRUE, stringsAsFactors = default.stringsAsFactors(),
		int64_as_string = FALSE, check_ring_dir = FALSE, fid_column_name = character(0),
		drivers = character(0), wkt_filter = character(0)) {

	layer = if (missing(layer))
		character(0)
	else
		enc2utf8(layer)
	if (nchar(dsn) < 1) {
		stop("`dsn` must point to a source, not an empty string.", call. = FALSE)
	}
	dsn_exists = file.exists(dsn)
	dsn_isdb = is_db_driver(dsn)
	if (length(dsn) == 1 && dsn_exists && !dsn_isdb)
		dsn = enc2utf8(normalizePath(dsn))

	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,
		stringsAsFactors = stringsAsFactors, geometry_column = geometry_column, ...)
}

#' @name st_read
#' @export
#' @details \code{read_sf} and \code{write_sf} are aliases for \code{st_read} and \code{st_write}, respectively, with some
#' modified default arguments.
#' \code{read_sf} and \code{write_sf} are quiet by default: they do not print information
#' about the data source. \code{read_sf} returns an sf-tibble rather than an sf-data.frame.
#' \code{write_sf} delete layers by default: it overwrites existing files without asking or warning.
#' @examples
#' # read geojson from string:
#' geojson_txt <- paste("{\"type\":\"MultiPoint\",\"coordinates\":",
#'    "[[3.2,4],[3,4.6],[3.8,4.4],[3.5,3.8],[3.4,3.6],[3.9,4.5]]}")
#' x = read_sf(geojson_txt)
#' x
read_sf <- function(..., quiet = TRUE, stringsAsFactors = FALSE, as_tibble = TRUE) {
	st_read(..., quiet = quiet, stringsAsFactors = stringsAsFactors, as_tibble = as_tibble)
}

clean_columns = function(obj, factorsAsCharacter) {
	permitted = c("character", "integer", "numeric", "Date", "POSIXct", "logical")
	for (i in seq_along(obj)) {
		if (is.factor(obj[[i]])) {
			obj[[i]] = if (factorsAsCharacter)
					as.character(obj[[i]])
				else
					as.numeric(obj[[i]])
		}
		if (! inherits(obj[[i]], permitted)) {
			if (inherits(obj[[i]], "POSIXlt"))
				obj[[i]] = as.POSIXct(obj[[i]])
			else if (is.numeric(obj[[i]]))
				obj[[i]] = as.numeric(obj[[i]]) # strips class
		}
		if (is.character(obj[[i]]))
			obj[[i]] = enc2utf8(obj[[i]])
	}
	ccls.ok = vapply(obj, function(x) inherits(x, permitted), TRUE)
	if (any(!ccls.ok)) {
		# nocov start
                nms <- names(obj)[!ccls.ok]
                cls <- sapply(obj, function(x) paste(class(x), collapse=";"))[!ccls.ok]
                warning("Dropping column(s) ", paste(nms, collapse=","),
                    " of class(es) ", paste(cls, collapse=","))
		obj = obj[ccls.ok]
		# nocov end
	}
	colclasses = vapply(obj, function(x) permitted[ which(inherits(x, permitted, which = TRUE) > 0)[1] ] , "")
	structure(obj, colclasses = colclasses)
}

abbreviate_shapefile_names = function(x) {
# from: rgdal/pkg/R/ogr_write.R:
    fld_names <- names(x)
#   if (!is.null(encoding)) {
#       fld_names <- iconv(fld_names, from=encoding, to="UTF-8")
#   }
	if (any(nchar(fld_names) > 10)) {
		fld_names <- abbreviate(fld_names, minlength = 7)
		warning("Field names abbreviated for ESRI Shapefile driver")
		if (any(nchar(fld_names) > 10))
			fld_names <- abbreviate(fld_names, minlength = 5) # nocov
	}
# fix for dots in DBF field names 121124
	if (length(wh. <- grep("\\.", fld_names) > 0))
		fld_names[wh.] <- gsub("\\.", "_", fld_names[wh.])

	if (length(fld_names) != length(unique(fld_names)))
		stop("Non-unique field names") # nocov

	names(x) = fld_names
	x
}

#' Write simple features object to file or database
#'
#' Write simple features object to file or database
#' @param obj object of class \code{sf} or \code{sfc}
#' @param dsn data source name (interpretation varies by driver - for some drivers, dsn is a file name, but may also be a
#' folder or contain a database name) or a Database Connection (currently
#' official support is for RPostgreSQL connections)
#' @param layer layer name (varies by driver, may be a file name without extension); if layer is missing, the
#' \link{basename} of \code{dsn} is taken.
#' @param driver character; name of driver to be used; if missing and \code{dsn} is not a Database Connection, a driver name is guessed from \code{dsn};
#' \code{st_drivers()} returns the drivers that are available with their properties; links to full driver documentation
#' 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; 
#' multiple options supported.
#' @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 
#' character strings (default), else into numbers by \code{as.numeric}.
#' @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 
#' \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 
#' 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. 
#' 
#' 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 
#' 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. 
#' \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}, 
#' it is returned as an \code{sf} object.
#' @examples
#' nc = st_read(system.file("shape/nc.shp", package="sf"))
#' st_write(nc, paste0(tempdir(), "/", "nc.shp"))
#' st_write(nc, paste0(tempdir(), "/", "nc.shp"), delete_layer = TRUE) # overwrites
#' 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_WKT",
#'   delete_dsn=TRUE) # overwrites
#' \dontrun{
#'  library(sp)
#'  example(meuse, ask = FALSE, echo = FALSE)
#'  try(st_write(st_as_sf(meuse), "PG:dbname=postgis", "meuse_sf",
#'      layer_options = c("OVERWRITE=yes", "LAUNDER=true")))
#'  demo(nc, ask = FALSE)
#'  try(st_write(nc, "PG:dbname=postgis", "sids", layer_options = "OVERWRITE=true"))
#' }
#' @export
st_write = function(obj, dsn, layer, ...) UseMethod("st_write")

#' @name st_write
#' @export
st_write.sfc = function(obj, dsn, layer, ...) {
	if (missing(layer))
		st_write.sf(st_sf(geom = obj), dsn, ...)
	else
		st_write.sf(st_sf(geom = obj), dsn, layer, ...)
}

#' @name st_write
#' @export
st_write.sf = function(obj, dsn, layer = NULL, ...,
		driver = guess_driver_can_write(dsn),
		dataset_options = NULL, layer_options = NULL, quiet = FALSE, factorsAsCharacter = TRUE,
		update = driver %in% db_drivers, delete_dsn = FALSE, delete_layer = FALSE,
		fid_column_name = NULL) {

	if (missing(dsn))
		stop("dsn should specify a data source or filename")
	if (inherits(dsn, c("DBIObject", "PostgreSQLConnection", "Pool"))) {
		if (inherits(dsn, "Pool")) {
			if (! requireNamespace("pool", quietly = TRUE)) # nocov start
				stop("package pool required, please install it first")
			dsn = pool::poolCheckout(dsn)
			on.exit(pool::poolReturn(dsn)) # nocov end
		}
		if (is.null(layer))
			layer = deparse(substitute(obj))
		dbWriteTable(dsn, name = layer, value = obj, ...,
			factorsAsCharacter = factorsAsCharacter)
		return(invisible(obj))
	} else if (!inherits(dsn, "character")) { # add methods for other dsn classes here...
		stop(paste("no st_write method available for dsn of class", class(dsn)[1]))
	}

	if (length(list(...)))
		stop(paste("unrecognized argument(s)", names(list(...)), "\n"))
	if (is.null(layer))
		layer <- file_path_sans_ext(basename(dsn))

	if (length(dsn) == 1 && length(grep("~", dsn)) == 1) # resolve ~
		dsn = normalizePath(dsn, mustWork = FALSE) # nocov

	# this seems to be always a good idea:
	dsn = enc2utf8(dsn)

	geom = st_geometry(obj)
	obj[[attr(obj, "sf_column")]] = NULL

	if (driver == "ESRI Shapefile") { # remove trailing .shp from layer name
		layer = sub(".shp$", "", layer)
		obj = abbreviate_shapefile_names(obj)
	}

	obj = clean_columns(as.data.frame(obj), factorsAsCharacter)
	# this attaches attr colclasses

	names(obj) = enc2utf8(names(obj))

	dim = if (length(geom) == 0)
			"XY"
		else
			class(geom[[1]])[1]

	fids = if (!is.null(fid_column_name)) {
			fids = as.character(obj[[fid_column_name]])
			obj[[fid_column_name]] = NULL
			fids
		} else
			character(0)

	ret = CPL_write_ogr(obj, dsn, layer, driver,
		as.character(dataset_options), as.character(layer_options),
		geom, dim, fids, quiet, update, delete_dsn, delete_layer)
	if (ret == 1) { # try through temp file:
		tmp = tempfile(fileext = paste0(".", tools::file_ext(dsn))) # nocov start
		if (!quiet)
			message(paste("writing first to temporary file", tmp))
		if (CPL_write_ogr(obj, tmp, layer, driver,
				as.character(dataset_options), as.character(layer_options),
				geom, dim, fids, quiet, update, delete_dsn, delete_layer) == 1)
			stop(paste("failed writing to temporary file", tmp))
		if (!file.copy(tmp, dsn, overwrite = update || delete_dsn || delete_layer))
			stop(paste("copying", tmp, "to", dsn, "failed"))
		if (!file.remove(tmp))
			warning(paste("removing", tmp, "failed"))
	} # nocov end
	invisible(obj)
}

#' @name st_write
#' @export
st_write.data.frame <- function(obj, dsn, layer = NULL, ...) {
    st_write.sf(obj = st_as_sf(obj), dsn = dsn, layer = layer, ...)
}

#' @name st_write
#' @export
write_sf <- function(..., quiet = TRUE, delete_layer = TRUE) {
	st_write(..., quiet = quiet, delete_layer = delete_layer)
}

#' Get GDAL drivers
#'
#' Get a list of the available GDAL drivers
#' @param what character: `"vector"` or `"raster"`, anything else will return all
#'   drivers.
#' @details The drivers available will depend on the installation of GDAL/OGR,
#'   and can vary; the `st_drivers()` function shows all the drivers that are
#'   readable, and which may be written. The field `vsi` refers to the driver's
#'   capability to read/create datasets through the VSI*L API. [See GDAL website
#'   for additional details on driver
#'   support](https://gdal.org/drivers/vector/index.html).
#' @return A `data.frame` with driver metadata.
#' @export
#' @md
#' @examples
#' st_drivers()
st_drivers = function(what = "vector") {
	ret = CPL_get_rgdal_drivers(0)
	row.names(ret) = ret$name
	switch(what,
		vector = ret[ret$is_vector,],
		raster = ret[ret$is_raster,],
		ret)
}

#' @export
print.sf_layers = function(x, ...) {
	n_gt = max(sapply(x$geomtype, length))
	x$geomtype = vapply(x$geomtype, function(x) paste(x, collapse = ", "), "")
	cat(paste("Driver:", x$driver, "\n"))
	x$driver = NULL
	x$features[x$features < 0] = NA
	cat("Available layers:\n")
	if (length(x$name) == 0) {
		cat("<none>\n") # nocov
		invisible(x)    # nocov
	} else {
		df = data.frame(unclass(x))
		gt = if (n_gt > 1)
				"geometry_types"
			else
				"geometry_type"
		names(df) = c("layer_name", gt, "features", "fields")
		print(df)
		invisible(df)
	}
}

#' List layers in a datasource
#'
#' List layers in a datasource
#' @param dsn data source name (interpretation varies by driver - for some drivers, \code{dsn} is a file name, but may also be a
#' folder, or contain the name and access credentials of a database)
#' @param options character; driver dependent dataset open options, multiple options supported.
#' @param do_count logical; if TRUE, count the features by reading them, even if their count is not reported by the driver
#' @name st_layers
#' @export
st_layers = function(dsn, options = character(0), do_count = FALSE) {
	if (missing(dsn))
		stop("dsn should specify a data source or filename")
	if (length(dsn) == 1 && file.exists(dsn))
		dsn = enc2utf8(normalizePath(dsn))
	ret = CPL_get_layers(dsn, options, do_count)
	if (length(ret[[1]]) > 0) {
		Encoding(ret[[1]]) <- "UTF-8"
		ret[[1]] <- enc2native(ret[[1]])
	}
	ret
}

guess_driver = function(dsn) {
  stopifnot(is.character(dsn))
  stopifnot(length(dsn) == 1)

	# find match: try extension first
	drv = extension_map[tolower(tools::file_ext(dsn))]
	if (is_db_driver(dsn))
		drv = prefix_map[tolower(strsplit(dsn, ":")[[1]][1])]

	drv <- unlist(drv)

	if (is.null(drv)) {
	  # no match
	  return(NA)
	}
	drv
}

is_db_driver = function(dsn) {
	any(grep(":", gsub(":[/\\]", "/", dsn)))
}

guess_driver_can_write = function(dns, drv = guess_driver(dns)) {
  if(is.na(drv)) {
    stop("Could not guess driver for ", dns, call. = FALSE)
  }
  if(!is_driver_available(drv)) {
    stop(unlist(drv), " driver not available in supported drivers, see `st_drivers()'", call. = FALSE)
  }
  if(!is_driver_can(drv, operation = "write")) {
    stop("Driver ", drv, " cannot write. see `st_drivers()'", call. = FALSE)
  }
  return(drv)
}

#' Check if driver is available
#'
#' Search through the driver table if driver is listed
#' @param drv character. Name of driver
#' @param drivers data.frame. Table containing driver names and support. Default
#' is from \code{\link{st_drivers}}
is_driver_available = function(drv, drivers = st_drivers()) {
  i = match(drv, drivers$name)
  if (is.na(i))
    return(FALSE)

  return(TRUE)
}

#' Check if a driver can perform an action
#'
#' Search through the driver table to match a driver name with
#' an action (e.g. \code{"write"}) and check if the action is supported.
#' @param drv character. Name of driver
#' @param drivers data.frame. Table containing driver names and support. Default
#' is from \code{\link{st_drivers}}
#' @param operation character. What action to check
is_driver_can = function(drv, drivers = st_drivers(), operation = "write") {
  stopifnot(operation %in% names(drivers))
  i = match(drv, drivers$name)
  if (!drivers[i, operation])
    return(FALSE)

  return(TRUE)
}

#' Map extension to driver
#' @docType data
extension_map <- list(
        "bna" = "BNA",
        "csv" = "CSV",
        "e00" = "AVCE00",
        "gdb" = "OpenFileGDB",
        "geojson" = "GeoJSON",
        "gml" = "GML",
        "gmt" = "GMT",
        "gpkg" = "GPKG",
        "gps" = "GPSBabel",
        "gtm" = "GPSTrackMaker",
        "gxt" = "Geoconcept",
        "jml" = "JML",
        "kml" = "KML",
        "map" = "WAsP",
        "mdb" = "Geomedia",
        "nc" = "netCDF",
        "ods" = "ODS",
        "osm" = "OSM",
        "pbf" = "OSM",
        "shp" = "ESRI Shapefile",
        "sqlite" = "SQLite",
        "vdv" = "VDV",
        "xls" = "xls",
        "xlsx" = "XLSX")

#' Map prefix to driver
#' @docType data
prefix_map <- list(
        "couchdb" = "CouchDB",
        "db2odbc" = "DB2ODBC",
        "dods" = "DODS",
        "gft" = "GFT",
        "mssql" = "MSSQLSpatial",
        "mysql" = "MySQL",
        "oci" = "OCI",
        "odbc" = "ODBC",
        "pg" = "PostgreSQL",
        "sde" = "SDE")

#' Drivers for which update should be \code{TRUE} by default
#' @docType data
db_drivers <- c(unlist(prefix_map), "GPKG", "SQLite")

Try the sf package in your browser

Any scripts or data that you put into this service are public.

sf documentation built on Jan. 28, 2020, 5:09 p.m.