throw out old internal silly functions

hypertidy · Dec 5, 2023 · 6573100 · 6573100
1 parent 9423418
commit 6573100
Show file tree

Hide file tree

Showing 6 changed files with 69 additions and 94 deletions.
diff --git a/R/reproj-external-types.R b/R/reproj-external-types.R
@@ -1,62 +1,62 @@
-get_proj_sc <- function(x, ...) {
-  crsmeta::crs_proj(x)
-}
-get_vertex_sc <- function(x, ...) {
-  x$vertex
-}
-get_meta_sc <- function(x, ...) {
-  x$meta
-}
-#' @rdname reproj
-#' @export
-reproj.sc <- function(x, target = NULL, ..., source = NULL) {
-if (is.null(source)) source <- get_proj_sc(x)
-
-  verts <- get_vertex_sc(x)
-  verts$z_ <- if (is.null(x$vertex[["z_"]])) 0 else x$vertex$z_
-  if (inherits(x, "QUAD") && is.null(x$vertex)) {
-    x$vertex <- verts
-    x$quad <- NULL
-  }
-  mat <- as.matrix(verts[c("x_", "y_", "z_")])
-  mat <- reproj::reproj(mat,
-                 source = source,
-                 target = target)
-  colnames(mat) <- c("x_", "y_", "z_")
-
-  x$vertex[c("x_", "y_", "z_")] <- as.data.frame(mat)
-  meta <- get_meta_sc(x)
-  ## take a punt
-  if (all(x$vertex$z_ == 0)) x$vertex$z_ <- NULL
-  meta["ctime"] <- Sys.time()
-  meta["proj"] <- target
-  x$meta <- rbind(meta, x$meta)
-  x
-
-}
-
-#' @rdname reproj
-#' @export
-reproj.mesh3d <- function(x, target, ..., source = NULL) {
-  xy <- t(x$vb[1:2, , drop = FALSE])
-  x$vb[1:2, ] <- t(reproj(cbind(xy, z = x$vb[3, , drop = TRUE]), target = target, source = to_proj(x$crs), ...))
-  x
-}
-#' @rdname reproj
-#' @export
-reproj.quadmesh <- function(x, target, ..., source = NULL) {
-  existingproj <- x$crs
-  if (existingproj == "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0") {
-    existingproj <- "+proj=longlat +datum=WGS84"  ## pretty harmless https://github.com/hypertidy/reproj/issues/10
-  }
-  x$vb[1:3, ] <- t(reproj::reproj(t(x$vb[1:3, , drop = FALSE]), target = target, source = existingproj))
-  x$raster_metadata <- x$crs <- NULL
-  warning("quadmesh raster information cannot be preserved after reprojection, dropping to mesh3d class")
-  class(x) <- setdiff( class(x), "quadmesh")
-  x
-}
-#' @rdname reproj
-#' @export
-reproj.triangmesh <- function(x, target, ..., source = NULL) {
-  reproj.quadmesh(x, target = target, source = source)
-}
+get_proj_sc <- function(x, ...) {
+  crsmeta::crs_proj(x)
+}
+get_vertex_sc <- function(x, ...) {
+  x$vertex
+}
+get_meta_sc <- function(x, ...) {
+  x$meta
+}
+#' @rdname reproj
+#' @export
+reproj.sc <- function(x, target = NULL, ..., source = NULL) {
+if (is.null(source)) source <- get_proj_sc(x)
+
+  verts <- get_vertex_sc(x)
+  verts$z_ <- if (is.null(x$vertex[["z_"]])) 0 else x$vertex$z_
+  if (inherits(x, "QUAD") && is.null(x$vertex)) {
+    x$vertex <- verts
+    x$quad <- NULL
+  }
+  mat <- as.matrix(verts[c("x_", "y_", "z_")])
+  mat <- reproj::reproj(mat,
+                 source = source,
+                 target = target)
+  colnames(mat) <- c("x_", "y_", "z_")
+
+  x$vertex[c("x_", "y_", "z_")] <- as.data.frame(mat)
+  meta <- get_meta_sc(x)
+  ## take a punt
+  if (all(x$vertex$z_ == 0)) x$vertex$z_ <- NULL
+  meta["ctime"] <- Sys.time()
+  meta["proj"] <- target
+  x$meta <- rbind(meta, x$meta)
+  x
+
+}
+
+#' @rdname reproj
+#' @export
+reproj.mesh3d <- function(x, target, ..., source = NULL) {
+  xy <- t(x$vb[1:2, , drop = FALSE])
+  x$vb[1:2, ] <- t(reproj(cbind(xy, z = x$vb[3, , drop = TRUE]), target = target, source = x$crs, ...))
+  x
+}
+#' @rdname reproj
+#' @export
+reproj.quadmesh <- function(x, target, ..., source = NULL) {
+  existingproj <- x$crs
+  if (existingproj == "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0") {
+    existingproj <- "+proj=longlat +datum=WGS84"  ## pretty harmless https://github.com/hypertidy/reproj/issues/10
+  }
+  x$vb[1:3, ] <- t(reproj::reproj(t(x$vb[1:3, , drop = FALSE]), target = target, source = existingproj))
+  x$raster_metadata <- x$crs <- NULL
+  warning("quadmesh raster information cannot be preserved after reprojection, dropping to mesh3d class")
+  class(x) <- setdiff( class(x), "quadmesh")
+  x
+}
+#' @rdname reproj
+#' @export
+reproj.triangmesh <- function(x, target, ..., source = NULL) {
+  reproj.quadmesh(x, target = target, source = source)
+}
diff --git a/R/reproj.R b/R/reproj.R
@@ -127,10 +127,8 @@ reproj.matrix <- function(x, target, ..., source = NULL, four = FALSE) {
     } else {
       stop("no 'source' projection included, and does not look like longitude/latitude values")
     }
-  } else {
-    source <- to_proj(source)
   }
-  target <- to_proj(target)  ## just sprintf("EPSG:%i", target) or sprintf("+init=epsg:%i", target)
+
   if (.ok_PROJ()) {
 
     if (dim(x)[2L] == 2L) {
@@ -163,12 +161,7 @@ reproj.matrix <- function(x, target, ..., source = NULL, four = FALSE) {
     }
   } else {
 
-    target <- to_proj(target)
-    validate_proj(target)
-
 
-    source <- to_proj(source)
-    validate_proj(source)
 
     srcmult <- if (is_ll(source)) {pi/180} else {1}
     tarmult <-  if(is_ll(target)) {180/pi} else {1}

diff --git a/R/sysdata.rda b/R/sysdata.rda
diff --git a/data-raw/DATASET.R b/data-raw/DATASET.R
@@ -3,9 +3,11 @@
 library(quadmesh)
 library(raster)
 .mesh3d <- quadmesh(crop(worldll, extent(100, 150, -60, -30)))
-data(wrld_simpl, package = "maptools")
-.sc <- silicate::SC(subset(wrld_simpl, NAME %in% c("Australia", "New Zealand")))
+#data(wrld_simpl, package = "maptools")
+#.sc <- silicate::SC(subset(wrld_simpl, NAME %in% c("Australia", "New Zealand")))
 
+## FIX .sc 2023-12-05
+.sc$meta$proj <- trimws(.sc$meta$proj)
 ## I will surely pay for this
 epsg <- rgdal::make_EPSG()
 idx <- grep("\\+proj\\=longlat", epsg$prj4)

diff --git a/tests/testthat/test-reproj-PROJ.R b/tests/testthat/test-reproj-PROJ.R
@@ -63,20 +63,6 @@ test_that("bad arguments don't fail if we can assume longlat", {
   expect_silent(reproj(pdat, llproj, source = laeaproj))
 })
 
-test_that("integer inputs become epsg strings", {
-    expect_true(grepl("EPSG:", to_proj(4326)))
-    expect_true(grepl("EPSG:", to_proj(3857)))
-
-    expect_true(grepl("EPSG:", to_proj("4326")))
-    expect_true(grepl("EPSG:", to_proj("3857")))
-
-    expect_silent(reproj(dat, laeaproj, source = getOption("reproj.default.longlat")))
-    expect_silent(reproj(pdat, getOption("reproj.default.longlat"), source = laeaproj))
-
-  expect_error(validate_proj(3434))
-
-  ##expect_silent(.onLoad())
-})
 
 test_that("z and t works", {
   expect_silent({

diff --git a/tests/testthat/test-reproj-proj4.R b/tests/testthat/test-reproj-proj4.R
@@ -26,9 +26,7 @@ test_that("basic reprojection works", {
   expect_equivalent(reproj(dat, source = llproj, target = laeaproj)[,1:2, drop = FALSE], pdat)
   expect_equivalent(reproj(pdat, source = laeaproj, target = llproj)[,1:2, drop = FALSE], dat)
 
-  leading <- " +proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0"
-  nospace <- "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs +towgs84=0,0,0"
-  expect_false(to_proj(leading) == leading)
+
 })
 
 test_that("identity reprojection ok", {
@@ -60,17 +58,13 @@ test_that("bad arguments don't fail if we can assume longlat", {
 
 test_that("integer inputs become epsg strings", {
 
-  ##expect_true(grepl("EPSG:4326", to_proj("4326")))
-  ##expect_true(grepl("EPSG:3857", to_proj("3857")))
-
-  expect_error(validate_proj(3434))
   expect_silent(reproj:::.onLoad())
   op <- options(reproj.assume.longlat = NULL)
   expect_true(!"reproj.assume.longlat" %in% names(options()))
   expect_silent(reproj:::.onLoad())
   expect_true("reproj.assume.longlat" %in% names(options()))
 
-  #expect_error(to_proj("I am longlat"), "not a string PROJ can understand")
+
 })