R/assign.R

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

#' Assign Assessment Status
#' This function requires a very specific data frame and is only written as a function
#' to enable unit testing.
#' @param .data a dataframe
#' @param .eval_colname a character string that will become the name of the column
#' that contains evaluation of the parameters evaluation status.
#' @return A data frame.
#' @examples
#' @export

assign_status <- function(.data, .eval_colname) {
  if (length(.eval_colname) != 1) {
    stop(paste(".eval_colname must be length 1. You supplied length:",
               length(.eval_colname)))
  }

  names.vec <- c("within_period", "min_years_samples", "wqs_violation",
                 "wqs_75_violation", "min_violations_year", "tmdl",
                 "ltco_rest_plan", "pollutant")
  names_log.vec <- !names.vec %in% names(.data)
  if (any(names_log.vec)) stop(paste0(".data must include name(s): ",
                                 paste(names.vec[names_log.vec], collapse = ", ")))

  status.df <- dplyr::mutate(.data,
                             assessment = dplyr::case_when(
                               !within_period ~ paste(rep("Manual Review Required (collected >10 years ago)", 3),
                                                      collapse = ": "),
                               is.na(wqs_violation) ~ paste(rep(paste("Manual Review Required",
                                                                      "(Not enough information to determine",
                                                                      "WQS treshold)"), 3),
                                                            collapse = ": "),
                               !min_years_samples & wqs_violation ~ "IR3: Impaired: Unconfirmed",
                               !min_years_samples & !wqs_violation & (!wqs_75_violation | is.na(wqs_75_violation))  ~ "IR3: Fully Supported: Unconfirmed",
                               !min_years_samples & !wqs_violation & wqs_75_violation  ~ "IR3: Stressed: Unconfirmed",
                               min_years_samples & !wqs_violation & (!wqs_75_violation | is.na(wqs_75_violation))  ~ "IR1: Fully Supported: Confirmed",
                               min_years_samples & !wqs_violation & wqs_75_violation  ~ "IR1: Stressed: Confirmed",
                               min_years_samples & wqs_violation & !min_violations_year  ~ "IR3: Impaired: Unconfirmed",
                               min_years_samples & wqs_violation &
                                 min_violations_year & tmdl  ~ "IR4a: Impaired: Confirmed",
                               min_years_samples & wqs_violation &
                                 min_violations_year & !tmdl & ltco_rest_plan  ~ "IR4b: Impaired: Unconfirmed",
                               min_years_samples & wqs_violation &
                                 min_violations_year & !tmdl & !ltco_rest_plan & pollutant  ~ "IR4c: Impaired: Confirmed",
                               min_years_samples & wqs_violation &
                                 min_violations_year & !tmdl & !ltco_rest_plan & !pollutant  ~ "IR5: Impaired: Confirmed",
                               TRUE ~ "ERROR"
                             )
  )

  names(status.df)[names(status.df) %in% "assessment"] <- .eval_colname

  error.vec <- status.df[.eval_colname] %in% "ERROR"
  if (any(error.vec)) {
    warning(paste(sum(error.vec),
                  "rows were not correctly assigned an assessment status.",
                  "Check assessment %in% 'ERROR'"))
  }

  final.df <- split_col(.data = status.df,
                        .col_name = .eval_colname,
                        .sep = ": ",
                        .new_names_vec = c("ir_category",
                                           "use_assessment",
                                           "use_assessment_confirmation"))

  return(final.df)
}

#' Assign Assessment Status
#' This function requires a very specific data frame and is only written as a function
#' to enable unit testing.
#' @param .data a dataframe
#' @param .col a column name of .data that should be updated with the hierarchy
#' represented as an ordered factor.
#' @param .type a single charcter string indicating the type of hierarchy to assign
#' .col.
#' @param .na_to_unassessed a logical indicating if NA values in .col should be
#' represented as "Unassessed".
#' @return A data frame where .col has been updated to an ordered factor.
#' @examples
#' @export

assign_assess_hier <- function(.data, .col, .type, .assign_unassessed) {
  levels.vec <- switch(
    EXPR = .type,
    "ir" = c("Unassessed", "IR1", "IR2", "IR3",
             "IR4a", "IR4b", "IR4c", "IR5"),
    "assess" = c("Unassessed", "Fully Supported",
                 "Stressed", "Impaired"),
    "confir" = c("Unassessed", "Unconfirmed",
                 "Confirmed"),
    stop(paste("\n .type must be 'ir', 'assess', or 'confir'.",
               "You supplied:", .type, "\n")))

  if (.assign_unassessed) {
    # .data[.col][is.na(.data[.col])] <- "Unassessed"
    .data[.col] <- ifelse(is.na(.data[[.col]]) | grepl("Manual Review",
                                                       .data[[.col]]),
                          "Unassessed",
                          .data[[.col]])
  }

  .data[.col] <- ordered(.data[[.col]],
                         levels = levels.vec)
  return(.data)
}

#' Switch the Assessment with the Waterbody Category Assignment.
#'
#' @param .assessment
#' @return A vector of character strings specifying waterbody categories.
#' @examples
#' @export

switch_wb_category <- Vectorize(
  vectorize.args = ".assessment",
  USE.NAMES = FALSE,
  FUN = function(.assessment) {
    switch(
      EXPR = .assessment,
      "IR5: Impaired: Confirmed" = "Impaired, IR5",
      "IR3: Fully Supported: Unconfirmed" = "Needs Verification, IR3",
      "IR3: Impaired: Unconfirmed" = "Needs Verification, IR3",
      "IR3: Stressed: Unconfirmed" = "Needs Verification, IR3",
      "IR3: Fully Supported: Unconfirmed" = "Needs Verification, IR3",
      "IR1: Stressed: Confirmed" = "Minor Impacts, IR1",
      "IR1: Fully Supported: Confirmed" = "Fully Supported, IR2",
      "Unassessed: Unassessed: Unassessed" = "Unassessed, IR3",
      stop("The supplied string does not match any of the expected inputs.")
    )
  }
)


#' Assign the appropriate Waterbody Category based on the provided assessment.
#'
#' @param .data a data frame.
#' @param .assess_col a character string of a column name within .data that
#' specifies the waterbody segment assessment.
#' @param .wb_colname a character string that will be used to name the column
#' that the waterbody category will be stored within.
#' @param .seg_id_col a character string representing the column name within
#'  .data that represents the waterbody segment ID.
#' @param .param_eval_col a character string representing the column name
#' within .data that represents summary evaluation of each parameter used to
#' inform an assessment.
#' @return A data frame containing the waterbody categories.
#' @examples
#' @export

assign_wb_category <- function(.data, .assess_col, .wb_colname, .seg_id_col, .param_eval_col) {
  names.vec <- c(.assess_col, .seg_id_col, .param_eval_col)
  check_names.vec <- names.vec[!names.vec %in% names(.data)]
  if (length(check_names.vec) > 0) {
    stop(paste("You must supply column names that exist within .data.",
               "The following names cannot be found in .data:",
               paste(check_names.vec, collapse = ", ")))
  }

  uses.df <- subset(x = stayCALM::class_use,
                    subset = !use %in% "shellfishing",# Remove when ready to assess shellfishing
                    select = c("class", "use"))

  .data[.wb_colname] <- switch_wb_category(.assessment = .data[[.assess_col]])

  split.list <- split(x = .data,
                      f = .data[.wb_colname])

  ir2_uses.df <- merge(x = uses.df,
                       y = split.list[["Fully Supported, IR2"]],
                       by = c("class", "use"))

  by.list <- by(ir2_uses.df,
                ir2_uses.df[.seg_id_col],
                FUN = function(i){
                  if (all(unique(i[.param_eval_col]) %in% "IR1: Fully Supported: Confirmed")) {
                    i[.wb_colname] <- "Fully Supported, IR1"
                  } else {
                    i[.wb_colname] <- "Fully Supported, IR2"
                  }
                  return(i)
                })

  by.df <- do.call(rbind, by.list)
  key.df <- unique(subset(x = by.df,
                          select = c(.seg_id_col, .wb_colname)))

  final.df <- replacement(.x = .data,
                          .y = key.df,
                          .by = .seg_id_col,
                          .replace_col = .wb_colname)
  return(final.df)

}


#' Assign the appropriate
#'
#' @param .trout_class a vector of strings signifying the types of trout based
#' variants should be assigned to a waterbody class.
#' \itemize{
#'  \item{"all"} {The original class will be returned as well as "(t)" and
#'   "(ts)" variants. For example, if "a" is the class supplied,
#'    "a, a(t), a(ts)" will be returned.}\
#'  \item{"trout"} {Only a trout variant, "(t)", of the supplied class will be
#'   returned. For example, if "a" is the class supplied, "a(t)" will be
#'   returned.}\
#'  \item{"trout_spawning"} {Only a trout spawning variant, "(ts)", of the
#'   supplied class will be returned. For example, if "a" is the class
#'    supplied, "a(ts)" will be returned.}\
#'  \item{"non_trout"} {The original class will be returned unaltered.
#'  For example, if "a" is the class supplied, "a" will be returned.
#'  In practice "non_trout" does not differ from "none." These two
#'  strings are supplied to act exffectively as explicit NAs and to
#'  provide the user a little bit of content related to how the class is
#'  treated in water quality standard regulations.}\
#'  \item{"none"}{The original class will be returned unaltered.
#'  For example, if "a" is the class supplied, "a" will be returned.
#'  In practice "none" does not differ from "non_trout." These two
#'  strings are supplied to act exffectively as explicit NAs and to
#'  provide the user a little bit of content related to how the class is
#'  treated in water quality standard regulations.}
#'   }
#' @return A list of character strings specifying the relavent class and trout
#' variants.
#' @examples
#' # "a", "a(t)", "a(ts)"
#' assign_trout_class(.trout_class = "all", .class = "a")
#' # "a(t)"
#' assign_trout_class(.trout_class = "trout", .class = "a")
#' # "a(ts)"
#' assign_trout_class(.trout_class = "trout_spawning", .class = "a")
#' # "a"
#' assign_trout_class(.trout_class = "non_trout", .class = "a")
#' # "a"
#' assign_trout_class(.trout_class = "none", .class = "a")
#' @export

assign_trout_class <- Vectorize(
  vectorize.args = c(".trout_class", ".class"),
  USE.NAMES = FALSE,
  FUN = function(.trout_class, .class) {
    switch(
      EXPR = .trout_class,
      "all" = class_variants(.class_vec = .class,
                             .variant_vec = c("", "(t)", "(ts)")),
      "trout" = class_variants(.class_vec = .class,
                               .variant_vec = "(t)"),
      "trout_spawning" = class_variants(.class_vec = .class,
                                        .variant_vec = "(ts)"),
      "non_trout" = .class,
      "none" = .class,
      stop(paste("The supplied string does not match any of the expected inputs:",
                 "'all', 'trout', 'trout_spawning', 'non_trout', and 'none'"))
    )
  }
)