R/plot_lift_curve_relative.R

In gloverd2/admr: Contains standard functions for Admiral Advance Analytics

#' plot_lift_curve_relative
#'
#' @description
#' Buckets data into groups using the difference in predicted values (\code{proposed_pred} - \code{incumbent_pred}) (see \code{\link{prep_num_bin}}) and finds average predictions and actual in each bucket.
#'
#' Note: Predictions should be annualised (independent of exposure)
#'
#' @param actual Array[Numeric] - Values we are aiming to predict.
#' @param incumbent_pred Array[Numeric] - Values that we have predicted by the incumbent model. Incumbent is the current model looking to be replaced.
#' @param proposed_pred Array[Numeric] - Values that we have predicted by the proposed model. Proposed is the new model looking to be replace the incumbent.
#' @param weight Optional: Array[Numeric] - Weighting of predictions. If NULL even weighting is used.
#' @param title Optional: String - Title for the plot.
#' @inheritParams prep_num_bin
#' @param incumbent_label Optional: String - Text to use to label the incumbent predictions.
#' @param proposed_pred Optional: String - Text to use to label the proposed predictions.
#' @param use_plotly Optional: boolean - If TRUE plotly object is returned else ggplot2 object.
#'
#' @return plotly/ggplot object of showing relative lift curve for given pair of predictions
#' @export
#'
#' @examples
#'
#' plot_lift_curve_relative(actual=1:100, incumbent_pred = seq(25,74.5,0.5) + rnorm(100, mean=0, sd = 10), proposed_pred=seq(1,100,1) + rnorm(100, mean=0, sd = 10), title="Example Lift Curve")
#' plot_lift_curve_relative(actual=1:100, incumbent_pred = seq(25,74.5,0.5) + rnorm(100, mean=0, sd = 10), proposed_pred=seq(1,100,1) + rnorm(100, mean=0, sd = 10), title="Example Lift Curve", method="gaussian_weight")
#'
plot_lift_curve_relative <- function(actual, incumbent_pred, proposed_pred, weight=NULL, title=NULL,
                                     n_bins=10, method="even_weight", use_labels=TRUE, mean=0.5, sd=0.3,
                                     incumbent_label="Incumbent", proposed_label="Proposed", use_plotly=TRUE){

  #Other inputs are asserted in the function prep_num_bin
  checkmate::assert_character(title, null.ok = TRUE)

  checkmate::assert_numeric(actual)

  checkmate::assert_numeric(incumbent_pred, len = length(actual))
  checkmate::assert_character(incumbent_label)

  checkmate::assert_numeric(proposed_pred, len = length(actual))
  checkmate::assert_character(proposed_label)

  checkmate::assert_logical(use_plotly, len=1)

  # Use no weighting if none given
  if (is.null(weight)){
    weight <- rep(1, length(actual))
  }else{
    checkmate::assert_numeric(weight, len=length(actual), lower=0)
  }


  # Create dataframe of output
  data <- data.frame(actual=actual, incumbent_pred=incumbent_pred, proposed_pred=proposed_pred, weight=weight) %>%
    dplyr::mutate(pred_diff = proposed_pred-incumbent_pred)

  #bin data
  data$bin <- prep_num_bin(var_to_band=data$pred_diff, n_bins=n_bins, weight=data$weight, method=method, use_labels=use_labels, mean=mean, sd=sd)$bins

  #Summarise bins
  agg_data <- data %>%
    dplyr::group_by(bin) %>%
    dplyr::summarise(actual=sum(actual * weight)/ sum(weight)
                    ,incumbent_pred=sum(incumbent_pred * weight)/ sum(weight)
                    ,proposed_pred=sum(proposed_pred * weight)/ sum(weight)
                    ,weight=sum(weight)
                    ,.groups = "keep")

  if (use_plotly==TRUE){

    plotly::plot_ly(data=agg_data) %>%
      plotly::add_trace(x=~bin, y=~actual, type="scatter", mode="line+marker", name="Actual") %>%
      plotly::add_trace(x=~bin, y=~incumbent_pred, type="scatter", mode="line+marker", name=incumbent_label) %>%
      plotly::add_trace(x=~bin, y=~proposed_pred, type="scatter", mode="line+marker", name=proposed_label) %>%
      plotly::add_trace(x=~bin, y=~weight, type="bar", name="Exposure", yaxis="y2", opacity=0.2) %>%
      plotly::layout(
                    title = title,
                    yaxis = list(title="Actual and Predicted Value", rangemode="nonnegative"),
                    yaxis2 = list(overlaying = "y", side = "right", title="Exposure", showgrid = FALSE, rangemode="nonnegative"),
                    xaxis = list(title=paste0("Bin (", proposed_label, "-", incumbent_pred, ")"))
      ) %>%
      return()
  }else{
    scale= mean(agg_data$actual + agg_data$incumbent_pred + agg_data$proposed_pred) / (3 * mean(agg_data$weight))

    out_plot <- ggplot2::ggplot(data=agg_data) +
      ggplot2::geom_point(ggplot2::aes(x=bin, y=actual, color="Actual")) +
      ggplot2::geom_line(ggplot2::aes(x=bin, y=actual, color="Actual", group=1)) +
      ggplot2::geom_point(ggplot2::aes(x=bin, y=incumbent_pred, color=incumbent_label)) +
      ggplot2::geom_line(ggplot2::aes(x=bin, y=incumbent_pred, color=incumbent_label, group=1)) +
      ggplot2::geom_point(ggplot2::aes(x=bin, y=proposed_pred, color=proposed_label)) +
      ggplot2::geom_line(ggplot2::aes(x=bin, y=proposed_pred, color=proposed_label, group=1)) +
      ggplot2::geom_col(ggplot2::aes(x=bin, y=weight * scale, fill="Exposure"), alpha=0.2) +
      ggplot2::scale_y_continuous(name="Actual and Predicted Value", sec.axis=ggplot2::sec_axis(~.*scale ,name="Exposure")) +
      ggplot2::labs(title=title, x="Bin", color="Data Type", fill="")

    if (use_labels){
      out_plot <- out_plot +
        ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, vjust = 1, hjust=1))
    }

    return(out_plot)
  }

}