1# Copyright (c) 2003-21 by Barry Rowlingson and Roger Bivand 2 3if (!is.R()) { 4 strsplit <- function(a,b) { 5 if (a == as.character(NA)) 6 return(as.character(NA)) 7 else list(unlist(unpaste(a, b))) 8 } 9} 10 11if (!isGeneric("rebuild_CRS")) 12 setGeneric("rebuild_CRS", function(obj) 13 standardGeneric("rebuild_CRS")) 14 15setMethod("rebuild_CRS", signature(obj = "CRS"), 16 function(obj) { 17 if (is.null(comment(obj))) { 18 obj <- CRS(slot(obj, "projargs")) 19 } 20 obj 21 } 22) 23 24 25"CRS" <- function(projargs=NA_character_, doCheckCRSArgs=TRUE, 26 SRS_string=NULL, get_source_if_boundcrs=TRUE) { 27# cautious change BDR 150424 28# trap NULL too 200225 29 if (is.null(projargs)) 30 warning("CRS: projargs should not be NULL; set to NA") 31 if ((is.null(projargs)) || (!is.na(projargs) && !nzchar(projargs))) projargs <- NA_character_ 32# condition added 140301 33 stopifnot(is.logical(doCheckCRSArgs)) 34 stopifnot(length(doCheckCRSArgs) == 1L) 35 stopifnot(is.logical(get_source_if_boundcrs)) 36 stopifnot(length(get_source_if_boundcrs) == 1L) 37 stopifnot(is.character(projargs)) 38# CRS_CACHE <- get("CRS_CACHE", envir=.sp_CRS_cache) 39 input_projargs <- projargs 40 if (!is.na(input_projargs)) { 41 res <- .sp_CRS_cache[[input_projargs]] 42 if (!is.null(res)) { 43 return(res) 44 } 45 } 46 if (doCheckCRSArgs && requireNamespace("rgdal", quietly = TRUE)) { 47 if (packageVersion("rgdal") >= "1.5.1" && !rgdal::new_proj_and_gdal()) { 48 if (is.na(projargs) && !is.null(SRS_string)) { 49 if (substring(SRS_string, 1, 4) == "EPSG") { 50 pa0 <- strsplit(SRS_string, ":")[[1]] 51 projargs <- paste0("+init=epsg:", pa0[2]) 52 } 53 } 54 } 55 } 56 if (!is.na(projargs)) { 57 if (length(grep("^[ ]*\\+", projargs)) == 0) { 58 if (is.null(SRS_string)) { 59 if (doCheckCRSArgs && 60 requireNamespace("rgdal", quietly = TRUE)) { 61 if (packageVersion("rgdal") >= "1.5.1") { 62 if (rgdal::new_proj_and_gdal()) { 63 SRS_string <- projargs 64 projargs <- NA_character_ 65 } else { 66 if (substring(projargs, 1, 4) == "EPSG") { 67 pa0 <- strsplit(projargs, ":")[[1]] 68 projargs <- paste0("+init=epsg:", pa0[2]) 69 } else { 70 stop("Cannot revert", projargs, 71 "to +init=epsg:") 72 } 73 } 74 } 75 } 76 } else { 77 stop(paste("PROJ4 argument-value pairs must begin with +:", 78 projargs)) 79 } 80 } 81 } 82 if (!is.na(projargs)) { 83 if (length(grep("latlon", projargs)) != 0) 84 stop("northings must follow eastings: ", projargs) 85 if (length(grep("lonlat", projargs)) != 0) { 86 projargs <- sub("lon", "long", projargs) 87 warning("'lonlat' changed to 'longlat': ", projargs) 88 } 89 } 90 if (is.na(projargs)) { 91 uprojargs <- projargs 92 } else { 93 uprojargs <- paste(unique(unlist(strsplit(projargs, " "))), 94 collapse=" ") 95 if (length(grep("= ", uprojargs)) != 0) 96 stop(paste("No spaces permitted in PROJ4 argument-value pairs:", 97 uprojargs)) 98 if (length(grep(" [:alnum:]", uprojargs)) != 0) 99 stop(paste("PROJ4 argument-value pairs must begin with +:", 100 uprojargs)) 101 } 102# if (length(grep("rgdal", search()) > 0) && 103# (sessionInfo()$otherPkgs$rgdal$Version > "0.4-2")) { 104# sessionInfo()/read.dcf() problem in loop 080307 105 comm <- NULL 106 if (!is.na(uprojargs) || (!is.null(SRS_string) && nzchar(SRS_string))) { 107 if (doCheckCRSArgs && requireNamespace("rgdal", quietly = TRUE)) { 108 if (packageVersion("rgdal") < "1.5.1") { 109 res <- rgdal::checkCRSArgs(uprojargs) 110 if (!res[[1]]) stop(res[[2]]) 111 uprojargs <- res[[2]] 112 } else if (packageVersion("rgdal") >= "1.5.1") { 113 if (rgdal::new_proj_and_gdal()) { 114 if (packageVersion("rgdal") >= "1.5.17") { 115 res <- rgdal::checkCRSArgs_ng(uprojargs=uprojargs, 116 SRS_string=SRS_string, 117 get_source_if_boundcrs=get_source_if_boundcrs) 118 } else { 119 res <- rgdal::checkCRSArgs_ng(uprojargs=uprojargs, 120 SRS_string=SRS_string) 121 } 122 if (!res[[1]]) stop(res[[2]]) 123 uprojargs <- res[[2]] 124 comm <- res[[3]] 125 } else { #stop("rgdal version mismatch") 126 if (!is.na(uprojargs)) { 127 res <- rgdal::checkCRSArgs(uprojargs) 128 if (!res[[1]]) stop(res[[2]]) 129 uprojargs <- res[[2]] 130 } 131 } 132 } else stop("rgdal version mismatch") 133 } 134 } 135 res <- new("CRS", projargs=uprojargs) 136 if (!is.null(comm)) comment(res) <- comm 137 if (!is.na(slot(res, "projargs"))) .sp_CRS_cache[[input_projargs]] <- res 138# CRS_CACHE[[input_projargs]] <- res 139# assign("CRS_CACHE", CRS_CACHE, envir=.sp_CRS_cache) 140 141 res 142} 143if (!isGeneric("wkt")) 144 setGeneric("wkt", function(obj) 145 standardGeneric("wkt")) 146 147setMethod("wkt", signature(obj = "CRS"), 148 function(obj) { 149 comm <- comment(obj) 150 if (is.null(comm)) { 151 if (get("rgdal_show_exportToProj4_warnings", 152 envir=.spOptions)) { 153 if (!get("thin_PROJ6_warnings", envir=.spOptions)) { 154 warning("CRS object has no comment") 155 } else { 156 if (get("PROJ6_warnings_count", 157 envir=.spOptions) == 0L) { 158 warning("CRS object has no comment\n repeated warnings suppressed") 159 } 160 assign("PROJ6_warnings_count", 161 get("PROJ6_warnings_count", 162 envir=.spOptions) + 1L, envir=.spOptions) 163 } 164 } 165 } 166 comm 167 } 168) 169 170 171"print.CRS" <- function(x, ...) 172{ 173 cat("Coordinate Reference System:\n") 174 pst <- paste(strwrap(x@projargs), collapse="\n") 175 if (nchar(pst) < 40) cat(paste("Deprecated Proj.4 representation:", pst, "\n")) 176 else cat(paste("Deprecated Proj.4 representation:\n", pst, "\n")) 177 wkt <- wkt(x) 178 if (!is.null(wkt)) { 179 cat("WKT2 2019 representation:\n") 180 cat(wkt, "\n") 181 } 182 invisible(pst) 183} 184 185setMethod("show", "CRS", function(object) print.CRS(object)) 186 187identicalCRS = function(x, y) { 188 if (! missing(y)) { 189 if (inherits(x, "ST")) x <- slot(slot(x, "sp"), "proj4string") 190 else if (inherits(x, "Raster")) x <- slot(x, "crs") 191 else x <- slot(x, "proj4string") 192 if (inherits(y, "ST")) y <- slot(slot(y, "sp"), "proj4string") 193 else if (inherits(y, "Raster")) y <- slot(y, "crs") 194 else y <- slot(y, "proj4string") 195 identicalCRS1(rebuild_CRS(x), rebuild_CRS(y)) 196 } else { # x has to be list: 197 stopifnot(is.list(x)) 198 if (inherits(x[[1]], "Tracks")) { 199 x <- unlist(lapply(x, function(j) { 200 y <- slot(j, "tracks") 201 if (!is.null(y)) lapply(y, function(l) 202 if (!is.null(l)) slot(l, "sp"))})) 203 } 204 if (length(x) > 1) { 205 if (inherits(x[[1]], "ST")) 206 x[[1]] <- slot(slot(x[[1]], "sp"), "proj4string") 207 else if (inherits(x[[1]], "Raster")) 208 x[[1]] <- slot(x[[1]], "crs") 209 else x[[1]] <- slot(x[[1]], "proj4string") 210 p1 = rebuild_CRS(x[[1]]) 211 !any(!sapply(x[-1], function(p2) { 212 if (inherits(p2, "ST")) 213 p2 <- slot(slot(p2, "sp"), "proj4string") 214 else if (inherits(p2, "Raster")) p2 <- slot(p2, "crs") 215 else p2 <- slot(p2, "proj4string") 216 identicalCRS1(rebuild_CRS(p2), p1)})) 217 } else 218 TRUE 219 } 220} 221 222identicalCRS1 = function(x, y) { 223 args_x <- strsplit(x@projargs, " +")[[1]] 224 args_y <- strsplit(y@projargs, " +")[[1]] 225 setequal(args_x, args_y) 226} 227 228is.na.CRS = function(x) { 229 is.na(x@projargs) && is.null(comment(slot(x, "proj4string"))) 230} 231