From 7a5dd652f762465c0a31b27e9db64fcc87f0848d Mon Sep 17 00:00:00 2001 From: wlangera Date: Tue, 26 Mar 2024 15:46:21 +0100 Subject: [PATCH] add unit tests --- DESCRIPTION | 3 + tests/testthat.R | 12 + tests/testthat/test-grid_designation.R | 417 ++++++++++++++++++ .../test-sample_from_binormal_circle.R | 209 +++++++++ .../test-sample_from_uniform_circle.R | 185 ++++++++ tests/testthat/test-sample_observations.R | 7 + tests/testthat/test-simulate_occurrences.R | 7 + 7 files changed, 840 insertions(+) create mode 100644 tests/testthat.R create mode 100644 tests/testthat/test-grid_designation.R create mode 100644 tests/testthat/test-sample_from_binormal_circle.R create mode 100644 tests/testthat/test-sample_from_uniform_circle.R create mode 100644 tests/testthat/test-sample_observations.R create mode 100644 tests/testthat/test-simulate_occurrences.R diff --git a/DESCRIPTION b/DESCRIPTION index 0b482c9..1011f50 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,3 +22,6 @@ Encoding: UTF-8 Language: en-GB Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.1 +Suggests: + testthat (>= 3.0.0) +Config/testthat/edition: 3 diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..3832375 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(02) + +test_check("02") diff --git a/tests/testthat/test-grid_designation.R b/tests/testthat/test-grid_designation.R new file mode 100644 index 0000000..53e47dd --- /dev/null +++ b/tests/testthat/test-grid_designation.R @@ -0,0 +1,417 @@ +# Load packages +library(testthat) +library(here) +library(sf) +library(dplyr) + +# Source functions +source(here("R", "grid_designation.R")) + +# Prepare example datasets +## number of points and extend +n_points <- 4 +xlim <- c(3841000, 3842000) +ylim <- c(3110000, 3112000) + +## dataset without coordinateUncertaintyInMeters +observations_sf1 <- data.frame( + lat = runif(n_points, ylim[1], ylim[2]), + long = runif(n_points, xlim[1], xlim[2]) + ) %>% + st_as_sf(coords = c("long", "lat"), crs = 3035) + +## dataset with coordinateUncertaintyInMeters +set.seed(123) +coordinate_uncertainty <- rgamma(n_points, shape = 5, rate = 0.1) +observations_sf2 <- observations_sf1 %>% + mutate(coordinateUncertaintyInMeters = coordinate_uncertainty) + +## dataset without geometry +observations_sf3 <- observations_sf2 %>% + st_drop_geometry() + +# Add buffer uncertainty in meters around points +observations_sf2_buffered <- observations_sf2 %>% + st_buffer(observations_sf2$coordinateUncertaintyInMeters) + +# Create grid +grid_df1 <- st_make_grid( + observations_sf2_buffered, + square = TRUE, + cellsize = c(200, 200) + ) %>% + st_sf() + +grid_df2 <- grid_df1 %>% + mutate(id = seq_len(nrow(grid_df1))) + +## grid without geometry +grid_df3 <- grid_df1 %>% + st_drop_geometry() + +# Unit tests +## expect errors +test_that("arguments are of the right class", { + # observations are sf dataframe + expect_error(grid_designation(observations_sf3, grid_df1), + regexp = "`observations` must be an sf object", + fixed = TRUE) + expect_error(grid_designation(observations = 2, grid_df1), + regexp = "`observations` must be an sf object", + fixed = TRUE) + expect_error(grid_designation(observations = "string", grid_df1), + regexp = "`observations` must be an sf object", + fixed = TRUE) + + # grid is sf dataframe + expect_error(grid_designation(observations_sf2, grid_df3), + regexp = "`grid` must be an sf object", + fixed = TRUE) + expect_error(grid_designation(observations_sf2, grid = 2), + regexp = "`grid` must be an sf object", + fixed = TRUE) + expect_error(grid_designation(observations_sf2, grid = "string"), + regexp = "`grid` must be an sf object", + fixed = TRUE) + + # id_col is string + expect_error(grid_designation(observations_sf2, grid = grid_df1, + id_col = 3), + regexp = "`id_col` must be a character vector of length 1.", + fixed = TRUE) + + # randomisation is string + expect_error(grid_designation(observations_sf2, grid = grid_df1, + randomisation = 3), + regexp = "`randomisation` must be a character vector.", + fixed = TRUE) + + # aggregate is logical + expect_error(grid_designation(observations_sf2, grid = grid_df1, + aggregate = "TRUE"), + regexp = "`aggregate` must be a logical vector of length 1.", + fixed = TRUE) +}) + +test_that("arguments are of the right length", { + # id_col has length 1 + expect_error(grid_designation(observations_sf2, grid = grid_df1, + id_col = c("col1", "col2")), + regexp = "`id_col` must be a character vector of length 1.", + fixed = TRUE) + + # aggregate has length 1 + expect_error(grid_designation(observations_sf2, grid = grid_df1, + aggregate = rep(TRUE, 3)), + regexp = "`aggregate` must be a logical vector of length 1.", + fixed = TRUE) +}) + +test_that("crs of observations and grid must match", { + expect_error( + grid_designation(observations_sf2, + grid = st_transform(grid_df1, crs = 4326)), + regexp = "sf::st_crs(observations) == sf::st_crs(grid) is not TRUE", + fixed = TRUE) +}) + +test_that('randomisation should be one of "uniform", "normal"', { + expect_error( + grid_designation(observations_sf2, grid_df1, randomisation = "beta"), + regexp = '`randomisation` should be one of "uniform", "normal".', + fixed = TRUE) +}) + +## expect warnings +test_that("unique ids if id column is provided", { + expect_warning( + grid_designation(observations_sf2, + grid = grid_df1 %>% + mutate(id = 1), + id_col = "id"), + regexp = "Column `id` does not contain unique ids for grid cells!", + fixed = TRUE) +}) + +test_that("provided id column present in provided grid", { + expect_warning( + grid_designation(observations_sf2, + grid = grid_df1 %>% + mutate(id = seq_len(nrow(grid_df1))), + id_col = "identifier"), + regexp = 'Column name "identifier" not present in provided grid!', + fixed = TRUE) +}) + +## expected outputs +test_that("output class is correct", { + # aggregate = TRUE + suppressWarnings({ + expect_s3_class(grid_designation(observations_sf1, grid = grid_df1), + class = "sf") + expect_s3_class(grid_designation(observations_sf1, grid = grid_df1), + class = "data.frame") + }) + expect_s3_class(grid_designation(observations_sf2, grid = grid_df1), + class = "sf") + expect_s3_class(grid_designation(observations_sf2, grid = grid_df1), + class = "data.frame") + + # aggregate = FALSE + suppressWarnings({ + expect_s3_class(grid_designation(observations_sf1, grid = grid_df1, + aggregate = FALSE), + class = "sf") + expect_s3_class(grid_designation(observations_sf1, grid = grid_df1, + aggregate = FALSE), + class = "data.frame") + }) + expect_s3_class(grid_designation(observations_sf2, grid = grid_df1, + aggregate = FALSE), + class = "sf") + expect_s3_class(grid_designation(observations_sf2, grid = grid_df1, + aggregate = FALSE), + class = "data.frame") +}) + +test_that("correct column names present", { + # aggregate = TRUE, randomisation = "uniform" + suppressWarnings({ + expect_contains(names(grid_designation(observations_sf1, grid = grid_df1)), + c("id", "n", "min_coord_uncertainty", "geometry")) + }) + expect_contains(names(grid_designation(observations_sf2, grid = grid_df1)), + c("id", "n", "min_coord_uncertainty", "geometry")) + expect_contains( + names(grid_designation( + observations_sf2, + grid = grid_df1 %>% + mutate(identifier = seq_len(nrow(grid_df1))), + id_col = "identifier")), + c("identifier", "n", "min_coord_uncertainty", "geometry")) + + # aggregate = TRUE, randomisation = "normal" + suppressWarnings({ + expect_contains(names(grid_designation(observations_sf1, grid = grid_df1, + randomisation = "normal")), + c("id", "n", "min_coord_uncertainty", "geometry")) + }) + expect_contains(names(grid_designation(observations_sf2, grid = grid_df1, + randomisation = "normal")), + c("id", "n", "min_coord_uncertainty", "geometry")) + expect_contains( + names(grid_designation( + observations_sf2, + grid = grid_df1 %>% + mutate(identifier = seq_len(nrow(grid_df1))), + id_col = "identifier", + randomisation = "normal")), + c("identifier", "n", "min_coord_uncertainty", "geometry")) + + # aggregate = FALSE, randomisation = "uniform" + suppressWarnings({ + expect_contains(names(grid_designation(observations_sf1, grid = grid_df1, + aggregate = FALSE)), + c("id", "coordinateUncertaintyInMeters", "geometry")) + }) + expect_contains(names(grid_designation(observations_sf2, grid = grid_df1, + aggregate = FALSE)), + c("id", "coordinateUncertaintyInMeters", "geometry")) + expect_contains( + names(grid_designation( + observations_sf2, + grid = grid_df1 %>% + mutate(identifier = seq_len(nrow(grid_df1))), + id_col = "identifier", + aggregate = FALSE)), + c("identifier", "coordinateUncertaintyInMeters", "geometry")) + + # aggregate = FALSE, randomisation = "normal" + suppressWarnings({ + expect_contains(names(grid_designation(observations_sf1, grid = grid_df1, + aggregate = FALSE, + randomisation = "normal")), + c("id", "coordinateUncertaintyInMeters", "geometry")) + }) + expect_contains(names(grid_designation(observations_sf2, grid = grid_df1, + aggregate = FALSE, + randomisation = "normal")), + c("id", "coordinateUncertaintyInMeters", "geometry")) + expect_contains( + names(grid_designation( + observations_sf2, + grid = grid_df1 %>% + mutate(identifier = seq_len(nrow(grid_df1))), + id_col = "identifier", + aggregate = FALSE, + randomisation = "normal")), + c("identifier", "coordinateUncertaintyInMeters", "geometry")) +}) + +test_that("no minimal coordinate uncertainty for empty grid cells", { + # randomisation = "uniform" + suppressWarnings({ + expect_equal(sum( + grid_designation(observations_sf1, + grid = grid_df1)$n == 0), + sum(is.na( + grid_designation(observations_sf1, + grid = grid_df1)$min_coord_uncertainty)) + ) + }) + expect_equal(sum( + grid_designation(observations_sf2, + grid = grid_df1)$n == 0), + sum(is.na( + grid_designation(observations_sf2, + grid = grid_df1)$min_coord_uncertainty)) + ) + + # randomisation = "normal" + suppressWarnings({ + expect_equal(sum( + grid_designation(observations_sf1, + grid = grid_df1, + randomisation = "normal")$n == 0), + sum(is.na( + grid_designation(observations_sf1, + grid = grid_df1, + randomisation = "normal")$min_coord_uncertainty)) + ) + }) + expect_equal(sum( + grid_designation(observations_sf2, + grid = grid_df1, + randomisation = "normal")$n == 0), + sum(is.na( + grid_designation(observations_sf2, + grid = grid_df1, + randomisation = "normal")$min_coord_uncertainty)) + ) +}) + +# Calculate all potential grid cells for the observations +sf::st_agr(observations_sf1) <- "constant" +sf::st_agr(observations_sf2_buffered) <- "constant" +sf::st_agr(grid_df2) <- "constant" +# No uncertainty +potential_gridcells_sf1 <- st_intersection(grid_df2, observations_sf1) %>% + pull(id) +# With uncertainty +potential_gridcells_sf2 <- st_intersection(grid_df2, + observations_sf2_buffered) %>% + pull(id) + +test_that("check possible outcomes for grid cell designation", { + # aggregate = TRUE, randomisation = "uniform" + suppressWarnings({ + expect_contains(potential_gridcells_sf1, + grid_designation(observations_sf1, grid = grid_df2, + id_col = "id") %>% + filter(n > 0) %>% + pull(id)) + }) + expect_contains(potential_gridcells_sf2, + grid_designation(observations_sf2, grid = grid_df2, + id_col = "id") %>% + filter(n > 0) %>% + pull(id)) + # aggregate = TRUE, randomisation = "normal" + suppressWarnings({ + expect_contains(potential_gridcells_sf1, + grid_designation(observations_sf1, grid = grid_df2, + id_col = "id", + randomisation = "normal") %>% + filter(n > 0) %>% + pull(id)) + }) + expect_contains(potential_gridcells_sf2, + grid_designation(observations_sf2, grid = grid_df2, + id_col = "id", + randomisation = "normal") %>% + filter(n > 0) %>% + pull(id)) + + # aggregate = FALSE, randomisation = "uniform" + suppressWarnings({ + expect_contains(potential_gridcells_sf1, + grid_designation(observations_sf1, grid = grid_df2, + id_col = "id", + aggregate = FALSE) %>% + pull(id)) + }) + expect_contains(potential_gridcells_sf2, + grid_designation(observations_sf2, grid = grid_df2, + id_col = "id", + aggregate = FALSE) %>% + pull(id)) + # aggregate = FALSE, randomisation = "normal" + suppressWarnings({ + expect_contains(potential_gridcells_sf1, + grid_designation(observations_sf1, grid = grid_df2, + id_col = "id", + randomisation = "normal", + aggregate = FALSE) %>% + pull(id)) + }) + expect_contains(potential_gridcells_sf2, + grid_designation(observations_sf2, grid = grid_df2, + id_col = "id", + randomisation = "normal", + aggregate = FALSE) %>% + pull(id)) +}) + +test_that("number of observations should equal numbers in grid", { + # randomisation = "uniform" + suppressWarnings({ + expect_equal(grid_designation(observations_sf1, grid = grid_df1) %>% + pull(n) %>% + sum(), + nrow(observations_sf1)) + }) + expect_equal(grid_designation(observations_sf2, grid = grid_df1) %>% + pull(n) %>% + sum(), + nrow(observations_sf2)) + # randomisation = "normal" + suppressWarnings({ + expect_equal(grid_designation(observations_sf1, grid = grid_df1, + randomisation = "normal") %>% + pull(n) %>% + sum(), + nrow(observations_sf1)) + }) + expect_equal(grid_designation(observations_sf2, grid = grid_df1, + randomisation = "normal") %>% + pull(n) %>% + sum(), + nrow(observations_sf2)) +}) + +test_that("number of observations be the same as output if aggregate = FALSE", { + # randomisation = "uniform" + suppressWarnings({ + expect_equal(grid_designation(observations_sf1, grid = grid_df1, + aggregate = FALSE) %>% + nrow(), + nrow(observations_sf1)) + }) + expect_equal(grid_designation(observations_sf2, grid = grid_df1, + aggregate = FALSE) %>% + nrow(), + nrow(observations_sf2)) + # randomisation = "normal" + suppressWarnings({ + expect_equal(grid_designation(observations_sf1, grid = grid_df1, + randomisation = "normal", + aggregate = FALSE) %>% + nrow(), + nrow(observations_sf1)) + }) + expect_equal(grid_designation(observations_sf2, grid = grid_df1, + randomisation = "normal", + aggregate = FALSE) %>% + nrow(), + nrow(observations_sf2)) +}) diff --git a/tests/testthat/test-sample_from_binormal_circle.R b/tests/testthat/test-sample_from_binormal_circle.R new file mode 100644 index 0000000..b8e5c66 --- /dev/null +++ b/tests/testthat/test-sample_from_binormal_circle.R @@ -0,0 +1,209 @@ +# Load packages +library(testthat) +library(here) +library(sf) +library(dplyr) + +# Source functions +source(here("R", "sample_from_binormal_circle.R")) + +# Prepare example datasets +## number of points and extend +n_points <- 4 +xlim <- c(3841000, 3842000) +ylim <- c(3110000, 3112000) + +## dataset without coordinateUncertaintyInMeters +observations_sf1 <- data.frame( + lat = runif(n_points, ylim[1], ylim[2]), + long = runif(n_points, xlim[1], xlim[2]) + ) %>% + st_as_sf(coords = c("long", "lat"), crs = 3035) + +## dataset with coordinateUncertaintyInMeters +set.seed(123) +coordinate_uncertainty <- rgamma(n_points, shape = 5, rate = 0.1) +observations_sf2 <- observations_sf1 %>% + mutate(coordinateUncertaintyInMeters = coordinate_uncertainty) + +## dataset without geometry +observations_sf3 <- observations_sf2 %>% + st_drop_geometry() + +# Unit tests +## expect errors +test_that("arguments are of the right class", { + # observations are sf dataframe + expect_error(sample_from_binormal_circle(observations_sf3), + regexp = "`observations` must be an sf object", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations = 2), + regexp = "`observations` must be an sf object", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations = "string"), + regexp = "`observations` must be an sf object", + fixed = TRUE) + + # pnorm is numeric between 0 and 1 + expect_error(sample_from_binormal_circle(observations_sf1, p_norm = "0.95"), + regexp = "`p_norm` must be a numeric vector of length 1.", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations_sf2, p_norm = "0.95"), + regexp = "`p_norm` must be a numeric vector of length 1.", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations_sf1, p_norm = -0.5), + regexp = "`p_norm` must be a single value between 0 and 1.", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations_sf2, p_norm = -0.5), + regexp = "`p_norm` must be a single value between 0 and 1.", + fixed = TRUE) + + # seed is numeric + expect_error(sample_from_binormal_circle(observations_sf1, seed = "123"), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations_sf2, seed = "123"), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) +}) + +test_that("arguments are of the right length", { + # pnorm is length 1 + expect_error(sample_from_binormal_circle(observations_sf1, + p_norm = seq(0.1, 0.3, 0.1)), + regexp = "`p_norm` must be a vector of length 1.", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations_sf2, + p_norm = seq(0.1, 0.3, 0.1)), + regexp = "`p_norm` must be a vector of length 1.", + fixed = TRUE) + + # seed has length 1 + expect_error(sample_from_binormal_circle(observations_sf1, seed = 1:3), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) + expect_error(sample_from_binormal_circle(observations_sf2, seed = 1:3), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) +}) + +## expect warnings +test_that("warning if coordinateUncertaintyInMeters column is not present", { + expect_warning(sample_from_binormal_circle(observations_sf1), + regexp = "No column `coordinateUncertaintyInMeters` present!", + fixed = TRUE) +}) + +## expected outputs +test_that("output class is correct", { + suppressWarnings({ + expect_s3_class(sample_from_binormal_circle(observations_sf1), + class = "sf") + expect_s3_class(sample_from_binormal_circle(observations_sf1), + class = "data.frame") + }) + expect_s3_class(sample_from_binormal_circle(observations_sf2), + class = "sf") + expect_s3_class(sample_from_binormal_circle(observations_sf2), + class = "data.frame") +}) + +test_that("correct column names present", { + suppressWarnings({ + expect_contains(names(sample_from_binormal_circle(observations_sf1)), + c("coordinateUncertaintyInMeters", "geometry")) + }) + expect_contains(names(sample_from_binormal_circle(observations_sf2)), + c("coordinateUncertaintyInMeters", "geometry")) +}) + +test_that("coordinateUncertaintyInMeters column is handled correctly", { + # in case of missing initial coordinateUncertaintyInMeters column + ## no seed + suppressWarnings({ + expect_equal( + sample_from_binormal_circle(observations_sf1) %>% + pull(coordinateUncertaintyInMeters), + rep(0, nrow(observations_sf1))) + ## different seeds + expect_equal( + sample_from_binormal_circle(observations_sf1, seed = 123) %>% + pull(coordinateUncertaintyInMeters), + rep(0, nrow(observations_sf1))) + expect_equal( + sample_from_binormal_circle(observations_sf1, seed = 456) %>% + pull(coordinateUncertaintyInMeters), + rep(0, nrow(observations_sf1))) + }) + + # in case of provided initial coordinateUncertaintyInMeters column + ## no seed + expect_equal( + sample_from_binormal_circle(observations_sf2) %>% + pull(coordinateUncertaintyInMeters), + observations_sf2 %>% + pull(coordinateUncertaintyInMeters)) + ## different seeds + expect_equal( + sample_from_binormal_circle(observations_sf2, seed = 123) %>% + pull(coordinateUncertaintyInMeters), + observations_sf2 %>% + pull(coordinateUncertaintyInMeters)) + expect_equal( + sample_from_binormal_circle(observations_sf2, seed = 456) %>% + pull(coordinateUncertaintyInMeters), + observations_sf2 %>% + pull(coordinateUncertaintyInMeters)) +}) + +# This function calculates if the distances between the sampled points and the +# original point are not larger than their coordinate uncertainty +test_smaller_distances <- function(observations, seed = NA) { + sample_dists <- sample_from_binormal_circle(observations, seed = seed) %>% + mutate(dist = st_distance(geometry, observations, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist) + test_dists_df <- observations %>% + st_drop_geometry() %>% + mutate(dist = sample_dists, + test = dist < coordinateUncertaintyInMeters) + + return(all(test_dists_df$test)) +} + +test_that("distance to new point falls within coordinate uncertainty", { + # in case of missing initial coordinateUncertaintyInMeters column + suppressWarnings({ + ## no seed + expect_equal( + sample_from_binormal_circle(observations_sf1) %>% + mutate(dist = st_distance(geometry, observations_sf1, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist), + rep(0, nrow(observations_sf1))) + ## different seeds + expect_equal( + sample_from_binormal_circle(observations_sf1, seed = 123) %>% + mutate(dist = st_distance(geometry, observations_sf1, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist), + rep(0, nrow(observations_sf1))) + expect_equal( + sample_from_binormal_circle(observations_sf1, seed = 456) %>% + mutate(dist = st_distance(geometry, observations_sf1, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist), + rep(0, nrow(observations_sf1))) + }) + + # in case of provided initial coordinateUncertaintyInMeters column + ## no seed + expect_true(test_smaller_distances(observations_sf2)) + ## different seeds + expect_true(test_smaller_distances(observations_sf2, seed = 123)) + expect_true(test_smaller_distances(observations_sf2, seed = 456)) +}) diff --git a/tests/testthat/test-sample_from_uniform_circle.R b/tests/testthat/test-sample_from_uniform_circle.R new file mode 100644 index 0000000..5cf16e3 --- /dev/null +++ b/tests/testthat/test-sample_from_uniform_circle.R @@ -0,0 +1,185 @@ +# Load packages +library(testthat) +library(here) +library(sf) +library(dplyr) + +# Source functions +source(here("R", "sample_from_uniform_circle.R")) + +# Prepare example datasets +## number of points and extend +n_points <- 4 +xlim <- c(3841000, 3842000) +ylim <- c(3110000, 3112000) + +## dataset without coordinateUncertaintyInMeters +observations_sf1 <- data.frame( + lat = runif(n_points, ylim[1], ylim[2]), + long = runif(n_points, xlim[1], xlim[2]) + ) %>% + st_as_sf(coords = c("long", "lat"), crs = 3035) + +## dataset with coordinateUncertaintyInMeters +set.seed(123) +coordinate_uncertainty <- rgamma(n_points, shape = 5, rate = 0.1) +observations_sf2 <- observations_sf1 %>% + mutate(coordinateUncertaintyInMeters = coordinate_uncertainty) + +## dataset without geometry +observations_sf3 <- observations_sf2 %>% + st_drop_geometry() + +# Unit tests +## expect errors +test_that("arguments are of the right class", { + # observations are sf dataframe + expect_error(sample_from_uniform_circle(observations_sf3), + regexp = "`observations` must be an sf object", + fixed = TRUE) + expect_error(sample_from_uniform_circle(observations = 2), + regexp = "`observations` must be an sf object", + fixed = TRUE) + expect_error(sample_from_uniform_circle(observations = "string"), + regexp = "`observations` must be an sf object", + fixed = TRUE) + + # seed is numeric + expect_error(sample_from_uniform_circle(observations_sf1, seed = "123"), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) + expect_error(sample_from_uniform_circle(observations_sf2, seed = "123"), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) +}) + +test_that("arguments are of the right length", { + # seed has length 1 + expect_error(sample_from_uniform_circle(observations_sf1, seed = 1:3), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) + expect_error(sample_from_uniform_circle(observations_sf2, seed = 1:3), + regexp = "`seed` must be a numeric vector of length 1.", + fixed = TRUE) +}) + +## expect warnings +test_that("warning if coordinateUncertaintyInMeters column is not present", { + expect_warning(sample_from_uniform_circle(observations_sf1), + regexp = "No column `coordinateUncertaintyInMeters` present!", + fixed = TRUE) +}) + +## expected outputs +test_that("output class is correct", { + suppressWarnings({ + expect_s3_class(sample_from_uniform_circle(observations_sf1), + class = "sf") + expect_s3_class(sample_from_uniform_circle(observations_sf1), + class = "data.frame") + }) + expect_s3_class(sample_from_uniform_circle(observations_sf2), + class = "sf") + expect_s3_class(sample_from_uniform_circle(observations_sf2), + class = "data.frame") +}) + +test_that("correct column names present", { + suppressWarnings({ + expect_contains(names(sample_from_uniform_circle(observations_sf1)), + c("coordinateUncertaintyInMeters", "geometry")) + }) + expect_contains(names(sample_from_uniform_circle(observations_sf2)), + c("coordinateUncertaintyInMeters", "geometry")) +}) + +test_that("coordinateUncertaintyInMeters column is handled correctly", { + # in case of missing initial coordinateUncertaintyInMeters column + ## no seed + suppressWarnings({ + expect_equal( + sample_from_uniform_circle(observations_sf1) %>% + pull(coordinateUncertaintyInMeters), + rep(0, nrow(observations_sf1))) + ## different seeds + expect_equal( + sample_from_uniform_circle(observations_sf1, seed = 123) %>% + pull(coordinateUncertaintyInMeters), + rep(0, nrow(observations_sf1))) + expect_equal( + sample_from_uniform_circle(observations_sf1, seed = 456) %>% + pull(coordinateUncertaintyInMeters), + rep(0, nrow(observations_sf1))) + }) + + # in case of provided initial coordinateUncertaintyInMeters column + ## no seed + expect_equal( + sample_from_uniform_circle(observations_sf2) %>% + pull(coordinateUncertaintyInMeters), + observations_sf2 %>% + pull(coordinateUncertaintyInMeters)) + ## different seeds + expect_equal( + sample_from_uniform_circle(observations_sf2, seed = 123) %>% + pull(coordinateUncertaintyInMeters), + observations_sf2 %>% + pull(coordinateUncertaintyInMeters)) + expect_equal( + sample_from_uniform_circle(observations_sf2, seed = 456) %>% + pull(coordinateUncertaintyInMeters), + observations_sf2 %>% + pull(coordinateUncertaintyInMeters)) +}) + +# This function calculates if the distances between the sampled points and the +# original point are not larger than their coordinate uncertainty +test_smaller_distances <- function(observations, seed = NA) { + sample_dists <- sample_from_uniform_circle(observations, seed = seed) %>% + mutate(dist = st_distance(geometry, observations, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist) + test_dists_df <- observations %>% + st_drop_geometry() %>% + mutate(dist = sample_dists, + test = dist < coordinateUncertaintyInMeters) + + return(all(test_dists_df$test)) +} + +test_that("distance to new point falls within coordinate uncertainty", { + # in case of missing initial coordinateUncertaintyInMeters column + suppressWarnings({ + ## no seed + expect_equal( + sample_from_uniform_circle(observations_sf1) %>% + mutate(dist = st_distance(geometry, observations_sf1, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist), + rep(0, nrow(observations_sf1))) + ## different seeds + expect_equal( + sample_from_uniform_circle(observations_sf1, seed = 123) %>% + mutate(dist = st_distance(geometry, observations_sf1, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist), + rep(0, nrow(observations_sf1))) + expect_equal( + sample_from_uniform_circle(observations_sf1, seed = 456) %>% + mutate(dist = st_distance(geometry, observations_sf1, + by_element = TRUE), + dist = as.numeric(dist)) %>% + pull(dist), + rep(0, nrow(observations_sf1))) + }) + + # in case of provided initial coordinateUncertaintyInMeters column + ## no seed + expect_true(test_smaller_distances(observations_sf2)) + ## different seeds + expect_true(test_smaller_distances(observations_sf2, seed = 123)) + expect_true(test_smaller_distances(observations_sf2, seed = 456)) +}) diff --git a/tests/testthat/test-sample_observations.R b/tests/testthat/test-sample_observations.R new file mode 100644 index 0000000..d0e10d3 --- /dev/null +++ b/tests/testthat/test-sample_observations.R @@ -0,0 +1,7 @@ +# Source functions +source(here("R", "sample_observations.R")) + +# Unit tests +test_that("multiplication works", { + expect_equal(2 * 2, 4) +}) diff --git a/tests/testthat/test-simulate_occurrences.R b/tests/testthat/test-simulate_occurrences.R new file mode 100644 index 0000000..71be511 --- /dev/null +++ b/tests/testthat/test-simulate_occurrences.R @@ -0,0 +1,7 @@ +# Source functions +source(here("R", "simulate_occurrences.R")) + +# Unit tests +test_that("multiplication works", { + expect_equal(2 * 2, 4) +})