tests/testthat/test-sample_strat.R

In tgoodbody/sgsR: Structurally Guided Sampling

o <- sample_strat(sraster = sraster, nSamp = 20)
o1 <- sample_strat(sraster = sraster, nSamp = 20, allocation = "equal", details = TRUE)
o2 <- sample_strat(sraster = sraster, nSamp = 100, allocation = "manual", weights = c(0.2, 0.2, 0.2, 0.4), details = TRUE)
o3 <- sample_strat(sraster = sraster, mraster = mraster$zq90, nSamp = 100, allocation = "optim", weights = c(0.2, 0.2, 0.2, 0.4), details = TRUE, force = TRUE)

existing <- extract_strata(sraster, existing)
existingna <- extract_strata(sraster, existingna)

toSample2 <- toSample <- allocate_prop(sraster = sraster, nSamp = 100)

oo <- sample_strat(sraster = sraster, nSamp = 20, existing = existing, include = TRUE, remove = TRUE)

test_that("errors", {
  expect_error(sample_strat(sraster = "sraster", nSamp = 20), "'sraster' must be type SpatRaster.")
  expect_error(sample_strat(sraster = sraster, nSamp = "20"), "'nSamp' must be type numeric.")
  expect_error(sample_strat(sraster = sraster, nSamp = 20, method = 1), "'method' must be type character.")
  expect_error(sample_strat(sraster = sraster, nSamp = 20, method = "c"), "'method' must be one of 'random' or 'Queinnec'.")
  expect_error(sample_strat(sraster = sraster, nSamp = 20, mindist = "200"), "'mindist' must be type numeric.")
  expect_error(sample_strat(sraster = sraster, nSamp = 200, existing = existing, include = "TRUE", remove = TRUE), "'include' must be type logical.")
  expect_error(sample_strat(sraster = sraster, nSamp = 200, existing = existing, include = TRUE, remove = "TRUE"), "'remove' must be type logical.")
  expect_error(sample_strat(sraster = sraster, nSamp = 200, existing = existing, include = TRUE, remove = TRUE, force = "TRUE"), "'force' must be type logical.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, wrow = "A"), "'wrow' must be type numeric.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, wcol = "A"), "'wcol' must be type numeric.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, wrow = 2), "'wrow' must be an odd number.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, wcol = 2), "'wcol' must be an odd number.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, plot = "TRUE"), "'plot' must be type logical.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, details = "TRUE"), "'details' must be type logical.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, existing = "A"), "'existing' must be a data.frame or sf object.")
  expect_error(sample_strat(sraster = sraster, nSamp = 25, existing = access), "'existing' geometry type must be 'sfc_POINT'.")

  expect_error(sample_strat(sraster = sraster, nSamp = 20, include = TRUE), "'existing' must be provided when 'include = TRUE'.")
  expect_error(sample_strat(sraster = sraster, nSamp = 20, remove = TRUE), "'existing' must be provided when 'remove = TRUE'.")
  expect_error(sample_strat(sraster = sraster, nSamp = 20, existing = data.frame()), "'existing' must have an attribute named 'strata'. Consider using extract_strata().")
  expect_error(sample_strat(sraster = sraster, nSamp = 20, existing = data.frame(strata = c(1, 2, 3))), "'existing' must have columns named 'X' and 'Y'.")
  expect_error(sample_strat(sraster = sraster, nSamp = 15000, access = access, allocation = "equal", buff_inner = 50, buff_outer = 200), "Insufficient candidate samples within the buffered access extent. Consider altering buffer widths.")
})


test_that("Total outputs", {
  expect_equal(nrow(o), 20L)
  expect_equal(ncol(o), 4L)

  expect_equal(nrow(oo), 20L)
  expect_equal(ncol(oo), 4L)

  #--- categorical ---#
  expect_message(sample_strat(sraster = x, nSamp = 200), "'sraster' has factor values. Converting to allow mapping.")
  expect_equal(ncol(sample_strat(sraster = x, nSamp = 200, access = access, buff_outer = 100, plot = TRUE)), 5L)
  expect_equal(ncol(sample_strat(sraster = x, nSamp = 200, plot = TRUE)), 5L)
})

test_that("messages", {
  expect_message(sample_strat(sraster = sraster, nSamp = 20), "Using 'Queinnec' sampling method.")
  expect_message(sample_strat(sraster = sraster, nSamp = 20, method = "random"), "Using 'random' sampling method. Ignoring 'existing', 'include', 'remove' if provided.")
  expect_message(sample_strat(sraster = sraster, nSamp = 20, mindist = 200, access = access, buff_inner = 50, buff_outer = 200), "An access layer has been provided. An internal buffer of 50 m and an external buffer of 200 m have been applied.")
  expect_message(sample_strat(sraster = sraster, nSamp = 20, mindist = 200, access = access, buff_outer = 200), "An access layer has been provided. An external buffer of 200 m have been applied.")
  expect_message(sample_strat(sraster = sraster, nSamp = 20, existing = existing, include = TRUE, remove = TRUE), "'include = TRUE & remove = TRUE' - Stratum 1 overrepresented - 45 samples removed.")
  expect_message(sample_strat(sraster = sraster, nSamp = 20, existing = existing, include = TRUE, remove = FALSE), "'include = TRUE & remove = FALSE' - Stratum 1 overrepresented by 45 samples but have not been removed. Expect a higher total 'nSamp' in output.")
  expect_message(sample_strat(sraster = sraster, nSamp = 200, existing = existing, include = TRUE, remove = TRUE), "Strata : 1 required no sample additions. Keeping all existing samples")
  expect_message(sample_strat(sraster = sraster, nSamp = 20, existing = data.frame(strata = c(1, 2, 3), x = c(1, 2, 3), y = c(1, 2, 3))), "'existing' column coordinate names are lowercase - converting to uppercase.")
  expect_message(sample_strat(sraster = sraster, nSamp = 20, existing = existingna), "Implementing proportional allocation of samples.")

  expect_message(sample_strat(sraster = sraster, nSamp = 25, access = access, buff_inner = 50, buff_outer = 200), "Buffered area contains 12454 available candidates. Sampling to reach 6 starting.")
})

test_that("Test equal", {
  expect_message(sample_strat(sraster = sraster, mraster = mraster$zq90, nSamp = 10, allocation = "equal", weights = c(0.2, 0.2, 0.2, 0.4)), "'weights' was specified but 'allocation = equal' - did you mean to use 'allocation = manual'?")
  expect_message(sample_strat(sraster = sraster, mraster = mraster$zq90, nSamp = 10, allocation = "equal", weights = c(0.2, 0.2, 0.2, 0.4)), "'mraster' was specified but 'allocation = equal' - did you mean to use 'allocation = optim'?")
  expect_equal(nrow(o1$sampleDist), 4L)
  expect_equal(sum(o1$sampleDist$total), 80L)
  expect_equal(unique(o1$samples$type), "new")

  expect_equal(sum(o2$sampleDist$total), 100L)

  expect_type(o2, "list")
  expect_s3_class(o1$samples, "sf")

  expect_equal(nrow(sample_strat(sraster = sraster, allocation = "equal", nSamp = 5, method = "random")), 20L)
})

test_that("Test manual", {
  expect_message(sample_strat(sraster = sraster, mraster = mraster$zq90, nSamp = 10, allocation = "manual", weights = c(0.2, 0.2, 0.2, 0.4)), "'mraster' was specified but 'allocation = manual' - did you mean to use 'allocation = optim'?")
  expect_error(sample_strat(sraster = sraster, nSamp = 10, allocation = "manual"), "'weights' must be defined if 'allocation = manual'.")

  expect_equal(o2$sampleDist$total[1], 20L)

  expect_type(o2, "list")
  expect_s3_class(o2$samples, "sf")

  expect_equal(nrow(sample_strat(sraster = sraster, allocation = "manual", weights = c(0.2, 0.2, 0.2, 0.4), nSamp = 10, method = "random")), 10L)
})

test_that("Test optim", {
  expect_message(sample_strat(sraster = sraster, mraster = mraster$zq90, nSamp = 10, allocation = "optim", weights = c(0.2, 0.2, 0.2, 0.4), details = TRUE), "'weights' was specified but 'allocation = optim' - did you mean to use 'allocation = manual'?")
  expect_error(sample_strat(sraster = sraster, nSamp = 20, allocation = "optim", mraster = "m"), "'mraster' must be type SpatRaster.")
  expect_message(sample_strat(sraster = sraster, mraster = mraster$zq90, nSamp = 100, allocation = "optim", weights = c(0.2, 0.2, 0.2, 0.4), details = TRUE), "nSamp of 100 is not perfectly divisible based on strata distribution. nSamp of 99 will be returned. Use 'force = TRUE' to brute force to 100.")
  expect_equal(sum(o3$sampleDist$total), 100L)

  expect_equal(sum(o2$sampleDist$total), 100L)

  expect_type(o3, "list")
  expect_s3_class(o3$samples, "sf")

  expect_equal(nrow(sample_strat(sraster = sraster, allocation = "optim", mraster = mraster$zq90, nSamp = 20, method = "random")), 20L)
})

test_that("existing", {
  expect_message(allocate_existing(toSample = toSample, existing = existingna), "16 samples in 'existing' are located where strata values are NA. Expect 16 additional samples in output.")

  toSample2$strata <- c(5, 6, 7, 8)

  expect_error(allocate_existing(toSample = toSample2, existing = existingna), "'existing' does not contain matching strata to those in 'sraster'. Check strata in both data sets & consider using extract_strata().")
})

test_that("force", {
  expect_equal(sum(allocate_force(toSample = toSample, nSamp = 100, diff = 1)$total), 99L)
  expect_equal(sum(allocate_force(toSample = toSample, nSamp = 100, diff = -1)$total), 101L)
})


test_that("category column", {
  xx <- strat_map(c(x, sraster))

  expect_equal(ncol(sample_strat(xx, nSamp = 1000, method = "random")), 4)
})


test_that("mindist", {
  samples <- vect(sample_strat(sraster = sraster, nSamp = 200, mindist = 200))
  
  # Calculate pairwise distances
  distances <- terra::distance(samples, samples)
  
  # Exclude distances between the same point (diagonal entries)
  diag(distances) <- Inf
  distances[upper.tri(distances)] <- Inf
  
  # Check if any distance is smaller than the threshold
  any_close <- distances < 200
  
  indices <- which(any_close, arr.ind = TRUE)
  
  expect_equal(nrow(indices),0)
  
  #--- random ---#
  samples <- vect(sample_strat(sraster = sraster, nSamp = 200, mindist = 200, method = "random"))
  
  # Calculate pairwise distances
  distances <- terra::distance(samples, samples)
  
  # Exclude distances between the same point (diagonal entries)
  diag(distances) <- Inf
  distances[upper.tri(distances)] <- Inf
  
  # Check if any distance is smaller than the threshold
  any_close <- distances < 200
  
  indices <- which(any_close, arr.ind = TRUE)
  
  expect_equal(nrow(indices),0)
})