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