R/assessment.R

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

#' Assign a unique group ID.
#'
#' @param .data a data frame
#' @param .keep a vector or list of vectors of column names in .data to
#' concatenate.
#' @param .numeric a logical value indicating if the function should returned
#' a concatenation of the fields supplied (FALSE) or a numeric ID (TRUE) for
#' each group in the supplied data.
#' @param .sep the field seperator character.
#' @return a vector representing a unique ID for each group of data.
#' @export

group_id <- function(.data, .keep, .numeric = FALSE,
                     .sep = "_", .collapse = "_") {
  if (!is.list(.keep)) .keep <- list(.keep)
  .data$keep <- .keep

  final.vec <- apply(.data, 1, function(row.i) {
    paste(as.character(row.i[unlist(row.i$keep)]),
          sep = .sep, collapse = .collapse)
  })
  if (.numeric == TRUE) final.vec <- as.numeric(factor(final.vec))
  return(final.vec)
}


#' Classify the sample as within or outside an assessment period.
#'
#' @param .date_vec a vector of dates.
#' @param .n_years_ago a single numeric value designating the sampling period
#' (present date minus .n_years_ago).
#' @return a logical vector. TRUE indicates that the sample is within the
#'  defined assessment period, while FALSE indicates that the sample is
#'  outside of the defined assessment period.
#' @export

assessment_period <- function(.date_vec, .n_years_ago = 10) {
  if (!is_date(.date_vec))
    stop(".date_vec must be class Date")
  if (.n_years_ago %% 1 != 0)
    stop(".n_years_ago must be a whole number")
  if (length(.n_years_ago) > 1)
    stop(".n_years_ago must represent a single integer value")

  # assessment_period.scalar <- Sys.Date() - lubridate::years(.n_years_ago)
  assessment_period.scalar <- date_subtraction(.date = Sys.Date(),
                                               .subtract = paste(.n_years_ago,
                                                                 "years"))

  .date_vec >= assessment_period.scalar
}


#' Classify the sample as meeting or failing minimum sample requirements.
#'
#' @param .x a vector, most likely a sample ID.
#' @param .min_samples an integer defining the minimum
#' number of samples required for an assessment
#' @return a logical vector. TRUE indicates that the defined group meets the
#'  minimum sample counts to perform an assessment, while FALSE indicates there
#'  are not enough samples to perform an assessment.
#' @export

assessment_min_counts <- function(.x, .min_samples) {
  if (.min_samples %% 1 != 0)
    stop(".min_samples must be a whole number")
  if (length(.min_samples) > 1)
    stop(".min_samples must represent a single integer value")

 length(.x) >= .min_samples
}


#' Classify the sample as meeting or failing minimum number of
#' independent sampling years.
#'
#' @param .date_vec the name of the date column unqouted. Must be class date.
#' @param .min_years an integer defining the minimum
#' number of independent sampling years required for an assessment.
#' @return a logical vector. TRUE indicates that the defined group meets
#'  the minimum independent years per group to perform an assessment,
#'  while FALSE indicates there are not enough independent years per group
#'  to perform an assessment.
#' @export

assessment_min_years <- function(.date_vec, .min_years) {

  if (!is_date(.date_vec)) stop(".date_vec must be class Date")
  if (.min_years %% 1 != 0) stop(".min_years must be a whole number")

  year.vec <- unique(format(.date_vec, "%Y"))
  length(year.vec) >= .min_years
}

#' Summarize the worst assessment per WI/PWL segment
#'
#' @param .data a data frame.
#' @param .seg_id_col a column name of .data that represents the WI/PWL
#'  segment ID.
#' @param .ir_col a column name of .data representing IR category.
#' @param .assess_col a column name of .data representing teh assessment
#'  status.
#' @param .confir_col a column name of .data representing the assessment
#'  confirmation status.
#' @return a data frame.
#' @export

summarize_seg_assessment <- function(.data, .seg_id_col, .ir_col,
                                     .assess_col, .confir_col) {
  by.list <- by(.data,
                .data[.seg_id_col],
                FUN = function(i) {

                  ir.df <- unique(subset(i, i[[.ir_col]] %in% max(i[[.ir_col]]),
                                         select = c(.ir_col, .assess_col, .confir_col)))
                  assess.df <- subset(ir.df, ir.df[[.assess_col]] %in% max(ir.df[[.assess_col]]))
                  confir.df <- subset(assess.df, assess.df[[.assess_col]] %in% max(assess.df[[.assess_col]]))

                  i$segment_assessment <- paste(vapply(confir.df, as.character, NA_character_),
                                                collapse = ": ")

                  return(i)
                })

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

  return(final.df)
}