Detailed proj_trans print

NAMESPACE

@@ -1,12 +1,15 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(format,proj_trans)
 S3method(print,proj_trans)
+S3method(str,proj_trans)
 S3method(wk_trans_inverse,proj_trans)
 export(ok_proj6)
 export(proj_crs_text)
 export(proj_trans)
 export(proj_trans_create)
 export(proj_version)
 importFrom(lifecycle,deprecated)
+importFrom(utils,str)
 importFrom(wk,wk_trans_inverse)
 useDynLib(PROJ, .registration = TRUE)

R/proj-info.R

@@ -0,0 +1,22 @@
+proj_trans_info <- function(trans) {
+  info <- .Call(C_proj_trans_info, trans)
+
+  info$area_of_use <- proj_area_of_use(info$area_of_use)
+  info$source_crs <- proj_crs_info(info$source_crs)
+  info$target_crs <- proj_crs_info(info$target_crs)
+
+  structure(info, class = "proj_trans_info")
+}
+
+proj_area_of_use <- function(area_of_use) {
+  if (is.null(area_of_use)) return(NULL)
+
+  area_of_use$bounds <- do.call(wk::rct, as.list(area_of_use$bounds))
+  structure(area_of_use, class = "proj_area_of_use")
+}
+
+proj_crs_info <- function(crs_info) {
+  crs_info$id <- sprintf("%s:%s", crs_info$authority, crs_info$code)
+  crs_info$area_of_use <- proj_area_of_use(crs_info$area_of_use)
+  structure(crs_info, class = "proj_crs_info")
+}

R/utils.R

@@ -0,0 +1,3 @@
+paste_line <- function(...) {
+  paste0(c(...), collapse = "\n")
+}

R/wk-trans.R

@@ -40,15 +40,61 @@ proj_trans_create <- function(source_crs, target_crs, use_z = NA, use_m = NA) {
   wk::new_wk_trans(trans, "proj_trans")
 }
 
+#' @importFrom wk wk_trans_inverse
+#' @export
+wk_trans_inverse.proj_trans <- function(trans, ...) {
+  trans_inv <- .Call(C_proj_trans_inverse, trans)
+  wk::new_wk_trans(trans_inv, "proj_trans")
+}
+
 #' @export
 print.proj_trans <- function(x, ...) {
-  cat(.Call(C_proj_trans_fmt, x))
+  info <- proj_trans_info(x)
+
+  # FIXME: cleanup repetitive code
+  lines <- paste_line(
+    sprintf("<proj_trans at %s>", .Call(C_xptr_addr, x)),
+    sprintf("type: %s", info$type),
+    sprintf("id: %s", info$id),
+    sprintf("description: %s", info$description),
+    sprintf("definition: %s", info$definition),
+    "area_of_use:",
+    sprintf("  name: %s", info$area_of_use$name),
+    sprintf("  bounds: %s", info$area_of_use$bounds),
+    "source_crs:",
+    sprintf("  type: %s", info$source_crs$type),
+    sprintf("  id: %s", info$source_crs$id),
+    sprintf("  name: %s", info$source_crs$name),
+    "  area_of_use:",
+    sprintf("    name: %s", info$source_crs$area_of_use$name),
+    sprintf("    bounds: %s", info$source_crs$area_of_use$bounds),
+    "target_crs:",
+    sprintf("  type: %s", info$target_crs$type),
+    sprintf("  id: %s", info$target_crs$id),
+    sprintf("  name: %s", info$target_crs$name),
+    "  area_of_use:",
+    sprintf("    name: %s", info$target_crs$area_of_use$name),
+    sprintf("    bounds: %s", info$target_crs$area_of_use$bounds)
+  )
+
+  cat(lines, sep = "\n")
+
   invisible(x)
 }
 
-#' @importFrom wk wk_trans_inverse
 #' @export
-wk_trans_inverse.proj_trans <- function(trans, ...) {
-  trans_inv <- .Call(C_proj_trans_inverse, trans)
-  wk::new_wk_trans(trans_inv, "proj_trans")
+#' @importFrom utils str
+str.proj_trans <- function(object, ...) {
+  cat(
+    sprintf("<proj_trans at %s>", .Call(C_xptr_addr, object)),
+    format(object),
+    sep = "\n"
+  )
+  invisible(object)
+}
+
+#' @export
+format.proj_trans <- function(x, ...) {
+  # FIXME: wkt or json may be better options
+  proj_trans_info(x)$definition
 }

src/init.c

@@ -8,20 +8,22 @@
 /* .Call calls */
 extern SEXP C_proj_crs_text(void *, void *);
 extern SEXP C_proj_trans_create(void *, void *, void *, void *);
-extern SEXP C_proj_trans_fmt(void *);
+extern SEXP C_proj_trans_info(void *);
 extern SEXP C_proj_trans_inverse(void *);
 extern SEXP C_proj_trans_list(void *, void *, void *);
 extern SEXP C_proj_trans_xy(void *, void *, void *, void *);
 extern SEXP C_proj_version(void);
+extern SEXP C_xptr_addr(void *);
 
 static const R_CallMethodDef CallEntries[] = {
     {"C_proj_crs_text",      (DL_FUNC) &C_proj_crs_text,      2},
     {"C_proj_trans_create",  (DL_FUNC) &C_proj_trans_create,  4},
-    {"C_proj_trans_fmt",     (DL_FUNC) &C_proj_trans_fmt,     1},
+    {"C_proj_trans_info",    (DL_FUNC) &C_proj_trans_info,    1},
     {"C_proj_trans_inverse", (DL_FUNC) &C_proj_trans_inverse, 1},
     {"C_proj_trans_list",    (DL_FUNC) &C_proj_trans_list,    3},
     {"C_proj_trans_xy",      (DL_FUNC) &C_proj_trans_xy,      4},
     {"C_proj_version",       (DL_FUNC) &C_proj_version,       0},
+    {"C_xptr_addr",          (DL_FUNC) &C_xptr_addr,          1},
     {NULL, NULL, 0}
 };
 /* End section generated by pkgbuild */

src/proj-utils.c

@@ -0,0 +1,59 @@
+#include <proj.h>
+#include <stdbool.h>
+
+#include "proj-utils.h"
+
+// polyfill PT_TYPE enums introduced in 7.2
+#if (PROJ_VERSION_MAJOR * 100 + PROJ_VERSION_MINOR) < 702
+#define PJ_TYPE_TEMPORAL_DATUM 25
+#define PJ_TYPE_ENGINEERING_DATUM 26
+#define PJ_TYPE_PARAMETRIC_DATUM 27
+#endif
+
+const char *proj_type_name(PJ_TYPE type)
+{
+  // clang-format off
+  switch (type) {
+    case PJ_TYPE_UNKNOWN: return "Unknown";
+    case PJ_TYPE_ELLIPSOID: return "Ellipsoid";
+    case PJ_TYPE_PRIME_MERIDIAN: return "Prime Meridian";
+
+    case PJ_TYPE_GEODETIC_REFERENCE_FRAME: return "Geodetic Reference Frame";
+    case PJ_TYPE_DYNAMIC_GEODETIC_REFERENCE_FRAME: return "Dynamic Geodetic Reference Frame";
+    case PJ_TYPE_VERTICAL_REFERENCE_FRAME: return "Vertical Reference Frame";
+    case PJ_TYPE_DYNAMIC_VERTICAL_REFERENCE_FRAME: return "Dynamic Vertical Reference Frame";
+    case PJ_TYPE_DATUM_ENSEMBLE: return "Datum Ensemble";
+
+    /** Abstract type, not returned by proj_get_type() */
+    case PJ_TYPE_CRS: return "CRS";
+
+    case PJ_TYPE_GEODETIC_CRS: return "Geodetic CRS";
+    case PJ_TYPE_GEOCENTRIC_CRS: return "Geocentric CRS";
+
+    /** proj_get_type() will never return that type, but
+     * PJ_TYPE_GEOGRAPHIC_2D_CRS or PJ_TYPE_GEOGRAPHIC_3D_CRS. */
+    case PJ_TYPE_GEOGRAPHIC_CRS: return "Geographic CRS";
+
+    case PJ_TYPE_GEOGRAPHIC_2D_CRS: return "Geographic 2D CRS";
+    case PJ_TYPE_GEOGRAPHIC_3D_CRS: return "GEOGRAPHIC 3D CRS";
+    case PJ_TYPE_VERTICAL_CRS: return "Vertical CRS";
+    case PJ_TYPE_PROJECTED_CRS: return "Projected CRS";
+    case PJ_TYPE_COMPOUND_CRS: return "Compound CRS";
+    case PJ_TYPE_TEMPORAL_CRS: return "Temporal CRS";
+    case PJ_TYPE_ENGINEERING_CRS: return "Engineering CRS";
+    case PJ_TYPE_BOUND_CRS: return "Bound CRS";
+    case PJ_TYPE_OTHER_CRS: return "Other CRS";
+
+    case PJ_TYPE_CONVERSION: return "Conversion";
+    case PJ_TYPE_TRANSFORMATION: return "Transformation";
+    case PJ_TYPE_CONCATENATED_OPERATION: return "Concatenated Operation";
+    case PJ_TYPE_OTHER_COORDINATE_OPERATION: return "Other Coordinate Operation";
+
+    case PJ_TYPE_TEMPORAL_DATUM: return "Temporal Datum";
+    case PJ_TYPE_ENGINEERING_DATUM: return "Engineering Datum";
+    case PJ_TYPE_PARAMETRIC_DATUM: return "Parametric Datum";
+
+    default: return "Unknown";
+  }
+  // clang-format on
+}

src/proj-utils.h

@@ -0,0 +1,5 @@
+#pragma once
+
+#include <proj.h>
+
+const char* proj_type_name(PJ_TYPE type);

src/r-utils.c

@@ -0,0 +1,7 @@
+#define R_NO_REMAP
+#include "r-utils.h"
+
+SEXP r_scalar_string(const char* str) {
+  return str != NULL ? Rf_ScalarString(Rf_mkCharCE(str, CE_UTF8))
+                     : Rf_ScalarString(NA_STRING);
+}

src/r-utils.h

@@ -0,0 +1,7 @@
+#pragma once
+
+#include <R.h>
+#include <Rinternals.h>
+
+SEXP r_scalar_string(const char* str);
+