From efe0ceae907821d165fc4e39070889af4ffab251 Mon Sep 17 00:00:00 2001 From: Michael Sumner Date: Sun, 12 May 2024 08:22:15 +0000 Subject: [PATCH] C versions of row_from/col_from --- DESCRIPTION | 3 ++- NEWS.md | 6 ++++++ R/C_versions.R | 5 ++++- src/cell.c | 24 --------------------- src/checks.c | 48 +++++++++++++++++++++++++++++++++++++++++ src/coordinates.c | 38 ++++++++++++++++++++++++++++++++ src/init.c | 19 ++++++++++------ src/vaster.h | 8 +++++++ tests/testthat/test-c.R | 15 +++++++++++++ 9 files changed, 134 insertions(+), 32 deletions(-) delete mode 100644 src/cell.c create mode 100644 src/checks.c create mode 100644 src/coordinates.c create mode 100644 src/vaster.h create mode 100644 tests/testthat/test-c.R diff --git a/DESCRIPTION b/DESCRIPTION index 1076011..3bade2d 100644 --- a/DESCRIPTION +++ b/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 = "mdsumner@gmail.com", 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 diff --git a/NEWS.md b/NEWS.md index 1d5def4..5dd8a60 100644 --- a/NEWS.md +++ b/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. diff --git a/R/C_versions.R b/R/C_versions.R index 5455c36..a142c66 100644 --- a/R/C_versions.R +++ b/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") } diff --git a/src/cell.c b/src/cell.c deleted file mode 100644 index e869cc5..0000000 --- a/src/cell.c +++ /dev/null @@ -1,24 +0,0 @@ -# include -# include - -SEXP row_from_y_C(SEXP dimension, SEXP extent, SEXP py) -{ - // FIXME: long vectors, and values > intmax - int nn = LENGTH(py); - double y_res = (REAL(extent)[3] - REAL(extent)[2])/REAL(dimension)[1]; - double y_max = REAL(extent)[3]; - double rownr; - SEXP out = PROTECT(Rf_allocVector(REALSXP, nn)); - for (int i = 0; i < nn; i++){ - if (REAL(py)[i] == REAL(extent)[2]) { - rownr = REAL(dimension)[1] - 1; - } else if (REAL(py)[i] > REAL(extent)[3] | REAL(py)[i] < REAL(extent)[2]) { - rownr = R_NaReal; - } else { - rownr = 1 + trunc(y_max - REAL(py)[i])/y_res; - } - REAL(out)[i] = rownr; - } - UNPROTECT(1); - return out; -} diff --git a/src/checks.c b/src/checks.c new file mode 100644 index 0000000..a38c41e --- /dev/null +++ b/src/checks.c @@ -0,0 +1,48 @@ +# include +# include + +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"); + + } +} diff --git a/src/coordinates.c b/src/coordinates.c new file mode 100644 index 0000000..a1494cb --- /dev/null +++ b/src/coordinates.c @@ -0,0 +1,38 @@ +# include +# include +# 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); + +} diff --git a/src/init.c b/src/init.c index b36e901..de2069a 100644 --- a/src/init.c +++ b/src/init.c @@ -3,15 +3,22 @@ #include // for NULL #include +/* 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); } diff --git a/src/vaster.h b/src/vaster.h new file mode 100644 index 0000000..5e49350 --- /dev/null +++ b/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); diff --git a/tests/testthat/test-c.R b/tests/testthat/test-c.R new file mode 100644 index 0000000..7af2260 --- /dev/null +++ b/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)) +