R/class_inheritance.R

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

#' Combine two vectors to create waterbody class variants.
#'
#' @param .class_vec a vector of waterbody class.
#' @param .variant_vec a vector of waterbody class variant patterns.
#' @param .sep (default = "") a scalar vector indicating how the pasted values should be separated.
#' @return A vector containing the combination of \code{.class_vec} and \code{.variant_vec}.
#' @examples
#' class_variants(c("A", "B"), c("", "(T)", "(TS)"))
#' class_variants(c("A", "B"), c("", "(T)"))
#' class_variants(c("A", "B"), c(""))
#' @export


class_variants <- function(.class_vec, .variant_vec, .sep = "") {
  if (any(is.na(.class_vec))) {
    stop(".class_vec should not contain NA")
  }

  if (any(is.na(.variant_vec))) {
    stop(".variant_vec should not contain NA")
  }

  if (!identical(unique(.class_vec), .class_vec)) {
    stop(".class_vec should only contain unique values")
  }

  if (!identical(unique(.variant_vec), .variant_vec)) {
    stop(".variant_vec should only contain unique values")
  }

  if (!is.factor(.class_vec)) {
    .class_vec <- factor(.class_vec,
                         levels = .class_vec)
  }

  do.call(paste, c(tidyr::crossing(.class_vec,
                                   .variant_vec),
                   sep = .sep))
}

#' NAs inherit the previous value
#'
#' @param .vec a vector ordered from left to right.
#' @return A vector.
#' @examples
#' int.vec <- c(20, NA, NA, NA, 10, NA, 5, NA)
#' inherit(.vec = int.vec)
#' na.vec <- c(NA, NA, NA, NA, 10, NA, 5, NA)
#' inherit(.vec = na.vec)
#' @export

inherit <- function(.vec) {
  logic.vec <- !is.na(.vec)
  logic.vec <- logic.vec | !cumsum(logic.vec)
  .vec[logic.vec][cumsum(logic.vec)]
}

#' Thresholds inherited by class hierarchy
#'
#' @param .data a dataframe
#' @param ... unquoted column name(s) for aggregated (grouping)
#' @param .class_col an unqouted column name representing an ordered factor of waterbody classes
#' @param .level_vec a vector of class levels.
#' @return A data frame.
#' @examples
#' @export

class_inheritance <- function(.data, ..., .class_col, .levels_vec) {

  if (!identical(unique(.levels_vec), .levels_vec)) {
    stop(".levels_vec should only contain unique values")
  }

  if (any(sapply(.data, function(i) typeof(i) == "list"))) {
    warning("list columns cannot be inherited")
  }

  .group_cols <- rlang::enquos(...)

  final.df <- .data %>%
    dplyr::mutate({{.class_col}} := factor({{.class_col}},
                                           levels = .levels_vec,
                                           ordered = TRUE),
                  keep = TRUE) %>%
    tidyr::complete({{.class_col}},
                    tidyr::nesting(dplyr::select(., !!! .group_cols)),
    ) %>%
    dplyr::group_by(!!! .group_cols) %>%
    dplyr::mutate_at(vars(-group_cols()), inherit) %>%
    dplyr::ungroup() %>%
    dplyr::filter(keep == TRUE) %>%
    dplyr::select(-keep)
}

wqs_inheritance <- function(.data, ..., .class_col, .levels) {

  if (is.list(.levels)) {
    NULL
  } else {
    class_inheritance(.data, !!! rlang::enquos(...), .class_col, .levels_vec = .levels)
  }
}