1
2#' @name st_transform
3#' @param type character; one of \code{have_datum_files}, \code{proj}, \code{ellps}, \code{datum}, \code{units} or \code{prime_meridians}; see Details.
4#' @param path character; PROJ search path to be set
5#' @export
6#' @details \code{sf_proj_info} lists the available projections, ellipses, datums, units, or data search path of the PROJ library when \code{type} is equal to proj, ellps, datum, units or path; when \code{type} equals \code{have_datum_files} a boolean is returned indicating whether datum files are installed and accessible (checking for \code{conus}).
7#'
8#' for PROJ >= 6, \code{sf_proj_info} does not provide option \code{type = "datums"}.
9#' PROJ < 6 does not provide the option \code{type = "prime_meridians"}.
10#'
11#' for PROJ >= 7.1.0, the "units" query of \code{sf_proj_info} returns the \code{to_meter}
12#' variable as numeric, previous versions return a character vector containing a numeric expression.
13#' @examples
14#' sf_proj_info("datum")
15sf_proj_info = function(type = "proj", path) {
16
17	if (type == "have_datum_files")
18		return(CPL_have_datum_files(0))
19
20	if (type == "path")
21		return(CPL_get_data_dir(FALSE))
22
23	if (!missing(path) && is.character(path))
24		return(invisible(CPL_set_data_dir(path)))
25
26	if (type == "network")
27		return(CPL_is_network_enabled(TRUE))
28
29	opts <- c("proj", "ellps", "datum", "units", "prime_meridians")
30	if (!(type %in% opts))
31		stop("unknown type") # nocov
32	t <- as.integer(match(type[1], opts) - 1)
33	res = CPL_proj_info(as.integer(t))
34	if (type == "proj")
35		res$description <- sapply(strsplit(as.character(res$description), "\n"),
36			function(x) x[1])
37	data.frame(res)
38}
39
40#' directly transform a set of coordinates
41#'
42#' directly transform a set of coordinates
43#' @param from character description of source CRS, or object of class \code{crs},
44#' or pipeline describing a transformation
45#' @param to character description of target CRS, or object of class \code{crs}
46#' @param pts two-column numeric matrix, or object that can be coerced into a matrix
47#' @param keep logical value controlling the handling of unprojectable points. If
48#' `keep` is `TRUE`, then such points will yield `Inf` or `-Inf` in the
49#' return value; otherwise an error is reported and nothing is returned.
50#' @param warn logical; if \code{TRUE}, warn when non-finite values are generated
51#' @param authority_compliant logical; \code{TRUE} means handle axis order authority compliant (e.g. EPSG:4326 implying x=lat, y=lon), \code{FALSE} means use visualisation order (i.e. always x=lon, y=lat)
52#' @return two-column numeric matrix with transformed/converted coordinates, returning invalid values as \code{Inf}
53#' @export
54sf_project = function(from = character(0), to = character(0), pts, keep = FALSE, warn = TRUE,
55		authority_compliant = st_axis_order()) {
56
57	if (!is.logical(keep) || length(keep) != 1 || is.na(keep))
58		stop("'keep' must be single-length non-NA logical value")
59	proj_from_crs = function(x) {
60		if (inherits(x, "crs")) {
61			x = if (sf_extSoftVersion()["proj.4"] >= "6.0.0")
62				x$wkt
63			else
64				x$proj4string
65		}
66		if (length(x)) {
67			v = CPL_proj_is_valid(x)
68			if (!v[[1]])
69				stop(paste0(v[[2]], ": ", x))
70			x[1]
71		} else
72			x # empty: character(0)
73	}
74
75	from_to = c(proj_from_crs(from), proj_from_crs(to))
76	if ((length(from_to) == 1) && !missing(authority_compliant))
77		stop("when specifying a projection pipeline, setting authority_compliant has no effect")
78
79	CPL_proj_direct(from_to, as.matrix(pts), keep, warn, authority_compliant)
80}
81
82#' Manage PROJ settings
83#'
84#' Manage PROJ search path and network settings
85#' @param paths the search path to be set; omit if no paths need to be set
86#' @return `sf_proj_search_paths()` returns the search path (possibly after setting it)
87#' @name proj_tools
88#' @export
89sf_proj_search_paths = function(paths = character(0)) {
90	if (length(paths) == 0)
91		CPL_get_proj_search_paths(paths) # get
92	else
93		CPL_set_proj_search_paths(as.character(paths)) # set
94}
95
96#' @param enable logical; set this to enable (TRUE) or disable (FALSE) the proj network search facility
97#' @param url character; use this to specify and override the default proj network CDN
98#' @return `sf_proj_network` when called without arguments returns a logical indicating whether
99#' network search of datum grids is enabled, when called with arguments it returns a character
100#' vector with the URL of the CDN used (or specified with `url`).
101#' @name proj_tools
102#' @export
103sf_proj_network = function(enable = FALSE, url = character(0)) {
104	if (missing(enable) && missing(url))
105		CPL_is_network_enabled()
106	else
107		CPL_enable_network(url, enable)
108}
109
110#' @param source_crs object of class `crs` or character
111#' @param target_crs object of class `crs` or character
112#' @param authority character; constrain output pipelines to those of authority
113#' @param AOI length four numeric; desired area of interest for the resulting
114#' coordinate transformations (west, south, east, north, in degrees).
115#' For an area of interest crossing the anti-meridian, west will be greater than east.
116#' @param Use one of "NONE", "BOTH", "INTERSECTION", "SMALLEST", indicating how AOI's
117#' of source_crs and target_crs are being used
118#' @param grid_availability character; one of "USED" (Grid availability is only used for sorting
119#' results. Operations where some grids are missing will be sorted last), "DISCARD"
120#' (Completely discard an operation if a required grid is missing)
121#' , "IGNORED" (Ignore grid availability at all. Results will be presented as if all grids were
122#' available.), or "AVAILABLE" (Results will be presented as if grids known to PROJ (that is
123#' registered in the grid_alternatives table of its database) were available. Used typically when
124#' networking is enabled.)
125#' @param desired_accuracy numeric; only return pipelines with at least this accuracy
126#' @param strict_containment logical; default FALSE; permit partial matching of the area
127#' of interest; if TRUE strictly contain the area of interest.
128#' The area of interest is either as given in AOI, or as implied by the
129#' source/target coordinate reference systems
130#' @param axis_order_authority_compliant logical; if FALSE always
131#' choose ‘x’ or longitude for the first
132#' axis; if TRUE, follow the axis orders given by the coordinate reference systems when
133#' constructing the for the first axis; if FALSE, follow the axis orders given by
134#' @return `sf_proj_pipelines` returns a table with candidate coordinate transformation
135#' pipelines along with their accuracy; `NA` accuracy indicates ballpark accuracy.
136#' @name proj_tools
137#' @export
138sf_proj_pipelines = function(source_crs, target_crs, authority = character(0), AOI = numeric(0),
139		Use = "NONE", grid_availability = "USED", desired_accuracy = -1.0,
140		strict_containment = FALSE, axis_order_authority_compliant = st_axis_order()) {
141	stopifnot(!missing(source_crs), !missing(target_crs))
142	if (inherits(source_crs, "crs"))
143		source_crs = source_crs$wkt
144	if (inherits(target_crs, "crs"))
145		target_crs = target_crs$wkt
146	stopifnot(is.character(source_crs), is.character(target_crs))
147
148	ret = CPL_get_pipelines(c(source_crs, target_crs), as.character(authority),
149		as.numeric(AOI), as.character(Use), as.character(grid_availability),
150		as.numeric(desired_accuracy), as.logical(strict_containment),
151		as.logical(axis_order_authority_compliant))
152	if (nrow(ret)) {
153		if (substr(ret$definition[1], 1, 1) != "+") # paste + to every word
154			ret$definition =
155				sapply(strsplit(ret$definition, " "),
156					function(x) paste0(paste0("+", x), collapse=" "))
157		ret$containment = strict_containment
158		structure(ret, class = c("proj_pipelines", "data.frame"),
159			source_crs = source_crs, target_crs = target_crs)
160	} else
161		invisible(NULL)
162}
163
164#' @export
165print.proj_pipelines = function(x, ...) {
166	cat("Candidate coordinate operations found: ", nrow(x), "\n")
167	nos <- which(!x$instantiable)
168	if (length(nos) > 0L)
169		xx <- x[-nos,]
170	else
171		xx <- x
172	xx <- xx[order(xx$accuracy),]
173	y = xx[1,]
174	cat("Strict containment:    ", y$containment, "\n")
175	cat("Axis order auth compl: ", y$axis_order, "\n")
176	cat("Source: ", attr(x, "source_crs"), "\n")
177	cat("Target: ", attr(x, "target_crs"), "\n")
178	if (is.na(y$accuracy))
179		cat("Best instantiable operation has only ballpark accuracy", "\n")
180	else
181		cat("Best instantiable operation has accuracy:", y$accuracy, "m\n")
182	cat("Description: ")
183	desc <- strwrap(y$description, exdent=13, width=0.8*getOption("width"))
184	if (length(desc) == 1L)
185		cat(desc, "\n")
186	else
187		cat(desc, sep="\n")
188	cat("Definition:  ")
189	def <- strwrap(y$definition, exdent=13, width=0.8*getOption("width"))
190	if (length(def) == 1L)
191		cat(def, "\n")
192	else
193		cat(def, sep="\n")
194	# nos:
195	if (length(nos) > 0L) {
196		grds <- attr(x, "grids")
197		for (i in seq(along=nos)) {
198			grd <- grds[[nos[i]]]
199			ii <- length(grd)
200			if (ii > 0L) {
201				cat("Operation", nos[i], "is lacking", ii,
202				ifelse(ii == 1L, "grid", "grids"),
203					"with accuracy", x$accuracy[nos[i]], "m\n")
204				for (j in 1:ii) {
205					cat("Missing grid:", grd[[j]][[1]], "\n")
206					if (nzchar(grd[[j]][[2]])) cat("Name:", grd[[j]][[2]], "\n")
207					if (nzchar(grd[[j]][[4]])) cat("URL:", grd[[j]][[4]], "\n")
208				}
209			}
210		}
211	}
212	invisible(x)
213}
214