tests/testthat/test-connectors.R

In fieldopt: Area-Frame and Dual-Frame Survey Design under Real Field Cost

# survey designs, frame overlap and the areaframe export

test_that("as_svydesign reproduces the Horvitz-Thompson total and the replicate variance", {
  skip_if_not_installed("survey")
  set.seed(2)
  cells <- expand.grid(x = 1:12, y = 1:12)
  cells$unit <- paste0("c", 1:144)
  cells$crop <- 10 + cells$x + rnorm(144)
  cells$h <- rep(c("w", "e"), each = 72)
  s <- select_units(cells, n = 24, strata = "h", seed = 1)
  d <- as_svydesign(s)
  tot <- survey::svytotal(~crop, d)
  expect_equal(unname(coef(tot)), design_variance(s, "crop")$total)
  u <- select_units(cells, n = 24, method = "srs", seed = 5) # unstratified: the srs approximation is exact
  d2 <- as_svydesign(u, variance = "srs")
  expect_equal(unname(coef(survey::svytotal(~crop, d2))), design_variance(u, "crop")$total)
  expect_equal(as.numeric(survey::SE(survey::svytotal(~crop, d2)))^2, design_variance(u, "crop")$variance_srs, tolerance = 1e-6)
  r <- select_units(cells, n = 24, method = "systematic", replicates = 4, seed = 3)
  dr <- as_svydesign(r)
  expect_s3_class(dr, "svyrep.design")
  dv <- design_variance(r, "crop")
  tr <- survey::svytotal(~crop, dr)
  expect_equal(unname(coef(tr)), dv$total, tolerance = 1e-8)
  expect_equal(unname(survey::SE(tr))^2, dv$variance, tolerance = 1e-6)
  expect_error(as_svydesign(cells), "select_units")
})

test_that("frame_overlap matches establishments to cells and marks the domains", {
  cells <- expand.grid(x = 1:5, y = 1:5)
  cells$unit <- paste0("c", 1:25)
  farms <- data.frame(unit = c("f1", "f2", "f3", "f4"), x = c(1.2, 3.4, 9, 2.49), y = c(1.1, 2.6, 9, 1.5))
  ov <- frame_overlap(farms, cells, cell_size = 1)
  expect_equal(ov$list$cell, c("c1", "c13", NA, "c2"))
  expect_equal(ov$list$domain, c("ab", "ab", "b", "ab"))
  expect_equal(sum(ov$cells$listed), 3)
  expect_equal(ov$cells$listed_units[[1]], "f1")
  expect_equal(ov$cells$listed_units[[13]], "f2")
  pr <- data.frame(unit = "f3", cell = "c25")
  ov2 <- frame_overlap(farms, cells, cell_size = 1, pairs = pr)
  expect_equal(ov2$list$domain[3], "ab")
  expect_equal(ov2$cells$listed[25], 1L)
  expect_error(frame_overlap(farms, cells, cell_size = 1, pairs = data.frame(unit = "f9", cell = "c1")), "Unknown list")
  expect_error(frame_overlap(farms, cells, cell_size = 0), "positive")
  skip_if_not_installed("sf")
  sq <- sf::st_sfc(sf::st_polygon(list(rbind(c(0, 0), c(0, 2), c(2, 2), c(2, 0), c(0, 0)))), crs = 4326)
  poly <- sf::st_sf(unit = paste0("p", 1:4), geometry = sf::st_make_grid(sq, n = 2))
  pts <- sf::st_sf(unit = c("a", "b"), geometry = sf::st_sfc(sf::st_point(c(0.5, 0.5)), sf::st_point(c(5, 5)), crs = 4326))
  ovs <- frame_overlap(pts, poly)
  expect_equal(ovs$list$cell, c("p1", NA))
  expect_equal(ovs$list$domain, c("ab", "b"))
  expect_equal(ovs$cells$listed, c(1L, 0L, 0L, 0L))
})

test_that("read_areaframe reads the service export", {
  skip_if_not_installed("arrow")
  path <- "/Users/leite/Github/areaframe/cells.parquet"
  skip_if_not(file.exists(path))
  f <- read_areaframe(path)
  expect_true(all(c("unit", "lat", "lon", "area") %in% names(f)))
  expect_gt(nrow(f), 10)
  expect_true(all(f$area > 0))
  s <- select_units(f, n = 10, size = "area", seed = 1)
  expect_equal(sum(s$sampled), 10)
  skip_if_not_installed("sf")
  g <- read_areaframe(path, sf = TRUE)
  expect_s3_class(g, "sf")
  expect_equal(nrow(g), nrow(f))
  expect_error(read_areaframe("nope.parquet"), "not found")
})