R/survey.R

In BWAM/stayCALM: Stay Calm when Applying a Consolidated Assessment Listing Methodology (CALM)

#' Survey the data to obtain the metrics necessary for the CALM
#'
#' @param .id a vector that will be used to group the data.
#' @param .attaining_wqs a logical vector indicating if an observation
#' is attaining a water quality standard.
#' @param .attaining_75 a logical vector indicating if an observation
#' is attaining the 75th percentile of a water quality standard.
#' @param .year a numeric vector containg the year the observation was
#' collected.
#' @param .tmdl a vector. This is a place holder until this data is
#' available.
#' @param .ltco a vector. This is a place holder until this data is
#' available.
#' @param .pollutant a vector. This is a place holder until this data is
#' available.
#' @return A data frame.
#' @examples
#' @export

survey <- function(.id, .attaining_wqs, .attaining_75, .year, .water_type,
                   .tmdl = FALSE, .ltco = FALSE, .pollutant = FALSE,
                   .id_col_name) {
  new.df <- data.frame(id = .id,
                       attaining_wqs = .attaining_wqs,
                       attaining_75 = .attaining_75,
                       year = .year,
                       water_type = .water_type,
                       tmdl = .tmdl,
                       ltco = .ltco,
                       pollutant = .pollutant,
                       stringsAsFactors = FALSE)

  final.list <- by(data = new.df,
                   INDICES = new.df$id,
                   FUN = function(df) {
                     survey_indv(.id = df$id,
                                 .attaining_wqs = df$attaining_wqs,
                                 .attaining_75 = df$attaining_75,
                                 .year = df$year,
                                 .water_type = df$water_type,
                                 .tmdl = df$tmdl,
                                 .ltco = df$ltco,
                                 .pollutant = df$pollutant,
                                 .id_col_name = .id_col_name)

                   })

  final.df <- do.call(rbind, final.list)
  return(final.df)
}

# helpers -----------------------------------------------------------------

#' Survey an individual group to obtain the metrics necessary for the CALM
#'
#' @param .id a vector that will be used to group the data. This must be
#' one unique string.
#' @param .attaining_wqs a logical vector indicating if an observation
#' is attaining a water quality standard.
#' @param .attaining_75 a logical vector indicating if an observation
#' is attaining the 75th percentile of a water quality standard.
#' @param .year a numeric vector containg the year the observation was
#' collected.
#' @param .tmdl a vector. This is a place holder until this data is
#' available.
#' @param .ltco a vector. This is a place holder until this data is
#' available.
#' @param .pollutant a vector. This is a place holder until this data is
#' available.
#' @return A data frame.
#' @examples
#' @export
survey_indv <- function(.id, .attaining_wqs, .attaining_75,
                        .year, .water_type, .tmdl = FALSE, .ltco = FALSE,
                        .pollutant = FALSE,
                        .id_col_name) {
  if (length(unique(.id)) > 1) stop(".id must represent one unique ID")
  new.df <- data.frame(id_col = unique(.id),
                       stringsAsFactors = FALSE)
  names(new.df) <- .id_col_name

# wqs_violation -----------------------------------------------------------
  new.df$wqs_violation <- na_if(.vec = .attaining_wqs,
                                .else_fun = any(.attaining_wqs == FALSE,
                                                na.rm = TRUE))

# wqs_75_violation --------------------------------------------------------
  new.df$wqs_75_violation <- na_if(.vec = .attaining_75,
                                   .else_fun = any(.attaining_75 == FALSE,
                                                   na.rm = TRUE))

# min_years_samples -------------------------------------------------------
  n_req.scalar <- switch_count(.water_type)

    new.df$min_years_samples <- and(
      .left = na_if(.vec = .year,
                    .else_fun = length(unique(.year)) >= 2),
      .right = na_if(.vec = .id,
                     .else_fun = length(.id) >= n_req.scalar)
    )

# min_violations_year -----------------------------------------------------
    new.df$min_violations_year = na_if(.vec = .attaining_wqs,
                                       .else_fun = sum(
                                         tapply(
                                           X = .attaining_wqs == FALSE,
                                           INDEX = .year,
                                           FUN = sum,
                                           na.rm = TRUE
                                         )) > 0)

# tmdl --------------------------------------------------------------------
  new.df$tmdl = unique(.tmdl)

# ltcp --------------------------------------------------------------------
  new.df$ltco_rest_plan = unique(.ltco)

# pollutant ---------------------------------------------------------------
  new.df$pollutant = unique(.pollutant)

  return(new.df)
}



# helpers -----------------------------------------------------------------

na_if <- function(.vec, .else_fun) {
  ifelse(test = all(is.na(.vec)),
         yes = NA,
         no = .else_fun)
}

and <- function(.left, .right) {
  .left & .right
}

switch_count <- Vectorize(vectorize.args = ".vec",
                          FUN = function(.vec) {
                            switch(.vec,
                                   "flow" = 8,
                                   "pond" = 6,
                                   stop(".vec must be 'flow' or 'pond'. \n",
                                        "You supplied:", .vec, "\n"))
                          })