diff --git a/DESCRIPTION b/DESCRIPTION index 737911a..432868e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: spsurvey Title: Spatial Sampling Design and Analysis -Version: 5.0.0 +Version: 5.0.1 Authors@R: c( person("Michael", "Dumelle", role=c("aut","cre"), email = "Dumelle.Michael@epa.gov", comment = c(ORCID = "0000-0002-3393-5529")), diff --git a/NEWS.md b/NEWS.md index 04d1ae9..53f8ccd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# spsurvey 5.0.1 (2021-10-18) + +## Bug fix + +* Addressed Solaris performance problems. + # spsurvey 5.0.0 (2021-10-15) ## Major Updates diff --git a/R/dsgn_check.R b/R/dsgn_check.R index 7963e71..fbfb75c 100644 --- a/R/dsgn_check.R +++ b/R/dsgn_check.R @@ -347,20 +347,20 @@ dsgn_check <- function(sframe, sf_type, legacy_sites, legacy_option, stratum, se if (is.list(n_over)) { if (any(sapply(stratum, function(x) (n_base[[x]] + ifelse(is.null(n_over[[x]]), 0, sum(n_over[[x]]))) > NROW(sframe[sframe[[stratum_var]] == x, , drop = FALSE])))) { stop_ind <- TRUE - stop_mess <- paste0("For each stratum, the sum of the base sites and 'Over' replacement sites must be no larger than the number of rows in 'sframe' representing that stratum") + stop_mess <- paste0("For each stratum, the sum of the base sites and 'Over' replacement sites must be no larger than the number of rows in 'sframe' representing that stratum.") stop_df <- rbind(stop_df, data.frame(func = I("n_base + n_over"), I(stop_mess))) } } else { if (any(sapply(stratum, function(x) (n_base[[x]] + sum(n_over)) > NROW(sframe[sframe[[stratum_var]] == x, , drop = FALSE])))) { stop_ind <- TRUE - stop_mess <- paste0("For each stratum, the sum of the base sites and 'Over' replacement sites must be no larger than the number of rows in 'sframe' representing that stratum") + stop_mess <- paste0("For each stratum, the sum of the base sites and 'Over' replacement sites must be no larger than the number of rows in 'sframe' representing that stratum.") stop_df <- rbind(stop_df, data.frame(func = I("n_base + n_over"), I(stop_mess))) } } } else { if ((n_base + sum(n_over)) > NROW(sframe)) { stop_ind <- TRUE - stop_mess <- paste0("The sum of the base sites and 'Over' replacement sites must be no larger than the number of rows in 'sframe'") + stop_mess <- paste0("The sum of the base sites and 'Over' replacement sites must be no larger than the number of rows in 'sframe'.") stop_df <- rbind(stop_df, data.frame(func = I("n_base + n_over"), I(stop_mess))) } } @@ -375,6 +375,14 @@ dsgn_check <- function(sframe, sf_type, legacy_sites, legacy_option, stratum, se } } + # find system info + on_solaris <- Sys.info()[["sysname"]] == "SunOS" + if (on_solaris) { + stop_ind <- TRUE + stop_mess <- paste0("grts() and irs() are not supported on Solaris.") + stop_df <- rbind(stop_df, data.frame(func = I("Solaris"), I(stop_mess))) + } + ### If any issues, write out stop_df and then stop if (stop_ind) { names(stop_df) <- c("Design Input", "Error Message") diff --git a/R/grts.R b/R/grts.R index e0d306b..48b3d0d 100644 --- a/R/grts.R +++ b/R/grts.R @@ -274,10 +274,12 @@ #' of natural resources. \emph{Journal of the american Statistical association}, 99(465), 262-278. #' #' @examples +#' \dontrun{ #' sample <- grts(NE_Lakes, n_base = 100) #' strata_n <- c(low = 25, high = 30) #' sample_strat <- grts(NE_Lakes, n_base = strata_n, stratum_var = "ELEV_CAT") #' sample_over <- grts(NE_Lakes, n_base = 30, n_over = 5) +#' } #' @export ################################################################################ grts <- function(sframe, n_base, stratum_var = NULL, seltype = NULL, caty_var = NULL, diff --git a/R/irs.R b/R/irs.R index fbe7f3d..44a258a 100644 --- a/R/irs.R +++ b/R/irs.R @@ -21,13 +21,14 @@ #' } #' #' @examples +#' \dontrun{ #' sample <- irs(NE_Lakes, n_base = 100) #' strata_n <- c(low = 25, high = 30) #' sample_strat <- irs(NE_Lakes, n_base = strata_n, stratum_var = "ELEV_CAT") #' sample_over <- irs(NE_Lakes, n_base = 30, n_over = 5) +#' } #' @export ############################################################################### - irs <- function(sframe, n_base, stratum_var = NULL, seltype = NULL, caty_var = NULL, caty_n = NULL, aux_var = NULL, legacy_var = NULL, legacy_sites = NULL, legacy_stratum_var = NULL, diff --git a/R/sp_balance.R b/R/sp_balance.R index 8331a2e..5af9a2b 100644 --- a/R/sp_balance.R +++ b/R/sp_balance.R @@ -61,16 +61,24 @@ #' @export #' #' @examples +#' \dontrun{ #' sample <- grts(NE_Lakes, 30) #' sp_balance(sample$sites_base, NE_Lakes) #' strata_n <- c(low = 25, high = 30) #' sample_strat <- grts(NE_Lakes, n_base = strata_n, stratum_var = "ELEV_CAT") #' sp_balance(sample_strat$sites_base, NE_Lakes, stratum_var = "ELEV_CAT", metric = "rmse") +#' } sp_balance <- function(object, sframe, stratum_var = NULL, ip = NULL, metrics = "pielou", extents = FALSE) { if (inherits(object, "spdesign")) { stop("object must be an sf object. If object is output from grts() or irs(), instead 1) use object$sites_legacy, object$sites_base, object$sites_over, or object$sites_near; or 2) use sp_rbind().") } + # find system info + on_solaris <- Sys.info()[["sysname"]] == "SunOS" + if (on_solaris) { + stop("sp_balance() is not supported on Solaris.") + } + if (is.null(stratum_var)) { object$stratum_var <- "None" sframe$stratum_var <- "None" diff --git a/R/sp_plot.R b/R/sp_plot.R index 2ac03c3..cddff9d 100644 --- a/R/sp_plot.R +++ b/R/sp_plot.R @@ -87,12 +87,14 @@ #' @export #' #' @examples +#' \dontrun{ #' data("NE_Lakes") #' sp_plot(NE_Lakes, formula = ~ELEV_CAT) #' sample <- grts(NE_Lakes, 30) #' sp_plot(sample, NE_Lakes) #' data("NLA_PNW") #' sp_plot(NLA_PNW, formula = ~BMMI) +#' } sp_plot <- function(object, ...) { UseMethod("sp_plot", object) } @@ -104,6 +106,12 @@ sp_plot.default <- function(object, formula = ~1, xcoord, ycoord, crs, var_args = NULL, varlevel_args = NULL, geom = FALSE, onlyshow = NULL, fix_bbox = TRUE, ...) { + # find system info + on_solaris <- Sys.info()[["sysname"]] == "SunOS" + if (on_solaris) { + stop("sp_plot() is not supported on Solaris.") + } + # coerce to sf if (!inherits(object, "sf")) { object <- st_as_sf(object, coords = c(xcoord, ycoord), crs = crs) @@ -290,6 +298,13 @@ sp_plot.default <- function(object, formula = ~1, xcoord, ycoord, crs, sp_plot.spdesign <- function(object, sframe = NULL, formula = ~siteuse, siteuse = NULL, var_args = NULL, varlevel_args = NULL, geom = FALSE, onlyshow = NULL, fix_bbox = TRUE, ...) { + + # find system info + on_solaris <- Sys.info()[["sysname"]] == "SunOS" + if (on_solaris) { + stop("sp_plot() is not supported on Solaris.") + } + if ((is.null(siteuse) & (!is.null(object$sites_near))) | "Near" %in% siteuse) { object$sites_near$siteuse <- "Near" } diff --git a/R/sp_rbind.R b/R/sp_rbind.R index 2bd8236..c995a48 100644 --- a/R/sp_rbind.R +++ b/R/sp_rbind.R @@ -22,9 +22,9 @@ #' @export #' #' @examples +#' \dontrun{ #' sample <- grts(NE_Lakes, 50, n_over = 10) #' sample <- sp_rbind(sample) -#' \dontrun{ #' write_sf(sample, "mypath/sample.shp") #' } sp_rbind <- function(object, siteuse = NULL) { diff --git a/R/sp_summary.R b/R/sp_summary.R index 87dd882..cc77078 100644 --- a/R/sp_summary.R +++ b/R/sp_summary.R @@ -59,11 +59,13 @@ #' @export #' #' @examples +#' \dontrun{ #' data("NE_Lakes") #' sp_summary(NE_Lakes, ELEV ~ 1) #' sp_summary(NE_Lakes, ~ ELEV_CAT * AREA_CAT) #' sample <- grts(NE_Lakes, 100) #' sp_summary(sample, ~ ELEV_CAT * AREA_CAT) +#' } sp_summary <- function(object, ...) { UseMethod("sp_summary", object) } @@ -72,6 +74,13 @@ sp_summary <- function(object, ...) { #' @method sp_summary default #' @export sp_summary.default <- function(object, formula = ~1, onlyshow = NULL, ...) { + + # find system info + on_solaris <- Sys.info()[["sysname"]] == "SunOS" + if (on_solaris) { + stop("sp_summary() is not supported on Solaris.") + } + # making formlist (utils.R) formlist <- make_formlist(formula, onlyshow, object) # making varsf (utils.R) diff --git a/README.md b/README.md index 0ea9ead..e44e905 100644 --- a/README.md +++ b/README.md @@ -78,7 +78,7 @@ citation(package = "spsurvey") #> To cite the spsurvey package in publications use: #> #> Dumelle, Michael., Kincaid, T. M., Olsen, A. R., and Weber, M. H. (2021). spsurvey: -#> Spatial Sampling Design and Analysis. R package version 5.0.0. +#> Spatial Sampling Design and Analysis. R package version 5.0.1. #> #> A BibTeX entry for LaTeX users is #> @@ -86,7 +86,7 @@ citation(package = "spsurvey") #> title = {spsurvey: Spatial Sampling Design and Analysis}, #> author = {Michael Dumelle and Thomas M. Kincaid and Anthony R. Olsen and Marc H. Weber}, #> year = {2021}, -#> note = {R package version 5.0.0}, +#> note = {R package version 5.0.1}, #> } ``` diff --git a/cran-comments.md b/cran-comments.md index b25aaea..8f59bd6 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,51 +1,43 @@ -This is a major update introducing several updates to pre-existing functions -Some of these changes are breaking; we alert users to this fact in the `NEWS.md` file -and in a startup message upon loading the package. In addition, some -new functions were added. +This is a minor update addressing Solaris performance problems. ------- ## Test environments -* Tests run on October 15, 2021 (rhub version 1.1.1) + +* Tests run on October 18, 2021 (rhub version 1.1.1) * Build reports can be viewed through their hyperlinked Build ID URLs * `rhub::check_for_cran()` * Platform: Windows Server 2008 R2 SP1, R-devel, 32/64 bit * Status: success (NOTE related to manual PDF size -- see next section) - * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.0.tar.gz-2835f96162ea4b4fa9f946614b80775c + * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.1.tar.gz-a4d656b6638b424ebe6d856cbafe69b5 * Platform: Fedora Linux, R-devel, clang, gfortran * Status: success (NOTE related to manual PDF size -- see next section) - * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.0.tar.gz-3e7a8d16eba44f46befc13a83b2680a6 + * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.1.tar.gz-5605a60bc9a244c9a98ec169dc2a6fc5 * Platform: Ubuntu Linux 20.04.1 LTS, R-release, GCC * Status: SUCCESS (NOTE related to manual PDF size see next section) - * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.0.tar.gz-cbb896af25454f17a7eaf4aac0d72d76 + * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.1.tar.gz-a3841f544902438cb731c8399e582bc5 * `rhub::check_on_windows()` * Platform: Windows Server 2008 R2 SP1, R-release, 32/64 bit * success (NOTE related to manual PDF size -- see next section) - * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.0.tar.gz-2c912c5200234b0e9f2d296457564757 + * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.1.tar.gz-54655dd37aa64eec800ba369ce921ecf * `rhub::check_on_linux()` * Platform: Debian Linux, R-release, GCC * success (NOTE related to manual PDF size -- see next section) - * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.0.tar.gz-ee578c071fb14bf982b487bfa4c07b89 + * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.1.tar.gz-cf184d638b814ac3a2770048fdbc2645 -* `rhub::check_on_ubuntu()` - * Platform: Ubuntu Linux 20.04.1 LTS, R-release, GCC - * success (NOTE related to manual PDF size -- see next section) - * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.0.tar.gz-921468a2297d4721a23c49fddae151d0 +* `rhub::check_on_solaris()` + * Platform: Oracle Solaris 10, x86, 32 bit, R-release + * success (NOTE related to panual PDF size -- see next section) + * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.1.tar.gz-4b382f8214e24e3ab589d463fc93c417 * `rhub::check(platform = "macos-highsierra-release-cran")` * Platform: macOS 10.13.6 High Sierra, R-release, CRAN's setup * Status: SUCCESS (NOTE related to manual PDF size see next section) - * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.0.tar.gz-1bba837e167b4ae5b111ad5ac445a936 - -* GitHub actions (`usethis::use_github_action_check_standard()` also available [here](https://github.com/r-lib/actions/blob/master/examples/check-standard.yaml)) - * Platform: windows-latest (release), macOS-latest (release), ubuntu-20.04 (release), ubundo-20.04 (devel) - * Build ID: GitHub actions R-CMD-check results for spsurvey are available [here](https://github.com/USEPA/spsurvey/actions/workflows/R-CMD-check.yaml). This push corresponds to - R-CMD-check 22 (news and cran comment updates) on October 15, 2021. - + * Build ID: https://builder.r-hub.io/status/spsurvey_5.0.1.tar.gz-f1f08046f1894225a104b6020907d7b1 ## R CMD check results @@ -64,5 +56,4 @@ reflect the size of the final PDF manual installed upon package build. ## Downstream dependencies -I have let the authors of packages that import and suggest spsurvey know that we -are releasing a major update. +This minor update should not affect any downstream dependencies (apart from those impacted by the release of version 5.0.0) diff --git a/inst/CITATION b/inst/CITATION index 5ff76b4..1ee87f9 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -5,8 +5,8 @@ citEntry( title="spsurvey: Spatial Sampling Design and Analysis", author="Michael Dumelle, Thomas M. Kincaid, Anthony R. Olsen, and Marc H. Weber", year=2021, - note="R package version 5.0.0", + note="R package version 5.0.1", textVersion=paste("Dumelle, Michael., Kincaid, T. M., Olsen, A. R., and Weber, M. H. (2021).", "spsurvey: Spatial Sampling Design and Analysis.", - "R package version 5.0.0.") + "R package version 5.0.1.") ) diff --git a/man/grts.Rd b/man/grts.Rd index 6d42566..2c6e753 100644 --- a/man/grts.Rd +++ b/man/grts.Rd @@ -289,11 +289,13 @@ For technical details, see Stevens and Olsen (2004). any replacement sites that may be required. } \examples{ +\dontrun{ sample <- grts(NE_Lakes, n_base = 100) strata_n <- c(low = 25, high = 30) sample_strat <- grts(NE_Lakes, n_base = strata_n, stratum_var = "ELEV_CAT") sample_over <- grts(NE_Lakes, n_base = 30, n_over = 5) } +} \references{ Stevens Jr., Don L. and Olsen, Anthony R. (2004). Spatially balanced sampling of natural resources. \emph{Journal of the american Statistical association}, 99(465), 262-278. diff --git a/man/irs.Rd b/man/irs.Rd index 9a25588..8ca8e8c 100644 --- a/man/irs.Rd +++ b/man/irs.Rd @@ -288,11 +288,13 @@ requiring a minimum distance between sites, and selecting replacement sites. any replacement sites that may be required. } \examples{ +\dontrun{ sample <- irs(NE_Lakes, n_base = 100) strata_n <- c(low = 25, high = 30) sample_strat <- irs(NE_Lakes, n_base = strata_n, stratum_var = "ELEV_CAT") sample_over <- irs(NE_Lakes, n_base = 30, n_over = 5) } +} \seealso{ \describe{ \item{\code{\link{grts}}}{ to select a sample that is spatially balanced} diff --git a/man/sp_balance.Rd b/man/sp_balance.Rd index 006436a..98e0724 100644 --- a/man/sp_balance.Rd +++ b/man/sp_balance.Rd @@ -65,12 +65,14 @@ sampling frame) of design sites using Voronoi polygons (Dirichlet tessellations). } \examples{ +\dontrun{ sample <- grts(NE_Lakes, 30) sp_balance(sample$sites_base, NE_Lakes) strata_n <- c(low = 25, high = 30) sample_strat <- grts(NE_Lakes, n_base = strata_n, stratum_var = "ELEV_CAT") sp_balance(sample_strat$sites_base, NE_Lakes, stratum_var = "ELEV_CAT", metric = "rmse") } +} \author{ Michael Dumelle \email{Dumelle.Michael@epa.gov} } diff --git a/man/sp_plot.Rd b/man/sp_plot.Rd index 3cc68fe..98daa89 100644 --- a/man/sp_plot.Rd +++ b/man/sp_plot.Rd @@ -114,6 +114,7 @@ methods can supply additional arguments to \code{plot.sf()}. For more informatio plotting in \code{sf}, run \code{?sf::plot.sf()}. } \examples{ +\dontrun{ data("NE_Lakes") sp_plot(NE_Lakes, formula = ~ELEV_CAT) sample <- grts(NE_Lakes, 30) @@ -121,6 +122,7 @@ sp_plot(sample, NE_Lakes) data("NLA_PNW") sp_plot(NLA_PNW, formula = ~BMMI) } +} \author{ Michael Dumelle \email{Dumelle.Michael@epa.gov} } diff --git a/man/sp_rbind.Rd b/man/sp_rbind.Rd index 15fd24c..8d42c69 100644 --- a/man/sp_rbind.Rd +++ b/man/sp_rbind.Rd @@ -27,9 +27,9 @@ into a single \code{sf} object. This function is most useful when a single (e.g. writing out a single shapefile using \code{sf::write_sf()}). } \examples{ +\dontrun{ sample <- grts(NE_Lakes, 50, n_over = 10) sample <- sp_rbind(sample) -\dontrun{ write_sf(sample, "mypath/sample.shp") } } diff --git a/man/sp_summary.Rd b/man/sp_summary.Rd index 00c75b2..076faae 100644 --- a/man/sp_summary.Rd +++ b/man/sp_summary.Rd @@ -63,12 +63,14 @@ of the formula contains a variable, the summary will be of the left-hand size va for each level of each right-hand side variable. } \examples{ +\dontrun{ data("NE_Lakes") sp_summary(NE_Lakes, ELEV ~ 1) sp_summary(NE_Lakes, ~ ELEV_CAT * AREA_CAT) sample <- grts(NE_Lakes, 100) sp_summary(sample, ~ ELEV_CAT * AREA_CAT) } +} \author{ Michael Dumelle \email{Dumelle.Michael@epa.gov} } diff --git a/tests/testthat/test-grts.R b/tests/testthat/test-grts.R index 079a40c..52ef2d1 100644 --- a/tests/testthat/test-grts.R +++ b/tests/testthat/test-grts.R @@ -1,722 +1,730 @@ context("grts") -# set reproducible seed (as there are random components here) -set.seed(5) - -################################################# -########### NE_LAKES DATA TESTS -################################################# - -#-------------------------------------- -#-------- 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) -}) - -# 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) -}) - -#-------------------------------------- -#-------- 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) - caty_n_over <- c(small = 5, large = 5) - n_over <- sum(caty_n_over) - grts_output <- grts(NE_Lakes, - n_base = n_base, seltype = "unequal", - caty_var = "AREA_CAT", caty_n = caty_n, n_over = caty_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) -}) - -#-------------------------------------- -#-------- 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) -}) - -#-------------------------------------- -#-------- 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) - expect_equal(NROW(grts_output$sites_near), (n_base - n_legacy + 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) -}) - -################################################# -########### 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) -}) - -# 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) -}) - -#-------------------------------------- -#-------- 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) -}) - -# 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) -}) +# 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) + + ################################################# + ########### NE_LAKES DATA TESTS + ################################################# + + #-------------------------------------- + #-------- 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) + }) + + # 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) + }) + + #-------------------------------------- + #-------- 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) + caty_n_over <- c(small = 5, large = 5) + n_over <- sum(caty_n_over) + grts_output <- grts(NE_Lakes, + n_base = n_base, seltype = "unequal", + caty_var = "AREA_CAT", caty_n = caty_n, n_over = caty_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) + }) + + #-------------------------------------- + #-------- 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) + }) + + #-------------------------------------- + #-------- 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) + expect_equal(NROW(grts_output$sites_near), (n_base - n_legacy + 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) + }) + + ################################################# + ########### 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) + }) + + # 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) + }) + + #-------------------------------------- + #-------- 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) + }) + + # 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) + }) +} diff --git a/tests/testthat/test-irs.R b/tests/testthat/test-irs.R index 14511a5..67045ed 100644 --- a/tests/testthat/test-irs.R +++ b/tests/testthat/test-irs.R @@ -1,722 +1,730 @@ context("irs") -# set reproducible seed (as there are random components here) -set.seed(5) - -################################################# -########### NE_LAKES DATA TESTS -################################################# - -#-------------------------------------- -#-------- Regular -#-------------------------------------- - -# number of irs columns added -col_irs_add <- 9 - -# number of NE_Lakes columns -col_data <- NCOL(NE_Lakes) - -# number of irs columns plus NE_Lakes columns -col_out <- col_irs_add + col_data - -# unstratified, equal probability -test_that("algorithm executes", { - n_base <- 50 - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal") - # see if function ran without error - expect_true(exists("irs_output")) - # no legacy sites - expect_equal(NROW(irs_output$sites_legacy), 0) - # base sample size of 50 - expect_equal(NROW(irs_output$sites_base), n_base) - # no rho replacement sites - expect_equal(NROW(irs_output$sites_over), 0) - # no nn replacement sites - expect_equal(NROW(irs_output$sites_near), 0) - # no legacy sites - expect_equal(NCOL(irs_output$sites_legacy), 1) - # base sample size columns should equal extra columns plus original columns - expect_equal(NCOL(irs_output$sites_base), col_out) - # no rho replacement sites - expect_equal(NCOL(irs_output$sites_over), 1) - # no nn replacement sites - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# stratified, equal probability -test_that("algorithm executes", { - n_base <- c(low = 20, high = 30) - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", stratum_var = "ELEV_CAT") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# unstratified, unequal probability -test_that("algorithm executes", { - n_base <- 50 - caty_n <- c(small = 24, large = 26) - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "unequal", caty_var = "AREA_CAT", caty_n = caty_n) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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)) - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT", - caty_var = "AREA_CAT", caty_n = caty_n - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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) - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT", - caty_var = "AREA_CAT", caty_n = caty_n - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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)) - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT", - caty_var = "AREA_CAT", caty_n = caty_n - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# unstratified, proportional (to size) probability -test_that("algorithm executes", { - n_base <- 50 - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "proportional", aux_var = "AREA") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out + 1) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# stratified, proportional probability -test_that("algorithm executes", { - n_base <- c(low = 20, high = 30) - irs_output <- irs(NE_Lakes, n_base = n_base, stratum_var = "ELEV_CAT", aux_var = "AREA") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out + 1) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -#-------------------------------------- -#-------- Legacy -#-------------------------------------- - -# legacy sites, unstratified, equal probability -test_that("algorithm executes", { - n_base <- 50 - n_legacy <- NROW(NE_Lakes_Legacy) - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), col_out) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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) - irs_output <- irs(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("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - n_legacy_low <- sum(irs_output$sites_legacy$stratum == "low") - n_legacy_high <- sum(irs_output$sites_legacy$stratum == "high") - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - n_legacy_low - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - n_legacy_high - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base) - n_legacy) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), col_out) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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) - irs_output <- irs(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("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), col_out) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# legacy sites, proportional probability -test_that("algorithm executes", { - n_base <- 50 - n_legacy <- NROW(NE_Lakes_Legacy) - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "proportional", - aux_var = "AREA", legacy_sites = NE_Lakes_Legacy, - legacy_aux_var = "AREA" - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), col_out + 1) - expect_equal(NCOL(irs_output$sites_base), col_out + 1) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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) - irs_output <- irs(NE_Lakes_bind, n_base = n_base, seltype = "equal", legacy_var = "LEGACY") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), col_out + 1) # as legacy variable added - expect_equal(NCOL(irs_output$sites_base), col_out + 1) # as legacy variable added - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -#-------------------------------------- -#-------- Minimum Distance -#-------------------------------------- - -# minimum distance, unstratified, equal probability -test_that("algorithm executes", { - library(sf) - n_base <- 50 - mindis <- 1600 - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", mindis = mindis) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) - dist_mx <- as.vector(st_distance(irs_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 - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), n_over) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), col_out) - expect_equal(NCOL(irs_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) - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "equal", - stratum_var = "ELEV_CAT", n_over = n_over - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal( - NROW(irs_output$sites_over[irs_output$sites_over$stratum == "low", , drop = FALSE]), - n_over[["low"]] - ) - expect_equal( - NROW(irs_output$sites_over[irs_output$sites_over$stratum == "high", , drop = FALSE]), - n_over[["high"]] - ) - expect_equal(NROW(irs_output$sites_over), sum(unlist(n_over))) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), col_out) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# rho replacement sites, unstratified, unequal probability -test_that("algorithm executes", { - n_base <- 50 - caty_n <- c(small = 24, large = 26) - caty_n_over <- c(small = 5, large = 5) - n_over <- sum(caty_n_over) - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "unequal", - caty_var = "AREA_CAT", caty_n = caty_n, n_over = caty_n_over - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), n_over) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), col_out) - expect_equal(NCOL(irs_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 - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "proportional", - aux_var = "AREA", n_over = n_over - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), n_over) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out + 1) - expect_equal(NCOL(irs_output$sites_over), col_out + 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -#-------------------------------------- -#-------- NN replacement -#-------------------------------------- - -# nn replacement sites, unstratified, equal probability -test_that("algorithm executes", { - n_base <- 50 - n_near <- 2 - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", n_near = n_near) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), n_base * n_near) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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 - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "equal", - stratum_var = "ELEV_CAT", n_near = n_near - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), - n_base[["low"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), - n_base[["high"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), n_near * sum(n_base)) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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 - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "unequal", - caty_var = "AREA_CAT", caty_n = caty_n, n_near = n_near - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), n_base * n_near) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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 - irs_output <- irs(NE_Lakes, - n_base = n_base, seltype = "proportional", - aux_var = "AREA", n_near = n_near - ) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), n_base * n_near) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out + 1) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), col_out + 1) -}) - -#-------------------------------------- -#-------- NN replacement -#-------------------------------------- - -# both replacement sites, unstratified -test_that("algorithm executes", { - n_base <- 50 - n_over <- 5 - n_near <- 2 - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over, n_near = n_near) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), n_over) - expect_equal(NROW(irs_output$sites_near), (n_base + n_over) * n_near) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), col_out) - expect_equal(NCOL(irs_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)) - irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy, n_over = n_over, n_near = n_near) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) - expect_equal(NROW(irs_output$sites_over), n_over) - expect_equal(NROW(irs_output$sites_near), (n_base - n_legacy + n_over) * n_near) - expect_equal(NCOL(irs_output$sites_legacy), col_out + 1) - expect_equal(NCOL(irs_output$sites_base), col_out + 1) - expect_equal(NCOL(irs_output$sites_over), col_out + 1) - expect_equal(NCOL(irs_output$sites_near), col_out + 1) -}) - -################################################# -########### Illinois_River DATA TESTS -################################################# - -# number of irs columns added -col_irs_add <- 9 - -# number of Illinois_River columns -col_data <- NCOL(Illinois_River) - -# number of irs columns plus Illinois_River columns -col_out <- col_irs_add + col_data - -#-------------------------------------- -#-------- Regular -#-------------------------------------- - -# unstratified, equal probability -test_that("algorithm executes", { - n_base <- 50 - irs_output <- irs(Illinois_River, n_base = n_base, seltype = "equal") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# stratified, equal probability -test_that("algorithm executes", { - n_base <- c(Oklahoma = 20, Arkansas = 30) - irs_output <- irs(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Oklahoma", , drop = FALSE]), - n_base[["Oklahoma"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Arkansas", , drop = FALSE]), - n_base[["Arkansas"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -#-------------------------------------- -#-------- Legacy -#-------------------------------------- - -# legacy sites, unstratified, equal probability -test_that("algorithm executes", { - n_base <- 50 - n_legacy <- nrow(Illinois_River_Legacy) - irs_output <- irs(Illinois_River, n_base = n_base, seltype = "equal", legacy_sites = Illinois_River_Legacy) - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), col_out) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_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) - irs_output <- irs(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("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), n_legacy) - n_legacy_Oklahoma <- sum(irs_output$sites_legacy$stratum == "Oklahoma") - n_legacy_Arkansas <- sum(irs_output$sites_legacy$stratum == "Arkansas") - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Oklahoma", , drop = FALSE]), - n_base[["Oklahoma"]] - n_legacy_Oklahoma - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Arkansas", , drop = FALSE]), - n_base[["Arkansas"]] - n_legacy_Arkansas - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base) - n_legacy) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), col_out) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -################################################# -########### Lake_Ontario DATA TESTS -################################################# - -# number of irs columns added -col_irs_add <- 9 - -# number of Lake_Ontario columns -col_data <- NCOL(Lake_Ontario) - -# number of irs columns plus Lake_Ontario columns -col_out <- col_irs_add + col_data - -#-------------------------------------- -#-------- Regular -#-------------------------------------- - -# unstratified, equal probability -test_that("algorithm executes", { - n_base <- 50 - irs_output <- irs(Lake_Ontario, n_base = n_base, seltype = "equal") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal(NROW(irs_output$sites_base), n_base) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) - -# stratified, equal probability -test_that("algorithm executes", { - n_base <- c(CAN = 20, USA = 30) - irs_output <- irs(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY") - expect_true(exists("irs_output")) - expect_equal(NROW(irs_output$sites_legacy), 0) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "CAN", , drop = FALSE]), - n_base[["CAN"]] - ) - expect_equal( - NROW(irs_output$sites_base[irs_output$sites_base$stratum == "USA", , drop = FALSE]), - n_base[["USA"]] - ) - expect_equal(NROW(irs_output$sites_base), sum(n_base)) - expect_equal(NROW(irs_output$sites_over), 0) - expect_equal(NROW(irs_output$sites_near), 0) - expect_equal(NCOL(irs_output$sites_legacy), 1) - expect_equal(NCOL(irs_output$sites_base), col_out) - expect_equal(NCOL(irs_output$sites_over), 1) - expect_equal(NCOL(irs_output$sites_near), 1) -}) +# 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) + + ################################################# + ########### NE_LAKES DATA TESTS + ################################################# + + #-------------------------------------- + #-------- Regular + #-------------------------------------- + + # number of irs columns added + col_irs_add <- 9 + + # number of NE_Lakes columns + col_data <- NCOL(NE_Lakes) + + # number of irs columns plus NE_Lakes columns + col_out <- col_irs_add + col_data + + # unstratified, equal probability + test_that("algorithm executes", { + n_base <- 50 + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal") + # see if function ran without error + expect_true(exists("irs_output")) + # no legacy sites + expect_equal(NROW(irs_output$sites_legacy), 0) + # base sample size of 50 + expect_equal(NROW(irs_output$sites_base), n_base) + # no rho replacement sites + expect_equal(NROW(irs_output$sites_over), 0) + # no nn replacement sites + expect_equal(NROW(irs_output$sites_near), 0) + # no legacy sites + expect_equal(NCOL(irs_output$sites_legacy), 1) + # base sample size columns should equal extra columns plus original columns + expect_equal(NCOL(irs_output$sites_base), col_out) + # no rho replacement sites + expect_equal(NCOL(irs_output$sites_over), 1) + # no nn replacement sites + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # stratified, equal probability + test_that("algorithm executes", { + n_base <- c(low = 20, high = 30) + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", stratum_var = "ELEV_CAT") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # unstratified, unequal probability + test_that("algorithm executes", { + n_base <- 50 + caty_n <- c(small = 24, large = 26) + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "unequal", caty_var = "AREA_CAT", caty_n = caty_n) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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)) + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT", + caty_var = "AREA_CAT", caty_n = caty_n + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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) + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT", + caty_var = "AREA_CAT", caty_n = caty_n + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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)) + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "unequal", stratum_var = "ELEV_CAT", + caty_var = "AREA_CAT", caty_n = caty_n + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # unstratified, proportional (to size) probability + test_that("algorithm executes", { + n_base <- 50 + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "proportional", aux_var = "AREA") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out + 1) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # stratified, proportional probability + test_that("algorithm executes", { + n_base <- c(low = 20, high = 30) + irs_output <- irs(NE_Lakes, n_base = n_base, stratum_var = "ELEV_CAT", aux_var = "AREA") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out + 1) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + #-------------------------------------- + #-------- Legacy + #-------------------------------------- + + # legacy sites, unstratified, equal probability + test_that("algorithm executes", { + n_base <- 50 + n_legacy <- NROW(NE_Lakes_Legacy) + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), col_out) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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) + irs_output <- irs(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("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + n_legacy_low <- sum(irs_output$sites_legacy$stratum == "low") + n_legacy_high <- sum(irs_output$sites_legacy$stratum == "high") + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] - n_legacy_low + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] - n_legacy_high + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base) - n_legacy) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), col_out) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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) + irs_output <- irs(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("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), col_out) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # legacy sites, proportional probability + test_that("algorithm executes", { + n_base <- 50 + n_legacy <- NROW(NE_Lakes_Legacy) + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "proportional", + aux_var = "AREA", legacy_sites = NE_Lakes_Legacy, + legacy_aux_var = "AREA" + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), col_out + 1) + expect_equal(NCOL(irs_output$sites_base), col_out + 1) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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) + irs_output <- irs(NE_Lakes_bind, n_base = n_base, seltype = "equal", legacy_var = "LEGACY") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), col_out + 1) # as legacy variable added + expect_equal(NCOL(irs_output$sites_base), col_out + 1) # as legacy variable added + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + #-------------------------------------- + #-------- Minimum Distance + #-------------------------------------- + + # minimum distance, unstratified, equal probability + test_that("algorithm executes", { + library(sf) + n_base <- 50 + mindis <- 1600 + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", mindis = mindis) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + dist_mx <- as.vector(st_distance(irs_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 + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), n_over) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), col_out) + expect_equal(NCOL(irs_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) + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "equal", + stratum_var = "ELEV_CAT", n_over = n_over + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal( + NROW(irs_output$sites_over[irs_output$sites_over$stratum == "low", , drop = FALSE]), + n_over[["low"]] + ) + expect_equal( + NROW(irs_output$sites_over[irs_output$sites_over$stratum == "high", , drop = FALSE]), + n_over[["high"]] + ) + expect_equal(NROW(irs_output$sites_over), sum(unlist(n_over))) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), col_out) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # rho replacement sites, unstratified, unequal probability + test_that("algorithm executes", { + n_base <- 50 + caty_n <- c(small = 24, large = 26) + caty_n_over <- c(small = 5, large = 5) + n_over <- sum(caty_n_over) + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "unequal", + caty_var = "AREA_CAT", caty_n = caty_n, n_over = caty_n_over + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), n_over) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), col_out) + expect_equal(NCOL(irs_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 + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "proportional", + aux_var = "AREA", n_over = n_over + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), n_over) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out + 1) + expect_equal(NCOL(irs_output$sites_over), col_out + 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + #-------------------------------------- + #-------- NN replacement + #-------------------------------------- + + # nn replacement sites, unstratified, equal probability + test_that("algorithm executes", { + n_base <- 50 + n_near <- 2 + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", n_near = n_near) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), n_base * n_near) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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 + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "equal", + stratum_var = "ELEV_CAT", n_near = n_near + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "low", , drop = FALSE]), + n_base[["low"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "high", , drop = FALSE]), + n_base[["high"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), n_near * sum(n_base)) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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 + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "unequal", + caty_var = "AREA_CAT", caty_n = caty_n, n_near = n_near + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), n_base * n_near) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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 + irs_output <- irs(NE_Lakes, + n_base = n_base, seltype = "proportional", + aux_var = "AREA", n_near = n_near + ) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), n_base * n_near) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out + 1) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), col_out + 1) + }) + + #-------------------------------------- + #-------- NN replacement + #-------------------------------------- + + # both replacement sites, unstratified + test_that("algorithm executes", { + n_base <- 50 + n_over <- 5 + n_near <- 2 + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", n_over = n_over, n_near = n_near) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), n_over) + expect_equal(NROW(irs_output$sites_near), (n_base + n_over) * n_near) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), col_out) + expect_equal(NCOL(irs_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)) + irs_output <- irs(NE_Lakes, n_base = n_base, seltype = "equal", legacy_sites = NE_Lakes_Legacy, n_over = n_over, n_near = n_near) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) + expect_equal(NROW(irs_output$sites_over), n_over) + expect_equal(NROW(irs_output$sites_near), (n_base - n_legacy + n_over) * n_near) + expect_equal(NCOL(irs_output$sites_legacy), col_out + 1) + expect_equal(NCOL(irs_output$sites_base), col_out + 1) + expect_equal(NCOL(irs_output$sites_over), col_out + 1) + expect_equal(NCOL(irs_output$sites_near), col_out + 1) + }) + + ################################################# + ########### Illinois_River DATA TESTS + ################################################# + + # number of irs columns added + col_irs_add <- 9 + + # number of Illinois_River columns + col_data <- NCOL(Illinois_River) + + # number of irs columns plus Illinois_River columns + col_out <- col_irs_add + col_data + + #-------------------------------------- + #-------- Regular + #-------------------------------------- + + # unstratified, equal probability + test_that("algorithm executes", { + n_base <- 50 + irs_output <- irs(Illinois_River, n_base = n_base, seltype = "equal") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # stratified, equal probability + test_that("algorithm executes", { + n_base <- c(Oklahoma = 20, Arkansas = 30) + irs_output <- irs(Illinois_River, n_base = n_base, seltype = "equal", stratum_var = "STATE_NAME") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Oklahoma", , drop = FALSE]), + n_base[["Oklahoma"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Arkansas", , drop = FALSE]), + n_base[["Arkansas"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + #-------------------------------------- + #-------- Legacy + #-------------------------------------- + + # legacy sites, unstratified, equal probability + test_that("algorithm executes", { + n_base <- 50 + n_legacy <- nrow(Illinois_River_Legacy) + irs_output <- irs(Illinois_River, n_base = n_base, seltype = "equal", legacy_sites = Illinois_River_Legacy) + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + expect_equal(NROW(irs_output$sites_base), n_base - n_legacy) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), col_out) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_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) + irs_output <- irs(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("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), n_legacy) + n_legacy_Oklahoma <- sum(irs_output$sites_legacy$stratum == "Oklahoma") + n_legacy_Arkansas <- sum(irs_output$sites_legacy$stratum == "Arkansas") + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Oklahoma", , drop = FALSE]), + n_base[["Oklahoma"]] - n_legacy_Oklahoma + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "Arkansas", , drop = FALSE]), + n_base[["Arkansas"]] - n_legacy_Arkansas + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base) - n_legacy) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), col_out) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + ################################################# + ########### Lake_Ontario DATA TESTS + ################################################# + + # number of irs columns added + col_irs_add <- 9 + + # number of Lake_Ontario columns + col_data <- NCOL(Lake_Ontario) + + # number of irs columns plus Lake_Ontario columns + col_out <- col_irs_add + col_data + + #-------------------------------------- + #-------- Regular + #-------------------------------------- + + # unstratified, equal probability + test_that("algorithm executes", { + n_base <- 50 + irs_output <- irs(Lake_Ontario, n_base = n_base, seltype = "equal") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal(NROW(irs_output$sites_base), n_base) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) + + # stratified, equal probability + test_that("algorithm executes", { + n_base <- c(CAN = 20, USA = 30) + irs_output <- irs(Lake_Ontario, n_base = n_base, seltype = "equal", stratum_var = "COUNTRY") + expect_true(exists("irs_output")) + expect_equal(NROW(irs_output$sites_legacy), 0) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "CAN", , drop = FALSE]), + n_base[["CAN"]] + ) + expect_equal( + NROW(irs_output$sites_base[irs_output$sites_base$stratum == "USA", , drop = FALSE]), + n_base[["USA"]] + ) + expect_equal(NROW(irs_output$sites_base), sum(n_base)) + expect_equal(NROW(irs_output$sites_over), 0) + expect_equal(NROW(irs_output$sites_near), 0) + expect_equal(NCOL(irs_output$sites_legacy), 1) + expect_equal(NCOL(irs_output$sites_base), col_out) + expect_equal(NCOL(irs_output$sites_over), 1) + expect_equal(NCOL(irs_output$sites_near), 1) + }) +} diff --git a/tests/testthat/test-sp_balance.R b/tests/testthat/test-sp_balance.R index 6d58f56..65e16f3 100644 --- a/tests/testthat/test-sp_balance.R +++ b/tests/testthat/test-sp_balance.R @@ -1,34 +1,43 @@ context("sp_balance") -# set reproducible seed (as there are random components here) -set.seed(5) +# find system info +on_solaris <- Sys.info()[["sysname"]] == "SunOS" +if (on_solaris) { + test_that("on solaris", { + expect_true(on_solaris) + }) +} else { -test_that("sp_balance works unstrat", { - n_base <- 50 - eqprob <- grts(NE_Lakes, n_base = n_base) - spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes) - expect_equal(NROW(spb_eqprob), 1) - expect_equal(NCOL(spb_eqprob), 3) - spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes, - metrics = c("pielou", "simpsons", "rmse", "mse", "mae", "medae", "chisq") - ) - expect_equal(NROW(spb_eqprob), 7) - expect_equal(NCOL(spb_eqprob), 3) -}) + # set reproducible seed (as there are random components here) + set.seed(5) -test_that("sp_balance works unstrat custom ip", { - n_base <- 50 - NE_Lakes$ip <- n_base / nrow(NE_Lakes) + rnorm(NROW(NE_Lakes), sd = 0.01) - NE_Lakes$ip <- pmin(NE_Lakes$ip, 1) - NE_Lakes$ip <- pmax(NE_Lakes$ip, 0) - eqprob <- grts(NE_Lakes, n_base = n_base) - spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes, ip = "ip") - expect_equal(NROW(spb_eqprob), 1) - expect_equal(NCOL(spb_eqprob), 3) - spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes, - metrics = c("pielou", "simpsons", "rmse", "mse", "mae", "medae", "chisq"), - ip = "ip" - ) - expect_equal(NROW(spb_eqprob), 7) - expect_equal(NCOL(spb_eqprob), 3) -}) + test_that("sp_balance works unstrat", { + n_base <- 50 + eqprob <- grts(NE_Lakes, n_base = n_base) + spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes) + expect_equal(NROW(spb_eqprob), 1) + expect_equal(NCOL(spb_eqprob), 3) + spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes, + metrics = c("pielou", "simpsons", "rmse", "mse", "mae", "medae", "chisq") + ) + expect_equal(NROW(spb_eqprob), 7) + expect_equal(NCOL(spb_eqprob), 3) + }) + + test_that("sp_balance works unstrat custom ip", { + n_base <- 50 + NE_Lakes$ip <- n_base / nrow(NE_Lakes) + rnorm(NROW(NE_Lakes), sd = 0.01) + NE_Lakes$ip <- pmin(NE_Lakes$ip, 1) + NE_Lakes$ip <- pmax(NE_Lakes$ip, 0) + eqprob <- grts(NE_Lakes, n_base = n_base) + spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes, ip = "ip") + expect_equal(NROW(spb_eqprob), 1) + expect_equal(NCOL(spb_eqprob), 3) + spb_eqprob <- sp_balance(eqprob$sites_base, NE_Lakes, + metrics = c("pielou", "simpsons", "rmse", "mse", "mae", "medae", "chisq"), + ip = "ip" + ) + expect_equal(NROW(spb_eqprob), 7) + expect_equal(NCOL(spb_eqprob), 3) + }) +} diff --git a/tests/testthat/test-sp_plot.R b/tests/testthat/test-sp_plot.R index 55439f9..b79dd40 100644 --- a/tests/testthat/test-sp_plot.R +++ b/tests/testthat/test-sp_plot.R @@ -1,168 +1,178 @@ context("sp_plot") -# set reproducible seed (as there are random components here) -set.seed(5) - -#-------------------------------------- -#-------- one sided formula -#-------------------------------------- - -# one sided formulas -test_that("one sided formulas work", { - expect_error(sp_plot(NE_Lakes, formula = ~1), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, fix_bbox = FALSE), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV), NA) -}) - -# changing graphical parameters -test_that("one sided formulas work", { - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, pch = 19), NA) - var_args <- list(ELEV_CAT = list(main = "maintest")) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, var_args = var_args), NA) - varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, NA))) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) - varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, 2))) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) - expect_error(sp_plot(NE_Lakes, - formula = ~ELEV_CAT, - varlevel_args = varlevel_args, var_args = var_args, pch = 19 - ), NA) -}) - - -#-------------------------------------- -#-------- two sided formula -#-------------------------------------- - -# two sided formulas -test_that("two sided formulas work", { - expect_error(sp_plot(NE_Lakes, formula = ELEV ~ 1), NA) - expect_error(sp_plot(NE_Lakes, formula = ELEV ~ AREA_CAT, onlyshow = "small"), NA) -}) - -# changing graphical parameters -test_that("two sided formulas work", { - var_args <- list(AREA_CAT = list(ELEV_CAT = list(levels = c("low", "high"), pch = c(1, 19)))) - expect_error(sp_plot(NE_Lakes, formula = ELEV_CAT ~ AREA_CAT, var_args = var_args, onlyshow = "large"), NA) -}) - - -################################################# -########### spdesign -################################################# - -n_base <- 50 -eqprob <- grts(NE_Lakes, n_base = n_base) -eqprob_legacy <- grts(NE_Lakes, n_base = n_base, legacy_var = "LEGACY") -n_over <- 5 -eqprob_rho <- grts(NE_Lakes, n_base = n_base, n_over = n_over) -n_near <- 1 -eqprob_nn <- grts(NE_Lakes, n_base = n_base, n_near = n_near) -eqprob_both <- grts(NE_Lakes, n_base = n_base, n_over = n_over, n_near = n_near) -n_base_strat <- c(low = 25, high = 25) -eqprob_strat <- grts(NE_Lakes, n_base = n_base_strat, stratum_var = "ELEV_CAT") - -#-------------------------------------- -#-------- without sframe -#-------------------------------------- - -# test sp_plot works -test_that("sp_plot works", { - expect_error(sp_plot(eqprob, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_legacy, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_rho, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_nn, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_nn, formula = ~siteuse, siteuse = c("Base")), NA) - expect_error(sp_plot(eqprob_strat, formula = siteuse ~ stratum, onlyshow = "low"), NA) -}) - -# graphical paraemters -test_that("sp_plot works", { - var_args <- list(siteuse = list(main = "maintest")) - varlevel_args <- list(siteuse = list(levels = c("Base", "Over"), pch = c(1, 19))) - expect_error(sp_plot(eqprob_rho, - formula = ~siteuse, - varlevel_args = varlevel_args, var_args = var_args, cex = 0.5 - ), NA) - var_args <- list(ELEV_CAT = list(siteuse = list(levels = c("Base", "Over"), pch = c(1, 19)))) - expect_error(sp_plot(eqprob_rho, - formula = siteuse ~ ELEV_CAT, - var_args = var_args, onlyshow = "low", cex = 0.5 - ), NA) -}) - -#-------------------------------------- -#-------- with sframe -#-------------------------------------- - -# test sp_plot works -test_that("sp_plot works", { - expect_error(sp_plot(eqprob, NE_Lakes, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_legacy, NE_Lakes, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_rho, NE_Lakes, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_nn, NE_Lakes, formula = ~siteuse), NA) - expect_error(sp_plot(eqprob_nn, NE_Lakes, formula = ~siteuse, siteuse = c("Base")), NA) - expect_error(sp_plot(eqprob_strat, NE_Lakes, formula = siteuse ~ ELEV_CAT, onlyshow = "low"), NA) -}) - -# graphical parameters -test_that("sp_plot works", { - var_args <- list(siteuse = list(main = "maintest")) - varlevel_args <- list(siteuse = list(levels = c("Base", "Over"), pch = c(1, 19))) - expect_error(sp_plot(eqprob_rho, NE_Lakes, - formula = ~siteuse, - varlevel_args = varlevel_args, var_args = var_args, cex = 0.5 - ), NA) - var_args <- list(ELEV_CAT = list(siteuse = list(levels = c("Base"), pch = c(19)))) - expect_error(sp_plot(eqprob_rho, NE_Lakes, - formula = siteuse ~ ELEV_CAT, - var_args = var_args, onlyshow = "low", siteuse = c("Base"), cex = 1 - ), NA) -}) - -#-------------------------------------- -#-------- one sided formula -#-------------------------------------- - -# one sided formulas -test_that("one sided formulas work", { - expect_error(sp_plot(NE_Lakes, formula = ~1), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, fix_bbox = FALSE), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT), NA) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV), NA) -}) - -# changing graphical parameters -test_that("one sided formulas work", { - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, pch = 19), NA) - var_args <- list(ELEV_CAT = list(main = "maintest")) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, var_args = var_args), NA) - varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, NA))) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) - varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, 2))) - expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) - expect_error(sp_plot(NE_Lakes, - formula = ~ELEV_CAT, - varlevel_args = varlevel_args, var_args = var_args, pch = 19 - ), NA) -}) - - -#-------------------------------------- -#-------- two sided formula -#-------------------------------------- - -# two sided formulas -test_that("two sided formulas work", { - expect_error(sp_plot(NE_Lakes, formula = ELEV ~ 1), NA) - expect_error(sp_plot(NE_Lakes, formula = ELEV ~ AREA_CAT, onlyshow = "small"), NA) -}) - -# changing graphical parameters -test_that("two sided formulas work", { - var_args <- list(AREA_CAT = list(ELEV_CAT = list(levels = c("low", "high"), pch = c(1, 19)))) - expect_error(sp_plot(NE_Lakes, formula = ELEV_CAT ~ AREA_CAT, var_args = var_args, onlyshow = "large"), NA) -}) +# 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) + + #-------------------------------------- + #-------- one sided formula + #-------------------------------------- + + # one sided formulas + test_that("one sided formulas work", { + expect_error(sp_plot(NE_Lakes, formula = ~1), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, fix_bbox = FALSE), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV), NA) + }) + + # changing graphical parameters + test_that("one sided formulas work", { + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, pch = 19), NA) + var_args <- list(ELEV_CAT = list(main = "maintest")) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, var_args = var_args), NA) + varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, NA))) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) + varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, 2))) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) + expect_error(sp_plot(NE_Lakes, + formula = ~ELEV_CAT, + varlevel_args = varlevel_args, var_args = var_args, pch = 19 + ), NA) + }) + + + #-------------------------------------- + #-------- two sided formula + #-------------------------------------- + + # two sided formulas + test_that("two sided formulas work", { + expect_error(sp_plot(NE_Lakes, formula = ELEV ~ 1), NA) + expect_error(sp_plot(NE_Lakes, formula = ELEV ~ AREA_CAT, onlyshow = "small"), NA) + }) + + # changing graphical parameters + test_that("two sided formulas work", { + var_args <- list(AREA_CAT = list(ELEV_CAT = list(levels = c("low", "high"), pch = c(1, 19)))) + expect_error(sp_plot(NE_Lakes, formula = ELEV_CAT ~ AREA_CAT, var_args = var_args, onlyshow = "large"), NA) + }) + + + ################################################# + ########### spdesign + ################################################# + + n_base <- 50 + eqprob <- grts(NE_Lakes, n_base = n_base) + eqprob_legacy <- grts(NE_Lakes, n_base = n_base, legacy_var = "LEGACY") + n_over <- 5 + eqprob_rho <- grts(NE_Lakes, n_base = n_base, n_over = n_over) + n_near <- 1 + eqprob_nn <- grts(NE_Lakes, n_base = n_base, n_near = n_near) + eqprob_both <- grts(NE_Lakes, n_base = n_base, n_over = n_over, n_near = n_near) + n_base_strat <- c(low = 25, high = 25) + eqprob_strat <- grts(NE_Lakes, n_base = n_base_strat, stratum_var = "ELEV_CAT") + + #-------------------------------------- + #-------- without sframe + #-------------------------------------- + + # test sp_plot works + test_that("sp_plot works", { + expect_error(sp_plot(eqprob, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_legacy, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_rho, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_nn, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_nn, formula = ~siteuse, siteuse = c("Base")), NA) + expect_error(sp_plot(eqprob_strat, formula = siteuse ~ stratum, onlyshow = "low"), NA) + }) + + # graphical paraemters + test_that("sp_plot works", { + var_args <- list(siteuse = list(main = "maintest")) + varlevel_args <- list(siteuse = list(levels = c("Base", "Over"), pch = c(1, 19))) + expect_error(sp_plot(eqprob_rho, + formula = ~siteuse, + varlevel_args = varlevel_args, var_args = var_args, cex = 0.5 + ), NA) + var_args <- list(ELEV_CAT = list(siteuse = list(levels = c("Base", "Over"), pch = c(1, 19)))) + expect_error(sp_plot(eqprob_rho, + formula = siteuse ~ ELEV_CAT, + var_args = var_args, onlyshow = "low", cex = 0.5 + ), NA) + }) + + #-------------------------------------- + #-------- with sframe + #-------------------------------------- + + # test sp_plot works + test_that("sp_plot works", { + expect_error(sp_plot(eqprob, NE_Lakes, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_legacy, NE_Lakes, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_rho, NE_Lakes, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_nn, NE_Lakes, formula = ~siteuse), NA) + expect_error(sp_plot(eqprob_nn, NE_Lakes, formula = ~siteuse, siteuse = c("Base")), NA) + expect_error(sp_plot(eqprob_strat, NE_Lakes, formula = siteuse ~ ELEV_CAT, onlyshow = "low"), NA) + }) + + # graphical parameters + test_that("sp_plot works", { + var_args <- list(siteuse = list(main = "maintest")) + varlevel_args <- list(siteuse = list(levels = c("Base", "Over"), pch = c(1, 19))) + expect_error(sp_plot(eqprob_rho, NE_Lakes, + formula = ~siteuse, + varlevel_args = varlevel_args, var_args = var_args, cex = 0.5 + ), NA) + var_args <- list(ELEV_CAT = list(siteuse = list(levels = c("Base"), pch = c(19)))) + expect_error(sp_plot(eqprob_rho, NE_Lakes, + formula = siteuse ~ ELEV_CAT, + var_args = var_args, onlyshow = "low", siteuse = c("Base"), cex = 1 + ), NA) + }) + + #-------------------------------------- + #-------- one sided formula + #-------------------------------------- + + # one sided formulas + test_that("one sided formulas work", { + expect_error(sp_plot(NE_Lakes, formula = ~1), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, fix_bbox = FALSE), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT), NA) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV), NA) + }) + + # changing graphical parameters + test_that("one sided formulas work", { + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, pch = 19), NA) + var_args <- list(ELEV_CAT = list(main = "maintest")) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, var_args = var_args), NA) + varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, NA))) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) + varlevel_args <- list(ELEV_CAT = list(levels = c("low", "high"), cex = c(1, 2))) + expect_error(sp_plot(NE_Lakes, formula = ~ELEV_CAT, varlevel_args = varlevel_args), NA) + expect_error(sp_plot(NE_Lakes, + formula = ~ELEV_CAT, + varlevel_args = varlevel_args, var_args = var_args, pch = 19 + ), NA) + }) + + + #-------------------------------------- + #-------- two sided formula + #-------------------------------------- + + # two sided formulas + test_that("two sided formulas work", { + expect_error(sp_plot(NE_Lakes, formula = ELEV ~ 1), NA) + expect_error(sp_plot(NE_Lakes, formula = ELEV ~ AREA_CAT, onlyshow = "small"), NA) + }) + + # changing graphical parameters + test_that("two sided formulas work", { + var_args <- list(AREA_CAT = list(ELEV_CAT = list(levels = c("low", "high"), pch = c(1, 19)))) + expect_error(sp_plot(NE_Lakes, formula = ELEV_CAT ~ AREA_CAT, var_args = var_args, onlyshow = "large"), NA) + }) +} diff --git a/tests/testthat/test-sp_rbind.R b/tests/testthat/test-sp_rbind.R index fdcccaf..d40dde9 100644 --- a/tests/testthat/test-sp_rbind.R +++ b/tests/testthat/test-sp_rbind.R @@ -1,51 +1,60 @@ context("sp_rbind") -# set reproducible seed (as there are random components here) -set.seed(5) +# find system info +on_solaris <- Sys.info()[["sysname"]] == "SunOS" +if (on_solaris) { + test_that("on solaris", { + expect_true(on_solaris) + }) +} else { -test_that("sp_rbind works base", { - n_base <- 50 - eqprob <- grts(NE_Lakes, n_base) - eqprob_spr <- sp_rbind(eqprob) - expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) - expect_equal(NROW(eqprob_spr), n_base) -}) + # set reproducible seed (as there are random components here) + set.seed(5) -test_that("sp_rbind works legacy", { - n_base <- 50 - n_legacy <- sum(!is.na(NE_Lakes$LEGACY)) - eqprob <- grts(NE_Lakes, n_base = n_base, legacy_var = "LEGACY") - eqprob_spr <- sp_rbind(eqprob) - expect_equal(sum(eqprob_spr$siteuse == "Legacy"), n_legacy) - expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base - n_legacy) - expect_equal(NROW(eqprob_spr), n_base) -}) + test_that("sp_rbind works base", { + n_base <- 50 + eqprob <- grts(NE_Lakes, n_base) + eqprob_spr <- sp_rbind(eqprob) + expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) + expect_equal(NROW(eqprob_spr), n_base) + }) -test_that("sp_rbind works over", { - n_base <- 50 - n_over <- 5 - eqprob <- grts(NE_Lakes, n_base = n_base, n_over = n_over) - eqprob_spr <- sp_rbind(eqprob) - expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) - expect_equal(sum(eqprob_spr$siteuse == "Over"), n_over) - expect_equal(NROW(eqprob_spr), n_base + n_over) -}) + test_that("sp_rbind works legacy", { + n_base <- 50 + n_legacy <- sum(!is.na(NE_Lakes$LEGACY)) + eqprob <- grts(NE_Lakes, n_base = n_base, legacy_var = "LEGACY") + eqprob_spr <- sp_rbind(eqprob) + expect_equal(sum(eqprob_spr$siteuse == "Legacy"), n_legacy) + expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base - n_legacy) + expect_equal(NROW(eqprob_spr), n_base) + }) -test_that("sp_rbind works near", { - n_base <- 50 - n_near <- 5 - eqprob <- grts(NE_Lakes, n_base = n_base, n_near = n_near) - eqprob_spr <- sp_rbind(eqprob) - expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) - expect_equal(sum(substring(eqprob_spr$siteuse, 1, 4) == "Near"), n_base * n_near) - expect_equal(NROW(eqprob_spr), n_base + n_base * n_near) -}) + test_that("sp_rbind works over", { + n_base <- 50 + n_over <- 5 + eqprob <- grts(NE_Lakes, n_base = n_base, n_over = n_over) + eqprob_spr <- sp_rbind(eqprob) + expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) + expect_equal(sum(eqprob_spr$siteuse == "Over"), n_over) + expect_equal(NROW(eqprob_spr), n_base + n_over) + }) -test_that("sp_rbind works with siteuse", { - n_base <- 50 - n_near <- 5 - eqprob <- grts(NE_Lakes, n_base = n_base, n_near = n_near) - eqprob_spr <- sp_rbind(eqprob, siteuse = "Base") - expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) - expect_equal(NROW(eqprob_spr), n_base) -}) + test_that("sp_rbind works near", { + n_base <- 50 + n_near <- 5 + eqprob <- grts(NE_Lakes, n_base = n_base, n_near = n_near) + eqprob_spr <- sp_rbind(eqprob) + expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) + expect_equal(sum(substring(eqprob_spr$siteuse, 1, 4) == "Near"), n_base * n_near) + expect_equal(NROW(eqprob_spr), n_base + n_base * n_near) + }) + + test_that("sp_rbind works with siteuse", { + n_base <- 50 + n_near <- 5 + eqprob <- grts(NE_Lakes, n_base = n_base, n_near = n_near) + eqprob_spr <- sp_rbind(eqprob, siteuse = "Base") + expect_equal(sum(eqprob_spr$siteuse == "Base"), n_base) + expect_equal(NROW(eqprob_spr), n_base) + }) +} diff --git a/tests/testthat/test-sp_summary.R b/tests/testthat/test-sp_summary.R index 7f4ea70..c8038a8 100644 --- a/tests/testthat/test-sp_summary.R +++ b/tests/testthat/test-sp_summary.R @@ -1,261 +1,271 @@ context("sp_summary") -# set reproducible seed (as there are random components here) -set.seed(5) - -#-------------------------------------- -#-------- one sided formula -#-------------------------------------- - -# intercept only formula -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~1) - expect_true(exists("output")) - expect_equal(NCOL(output), 1) - expect_equal(length(output[, 1]), 1) -}) - -# single categorical variable -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~ELEV_CAT) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), length(unique(NE_Lakes$ELEV_CAT))) -}) - -# single categorical variable removing intercept -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT - 1) - expect_true(exists("output")) - expect_equal(NCOL(output), 1) - expect_equal(length(output[, 1]), length(unique(NE_Lakes$ELEV_CAT))) -}) - -# two categorical variables -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT + AREA_CAT) - expect_true(exists("output")) - expect_equal(NCOL(output), 3) - expect_equal(length(output[, 2]), length(unique(NE_Lakes$ELEV_CAT))) - expect_equal(length(output[, 3]), length(unique(NE_Lakes$AREA_CAT))) -}) - -# interaction between two categorical variables -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), length(unique(NE_Lakes$ELEV_CAT)) * length(unique(NE_Lakes$AREA_CAT))) -}) - -# onlyshow for interaction between two categorical variables -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT, onlyshow = "low:small") - expect_true(exists("output")) - expect_equal(NCOL(output), 1) - expect_equal(length(output[, 1]), 1) -}) - -# single categorical variable -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~ELEV) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 6) # 5 number summary plus mean -}) - -# * interaction operator works -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT * AREA_CAT) - expect_true(exists("output")) - expect_equal(NCOL(output), 4) -}) - -# . interaction operator works -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~.) - expect_true(exists("output")) - expect_equal(NCOL(output), NCOL(NE_Lakes)) # our summary removes geometry but includes total -}) - -# maxsum works operator works -test_that("one sided formulas work", { - output <- sp_summary(NE_Lakes, formula = ~AREA_CAT, maxsum = 1) - expect_true(exists("output")) - expect_equal(length(output[, 2]), 1) - - output <- sp_summary(NE_Lakes, formula = ~AREA_CAT) - expect_true(exists("output")) - expect_equal(length(output[, 2]), 2) -}) - -#-------------------------------------- -#-------- two sided formula -#-------------------------------------- - -# numeric left hand side variable -test_that("two sided formulas work", { - output <- sp_summary(NE_Lakes, formula = AREA ~ ELEV_CAT) - expect_true(exists("output")) - expect_equal(NROW(output), 2) - expect_equal(NCOL(output[[1]]), 6) - expect_equal(NROW(output[[1]]), 1) - expect_equal(NCOL(output[[2]]), 6) - expect_equal(NROW(output[[2]]), length(unique(NE_Lakes$ELEV_CAT))) -}) - -# numeric right hand side variable -test_that("two sided formulas work", { - output <- sp_summary(NE_Lakes, formula = AREA_CAT ~ ELEV_CAT) - expect_true(exists("output")) - expect_equal(NROW(output), 2) - expect_equal(NCOL(output[[1]]), length(unique(NE_Lakes$AREA_CAT))) - expect_equal(NROW(output[[1]]), 1) - expect_equal(NCOL(output[[2]]), length(unique(NE_Lakes$AREA_CAT))) - expect_equal(NROW(output[[2]]), length(unique(NE_Lakes$ELEV_CAT))) -}) - -################################################# -########### spdesign -################################################# - -n_base <- 50 -eqprob <- grts(NE_Lakes, n_base = n_base) -eqprob_legacy <- grts(NE_Lakes, n_base = n_base, legacy_sites = NE_Lakes_Legacy) -n_over <- 5 -eqprob_rho <- grts(NE_Lakes, n_base = n_base, n_over = n_over) -n_near <- 1 -eqprob_nn <- grts(NE_Lakes, n_base = n_base, n_near = n_near) -eqprob_both <- grts(NE_Lakes, n_base = n_base, n_over = n_over, n_near = n_near) -n_base_strat <- c(low = 25, high = 25) -eqprob_strat <- grts(NE_Lakes, n_base = n_base_strat, stratum_var = "ELEV_CAT") - -#-------------------------------------- -#-------- one sided formula -#-------------------------------------- - -# one sided formula -test_that("one sided formulas work", { - output <- sp_summary(eqprob, formula = ~siteuse) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 1) -}) - -# one sided formula with additional variable -test_that("one sided formulas work", { - output <- sp_summary(eqprob, formula = ~ siteuse + ELEV_CAT) - expect_true(exists("output")) - expect_equal(NCOL(output), 3) - expect_equal(sum(!is.na(output[, 2])), 1) -}) - -# use with legacy variable -test_that("one sided formulas work", { - output <- sp_summary(eqprob_legacy, formula = ~siteuse) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 2) -}) - -# siteuse variable being set -test_that("one sided formulas work", { - output <- sp_summary(eqprob_legacy, formula = ~siteuse, siteuse = "Base") - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 1) -}) - -# use with rho replacement -test_that("one sided formulas work", { - output <- sp_summary(eqprob_rho, formula = ~siteuse) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 2) -}) - -# siteuse variable being set -test_that("one sided formulas work", { - output <- sp_summary(eqprob_rho, formula = ~siteuse, siteuse = "Base") - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 1) -}) - -# use with nn replacement -test_that("one sided formulas work", { - output <- sp_summary(eqprob_nn, formula = ~siteuse) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 2) -}) - -# siteuse variable being set -test_that("one sided formulas work", { - output <- sp_summary(eqprob_nn, formula = ~siteuse, siteuse = "Base") - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 1) -}) - -# use with both replacement -test_that("one sided formulas work", { - output <- sp_summary(eqprob_both, formula = ~siteuse) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 3) -}) - -# siteuse variable being set -test_that("one sided formulas work", { - output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = "Base") - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 1) -}) - -# siteuse variable being set -test_that("one sided formulas work", { - output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = c("Base", "Over")) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 2) -}) - -# siteuse variable being set -test_that("one sided formulas work", { - output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = c("Base", "Near")) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 2) -}) - -# siteuse variable being set -test_that("one sided formulas work", { - output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = c("Over", "Near")) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 2) -}) - -# with a stratified design -test_that("one sided formulas work", { - output <- sp_summary(eqprob_strat, formula = ~siteuse) - expect_true(exists("output")) - expect_equal(NCOL(output), 2) - expect_equal(length(output[, 2]), 1) -}) - -#-------------------------------------- -#-------- two sided formula -#-------------------------------------- - -test_that("one sided formulas work", { - output <- sp_summary(eqprob_strat, formula = siteuse ~ stratum) - expect_true(exists("output")) - expect_equal(NROW(output), 2) - expect_equal(NCOL(output[[1]]), 1) - expect_equal(NROW(output[[1]]), 1) - expect_equal(NCOL(output[[2]]), 1) - expect_equal(NROW(output[[2]]), length(unique(eqprob_strat$sites_base$stratum))) -}) +# 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) + + #-------------------------------------- + #-------- one sided formula + #-------------------------------------- + + # intercept only formula + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~1) + expect_true(exists("output")) + expect_equal(NCOL(output), 1) + expect_equal(length(output[, 1]), 1) + }) + + # single categorical variable + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~ELEV_CAT) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), length(unique(NE_Lakes$ELEV_CAT))) + }) + + # single categorical variable removing intercept + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT - 1) + expect_true(exists("output")) + expect_equal(NCOL(output), 1) + expect_equal(length(output[, 1]), length(unique(NE_Lakes$ELEV_CAT))) + }) + + # two categorical variables + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT + AREA_CAT) + expect_true(exists("output")) + expect_equal(NCOL(output), 3) + expect_equal(length(output[, 2]), length(unique(NE_Lakes$ELEV_CAT))) + expect_equal(length(output[, 3]), length(unique(NE_Lakes$AREA_CAT))) + }) + + # interaction between two categorical variables + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), length(unique(NE_Lakes$ELEV_CAT)) * length(unique(NE_Lakes$AREA_CAT))) + }) + + # onlyshow for interaction between two categorical variables + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT:AREA_CAT, onlyshow = "low:small") + expect_true(exists("output")) + expect_equal(NCOL(output), 1) + expect_equal(length(output[, 1]), 1) + }) + + # single categorical variable + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~ELEV) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 6) # 5 number summary plus mean + }) + + # * interaction operator works + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~ ELEV_CAT * AREA_CAT) + expect_true(exists("output")) + expect_equal(NCOL(output), 4) + }) + + # . interaction operator works + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~.) + expect_true(exists("output")) + expect_equal(NCOL(output), NCOL(NE_Lakes)) # our summary removes geometry but includes total + }) + + # maxsum works operator works + test_that("one sided formulas work", { + output <- sp_summary(NE_Lakes, formula = ~AREA_CAT, maxsum = 1) + expect_true(exists("output")) + expect_equal(length(output[, 2]), 1) + + output <- sp_summary(NE_Lakes, formula = ~AREA_CAT) + expect_true(exists("output")) + expect_equal(length(output[, 2]), 2) + }) + + #-------------------------------------- + #-------- two sided formula + #-------------------------------------- + + # numeric left hand side variable + test_that("two sided formulas work", { + output <- sp_summary(NE_Lakes, formula = AREA ~ ELEV_CAT) + expect_true(exists("output")) + expect_equal(NROW(output), 2) + expect_equal(NCOL(output[[1]]), 6) + expect_equal(NROW(output[[1]]), 1) + expect_equal(NCOL(output[[2]]), 6) + expect_equal(NROW(output[[2]]), length(unique(NE_Lakes$ELEV_CAT))) + }) + + # numeric right hand side variable + test_that("two sided formulas work", { + output <- sp_summary(NE_Lakes, formula = AREA_CAT ~ ELEV_CAT) + expect_true(exists("output")) + expect_equal(NROW(output), 2) + expect_equal(NCOL(output[[1]]), length(unique(NE_Lakes$AREA_CAT))) + expect_equal(NROW(output[[1]]), 1) + expect_equal(NCOL(output[[2]]), length(unique(NE_Lakes$AREA_CAT))) + expect_equal(NROW(output[[2]]), length(unique(NE_Lakes$ELEV_CAT))) + }) + + ################################################# + ########### spdesign + ################################################# + + n_base <- 50 + eqprob <- grts(NE_Lakes, n_base = n_base) + eqprob_legacy <- grts(NE_Lakes, n_base = n_base, legacy_sites = NE_Lakes_Legacy) + n_over <- 5 + eqprob_rho <- grts(NE_Lakes, n_base = n_base, n_over = n_over) + n_near <- 1 + eqprob_nn <- grts(NE_Lakes, n_base = n_base, n_near = n_near) + eqprob_both <- grts(NE_Lakes, n_base = n_base, n_over = n_over, n_near = n_near) + n_base_strat <- c(low = 25, high = 25) + eqprob_strat <- grts(NE_Lakes, n_base = n_base_strat, stratum_var = "ELEV_CAT") + + #-------------------------------------- + #-------- one sided formula + #-------------------------------------- + + # one sided formula + test_that("one sided formulas work", { + output <- sp_summary(eqprob, formula = ~siteuse) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 1) + }) + + # one sided formula with additional variable + test_that("one sided formulas work", { + output <- sp_summary(eqprob, formula = ~ siteuse + ELEV_CAT) + expect_true(exists("output")) + expect_equal(NCOL(output), 3) + expect_equal(sum(!is.na(output[, 2])), 1) + }) + + # use with legacy variable + test_that("one sided formulas work", { + output <- sp_summary(eqprob_legacy, formula = ~siteuse) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 2) + }) + + # siteuse variable being set + test_that("one sided formulas work", { + output <- sp_summary(eqprob_legacy, formula = ~siteuse, siteuse = "Base") + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 1) + }) + + # use with rho replacement + test_that("one sided formulas work", { + output <- sp_summary(eqprob_rho, formula = ~siteuse) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 2) + }) + + # siteuse variable being set + test_that("one sided formulas work", { + output <- sp_summary(eqprob_rho, formula = ~siteuse, siteuse = "Base") + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 1) + }) + + # use with nn replacement + test_that("one sided formulas work", { + output <- sp_summary(eqprob_nn, formula = ~siteuse) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 2) + }) + + # siteuse variable being set + test_that("one sided formulas work", { + output <- sp_summary(eqprob_nn, formula = ~siteuse, siteuse = "Base") + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 1) + }) + + # use with both replacement + test_that("one sided formulas work", { + output <- sp_summary(eqprob_both, formula = ~siteuse) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 3) + }) + + # siteuse variable being set + test_that("one sided formulas work", { + output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = "Base") + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 1) + }) + + # siteuse variable being set + test_that("one sided formulas work", { + output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = c("Base", "Over")) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 2) + }) + + # siteuse variable being set + test_that("one sided formulas work", { + output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = c("Base", "Near")) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 2) + }) + + # siteuse variable being set + test_that("one sided formulas work", { + output <- sp_summary(eqprob_both, formula = ~siteuse, siteuse = c("Over", "Near")) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 2) + }) + + # with a stratified design + test_that("one sided formulas work", { + output <- sp_summary(eqprob_strat, formula = ~siteuse) + expect_true(exists("output")) + expect_equal(NCOL(output), 2) + expect_equal(length(output[, 2]), 1) + }) + + #-------------------------------------- + #-------- two sided formula + #-------------------------------------- + + test_that("one sided formulas work", { + output <- sp_summary(eqprob_strat, formula = siteuse ~ stratum) + expect_true(exists("output")) + expect_equal(NROW(output), 2) + expect_equal(NCOL(output[[1]]), 1) + expect_equal(NROW(output[[1]]), 1) + expect_equal(NCOL(output[[2]]), 1) + expect_equal(NROW(output[[2]]), length(unique(eqprob_strat$sites_base$stratum))) + }) +} diff --git a/vignettes/EDA.Rmd b/vignettes/EDA.Rmd index 904f955..e658cbd 100644 --- a/vignettes/EDA.Rmd +++ b/vignettes/EDA.Rmd @@ -1,5 +1,5 @@ --- -title: "Exploratory Data Analysis: Summarizing and Visualizing Sampling Frames, Design Sites, and Analysis Data" +title: "Summarizing and Visualizing Sampling Frames, Design Sites, and Analysis Data" author: "Michael Dumelle, Tom Kincaid, Anthony Olsen, and Marc Weber" output: html_document: @@ -12,7 +12,7 @@ output: smooth_scroll: no toc_depth: 2 vignette: > - %\VignetteIndexEntry{EDA} + %\VignetteIndexEntry{Summaries and Visualizations} %\VignetteEngine{knitr::rmarkdown} \usepackage[utf8]{inputenc} ---