R/calculate_max_min_risk.R

In DUToolkit: Visualizing and Quantifying Decision Uncertainty

#' Calculate risk measures at peak (or minimum)
#'
#' @description For each policy alternative, this function calculates the
#' risk measure at the peak values (or lowest values if the threshold is a minimum).
#'
#' @param max_min_values_list A list generated by [get_max_min_values()]
#' @param D A single threshold value
#' @param Dt_max A logical value indicating whether the decision threshold
#' is a maximum (`TRUE`) or a minimum (`FALSE`). The default is `TRUE`.
#'
#' @return A list of risk measure values.
#' @export
#'
#' @examples
#' tmin <- "2021-01-01"
#' tmax <- "2021-04-10"
#' D <- 750
#'
#' peak_values_list <- get_max_min_values(
#'   psa_data,
#'   tmin = tmin,
#'   tmax = tmax,
#'   Dt_max = TRUE
#' )
#'
#' calculate_max_min_risk(
#'   peak_values_list,
#'   D = D,
#'   Dt_max = TRUE
#' )
calculate_max_min_risk <- function(
    max_min_values_list,
    D,
    Dt_max = TRUE) {
  if (inherits(max_min_values_list, "list")) {
    risk <- lapply(max_min_values_list, calculate_max_min_risk_1, D, Dt_max)
  } else if (inherits(max_min_values_list, "data.frame")) {
    risk <- calculate_max_min_risk_1(max_min_values_list, D, Dt_max)
  } else {
    rlang::abort("The first argument is not a data.frame or list of data.frames",
      class = "data_type"
    )
  }
  return(risk)
}


#' Calculates risk measure at peak (or min) values for a single set of simulations
#'
#' @inheritParams calculate_max_min_risk
#' @noRd
#' @return A single risk measure value
calculate_max_min_risk_1 <- function(
    max_min_values_list,
    D,
    Dt_max = TRUE) {
  expected_risk <- ifelse(Dt_max == TRUE,
    sum(pmax(max_min_values_list$outcome, D) - D) /
      length(max_min_values_list$outcome),
    sum(D - pmin(max_min_values_list$outcome, D)) /
      length(max_min_values_list$outcome)
  )
  return(expected_risk)
}