Merge branch 'master' of github.com:HannaMeyer/CAST

R/nndm.R

@@ -143,12 +143,24 @@ nndm <- function(tpoints, modeldomain = NULL, ppoints = NULL, samplesize = 1000,
 
   # create sample points from modeldomain
   if(is.null(ppoints)&!is.null(modeldomain)){
+
+    # Check modeldomain is indeed a polygon
+    if(!any(c("sfc", "sf") %in% class(modeldomain))){
+      stop("modeldomain must be a sf/sfc object.")
+    }else if(!any(class(sf::st_geometry(modeldomain)) %in% c("sfc_POLYGON", "sfc_MULTIPOLYGON"))){
+      stop("modeldomain must be a sf/sfc polygon object.")
+    }
+
+    # Check whether modeldomain has the same crs as tpoints
     if(!identical(sf::st_crs(tpoints), sf::st_crs(modeldomain))){
       stop("tpoints and modeldomain must have the same CRS")
     }
+
+    # We sample
     message(paste0(samplesize, " prediction points are sampled from the modeldomain"))
     ppoints <- sf::st_sample(x = modeldomain, size = samplesize, type = sampling)
     sf::st_crs(ppoints) <- sf::st_crs(modeldomain)
+
   }else if(!is.null(ppoints)){
     if(!identical(sf::st_crs(tpoints), sf::st_crs(ppoints))){
       stop("tpoints and ppoints must have the same CRS")
@@ -165,6 +177,9 @@ nndm <- function(tpoints, modeldomain = NULL, ppoints = NULL, samplesize = 1000,
     ppoints <- sf::st_sf(geom=ppoints)
   }
 
+  # Input data checks
+  nndm_checks(tpoints, ppoints, phi, min_train)
+
   # if phi==max calculate the range of the size area
   if(phi=="max"){
     xmin <- min(sf::st_coordinates(ppoints)[,1])
@@ -176,9 +191,6 @@ nndm <- function(tpoints, modeldomain = NULL, ppoints = NULL, samplesize = 1000,
     phi <- as.numeric(max(sf::st_distance(p)))
   }
 
-  # Input data checks
-  nndm_checks(tpoints, ppoints, phi, min_train)
-
   # Compute nearest neighbour distances between training and prediction points
   Gij <- sf::st_distance(ppoints, tpoints)
   units(Gij) <- NULL
@@ -238,8 +250,8 @@ nndm <- function(tpoints, modeldomain = NULL, ppoints = NULL, samplesize = 1000,
 nndm_checks <- function(tpoints, ppoints, phi, min_train){
 
   # Check for valid range of phi
-  if(phi < 0 | !is.numeric(phi)){
-    stop("phi must be positive.")
+  if(phi < 0 | (!is.numeric(phi) & phi!= "max")){
+    stop("phi must be positive or set to 'max'.")
   }
 
   # min_train must be a single positive numeric

tests/testthat/test-nndm.R

@@ -0,0 +1,110 @@
+test_that("Valid range of phi", {
+
+  set.seed(1234)
+  poly <- sf::st_polygon(list(matrix(c(0,0,0,50,50,50,50,0,0,0), ncol=2,
+                                     byrow=TRUE)))
+  poly_sfc <- sf::st_sfc(poly)
+  tpoints_sfc <- sf::st_sample(poly_sfc, 50, type = "random")
+  ppoints_sfc <- sf::st_sample(poly_sfc, 50, type = "regular")
+
+  expect_error(nndm(tpoints_sfc, ppoints = ppoints_sfc, phi = -1),
+               "phi must be positive or set to 'max'.")
+})
+
+test_that("NNDM detects wrong data and geometry types", {
+
+  set.seed(1234)
+  poly <- sf::st_polygon(list(matrix(c(0,0,0,50,50,50,50,0,0,0), ncol=2,
+                                     byrow=TRUE)))
+  poly_sfc <- sf::st_sfc(poly)
+  tpoints_sfc <- sf::st_sample(poly_sfc, 50, type = "random")
+  ppoints_sfc <- sf::st_sample(poly_sfc, 50, type = "regular")
+
+  # tpoints
+  expect_error(suppressWarnings(nndm(1, ppoints = ppoints_sfc)),
+               "tpoints must be a sf/sfc object.")
+  expect_error(nndm(poly, ppoints = ppoints_sfc),
+               "tpoints must be a sf/sfc object.")
+  expect_error(nndm(sf::st_sfc(poly), ppoints = ppoints_sfc),
+               "tpoints must be a sf/sfc point object.")
+  # ppoints
+  expect_error(suppressWarnings(nndm(tpoints_sfc, ppoints = 1)),
+               "ppoints must be a sf/sfc object.")
+  expect_error(nndm(tpoints_sfc, ppoints = poly),
+               "ppoints must be a sf/sfc object.")
+  expect_error(nndm(tpoints_sfc, ppoints = poly_sfc),
+               "ppoints must be a sf/sfc point object.")
+
+  # model domain
+  expect_error(suppressWarnings(nndm(tpoints_sfc, modeldomain = 1)),
+               "modeldomain must be a sf/sfc object.")
+  expect_error(nndm(tpoints_sfc, modeldomain = ppoints_sfc),
+               "modeldomain must be a sf/sfc polygon object.")
+})
+
+test_that("NNDM detects different CRS in inputs", {
+
+  set.seed(1234)
+  poly <- sf::st_polygon(list(matrix(c(0,0,0,50,50,50,50,0,0,0), ncol=2,
+                                     byrow=TRUE)))
+  poly_sfc <- sf::st_sfc(poly)
+  tpoints_sfc <- sf::st_sample(poly_sfc, 50, type = "random")
+  ppoints_sfc <- sf::st_sample(poly_sfc, 50, type = "regular")
+
+  tpoints_sfc_4326 <- sf::st_set_crs(tpoints_sfc, 4326)
+  tpoints_sfc_3857 <- sf::st_set_crs(tpoints_sfc, 3857)
+  ppoints_sfc_4326 <- sf::st_set_crs(ppoints_sfc, 4326)
+  ppoints_sfc_3857 <- sf::st_set_crs(ppoints_sfc, 3857)
+  poly_sfc_4326 <- sf::st_set_crs(poly_sfc, 4326)
+
+  # tests
+  expect_error(nndm(tpoints_sfc_3857, ppoints = ppoints_sfc),
+               "tpoints and ppoints must have the same CRS")
+  expect_error(nndm(tpoints_sfc_3857, modeldomain = poly_sfc_4326),
+               "tpoints and modeldomain must have the same CRS")
+})
+
+
+
+test_that("NNDM yields the expected results for all data types", {
+
+  set.seed(1234)
+  poly <- sf::st_polygon(list(matrix(c(0,0,0,50,50,50,50,0,0,0), ncol=2,
+                                     byrow=TRUE)))
+  poly_sfc <- sf::st_sfc(poly)
+  tpoints_sfc <- sf::st_sample(poly_sfc, 50, type = "random")
+  ppoints_sfc <- sf::st_sample(poly_sfc, 50, type = "regular")
+
+  # tpoints, ppoints
+  expect_equal(as.numeric(nndm(tpoints_sfc, ppoints = tpoints_sfc)$Gjstar[1]), 3.7265881)
+  # tpoints, modeldomain
+  expect_equal(as.numeric(nndm(tpoints_sfc, modeldomain = poly_sfc)$Gjstar[5]), 4.9417614)
+  # change phi
+  expect_equal(as.numeric(nndm(tpoints_sfc, ppoints = tpoints_sfc, phi = 10)$Gjstar[10]), 4.8651321)
+  # change min_train
+  expect_equal(as.numeric(nndm(tpoints_sfc, ppoints = tpoints_sfc, phi = 20, min_train = 0.2)$Gjstar[15]), 3.466861)
+  # length checks
+  expect_equal(length(nndm(tpoints_sfc, ppoints = tpoints_sfc)$Gjstar), length(tpoints_sfc))
+  expect_equal(length(nndm(tpoints_sfc, ppoints = tpoints_sfc)$Gi), length(tpoints_sfc))
+  expect_gt(length(nndm(tpoints_sfc, modeldomain = poly_sfc)$Gij), 900)
+})
+
+test_that("NNDM yields the expected results for all CRS", {
+
+  set.seed(1234)
+  poly <- sf::st_polygon(list(matrix(c(0,0,0,50,50,50,50,0,0,0), ncol=2,
+                                     byrow=TRUE)))
+  poly_sfc <- sf::st_sfc(poly)
+  tpoints_sfc <- sf::st_sample(poly_sfc, 50, type = "random")
+  ppoints_sfc <- sf::st_sample(poly_sfc, 50, type = "regular")
+
+  # Projected
+  tpoints_3857 <- sf::st_set_crs(tpoints_sfc, 3857)
+  ppoints_3857 <- sf::st_set_crs(ppoints_sfc, 3857)
+  expect_equal(as.numeric(nndm(tpoints_3857, ppoints = ppoints_3857, phi = 10)$Gjstar[20]), 3.2921498)
+
+  # Geographic
+  tpoints_sf_4326 <- sf::st_set_crs(tpoints_sfc, 4326)
+  ppoints_sf_4326 <- sf::st_set_crs(ppoints_sfc, 4326)
+  expect_equal(as.numeric(nndm(tpoints_sf_4326, ppoints = ppoints_sf_4326, phi = 1000000)$Gjstar[20], 4), 355614.94)
+})