R/check_projection.R

In plotKML: Visualization of Spatial and Spatio-Temporal Objects in Google Earth

# Note: p4s_parameters list of proj4 parameter/value strings; Uses the string parsing functionality from the 'plyr' package;

extractProjValue <- function(p4s_parameters, param){
  
  # Locating the current PROJ4 parameter
  query <- plyr::ldply(p4s_parameters, stringr::str_locate, pattern = param)
  idx <- which(!is.na(query[, 1]) & !is.na(query[, 2]))
  
  # If the PROJ4 parameter is found we extract its value
  if (length(idx) > 0) {
    # Selecting the good param string
    param_value <- p4s_parameters[idx]
    # Extract the parameter value
    value <- strsplit(param_value, param)[[1]]
    value <- value[value != ""]
    return(value)
  } else { 
    value <- NA
    #warning(paste("Proj4string does not contain", param, "parameter.\n Consider converting to the referent CRS", get("ref_CRS", envir = plotKML.opts),"manually."))
  }
}


## parse string:
parse_proj4 <- function(p4s, params){

  if(missing(params)) {
    ref_CRS = get("ref_CRS", envir = plotKML.opts)
    value <- strsplit(ref_CRS, "\\+")[[1]]
    value <- value[value != ""]
    param_names <- sapply(strsplit(value, "="), function(x){x[1]})
    params <- as.list(paste("\\+", sapply(strsplit(value, "="), function(x){x[1]}), "=", sep="")) 
  }

  # Splitting the whole PROJ4 string
  p4s_parameters <- stringr::str_split(p4s, " ")[[1]]
  # Extraction of the values of parameters specified above
  x <- plyr::laply(params, extractProjValue, p4s_parameters = p4s_parameters)
  # colnames for better looking result
  value <- sapply(sapply(params, strsplit, "\\+"), function(x){x[2]})
  param_names <- sapply(strsplit(value, "="), function(x){x[1]})
  names(x) <- param_names

  return(x)
}

## Get proj4string from an object
getCRS.Spatial <- function(obj) {
  CRSargs(CRS(proj4string(obj)))
}

setMethod("getCRS", "Spatial", getCRS.Spatial)

getCRS.Raster <- function(obj) {
  CRSargs(projection(obj, asText = FALSE))
}

setMethod("getCRS", "Raster", getCRS.Raster)


## check projection for Raster objects
setMethod("is.projected", signature(obj = "Raster"),
	function(obj) {
		p4str <- getCRS(obj)
		if (is.na(p4str) || nchar(p4str) == 0) 

			return(as.logical(NA))
		else {

			x <- grep("longlat", p4str, fixed=TRUE)

			if (length(x) == 0)
				return(TRUE)
			else
				return(FALSE)
		}
	}
)

## check proj4string
check_projection <- function(obj, control = TRUE, ref_CRS = get("ref_CRS", envir = plotKML.opts)){
  
  if(is.na(proj4string(obj))){
    stop("Proj4 string missing")
  } 

  #  First, check if it is in the metric system or unprojected:
  if(is.projected(obj)){
    ret = FALSE
  } else {
    # Using PROJ.4 to get the PROJ4 string
    p4s <- getCRS(obj)
  
    # Parsing the PROJ4 string for proj and datum values
    params <- parse_proj4(p4s)
  
    # the default target proj4 string:
    value <- strsplit(ref_CRS, "\\+")[[1]]
    value <- value[value != ""]
    target_params <- stringr::str_trim(sapply(strsplit(value, "="), function(x){x[2]}))
    names(target_params) <- sapply(strsplit(value, "="), function(x){x[1]})
  
    # if already projection type is missing the string is invalid
    if(params["proj"] != ""){  
      # If test fails
      if (sum(is.na(match(params, target_params)))>0) {
        if (control==FALSE)
          stop(paste("'", ref_CRS, "' coordinate system required"))
        else
          ret <- FALSE
    }
    # If test succeed
    else {
        ret <- TRUE
      }
    }
  
  else {
    stop("A valid proj4string required. See 'CRS-methods' for more details.")
    }
  }

  return(ret)
}

# end of script;