Nothing
###############################################################################
# Function: grtspts_mindis (not exported)
# Programmer: Tony Olsen
# Date: September 28, 2020
#
#' Select a grts sample with minimum distance between sites.
#'
#' @param mindis Minimum distance required between sites in sample.
#'
#' @param sframe The \code{sf} object containing variables: \code{id} and \code{ip}.
#'
#' @param samplesize The sample size required for the stratum.
#'
#' @param stratum Character string that identifies stratum membership for each element
#' in the frame. Cannot be \code{NULL}.
#'
#' @param maxtry Number of maximum attempts to ensure minimum distance between sites.
#' Default is \code{10}.
#'
#' @param legacy_option Logical variable where if equal to \code{TRUE}, legacy sites are
#' to be incorporated into survey design.
#'
#' @param legacy_var Character value for name of column for legacy site variable.
#' Default is \code{NULL}.
#'
#' @param warn_ind A logical value where \code{TRUE} indicates a warning message.
#' Used for internal collection of messages only.
#'
#' @param warn_df A data frame containing messages warning of potential issues.
#' Used for internal collection of messages only.
#'
#'
#' @return sites A list of \code{sf} object of sample points, an \code{sf} object of over sample
#' points if any, warning indicator and warning messages \code{data.frame}.
#'
#' @author Tony Olsen \email{Olsen.Tony@@epa.gov}
#'
#' @keywords survey
#'
#' @noRd
###############################################################################
grtspts_mindis <- function(mindis, sframe, samplesize, stratum, maxtry = 10,
legacy_option = NULL, legacy_var = NULL,
warn_ind = NULL, warn_df = NULL) {
# select initial set of sites
sites <- sframe[get_address(sframe$xcoord, sframe$ycoord, rand = TRUE), ]
s <- UPpivotal(sites$ip)
sites_base <- sites[round(s) == 1, ]
# calculate distance between sites
site_dist <- st_distance(sites_base)
class(site_dist) <- "numeric"
nr <- nrow(sites_base)
# find sites less than mindis and set to FALSE otherwise set to TRUE
keep <- apply(site_dist, 1, function(x) {
ifelse(any(x[x > 0] < mindis), FALSE, TRUE)
})
# if any legacy sites keep those sites
if (legacy_option == TRUE) {
keep[sites_base$legacy] <- TRUE
}
# see if any sites are less than mindis and check until none or max tries
ntry <- 1
while (any(!keep)) {
# identify sites that will be treated as legacy probability sites in sample frame
sframe$probdis <- FALSE
sframe$probdis[sframe$idpts %in% sites_base$idpts[keep]] <- TRUE
# if any true legacy sites add them to sites to be kept
if (legacy_option == TRUE) {
sframe$probdis[sframe$legacy] <- TRUE
}
# Adjust initial inclusion probabilities to account for current mindis sites
# and any legacy sites
sframe$ip <- grtspts_ipleg(sframe$ip_init, sframe$probdis)
# select new sites that include legacy sites
sites <- sframe[get_address(sframe$xcoord, sframe$ycoord, rand = TRUE), ]
s <- UPpivotal(sites$ip)
sites_base <- sites[round(s) == 1, ]
# calculate distance between sites
site_dist <- st_distance(sites_base)
class(site_dist) <- "numeric"
nr <- nrow(sites_base)
# identify sites less than mindis
keep <- apply(site_dist, 1, function(x) {
ifelse(any(x[x > 0] < mindis), FALSE, TRUE)
})
# Change to TRUE if any legacy sites
if (legacy_option == TRUE) {
keep[sites_base$legacy] <- TRUE
}
# check if maxtry reached. If so write out warning message
if (ntry >= maxtry) {
keep <- rep(TRUE, nr)
warn <- paste0("Minimum distance between sites not attained after ", maxtry, " attempts.")
if (warn_ind) { # this code has a bug but is never called (the rbind fails because warn_df has a column warn and the bind has a column warning)
warn_df <- rbind(warn_df, data.frame(
stratum = stratum, func = I("grtspts_mindis"),
warning = warn
))
} else {
warn_ind <- TRUE
warn_df <- data.frame(stratum = stratum, func = I("grtspts_mindis"), warning = warn)
}
} else {
ntry <- ntry + 1
}
} # end of ntry loop
# drop internal variables
tmp <- names(sites_base)
sites_base <- subset(sites_base, select = tmp[!(tmp %in% c("probdis", "geometry"))])
# Put sites in reverse hierarchical order
sites_base <- rho(sites_base)
sites_base$siteuse <- NA
sites_base$replsite <- NA
sites <- list(
sites = sites_base,
warn_ind = warn_ind, warn_df = warn_df
)
invisible(sites)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.