tests/testthat/test-grts.R
In USEPA/spsurvey: Spatial Sampling Design and Analysis
context("grts")
# find system info
on_solaris <- Sys.info()[["sysname"]] == "SunOS"
if (on_solaris) {
test_that("on solaris", {
expect_true(on_solaris)
})
} else {
# set reproducible seed (as there are random components here)
set.seed(5)
test_local <- FALSE # FALSE for CRAN
#################################################
########### NE_LAKES DATA TESTS
#################################################
#--------------------------------------
#-------- Class Inheritance
#--------------------------------------
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal")
# class inheritance
expect_s3_class(grts_output, "sp_design")
})
#--------------------------------------
#-------- Work with sp_frame
#--------------------------------------
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(sp_frame(NE_Lakes), n_base = n_base, seltype = "equal")
# class inheritance
expect_s3_class(grts_output, "sp_design")
})
if (test_local) {
#--------------------------------------
#-------- Regular
#--------------------------------------
# number of grts columns added
col_grts_add <- 9
# number of NE_Lakes columns
col_data <- NCOL(NE_Lakes)
# number of grts columns plus NE_Lakes columns
col_out <- col_grts_add + col_data
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal")
# see if function ran without error
expect_true(exists("grts_output"))
# no legacy sites
expect_equal(NROW(grts_output$sites_legacy), 0)
# base sample size of 50
expect_equal(NROW(grts_output$sites_base), n_base)
# no rho replacement sites
expect_equal(NROW(grts_output$sites_over), 0)
# no nn replacement sites
expect_equal(NROW(grts_output$sites_near), 0)
# no legacy sites
expect_equal(NCOL(grts_output$sites_legacy), 1)
# base sample size columns should equal extra columns plus original columns
expect_equal(NCOL(grts_output$sites_base), col_out)
# no rho replacement sites
expect_equal(NCOL(grts_output$sites_over), 1)
# no nn replacement sites
expect_equal(NCOL(grts_output$sites_near), 1)
# class inheritance
expect_s3_class(grts_output, "sp_design")
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", stratum_var = "ELEV_CAT")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "unequal", caty_var = "AREA_CAT", caty_n = caty_n)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, unequal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
caty_n <- list(low = c(small = 10, large = 10), high = c(small = 10, large = 20))
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT",
caty_var = "AREA_CAT", caty_n = caty_n
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, unequal probability (with repeated caty_n)
test_that("algorithm executes", {
n_base <- c(low = 25, high = 25)
caty_n <- c(small = 12.5, large = 12.5)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT",
caty_var = "AREA_CAT", caty_n = caty_n
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, unequal probability (with different caty_n)
test_that("algorithm executes", {
n_base <- c(low = 25, high = 25)
caty_n <- list(low = c(small = 10, large = 15), high = c(small = 12, large = 13))
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT",
caty_var = "AREA_CAT", caty_n = caty_n
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, proportional (to size) probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "proportional", aux_var = "AREA")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, proportional probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
grts_output <- grts(NE_Lakes, n_base = n_base, stratum_var = "ELEV_CAT", aux_var = "AREA")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
test_that("A warning (in message form) is produced", {
n_base <- c(low = 20, high = 30)
expect_message(expect_error(grts(NE_Lakes, n_base = n_base, stratum_var = "XYZ")))
})
#--------------------------------------
#-------- Legacy
#--------------------------------------
# legacy sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "equal",
stratum_var = "ELEV_CAT", legacy_sites = NE_Lakes_Legacy,
legacy_stratum_var = "ELEV_CAT"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
n_legacy_low <- sum(grts_output$sites_legacy$stratum == "low")
n_legacy_high <- sum(grts_output$sites_legacy$stratum == "high")
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]] - n_legacy_low
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]] - n_legacy_high
)
expect_equal(NROW(grts_output$sites_base), sum(n_base) - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal",
caty_var = "AREA_CAT", caty_n = caty_n, legacy_sites = NE_Lakes_Legacy,
legacy_caty_var = "AREA_CAT"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, proportional probability
test_that("algorithm executes", {
n_base <- 50
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "proportional",
aux_var = "AREA", legacy_sites = NE_Lakes_Legacy,
legacy_aux_var = "AREA"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out + 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, unstratified, equal probability -- old method
test_that("algorithm executes", {
n_base <- 50
n_legacy <- NROW(NE_Lakes_Legacy)
NE_Lakes$LEGACY <- NA
NE_Lakes_Legacy$LEGACY <- paste0("LEGACY-SITES-", 1:5)
NE_Lakes_bind <- rbind(NE_Lakes_Legacy, NE_Lakes)
grts_output <- grts(NE_Lakes_bind, n_base = n_base, seltype = "equal", legacy_var = "LEGACY")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out + 1) # as legacy variable added
expect_equal(NCOL(grts_output$sites_base), col_out + 1) # as legacy variable added
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#--------------------------------------
#-------- Minimum Distance
#--------------------------------------
# minimum distance, unstratified, equal probability
test_that("algorithm executes", {
library(sf)
n_base <- 50
mindis <- 1600
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", mindis = mindis)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
dist_mx <- as.vector(st_distance(grts_output$sites_base))
expect_true(min(dist_mx[dist_mx > 0]) > mindis)
})
#--------------------------------------
#-------- RHO replacement
#--------------------------------------
# rho replacement sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_over <- 5
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# rho replacement sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
n_over <- list(low = 2, high = 3)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "equal",
stratum_var = "ELEV_CAT", n_over = n_over
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(
NROW(grts_output$sites_over[grts_output$sites_over$stratum == "low", , drop = FALSE]),
n_over[["low"]]
)
expect_equal(
NROW(grts_output$sites_over[grts_output$sites_over$stratum == "high", , drop = FALSE]),
n_over[["high"]]
)
expect_equal(NROW(grts_output$sites_over), sum(unlist(n_over)))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# rho replacement sites, unstratified, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_over <- 10
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal",
caty_var = "AREA_CAT", caty_n = caty_n, n_over = n_over
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# rho replacement sites, unstratified, proportional probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_over <- 10
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "proportional",
aux_var = "AREA", n_over = n_over
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), col_out + 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratification and n_over
test_that("algorithm executes", {
n_base <- c(low = 5, high = 6)
stratum_var <- "ELEV_CAT"
caty_n <- list(low = c(small = 2, large = 3), high = c(small = 3, large = 3))
caty_var <- "AREA_CAT"
n_over <- c(low = 4, high = 3)
grts_output <- grts(NE_Lakes, n_base, stratum_var, caty_n = caty_n, caty_var = caty_var, n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), sum(n_over))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#--------------------------------------
#-------- NN replacement
#--------------------------------------
# nn replacement sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_near <- 2
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_base * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
# nn replacement sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
n_near <- 2
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "equal",
stratum_var = "ELEV_CAT", n_near = n_near
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_near * sum(n_base))
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
# nn replacement sites, unstratified, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_near <- 2
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal",
caty_var = "AREA_CAT", caty_n = caty_n, n_near = n_near
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_base * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
# nn replacement sites, unstratified, proportional probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_near <- 2
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "proportional",
aux_var = "AREA", n_near = n_near
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_base * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out + 1)
})
# stratification and n_near
test_that("algorithm executes", {
n_base <- c(low = 5, high = 6)
stratum_var <- "ELEV_CAT"
n_near <- c(low = 2, high = 1)
grts_output <- grts(NE_Lakes, n_base, stratum_var, n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), sum(n_base * n_near))
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
#--------------------------------------
#-------- RHO and NN replacement
#--------------------------------------
# both replacement sites, unstratified
test_that("algorithm executes", {
n_base <- 50
n_over <- 5
n_near <- 2
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over, n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), (n_base + n_over) * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
#--------------------------------------
#-------- Bad name replacement
#--------------------------------------
test_that("algorithm executes", {
n_legacy <- NROW(NE_Lakes_Legacy)
n_base <- 50
n_over <- 5
n_near <- 2
NE_Lakes$siteID <- seq_len(nrow(NE_Lakes))
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy, n_over = n_over, n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), n_over)
# used to be n_base - n_legacy + n_over but made legacy sites have nn sites
expect_equal(NROW(grts_output$sites_near), (n_base + n_over) * n_near)
expect_equal(NCOL(grts_output$sites_legacy), col_out + 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), col_out + 1)
expect_equal(NCOL(grts_output$sites_near), col_out + 1)
})
#--------------------------------------
#-------- Projected CRS
#--------------------------------------
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(st_transform(NE_Lakes, 4326), n_base = n_base, seltype = "equal", projcrs_check = FALSE)
# see if function ran without error
expect_true(exists("grts_output"))
# no legacy sites
expect_equal(NROW(grts_output$sites_legacy), 0)
# base sample size of 50
expect_equal(NROW(grts_output$sites_base), n_base)
# no rho replacement sites
expect_equal(NROW(grts_output$sites_over), 0)
# no nn replacement sites
expect_equal(NROW(grts_output$sites_near), 0)
# no legacy sites
expect_equal(NCOL(grts_output$sites_legacy), 1)
# base sample size columns should equal extra columns plus original columns
expect_equal(NCOL(grts_output$sites_base), col_out)
# no rho replacement sites
expect_equal(NCOL(grts_output$sites_over), 1)
# no nn replacement sites
expect_equal(NCOL(grts_output$sites_near), 1)
})
#################################################
########### Illinois_River DATA TESTS
#################################################
# number of grts columns added
col_grts_add <- 9
# number of Illinois_River columns
col_data <- NCOL(Illinois_River)
# number of grts columns plus Illinois_River columns
col_out <- col_grts_add + col_data
#--------------------------------------
#-------- Regular
#--------------------------------------
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size
test_that("algorithm executes", {
n_base <- 500
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size, replacement sites
test_that("algorithm executes", {
n_base <- 50
n_over <- 200
grts_output <- grts(Illinois_River, n_base = n_base, n_over = n_over, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 20, Arkansas = 30)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 200, Arkansas = 300)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 20, Arkansas = 30)
n_over <- list(Oklahoma = 200, Arkansas = 300)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME", n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), sum(unlist(n_over)))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#--------------------------------------
#-------- Legacy
#--------------------------------------
# legacy sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_legacy <- nrow(Illinois_River_Legacy)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", legacy_sites = Illinois_River_Legacy)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 20, Arkansas = 30)
n_legacy <- nrow(Illinois_River_Legacy)
grts_output <- grts(Illinois_River,
n_base = n_base, seltype = "equal",
stratum_var = "STATE_NAME", legacy_sites = Illinois_River_Legacy,
legacy_stratum_var = "STATE_NAME"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
n_legacy_Oklahoma <- sum(grts_output$sites_legacy$stratum == "Oklahoma")
n_legacy_Arkansas <- sum(grts_output$sites_legacy$stratum == "Arkansas")
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]] - n_legacy_Oklahoma
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]] - n_legacy_Arkansas
)
expect_equal(NROW(grts_output$sites_base), sum(n_base) - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#################################################
########### Lake_Ontario DATA TESTS
#################################################
# number of grts columns added
col_grts_add <- 9
# number of Lake_Ontario columns
col_data <- NCOL(Lake_Ontario)
# number of grts columns plus Lake_Ontario columns
col_out <- col_grts_add + col_data
#--------------------------------------
#-------- Regular
#--------------------------------------
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size
test_that("algorithm executes", {
n_base <- 500
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size, replacement sites
test_that("algorithm executes", {
n_base <- 50
n_over <- 200
grts_output <- grts(Lake_Ontario, n_base = n_base, n_over = n_over, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(CAN = 20, USA = 30)
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "CAN", , drop = FALSE]),
n_base[["CAN"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "USA", , drop = FALSE]),
n_base[["USA"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, large sample size
test_that("algorithm executes", {
n_base <- c(CAN = 200, USA = 300)
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "CAN", , drop = FALSE]),
n_base[["CAN"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "USA", , drop = FALSE]),
n_base[["USA"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# replacement sites
test_that("algorithm executes", {
n_base <- c(CAN = 200, USA = 300)
n_over <- list(CAN = 100, USA = 100)
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY", n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "CAN", , drop = FALSE]),
n_base[["CAN"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "USA", , drop = FALSE]),
n_base[["USA"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), sum(unlist(n_over)))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
}
}
USEPA/spsurvey documentation built on Jan. 26, 2024, 4:18 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
context("grts")
# find system info
on_solaris <- Sys.info()[["sysname"]] == "SunOS"
if (on_solaris) {
test_that("on solaris", {
expect_true(on_solaris)
})
} else {
# set reproducible seed (as there are random components here)
set.seed(5)
test_local <- FALSE # FALSE for CRAN
#################################################
########### NE_LAKES DATA TESTS
#################################################
#--------------------------------------
#-------- Class Inheritance
#--------------------------------------
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal")
# class inheritance
expect_s3_class(grts_output, "sp_design")
})
#--------------------------------------
#-------- Work with sp_frame
#--------------------------------------
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(sp_frame(NE_Lakes), n_base = n_base, seltype = "equal")
# class inheritance
expect_s3_class(grts_output, "sp_design")
})
if (test_local) {
#--------------------------------------
#-------- Regular
#--------------------------------------
# number of grts columns added
col_grts_add <- 9
# number of NE_Lakes columns
col_data <- NCOL(NE_Lakes)
# number of grts columns plus NE_Lakes columns
col_out <- col_grts_add + col_data
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal")
# see if function ran without error
expect_true(exists("grts_output"))
# no legacy sites
expect_equal(NROW(grts_output$sites_legacy), 0)
# base sample size of 50
expect_equal(NROW(grts_output$sites_base), n_base)
# no rho replacement sites
expect_equal(NROW(grts_output$sites_over), 0)
# no nn replacement sites
expect_equal(NROW(grts_output$sites_near), 0)
# no legacy sites
expect_equal(NCOL(grts_output$sites_legacy), 1)
# base sample size columns should equal extra columns plus original columns
expect_equal(NCOL(grts_output$sites_base), col_out)
# no rho replacement sites
expect_equal(NCOL(grts_output$sites_over), 1)
# no nn replacement sites
expect_equal(NCOL(grts_output$sites_near), 1)
# class inheritance
expect_s3_class(grts_output, "sp_design")
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", stratum_var = "ELEV_CAT")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "unequal", caty_var = "AREA_CAT", caty_n = caty_n)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, unequal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
caty_n <- list(low = c(small = 10, large = 10), high = c(small = 10, large = 20))
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT",
caty_var = "AREA_CAT", caty_n = caty_n
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, unequal probability (with repeated caty_n)
test_that("algorithm executes", {
n_base <- c(low = 25, high = 25)
caty_n <- c(small = 12.5, large = 12.5)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT",
caty_var = "AREA_CAT", caty_n = caty_n
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, unequal probability (with different caty_n)
test_that("algorithm executes", {
n_base <- c(low = 25, high = 25)
caty_n <- list(low = c(small = 10, large = 15), high = c(small = 12, large = 13))
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT",
caty_var = "AREA_CAT", caty_n = caty_n
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, proportional (to size) probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "proportional", aux_var = "AREA")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, proportional probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
grts_output <- grts(NE_Lakes, n_base = n_base, stratum_var = "ELEV_CAT", aux_var = "AREA")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
test_that("A warning (in message form) is produced", {
n_base <- c(low = 20, high = 30)
expect_message(expect_error(grts(NE_Lakes, n_base = n_base, stratum_var = "XYZ")))
})
#--------------------------------------
#-------- Legacy
#--------------------------------------
# legacy sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "equal",
stratum_var = "ELEV_CAT", legacy_sites = NE_Lakes_Legacy,
legacy_stratum_var = "ELEV_CAT"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
n_legacy_low <- sum(grts_output$sites_legacy$stratum == "low")
n_legacy_high <- sum(grts_output$sites_legacy$stratum == "high")
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]] - n_legacy_low
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]] - n_legacy_high
)
expect_equal(NROW(grts_output$sites_base), sum(n_base) - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal",
caty_var = "AREA_CAT", caty_n = caty_n, legacy_sites = NE_Lakes_Legacy,
legacy_caty_var = "AREA_CAT"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, proportional probability
test_that("algorithm executes", {
n_base <- 50
n_legacy <- NROW(NE_Lakes_Legacy)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "proportional",
aux_var = "AREA", legacy_sites = NE_Lakes_Legacy,
legacy_aux_var = "AREA"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out + 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, unstratified, equal probability -- old method
test_that("algorithm executes", {
n_base <- 50
n_legacy <- NROW(NE_Lakes_Legacy)
NE_Lakes$LEGACY <- NA
NE_Lakes_Legacy$LEGACY <- paste0("LEGACY-SITES-", 1:5)
NE_Lakes_bind <- rbind(NE_Lakes_Legacy, NE_Lakes)
grts_output <- grts(NE_Lakes_bind, n_base = n_base, seltype = "equal", legacy_var = "LEGACY")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out + 1) # as legacy variable added
expect_equal(NCOL(grts_output$sites_base), col_out + 1) # as legacy variable added
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#--------------------------------------
#-------- Minimum Distance
#--------------------------------------
# minimum distance, unstratified, equal probability
test_that("algorithm executes", {
library(sf)
n_base <- 50
mindis <- 1600
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", mindis = mindis)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
dist_mx <- as.vector(st_distance(grts_output$sites_base))
expect_true(min(dist_mx[dist_mx > 0]) > mindis)
})
#--------------------------------------
#-------- RHO replacement
#--------------------------------------
# rho replacement sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_over <- 5
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# rho replacement sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
n_over <- list(low = 2, high = 3)
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "equal",
stratum_var = "ELEV_CAT", n_over = n_over
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(
NROW(grts_output$sites_over[grts_output$sites_over$stratum == "low", , drop = FALSE]),
n_over[["low"]]
)
expect_equal(
NROW(grts_output$sites_over[grts_output$sites_over$stratum == "high", , drop = FALSE]),
n_over[["high"]]
)
expect_equal(NROW(grts_output$sites_over), sum(unlist(n_over)))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# rho replacement sites, unstratified, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_over <- 10
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal",
caty_var = "AREA_CAT", caty_n = caty_n, n_over = n_over
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# rho replacement sites, unstratified, proportional probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_over <- 10
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "proportional",
aux_var = "AREA", n_over = n_over
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), col_out + 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratification and n_over
test_that("algorithm executes", {
n_base <- c(low = 5, high = 6)
stratum_var <- "ELEV_CAT"
caty_n <- list(low = c(small = 2, large = 3), high = c(small = 3, large = 3))
caty_var <- "AREA_CAT"
n_over <- c(low = 4, high = 3)
grts_output <- grts(NE_Lakes, n_base, stratum_var, caty_n = caty_n, caty_var = caty_var, n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), sum(n_over))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#--------------------------------------
#-------- NN replacement
#--------------------------------------
# nn replacement sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_near <- 2
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_base * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
# nn replacement sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(low = 20, high = 30)
n_near <- 2
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "equal",
stratum_var = "ELEV_CAT", n_near = n_near
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "low", , drop = FALSE]),
n_base[["low"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "high", , drop = FALSE]),
n_base[["high"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_near * sum(n_base))
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
# nn replacement sites, unstratified, unequal probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_near <- 2
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "unequal",
caty_var = "AREA_CAT", caty_n = caty_n, n_near = n_near
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_base * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
# nn replacement sites, unstratified, proportional probability
test_that("algorithm executes", {
n_base <- 50
caty_n <- c(small = 24, large = 26)
n_near <- 2
grts_output <- grts(NE_Lakes,
n_base = n_base, seltype = "proportional",
aux_var = "AREA", n_near = n_near
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), n_base * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out + 1)
})
# stratification and n_near
test_that("algorithm executes", {
n_base <- c(low = 5, high = 6)
stratum_var <- "ELEV_CAT"
n_near <- c(low = 2, high = 1)
grts_output <- grts(NE_Lakes, n_base, stratum_var, n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), sum(n_base * n_near))
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
#--------------------------------------
#-------- RHO and NN replacement
#--------------------------------------
# both replacement sites, unstratified
test_that("algorithm executes", {
n_base <- 50
n_over <- 5
n_near <- 2
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over, n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), (n_base + n_over) * n_near)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), col_out)
})
#--------------------------------------
#-------- Bad name replacement
#--------------------------------------
test_that("algorithm executes", {
n_legacy <- NROW(NE_Lakes_Legacy)
n_base <- 50
n_over <- 5
n_near <- 2
NE_Lakes$siteID <- seq_len(nrow(NE_Lakes))
grts_output <- grts(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy, n_over = n_over, n_near = n_near)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), n_over)
# used to be n_base - n_legacy + n_over but made legacy sites have nn sites
expect_equal(NROW(grts_output$sites_near), (n_base + n_over) * n_near)
expect_equal(NCOL(grts_output$sites_legacy), col_out + 1)
expect_equal(NCOL(grts_output$sites_base), col_out + 1)
expect_equal(NCOL(grts_output$sites_over), col_out + 1)
expect_equal(NCOL(grts_output$sites_near), col_out + 1)
})
#--------------------------------------
#-------- Projected CRS
#--------------------------------------
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(st_transform(NE_Lakes, 4326), n_base = n_base, seltype = "equal", projcrs_check = FALSE)
# see if function ran without error
expect_true(exists("grts_output"))
# no legacy sites
expect_equal(NROW(grts_output$sites_legacy), 0)
# base sample size of 50
expect_equal(NROW(grts_output$sites_base), n_base)
# no rho replacement sites
expect_equal(NROW(grts_output$sites_over), 0)
# no nn replacement sites
expect_equal(NROW(grts_output$sites_near), 0)
# no legacy sites
expect_equal(NCOL(grts_output$sites_legacy), 1)
# base sample size columns should equal extra columns plus original columns
expect_equal(NCOL(grts_output$sites_base), col_out)
# no rho replacement sites
expect_equal(NCOL(grts_output$sites_over), 1)
# no nn replacement sites
expect_equal(NCOL(grts_output$sites_near), 1)
})
#################################################
########### Illinois_River DATA TESTS
#################################################
# number of grts columns added
col_grts_add <- 9
# number of Illinois_River columns
col_data <- NCOL(Illinois_River)
# number of grts columns plus Illinois_River columns
col_out <- col_grts_add + col_data
#--------------------------------------
#-------- Regular
#--------------------------------------
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size
test_that("algorithm executes", {
n_base <- 500
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size, replacement sites
test_that("algorithm executes", {
n_base <- 50
n_over <- 200
grts_output <- grts(Illinois_River, n_base = n_base, n_over = n_over, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 20, Arkansas = 30)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 200, Arkansas = 300)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 20, Arkansas = 30)
n_over <- list(Oklahoma = 200, Arkansas = 300)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME", n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), sum(unlist(n_over)))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#--------------------------------------
#-------- Legacy
#--------------------------------------
# legacy sites, unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
n_legacy <- nrow(Illinois_River_Legacy)
grts_output <- grts(Illinois_River, n_base = n_base, seltype = "equal", legacy_sites = Illinois_River_Legacy)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
expect_equal(NROW(grts_output$sites_base), n_base - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# legacy sites, stratified, equal probability
test_that("algorithm executes", {
n_base <- c(Oklahoma = 20, Arkansas = 30)
n_legacy <- nrow(Illinois_River_Legacy)
grts_output <- grts(Illinois_River,
n_base = n_base, seltype = "equal",
stratum_var = "STATE_NAME", legacy_sites = Illinois_River_Legacy,
legacy_stratum_var = "STATE_NAME"
)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), n_legacy)
n_legacy_Oklahoma <- sum(grts_output$sites_legacy$stratum == "Oklahoma")
n_legacy_Arkansas <- sum(grts_output$sites_legacy$stratum == "Arkansas")
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Oklahoma", , drop = FALSE]),
n_base[["Oklahoma"]] - n_legacy_Oklahoma
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "Arkansas", , drop = FALSE]),
n_base[["Arkansas"]] - n_legacy_Arkansas
)
expect_equal(NROW(grts_output$sites_base), sum(n_base) - n_legacy)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), col_out)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
#################################################
########### Lake_Ontario DATA TESTS
#################################################
# number of grts columns added
col_grts_add <- 9
# number of Lake_Ontario columns
col_data <- NCOL(Lake_Ontario)
# number of grts columns plus Lake_Ontario columns
col_out <- col_grts_add + col_data
#--------------------------------------
#-------- Regular
#--------------------------------------
# unstratified, equal probability
test_that("algorithm executes", {
n_base <- 50
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size
test_that("algorithm executes", {
n_base <- 500
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# unstratified, large sample size, replacement sites
test_that("algorithm executes", {
n_base <- 50
n_over <- 200
grts_output <- grts(Lake_Ontario, n_base = n_base, n_over = n_over, seltype = "equal")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(NROW(grts_output$sites_base), n_base)
expect_equal(NROW(grts_output$sites_over), n_over)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, equal probability
test_that("algorithm executes", {
n_base <- c(CAN = 20, USA = 30)
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "CAN", , drop = FALSE]),
n_base[["CAN"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "USA", , drop = FALSE]),
n_base[["USA"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# stratified, large sample size
test_that("algorithm executes", {
n_base <- c(CAN = 200, USA = 300)
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY")
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "CAN", , drop = FALSE]),
n_base[["CAN"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "USA", , drop = FALSE]),
n_base[["USA"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), 0)
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), 1)
expect_equal(NCOL(grts_output$sites_near), 1)
})
# replacement sites
test_that("algorithm executes", {
n_base <- c(CAN = 200, USA = 300)
n_over <- list(CAN = 100, USA = 100)
grts_output <- grts(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY", n_over = n_over)
expect_true(exists("grts_output"))
expect_equal(NROW(grts_output$sites_legacy), 0)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "CAN", , drop = FALSE]),
n_base[["CAN"]]
)
expect_equal(
NROW(grts_output$sites_base[grts_output$sites_base$stratum == "USA", , drop = FALSE]),
n_base[["USA"]]
)
expect_equal(NROW(grts_output$sites_base), sum(n_base))
expect_equal(NROW(grts_output$sites_over), sum(unlist(n_over)))
expect_equal(NROW(grts_output$sites_near), 0)
expect_equal(NCOL(grts_output$sites_legacy), 1)
expect_equal(NCOL(grts_output$sites_base), col_out)
expect_equal(NCOL(grts_output$sites_over), col_out)
expect_equal(NCOL(grts_output$sites_near), 1)
})
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.