R/plot_special.R

In actxps: Create Actuarial Experience Studies: Prepare Data, Summarize Results, and Create Reports

#' Additional plotting functions for termination studies
#'
#' These functions create additional experience study plots that are not
#' available or difficult to produce using the [autoplot.exp_df()] function.
#'
#' @param object An object of class `exp_df` created by the function
#' [exp_stats()].
#' @param ... Additional arguments passed to [autoplot.exp_df()].
#' @param include_cred_adj If `TRUE`, credibility-weighted termination rates
#' will be plotted as well.
#' @param add_hline If `TRUE`, a blue dashed horizontal line will be drawn at
#' 100%.
#'
#' @details
#'
#' [plot_termination_rates()] - Create a plot of observed termination rates
#' and any expected termination rates attached to an `exp_df` object.
#'
#' [plot_actual_to_expected()] - Create a plot of actual-to-expected termination
#' rates attached to an `exp_df` object.
#'
#' @return a `ggplot` object
#'
#' @examples
#'
#' study_py <- expose_py(census_dat, "2019-12-31", target_status = "Surrender")
#' expected_table <- c(seq(0.005, 0.03, length.out = 10), 0.2, 0.15, rep(0.05, 3))
#'
#' study_py <- study_py |>
#'   mutate(expected_1 = expected_table[pol_yr],
#'          expected_2 = ifelse(inc_guar, 0.015, 0.03))
#'
#' exp_res <- study_py |> group_by(pol_yr) |>
#'   exp_stats(expected = c("expected_1", "expected_2"))
#'
#' plot_termination_rates(exp_res)
#'
#' plot_actual_to_expected(exp_res)
#'
#' @seealso [autoplot.exp_df()]
#'
#' @name plot_special
#' @rdname plot_special
#' @export
plot_termination_rates <- function(object, ..., include_cred_adj = FALSE) {

  verify_exp_df(object)
  if (include_cred_adj && (!attr(object, "xp_params")$credibility ||
                           is.null(attr(object, "expected")))) {
    cred_adj_warning()
  }

  .groups <- groups(object)
  piv_cols <- c("q_obs", attr(object, "expected"),
                if (include_cred_adj) paste0("adj_", attr(object, "expected")))

  object <- pivot_plot_special(object, piv_cols)

  attr(object, "groups") <- append(.groups, rlang::expr(Series), after = 1L)

  autoplot(object, y = Rate, ...)
}

#' @rdname plot_special
#' @export
plot_actual_to_expected <- function(object, ..., add_hline = TRUE) {

  verify_exp_df(object)

  piv_cols <- paste0("ae_", attr(object, "expected")) |>
    intersect(names(object))
  if (length(piv_cols) == 0) {
    rlang::abort(c(x = "The `exp_df` object does not have any actual-to-expected results available.",
                   i = "Hint: to add expected values, use the `expected` argument in `exp_stats()`"
    ))
  }

  .groups <- groups(object)

  object <- pivot_plot_special(object, piv_cols, values_to = "A/E ratio")

  attr(object, "groups") <- append(.groups, rlang::expr(Series), after = 1L)
  p <- autoplot(object, y = `A/E ratio`, ...)

  if (add_hline) {
    p <- p + ggplot2::geom_hline(yintercept = 1,
                                 linetype = 2, color = "#112599")
  }

  p

}

# this function is used to pivot `exp_df` or `trx_df` objects before they're
# passed to special plotting functions
#' @param object An `exp_df` or `trx_df` object
#' @param piv_cols A primary set of columns to pivot longer
#' @param values_to Name of the values column in the pivoted object.
#' @noRd
pivot_plot_special <- function(object, piv_cols, values_to = "Rate") {

  hold_class <- class(object)
  xp_params <- attr(object, "xp_params")
  piv_cols <- intersect(piv_cols, names(object))

  object <- if (!xp_params$conf_int) {
    object |>
      tidyr::pivot_longer(dplyr::all_of(piv_cols),
                          names_to = "Series",
                          values_to = values_to)
  } else {

    extra_piv_cols <- c(
      piv_cols |> paste0("_upper"),
      piv_cols |> paste0("_lower")
    ) |>
      intersect(names(object))

    object |>
      dplyr::rename_at(piv_cols, \(x) paste(x, values_to, sep = "_")) |>
      tidyr::pivot_longer(c(dplyr::all_of(piv_cols |>
                                            paste(values_to, sep = "_")),
                            dplyr::all_of(extra_piv_cols)),
                          names_to = c("Series", ".value"),
                          names_pattern =
                            paste0("^(",
                                   paste0(piv_cols, collapse = "|"),
                                   ")_(", values_to, "|upper|lower)")) |>
      dplyr::rename_at(c("lower", "upper"),
                       \(x) paste(values_to, x, sep = "_"))
  }

  class(object) <- hold_class
  attr(object, "xp_params") <- xp_params
  object

}

# This internal function provides a common warning that is used by multiple
# functions.
cred_adj_warning <- function() {
  rlang::warn(c("*" = "`object` has no credibility-weighted termination rates.",
                "i" = "Pass `credibility = TRUE` and one or more column names to `expected` when calling `exp_stats()` to calculate credibility-weighted termination rates."))
}