R/tidyrisk_factor.R

In davidski/evaluator: Quantified Risk Assessment Toolkit

# Constructors ------------------------------------------------------------

#' Construct a tidyrisk_factor object
#'
#' @param samples samples
#' @param factor_label fl
#' @param details details
#' @name tidyrisk_factor
NULL

#' @rdname tidyrisk_factor
#' @importFrom vctrs vec_assert new_vctr
new_tidyrisk_factor <- function(samples = double(), factor_label = character(),
                               details = list()) {
  vctrs::vec_assert(samples, double())
  vctrs::vec_assert(factor_label, character())
  if (!factor_label %in% c("TF", "TEF", "TC", "DIFF", "LM", "PLM", "SLF", "SLM")) {
    stop("Factor label is not a supported OpenFAIR type.", call. = FALSE)
  }
  vctrs::vec_assert(details, list())
  vctrs::new_vctr(samples, factor_label = factor_label, details = details,
                  class = "tidyrisk_factor")
}

#' @rdname tidyrisk_factor
tidyrisk_factor <- function(samples, factor_label, details = list()) {
  samples <- vctrs::vec_cast(samples, double())
  factor_label <- vctrs::vec_cast(factor_label, character())
  details <- vctrs::vec_cast(details, list())
  new_tidyrisk_factor(samples, factor_label, details)
}

factor_label <- function(x) attr(x, "factor_label")
details <- function(x) attr(x, "details")

vec_ptype_abbr.tidyrisk_factor <- function(x) {
  "r_fctr"
}

is_tidyrisk_factor <- function(x) {
  inherits(x, "tidyrisk_factor")
}

as_tidyrisk_factor <- function(x, factor_label) {
  vec_cast(x, new_tidyrisk_factor(x, factor_label))
}

# Formatters --------------------------------------------------------------

#' @importFrom cli cat_line cat_bullet cat_rule cat_print style_bold
#' @importFrom vctrs vec_data
#' @importFrom purrr walk2
format.tidyrisk_factor <- function(x, ...) {
  cli::cat_line("# Factor samples: ", length(vctrs::vec_data(x)))
  cli::cat_line("# Factor label: ", factor_label(x))
  if (length(details(x)) == 0) {
    cli::cat_bullet("# Summary details: None.")
  } else {
    purrr::walk2(names(details(x)), details(x)
                 ~ cli::cat_bullet("# Summary detail: ", cli::style_bold(.x),
                                   " ", .y))
    cli::cat_rule()
  }
  cli::cat_print(vctrs::vec_data(x))

  invisible(x)
}

#' @importFrom vctrs vec_data
summary.tidyrisk_factor <- function(object, ...) {
  samples <- vctrs::vec_data(object)
  switch(factor_label(object),
         LM = {
           if (length(samples) == 0 || sum(samples, na.rm = TRUE) == 0) {
             list(ale = 0, sle_max = 0, sle_min = 0, sle_mean = 0,
                  sle_median = 0)
           } else {
             list(ale = sum(samples),
                  sle_max = max(samples),
                  sle_min = min(samples[samples > 0]),
                  sle_mean = mean(samples[samples > 0]),
                  sle_median = stats::median(samples[samples > 0])
             )
           }},
         list()
  )
}

# Casts -------------------------------------------------------------------

#' Cast a `tidyrisk_factor` vector to a specified type
#'
#' @inheritParams vctrs::vec_cast
#'
#' @method vec_cast tidyrisk_factor
#' @importFrom vctrs vec_cast
vec_cast.tidyrisk_factor <- function(x, to) UseMethod("vec_cast.tidyrisk_factor")

#' @method vec_cast.tidyrisk_factor default
#' @importFrom vctrs stop_incompatible_cast
vec_cast.tidyrisk_factor.default <- function(x, to) {
  stop_incompatible_cast(x, to)
}

#' @method vec_cast.tidyrisk_factor class_pred
vec_cast.tidyrisk_factor.class_pred <- function(x, to) {

  # first go tidyrisk_factor -> factor
  # then recast as tidyrisk_factor with correct attributes

  tidyrisk_factor(
    samples = x,
    factor_label = "TF"
  )

}

# Arithmetic and Comparisons ----------------------------------------------

#' @importFrom vctrs vec_proxy_equal vec_data
#' @keywords internal
vec_proxy_compare.tidyrisk_factor <- function(x) {
  # allows you to compare two class_pred objects robustly
  # converting to character would confuse NA with equivocal
  vctrs::vec_data(x)
}

# Misc --------------------------------------------------------------------

#' Create a tidyrisk_factor sample function
#'
#' @param factor_label abbreviation of the OpenFAIR element
#' @importFrom rlang as_function
tidyrisk_factory <- function(factor_label = "TC") {

  function(.n = 1, ..., .func) {
    my_func <- rlang::as_function(.func)
    #dots <- enquos(...)

    samples <- my_func(n = .n, ...)
    tidyrisk_factor(samples = samples, factor_label = factor_label)
  }
}