R/proj.R

In mdsumner/basf: Plot Simple Features with 'base' Sensibilities

#' Reproject with sf
#'
#' Structure of input can be a matrix or a data.frame or anything coercible to a matrix.
#' Output maintains the structure of the input, but reprojects the first two (or three or four) columns.
#'
#' Use 'proj_xy' and 'proj_xyz' for clarity on those specific cases.
#'
#' If input has more than 4 columns, it's assumed only the first two are used as per 'proj_xy'.
#' @param x points
#' @param target projection of output (WKT, projstring, auth:code, anything proj understands)
#' @param ... argments ignored
#' @param source projection of input (same format as target)
#' @param yx use authority compliance
#'
#' @return matrix of projected points
#' @export
#' @aliases proj_xy proj_xyz
#' @examples
#' proj_xy(cbind(147, -42), "+proj=laea")
proj <- function(x, target, ..., source = NULL, yx = FALSE) {
  x_in <- as.matrix(x)
  if (dim(x_in)[2L] > 4) {
    message("'x' provided with more than 4 columns, only using the the first 2\n - limit to 2, 3, or a maximum 4 columns to use all")
    x_in <- x[,1:2]
  }
  if (is.null(source)) {
    message("no 'source' projection provided, assuming longlat OGC:CRS84")
    source <- "OGC:CRS84"
  }
  if (!gdal) {
    x[, seq_len(dim(x_in)[2L])] <- sf::sf_project(pts = x_in, to = target, from = source, authority_compliant = !yx, keep = TRUE, warn = FALSE)
  } else {
    # ## nuh, this is unuseable because you can't get "out of bounds" values ...
    # na <- rowSums(is.na(x_in)) > 0
    # sfout <- sf::st_coordinates(sf::st_transform(sf::st_sfc(sf::st_multipoint(x_in[!na, ]), crs = sf::st_crs(source)),
    #                                              sf::st_crs(target)))
    # dump <- grep("^L", colnames(sfout))
    # browser()
    # x[!na, seq_len(dim(x_in)[2L])] <- sfout[, -dump]
    # x
  }
}

#' @export
#' @name proj
proj_xy <- function(x, target, ..., source = NULL, yx = FALSE, gdal = FALSE) {
  proj(x[,1:2], target, ..., source = source, yx = yx, gdal = gdal)
}
#' @export
#' @name proj
proj_xyz <- function(x, target, ..., source = NULL, yx = FALSE, gdal = FALSE) {
  proj(x[,1:3], target, ..., source = source, yx = yx, gdal = gdal)
}