1# Copyright (c) 2003-19 by Barry Rowlingson and Roger Bivand
2
3#.valid.CRSobj <- function(object) {
4#	if (exists("is.R") && is.function(is.R) && is.R()) {
5#		projargNA <- is.na(object@projargs)
6#	} else {
7#		projargNA <- is.na(as.numeric(object@projargs))
8#	}
9#	if (!projargNA) {
10#		res <- .Call("checkCRSArgs", object@projargs,
11#				PACKAGE="rgdal")
12#	} else res <- list(TRUE, as.character(NA))
13#	if (!res[[1]]) {
14#	    	return(res[[2]])
15#	} else {
16#		return(res[[1]])
17#	}
18#
19#}
20#
21#setValidity("CRS", .valid.CRSobj)
22
23
24"CRSargs" <- function(object) {
25	if (!is(object, "CRS")) stop("not a CRS object")
26
27	if (!is.na(object@projargs)) {
28            if (new_proj_and_gdal())
29                res <- (checkCRSArgs_ng(object@projargs)[[2]])
30            else res <- (checkCRSArgs(object@projargs)[[2]])
31            res <- paste(unique(unlist(strsplit(res, " "))),
32		collapse=" ")
33            return(sub("^\\s+", "", res))
34	} else return(as.character(NA))
35}
36
37checkCRSArgs <- function(uprojargs=NA_character_) {
38  if (packageVersion("rgdal") >= "1.5.1" && length(grep("ob_tran", uprojargs)) > 0L) {
39    return(list(TRUE, uprojargs))
40  }
41# pkgdown work-around
42  if (is.na(get("has_proj_def.dat", envir=.RGDAL_CACHE))) {
43    assign("has_proj_def.dat", .Call("PROJ4_proj_def_dat_Installed",
44      PACKAGE="rgdal"), envir=.RGDAL_CACHE)
45  }
46# RSB Web Mercator bug 180313 (for 5.0.0)
47  drop_nadgrids <- FALSE
48  if (strsplit(strsplit(getPROJ4VersionInfo(), ",")[[1]][1], " ")[[1]][2]
49    == "5.0.0") {
50    if (length(grep("+init=epsg:3857", uprojargs)) > 0L) drop_nadgrids <- TRUE
51  }
52# RSB 2015-05-21
53# fix for omission of proj_defs.dat in PROJ.4 4.9.1
54  if ((!get("has_proj_def.dat", envir=.RGDAL_CACHE)) && (!PROJis6ormore())) {
55      message("NOTE: rgdal::checkCRSArgs: no proj_defs.dat in PROJ.4 shared files")
56      uprojargs <- proj_def_bug_fix(uprojargs)
57  }
58  res <- .Call("RGDAL_checkCRSArgs", uprojargs, PACKAGE="rgdal")
59  if (drop_nadgrids) {
60    uuproj <- strsplit(res[[2]], " ")[[1]]
61    hit_nad <- grep("nadgrids", uuproj)
62    hit_init <- grep("init", uuproj)
63    if (length(c(hit_nad, hit_init) > 0))
64      res[[2]] <- paste(uuproj[-c(hit_nad, hit_init)], collapse=" ")
65  }
66  res[[2]] <- sub("^\\s+", "", res[[2]])
67# fix for pj_get_def() +no_uoff/+no_off bug
68  no_uoff <- length(grep("+no_uoff", uprojargs, fixed=TRUE) > 0)
69  no_off <- length(grep("+no_off", uprojargs, fixed=TRUE) > 0)
70  if (no_uoff) {
71      if( length(grep("+no_uoff", res[[2]], fixed=TRUE)) == 0)
72          res[[2]] <- sub("+no_defs", "+no_uoff +no_defs", res[[2]], fixed=TRUE)
73  }
74  if (no_off) {
75      if (length(grep("+no_off", res[[2]], fixed=TRUE)) == 0)
76          res[[2]] <- sub("+no_defs", "+no_off +no_defs", res[[2]], fixed=TRUE)
77  }
78  res
79}
80
81checkCRSArgs_ng <- function(uprojargs=NA_character_, SRS_string=NULL,
82  get_source_if_boundcrs=TRUE) {
83  no_SRS <- is.null(SRS_string)
84  no_PROJ <- is.na(uprojargs)
85  prefer_proj <- get_prefer_proj()
86  res <- vector(mode="list", length=3L)
87  res[[1]] <- FALSE
88  res[[2]] <- NA_character_
89  res[[3]] <- NA_character_
90  if (!no_SRS) {
91    stopifnot(is.character(SRS_string))
92    stopifnot(length(SRS_string) == 1L)
93  }
94  if (!no_PROJ) {
95    stopifnot(is.character(uprojargs))
96    stopifnot(length(uprojargs) == 1L)
97    if (grepl("\\+init\\=", uprojargs)) prefer_proj <- FALSE
98  }
99  if (!no_SRS) {
100    uprojargs1 <- try(showSRID(SRS_string, format="PROJ", multiline="NO",
101        prefer_proj=prefer_proj), silent=TRUE)
102    if (inherits(uprojargs1, "try-error")) {
103      res[[1]] <- FALSE
104      res[[2]] <- NA_character_
105    } else {
106      res[[1]] <- TRUE
107      res[[2]] <- gsub(" \\+type\\=crs", "", uprojargs1)
108    }
109    wkt2 <- try(showSRID(SRS_string, format="WKT2", multiline="YES",
110        prefer_proj=prefer_proj), silent=TRUE)
111    if (!inherits(wkt2, "try-error")) {
112      if (get_enforce_xy()) wkt2 <- try(.Call("proj_vis_order", wkt2,
113        PACKAGE="rgdal"), silent=TRUE)
114      if (!inherits(wkt2, "try-error")) {
115        res[[3]] <- wkt2
116      }
117    }
118  } else if (!no_PROJ) {
119    uprojargs <- sub("^\\s+", "", uprojargs)
120    if (prefer_proj && !grepl("\\+type\\=crs", uprojargs))
121      uprojargs <- paste0(uprojargs, " +type=crs")
122    uprojargs1 <- try(showSRID(uprojargs, format="PROJ", multiline="NO",
123        prefer_proj=prefer_proj), silent=TRUE)
124    if (inherits(uprojargs1, "try-error")) {
125      res[[1]] <- FALSE
126      res[[2]] <- NA_character_
127    } else {
128      res[[1]] <- TRUE
129      res[[2]] <- gsub(" \\+type\\=crs", "", uprojargs1)
130    }
131    wkt2 <- try(showSRID(uprojargs, format="WKT2", multiline="YES",
132        prefer_proj=prefer_proj), silent=TRUE)
133    if (!inherits(wkt2, "try-error")) {
134      if (get_source_if_boundcrs) {
135        if (length(grep("^BOUNDCRS", wkt2)) > 0L) {
136          wkt2a <- try(.Call("get_source_crs", wkt2, PACKAGE="rgdal"),
137            silent=TRUE)
138          if (!inherits(wkt2a, "try-error")) wkt2 <- wkt2a
139        }
140      }
141      if (get_enforce_xy()) {
142        wkt2a <- try(.Call("proj_vis_order", wkt2, PACKAGE="rgdal"),
143          silent=TRUE)
144          if (!inherits(wkt2a, "try-error")) {
145            wkt2 <- wkt2a
146          }
147      }
148      res[[3]] <- wkt2
149    }
150  }
151  res
152}
153
154compare_CRS <- function(CRS1, CRS2) {
155    stopifnot(new_proj_and_gdal())
156    stopifnot(inherits(CRS1, "CRS"))
157    stopifnot(inherits(CRS2, "CRS"))
158    type1 <- FALSE
159    if (is.null(comment(CRS1))) {
160        from_args <- paste0(slot(CRS1, "projargs"), " +type=crs")
161        warning("NULL source CRS comment, falling back to PROJ string")
162        if (is.na(from_args))
163	    stop("No transformation possible from NA source CRS")
164        if (length(grep("\\+init\\=", from_args)) > 0) {
165            warning("+init dropped in PROJ string")
166            strres <- unlist(strsplit(from_args, " "))
167            from_args <- paste(strres[-grep("\\+init\\=", strres)],
168                collapse=" ")
169        }
170    } else {
171       type1 <- TRUE
172       from_args <- comment(CRS1)
173    }
174    type2 <- FALSE
175    if (is.null(comment(CRS2))) {
176        warning("NULL target CRS comment, falling back to PROJ string")
177        to_args <- paste0(slot(CRS2, "projargs"), " +type=crs")
178        if (is.na(to_args))
179	    stop("No transformation possible to NA target CRS")
180        if (length(grep("\\+init\\=", to_args)) > 0) {
181            warning("+init dropped in PROJ string")
182            strres <- unlist(strsplit(to_args, " "))
183            to_args <- paste(strres[-grep("\\+init\\=", strres)], collapse=" ")
184        }
185    } else {
186        type2 <- TRUE
187        to_args <- comment(CRS2)
188    }
189    res0 <- .Call("CRS_compare", as.character(from_args), as.character(to_args),
190        as.logical(type1), as.logical(type2), PACKAGE="rgdal")
191    res <- as.logical(res0)
192    names(res) <- c("strict", "equivalent", "equivalent_except_axis_order")
193    res
194}
195
196proj_def_bug_fix <- function(uprojargs) {
197    if (length(grep("no_defs", uprojargs)) == 0L &&
198# corrected 20150904
199        length(grep("init", uprojargs)) == 0L) {
200        if (length(grep("ellps", uprojargs)) == 0L &&
201# corrected 20150905
202            length(grep("datum", uprojargs)) == 0L) {
203            tags <- sapply(strsplit(strsplit("+proj=longlat +no_defs",
204                "\\+")[[1]], "="), "[", 1)
205# based on proj/src/pj_init.c lines 191-197
206            if (!any(c("datum", "ellps", "a", "b", "rf", "f") %in% tags)) {
207                uprojargs <- paste(uprojargs, "+ellps=WGS84", sep=" ")
208           }
209         }
210    }
211    uprojargs
212}
213