C versions of row_from/col_from

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: vaster
 Title: Tools for Raster Grid Logic 
-Version: 0.0.2
+Version: 0.0.2.9001
 Authors@R: c(person("Michael", "Sumner", email = "[email protected]", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-2471-7511")))
 Description: Provides raster grid logic, the grid operations that don't require access to materialized data, i.e. most of them. 
  Grids are arrays with dimension and extent, and many operations are functions of just the dimension 'nrows', 'ncols' or 
@@ -9,6 +9,7 @@ Description: Provides raster grid logic, the grid operations that don't require
  row and column, or row and column to cell index, row, column or cell index to position. Cell index, and row,column posiiton
  exist independently of any other use of a raster grid. 
 License: MIT + file LICENSE
+NeedsCompilation: yes
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1

NEWS.md

@@ -1,3 +1,9 @@
+# vaster dev
+
+* We now have internal functions `col_from_x_c()` and `row_from_y_c()` that use C under the hood, these currently return 0-based indexes. 
+
+* Package now requires compilation, with the R C api. 
+
 # vaster 0.0.2
 
 * Speed up `x_from_col` and `y_from_row`, fixes #19. 

R/C_versions.R

@@ -1,3 +1,6 @@
 row_from_y_c <- function(dimension, extent, y) {
-  .Call("row_from_y_C", dimension, extent, y, PACKAGE = "vaster")
+  .Call("row_from_y_", as.integer(dimension[2L]), as.double(extent[3:4]), as.double(y), PACKAGE = "vaster")
+}
+col_from_x_c <- function(dimension, extent, x) {
+  .Call("col_from_x_", as.integer(dimension[1L]), as.double(extent[1:2]), as.double(x), PACKAGE = "vaster")
 }

src/checks.c

@@ -0,0 +1,48 @@
+# include <R.h>
+# include <Rinternals.h>
+
+void check_size(SEXP size) {
+  if ((INTEGER(size)[0] == R_NaInt) | (INTEGER(size)[0] < 1)) {
+    Rf_error("%s", "bad dimension ncol or nrow is < 1 or missing");
+  }
+}
+void check_range(SEXP range) {
+  double c_max = REAL(range)[1];
+  double c_min = REAL(range)[0];
+  if (!R_finite(c_max) | !R_finite(c_min) | (c_max <= c_min)) {
+    Rf_error("%s", "bad extent, xmax <= xmin, ymax <= ymin, or missing values");
+  }
+}
+
+void check_extent(SEXP extent) {
+  int nn = LENGTH(extent);
+  if (nn != 4) {
+    Rf_error("%s", "extent must be numeric length 4");
+  }
+ double y_max = REAL(extent)[3];
+ double y_min = REAL(extent)[2];
+ double x_max = REAL(extent)[1];
+ double x_min = REAL(extent)[0];
+ if (!R_finite(x_max) | !R_finite(x_min) | (x_max <= x_min)) {
+   Rf_error("%s", "bad extent, xmax <= xmin or missing values");
+ }
+ if (!R_finite(y_max) | !R_finite(y_min) | (y_max <= y_min)) {
+   Rf_error("%s", "bad extent, ymax <= ymin or missing values");
+ }
+}
+
+void check_dimension(SEXP dimension) {
+  int nn = LENGTH(dimension);
+  if (nn != 2) {
+    Rf_error("%s", "dimension must be numeric length 2");
+  }
+
+  if (INTEGER(dimension)[0] < 1) {  // or missing or bad length or bad type
+    Rf_error("%s", "bad dimension ncol is < 1 or missing");
+
+  }
+  if (INTEGER(dimension)[1] < 1) {
+    Rf_error("%s", "bad dimension nrow is < 1 or missing");
+
+  }
+}

src/coordinates.c

@@ -0,0 +1,38 @@
+# include <R.h>
+# include <Rinternals.h>
+# include "vaster.h"
+
+SEXP bin_from_float(SEXP bins, SEXP range, SEXP coord) {
+ int nn = LENGTH(coord);
+  double scl = (REAL(range)[1] - REAL(range)[0])/INTEGER(bins)[0];
+  SEXP out;
+  out = PROTECT(Rf_allocVector(REALSXP, nn));
+
+  for (int i = 0; i < nn; i++) {
+    if (REAL(coord)[i] == REAL(range)[1]) {
+      REAL(out)[i] = INTEGER(bins)[0] - 1;
+    } else if ((REAL(coord)[i] > REAL(range)[1]) | (REAL(coord)[i] < REAL(range)[0])) {
+      REAL(out)[i] = R_NaReal;
+    } else {
+      REAL(out)[i] =    trunc((REAL(range)[1] - REAL(coord)[i])/scl);
+    }
+  }
+  UNPROTECT(1);
+  return out;
+}
+SEXP col_from_x_(SEXP ncol, SEXP xlim, SEXP px)
+{
+  check_size(ncol);
+  check_range(xlim);
+
+ return bin_from_float(ncol, xlim, px);
+}
+SEXP row_from_y_(SEXP nrow, SEXP ylim, SEXP py)
+{
+  check_size(nrow);
+  check_range(ylim);
+
+
+  return bin_from_float(nrow, ylim, py);
+
+}

src/init.c

@@ -3,15 +3,22 @@
 #include <stdlib.h> // for NULL
 #include <R_ext/Rdynload.h>
 
+/* FIXME: 
+   Check these declarations against the C/Fortran source code.
+*/
 
 /* .Call calls */
-extern SEXP row_from_y_C(SEXP, SEXP, SEXP);
+extern SEXP col_from_x_(SEXP, SEXP, SEXP);
+extern SEXP row_from_y_(SEXP, SEXP, SEXP);
+
 static const R_CallMethodDef CallEntries[] = {
-  {"row_from_y_C",  (DL_FUNC) &row_from_y_C,  3},
-  {NULL, NULL, 0}
+    {"col_from_x_", (DL_FUNC) &col_from_x_, 3},
+    {"row_from_y_", (DL_FUNC) &row_from_y_, 3},
+    {NULL, NULL, 0}
 };
 
-void R_init_vaster(DllInfo *dll) {
-  R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
-  R_useDynamicSymbols(dll, FALSE);
+void R_init_vaster(DllInfo *dll)
+{
+    R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
+    R_useDynamicSymbols(dll, FALSE);
 }

src/vaster.h

@@ -0,0 +1,8 @@
+void check_range(SEXP);
+void check_size(SEXP);
+
+void check_extent(SEXP);
+void check_dimension(SEXP);
+SEXP row_from_y_(SEXP, SEXP, SEXP);
+SEXP col_from_x_(SEXP, SEXP, SEXP);
+SEXP bin_from_float(SEXP, SEXP, SEXP);

tests/testthat/test-c.R

@@ -0,0 +1,15 @@
+dm <- c(360, 180)
+dm_bad <- c(NA,5)
+dm_neg <- c(6, -2)
+
+ex <- c(-180, 180, -90, 90)
+ex_bad <- c(-5, 5, NA, 0)
+ex_ord <- c(5, 15, 20, 2)
+
+xy <- cbind(c(0, 100, -100, -30, 25),
+            c(0, 80, -80, -20, -25))
+
+expect_equal(row_from_y_c(dm, ex, xy[,2]), row_from_y(dm, ex, xy[,2]) -1)
+expect_error(row_from_y_c(dm, ex_bad, xy[,2]))
+expect_error(row_from_y_c(dm, ex_ord, 1))
+