Merge pull request #38 from USEPA/develop

Develop

.Rbuildignore

@@ -9,3 +9,4 @@
 ^_pkgdown\.yml$
 ^docs$
 ^pkgdown$
+^CRAN-SUBMISSION$

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: spsurvey
 Title: Spatial Sampling Design and Analysis
-Version: 5.4.1
+Version: 5.5.0
 Authors@R: c(
     person("Michael", "Dumelle", role=c("aut","cre"),
            email = "[email protected]", comment = c(ORCID = "0000-0002-3393-5529")),

NAMESPACE

@@ -15,6 +15,7 @@ S3method(sp_summary,sp_design)
 S3method(summary,sp_design)
 S3method(summary,sp_frame)
 export(adjwgt)
+export(adjwgtNR)
 export(ash1_wgt)
 export(attrisk_analysis)
 export(cat_analysis)

NEWS.md

@@ -1,3 +1,25 @@
+# spsurvey 5.5.0
+
+## Minor Updates
+
+* `n_over` is now recycled if the design is stratified and `n_over` is a length-one numeric vector.
+* Added an `adjwgtNR()` function to perform non-response weight adjustments.
+* Warning and error messages from `grts()`, `irs()`, and `*_analysis()` functions now print using `message()` instead of `cat()`. This change makes the resulting output more consistent with standard practice and easier to suppress when desired (#36).
+* Changed default behavior in `attrisk_analysis()`, `diffrisk_analysis()`, and
+  `relrisk_analysis()` regarding the handling of `response_levels` and `stressor_levels`.
+  Previously, if `response_levels` and `stressor_levels` were specified, 
+  their elements required names.
+  Now, if `response_levels` is specified and its names are `NULL`, then its names are set to `vars_response`,
+  and if `stressor_levels` is specified and its names are `NULL`, then its names are set to `vars_stressor` (#33).
+
+## Bug Fixes
+
+* Fixed a bug that caused an erorr in `grts()` and `irs()` occurred when at least
+  one variable name in `sframe` was named `"siteID"`, `"siteuse"`, `"replsite"`,
+  `"lon_WGS84"`, `"lat_WGS84"`, `"stratum"`, `"wgt"`, `"ip"`, `"caty"`, `"aux"`,
+  `xcoord`, `ycoord`, or `idpts` and the name of the geometry column in `sframe`
+  was not named `"geometry"` (#32).
+
 # spsurvey 5.4.1
 
 ## Minor Updates
@@ -32,13 +54,13 @@
 ## Bug fixes
 
 * Fixed a bug that prevented proper printing of the `Indicator` column when using `change_analysis()` with `test = median`.
-* Fixed a bug that made `change_analysis` sensititve to the ordering of the levels of variables in `var_cat` if those variables were factors.
+* Fixed a bug that made `change_analysis` sensitive to the ordering of the levels of variables in `var_cat` if those variables were factors.
 * Fixed a bug in `sp_summary()` that incorrectly ordered the `siteuse` variable.
 * Fixed a bug in `sp_summary()` that failed to summarize data frames that did not have an `sf_column` attribute.
 * Fixed a bug in `*_analysis()` functions when `popsize` is a list intended for use with `survey::calibrate()`.
 * Fixed a bug in `*analysis()` functions that returned an error while performing percentile estimation when there was no variability in at least one variable in `vars` for at least one level of one variable in `subpops`.
 * Fixed a bug in `grts()` that caused an error for some combinations of `n_base` and `n_over`.
-* Fixed a bug in `change_analysis()` that returned an error when at least one varible in `vars_cat` has only one unique value.
+* Fixed a bug in `change_analysis()` that returned an error when at least one variable in `vars_cat` has only one unique value.
 
 # spsurvey 5.3.0
 

R/adjwgtNR.R

@@ -0,0 +1,75 @@
+############################################################################
+# Function: adjwgtNR (exported)
+# Programmer: Tony Olsen
+# Date: April 5, 2022
+#
+#' Adjust survey design weights for non-response by categories
+#'
+#' @description Adjust weights for target sample units that do not respond 
+#' and are missing at random within categories. The missing at random
+#' assumption implies that their sample weight may be assigned to
+#' specific categories of units that have responded (i.e., have been
+#' sampled). This is a class-based method for non-response adjustment.
+#'
+#' @param wgt vector of weights for each sample unit that will be adjusted
+#'  for non-response. Weights must be weights for the design as implemented.
+#'  All weights must be greater than zero.
+#'           
+#' @param MARClass vector that identifies for each sample unit the category
+#'  that will be used in non-response weight adjustment for sample units 
+#'  that are known to be target. Within each missing at random (MAR) 
+#'  category, the missing sample units that are not sampled are assumed to
+#'  be missing at random.
+#'            
+#' @param EvalStatus vector of the evaluation status for each sample unit.
+#'  Values must include the values given in TNRclass and TRClass. May 
+#'  include other values not required for the non-response adjustment.
+#'                 
+#' @param TNRClass subset of values in EvalStatus that identify sample units
+#'  whose target status is known and that do not respond (i.e., are not 
+#'  sampled).
+#'                  
+#' @param TRClass Subset of values in EvalStatus that identify sample units 
+#'  whose target status is known and that respond (i.e., are target and
+#'  sampled).
+#'
+#' @return Vector of sample unit weights that are adjusted for non-response
+#'  and that is the same length of input weights. Weights for sample 
+#'  units that did not response but were known to be eligible are set
+#'  to zero. Weights for all other sample units are also set to zero.
+#' 
+#' @export
+#'
+#' @author Tony Olsen \email{[email protected]}
+#' 
+#' @keywords survey non-response weight adjustment
+#' 
+#' @examples
+#' set.seed(5)
+#' wgt <- runif(40)
+#' MARClass <- rep(c("A", "B"), rep(20, 2))
+#' EvalStatus <- sample(c("Not_Target", "Target_Sampled", "Target_Not_Sampled"), 40, replace = TRUE)
+#' TNRClass <- "Target_Not_Sampled"
+#' TRClass <- "Target_Sampled"
+#' adjwgtNR(wgt, MARClass, EvalStatus, TNRClass, TRClass)
+#' # function that has an error check
+adjwgtNR  <- function(wgt, MARClass, EvalStatus, TNRClass, TRClass){
+  tstTNRClass <- EvalStatus %in% c(TNRClass)
+  tstTRClass <- EvalStatus %in% c(TRClass)
+  num <- tapply(wgt[tstTNRClass | tstTRClass],
+                MARClass[tstTNRClass | tstTRClass], sum)
+  den <- tapply(wgt[tstTRClass], MARClass[tstTRClass], sum)
+  # error check
+  # could use any(! unique(MARClass[tstTNRClass]) %in% unique(MARClass[tstTRClass]))
+  if (length(num) > length(den)) {
+    stop("At least one level of MARClass does not have any EvalStatus values in
+         TRClass, so no non-response weight adjustment can be performed.
+         Consider aggregating categories so that all levels of MARClass are
+         instead in TRClass.", call. = FALSE)
+  }
+  ar <- num/den[match(names(num), names(den))]
+  wgt[tstTRClass] <- wgt[tstTRClass] *
+    ar[match(MARClass, names(ar))][tstTRClass]
+  wgt[!tstTRClass] <- 0
+  as.vector(wgt)
+}

R/attrisk_analysis.R

@@ -62,7 +62,9 @@
 #'   contains the values \code{"Poor"} and \code{"Good"} for the first and
 #'   second levels, respectively, of each element in the \code{vars_response}
 #'   argument and that uses values in the \code{vars_response} argument as names
-#'   for the list.  The default value is NULL.
+#'   for the list.  If \code{response_levels} is provided without names,
+#'   then the names of \code{response_levels} are set to \code{vars_response}.
+#'   The default value is NULL.
 #'
 #' @param stressor_levels List providing the category values (levels) for each
 #'   element in the \code{vars_stressor} argument.  Each element in the list
@@ -74,7 +76,9 @@
 #'   contains the values \code{"Poor"} and \code{"Good"} for the first and
 #'   second levels, respectively, of each element in the \code{vars_stressor}
 #'   argument and that uses values in the \code{vars_stressor} argument as names
-#'   for the list.  The default value is NULL.
+#'   for the list.  If \code{stressor_levels} is provided without names,
+#'   then the names of \code{stressor_levels} are set to \code{vars_stressor}. 
+#'   The default value is NULL.
 #'
 #' @param subpops Vector composed of character values that identify the
 #'   names of subpopulation (domain) variables in \code{dframe}.
@@ -572,6 +576,9 @@ attrisk_analysis <- function(dframe, vars_response, vars_stressor, response_leve
         msg <- "Argument response_levels must be the same length as argument vars_response.\n"
         error_vec <- c(error_vec, msg)
       }
+      if (is.null(names(response_levels))) { # set default names if none provided
+        names(response_levels) <- vars_response
+      }
       if (any(sapply(response_levels, function(x) length(x) != 2))) {
         error_ind <- TRUE
         msg <- "Each element of argument response_levels must contain only two values.\n"
@@ -622,6 +629,9 @@ attrisk_analysis <- function(dframe, vars_response, vars_stressor, response_leve
         msg <- "Argument stressor_levels must be the same length as argument vars_stressor.\n"
         error_vec <- c(error_vec, msg)
       }
+      if (is.null(names(stressor_levels))) { # set default names if none provided
+        names(stressor_levels) <- vars_stressor
+      }
       if (any(sapply(stressor_levels, function(x) length(x) != 2))) {
         error_ind <- TRUE
         msg <- "Each element of argument stressor_levels must contain only two values.\n"
@@ -664,17 +674,17 @@ attrisk_analysis <- function(dframe, vars_response, vars_stressor, response_leve
   if (error_ind) {
     error_vec <<- error_vec
     if (length(error_vec) == 1) {
-      cat("During execution of the program, an error message was generated.  The error \nmessage is stored in a vector named 'error_vec'.  Enter the following command \nto view the error message: errorprnt()\n")
+      message("During execution of the program, an error message was generated.  The error \nmessage is stored in a vector named 'error_vec'.  Enter the following command \nto view the error message: errorprnt()\n")
     } else {
-      cat(paste("During execution of the program,", length(error_vec), "error messages were generated.  The error \nmessages are stored in a vector named 'error_vec'.  Enter the following \ncommand to view the error messages: errorprnt()\n"))
+      message(paste("During execution of the program,", length(error_vec), "error messages were generated.  The error \nmessages are stored in a vector named 'error_vec'.  Enter the following \ncommand to view the error messages: errorprnt()\n"))
     }
 
     if (warn_ind) {
       warn_df <<- warn_df
       if (nrow(warn_df) == 1) {
-        cat("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
+        message("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
       } else {
-        cat(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
+        message(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
       }
     }
     stop("See the preceding message(s).")
@@ -1218,9 +1228,9 @@ attrisk_analysis <- function(dframe, vars_response, vars_stressor, response_leve
   if (warn_ind) {
     warn_df <<- warn_df
     if (nrow(warn_df) == 1) {
-      cat("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
+      message("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
     } else {
-      cat(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
+      message(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
     }
   }
 

R/cat_analysis.R

@@ -493,17 +493,17 @@ cat_analysis <- function(dframe, vars, subpops = NULL, siteID = NULL, weight = "
   if (error_ind) {
     error_vec <<- error_vec
     if (length(error_vec) == 1) {
-      cat("During execution of the program, an error message was generated.  The error \nmessage is stored in a vector named 'error_vec'.  Enter the following command \nto view the error message: errorprnt()\n")
+      message("During execution of the program, an error message was generated.  The error \nmessage is stored in a vector named 'error_vec'.  Enter the following command \nto view the error message: errorprnt()\n")
     } else {
-      cat(paste("During execution of the program,", length(error_vec), "error messages were generated.  The error \nmessages are stored in a vector named 'error_vec'.  Enter the following \ncommand to view the error messages: errorprnt()\n"))
+      message(paste("During execution of the program,", length(error_vec), "error messages were generated.  The error \nmessages are stored in a vector named 'error_vec'.  Enter the following \ncommand to view the error messages: errorprnt()\n"))
     }
 
     if (warn_ind) {
       warn_df <<- warn_df
       if (nrow(warn_df) == 1) {
-        cat("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
+        message("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
       } else {
-        cat(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
+        message(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
       }
     }
     stop("See the preceding message(s).")
@@ -635,9 +635,9 @@ cat_analysis <- function(dframe, vars, subpops = NULL, siteID = NULL, weight = "
   if (warn_ind) {
     warn_df <<- warn_df
     if (nrow(warn_df) == 1) {
-      cat("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
+      message("During execution of the program, a warning message was generated.  The warning \nmessage is stored in a data frame named 'warn_df'.  Enter the following command \nto view the warning message: warnprnt()\n")
     } else {
-      cat(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
+      message(paste("During execution of the program,", nrow(warn_df), "warning messages were generated.  The warning \nmessages are stored in a data frame named 'warn_df'.  Enter the following \ncommand to view the warning messages: warnprnt() \nTo view a subset of the warning messages (say, messages number 1, 3, and 5), \nenter the following command: warnprnt(m=c(1,3,5))\n"))
     }
   }