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