R/wrap_eval.R

In signaux-faibles/MLsegmentr: Model evaluation on data segments

#' Compute Precision-Recall curves, and AUCPR
#'
#' Auxiliary function to build an eval_function object.
#'
#' To be used with options "wrap_eval_fun", "unnest = TRUE", and with plotting
#' function "aux_plot_pr_curve".
#'
#'
#' @param eval_frame Data.frame, valid eval_frame.
#'
#' @return
#' @export
#'
aux_compute_prcurve <- function(eval_frame) {
  ### TODO: issue with simple problems, not sur why. PRROC::pr.curve does not
  ### allow curve = TRUE in some edge conditions
  if (all(eval_frame$target == 0) ||
    all(eval_frame$prediction == 0) ||
    all(eval_frame$target == 1) ||
    all(eval_frame$prediction == 1)){
    take_curve <- FALSE
  } else {
    take_curve <-  TRUE
  }

  pr_object <- PRROC::pr.curve(
    scores.class0 = eval_frame$prediction,
    weights.class0 =  eval_frame$target,
    curve = take_curve)

  # computing PR Curve frame
  prcurve <- as.data.frame(pr_object$curve)

  if (!is.null(pr_object$curve))
    names(prcurve) <- c("recall", "precision", "threshold")

  # computing AUCPR
  aucpr <- ifelse(is.na(pr_object$auc.davis.goadrich), #nolint
    pr_object$auc.integral, #nolint
    pr_object$auc.davis.goadrich) #nolint

  # Computing F1 and F2 scores, and precision and recall at these thresholds
  f1_scores <- Fscore_from_prcurve(prcurve = prcurve, alpha = 1)
  f2_scores <- Fscore_from_prcurve(prcurve = prcurve, alpha = 2)
  max_index_f1 <- which.max(f1_scores)
  max_index_f2 <- which.max(f2_scores)

  F1 <- dplyr::bind_cols(
    tibble::tibble(fscore = f1_scores[max_index_f1]),
    prcurve[max_index_f1, ]
  )

  F2 <- dplyr::bind_cols(
    tibble::tibble(fscore =  f2_scores[max_index_f2]),
    prcurve[max_index_f2, ]
  )

  res <- list(aucpr = aucpr, prcurve = prcurve, F1 = F1, F2 = F2)

  return(res)
}


#' Plot PR-curves
#'
#' Auxiliary plot function to build an eval_function object.
#'
#' To be used with options "wrap_eval_fun", "unnest = TRUE", and with plotting
#' function "aux_compute_prcurve".
#'
#' @param eval_frame Data.frame, expected output form aux_compute_prcurve
#' @param priority Either "auto", or a permutation of "prediction_type", "segment" and
#' "target_type". Maybe only used for plotting?
#'
#' @return
#' @export
#'
aux_plot_prcurve <- function(eval_frame, priority = "auto") {

   if (priority == "auto") {
     priority <-  c("prediction_type", "segment", "target_type")
     has_several_values <-  sapply(
       priority,
       function(name) {
         dplyr::n_distinct(eval_frame[[name]]) > 1
       }
       )

     priority <- c(priority[has_several_values], priority[!has_several_values])
     assertthat::assert_that(length(priority) == 3)
   }

  ## Plot
  if (requireNamespace("ggplot2") && requireNamespace("ggrepel")) {
    p <- ggplot2::ggplot(
      data = eval_frame %>%
        dplyr::filter(evaluation_name == "prcurve") %>%
        tidyr::unnest(),
      ggplot2::aes_string(x = "recall", y = "precision", color = priority[1])
      ) +
      ggplot2::geom_path() +
      ggplot2::facet_grid(reformulate(priority[2], priority[3])) +
      ggplot2::xlim(0, 1) +
      ggplot2::ylim(0, 1)

  ##  # Print Fscores
   p  <- p +
     ggrepel::geom_text_repel(
       data = eval_frame %>%
         dplyr::filter(evaluation_name %in% c("F1", "F2")) %>%
         tidyr::unnest() %>%
         dplyr::mutate(
           F_score_label = paste0(
             evaluation_name,
             ": ",
             round(fscore, digits = 3)
           )
           ),
         ggplot2::aes(label = F_score_label),
         na.rm = TRUE
     )

   # Print AUCPR
   p <-  p +
     ggrepel::geom_label_repel(
       data = eval_frame %>%
         dplyr::filter(evaluation_name == "aucpr") %>%
         tidyr::unnest() %>%
         dplyr::mutate(aucpr_label = paste0(
             "aucpr:",
             round(evaluation, digits = 3))),
         ggplot2::aes(label = aucpr_label, x = 0, y = 1),
         nudge_x = -1,
         na.rm = TRUE
     )

   plot(p)
  } else {
    warning("Please install ggplot2 and ggrepel for plotting")
  }
}

aux_cv_summary_prcurve <- function(eval_frame){
  additionnal_summary  <- eval_frame %>%
    filter(evaluation_type %in% c("aucpr", "F1", "F2")) %>%
    group_by(evaluation_type) %>%
    summarize(evaluation = c(
        mean = mean(evaluation),
        sd = sd(evaluation)
        ))

    return(additionnal_summary)
}

#' eval_function object to asses precision and recall
#'
#' Draws precision recall curves and prints aucpr and F1, F2 scores.
#'
#' @return eval_function object
#' @export
#'
eval_precision_recall <- function(){

  res <- eval_function(
    eval_fun      = aux_compute_prcurve,
    plot_fun      = aux_plot_prcurve,
    cv_summary_fun = aux_cv_summary_prcurve,
    wrap_eval_fun = TRUE,
    unnest        = TRUE
  )

  return(res)
}

#' Get examples with most differences between models
#'
#' @param eval_frame as generated by an Assesser object
#' @param test_frame with additional data ?
#' @param n Number of entries to keep
#'
#' @return a data.frame
#' @export
#'
main_diff_eval <- function(eval_frame, test_frame, n = 20){
  aux_vect_diffs <- function(df){
    nv <- df$prediction_type
    lv <- nrow(df)
    vec <- df$prediction
    names <- matrix(rep(nv, lv), nrow = lv, byrow = T)
    names <- paste0(names[lower.tri(names)],
      "_",
      t(names)[lower.tri(names)])
    m1 <- matrix(rep(vec, lv), nrow = lv, byrow = T)
    m <- (m1 - t(m1))[lower.tri(m1)]
    names(m) <- names
    return(as.data.frame(t(m)))
  }

  eval_frame <- eval_frame %>%
    dplyr::group_by(.id) %>%
    tidyr::nest(.key = results) %>%
    dplyr::mutate(diffs = purrr::map(results, aux_vect_diffs)) %>%
    dplyr::select(-results) %>%
    tidyr::unnest(.sep = "_") %>%
    tidyr::gather(dplyr::starts_with("diffs"), key = ".diff", value = ".amount")

  aux_top_n_last_n <- function(my_data, n = n){
    res <- dplyr::bind_rows(
      my_data %>%
        head(n),
      my_data %>%
        tail(n)
    )
    return(res)
  }

  eval_frame <- eval_frame %>%
    dplyr::group_by(.diff) %>%
    arrange(.amount) %>%
    dplyr::do(aux_top_n_last_n(., n)) %>%
    dplyr::ungroup()

  # TODO dangerous: what if test-frame's order is changed before function call !
  binded_frame <- dplyr::bind_cols(
    eval_frame,
    as.data.frame(test_frame)[eval_frame$.id, ]
  )
  return(binded_frame)
}

#' Get F-Score from PR-Curve
#'
#' This help function gets the Fscore from the prcurve. It is expected that
#' first column is recall, second column is precision, as in PRROC prcurves.
#'
#' @param prcurve Dataframe with first column giving precision, second column
#' recall
#' @param alpha Compute the F-alpha score (any positive double)
#'
#' @return Returns a vector of F-scores with same length as number of rows of
#' input
Fscore_from_prcurve <- function(prcurve, alpha){
  assertthat::assert_that(alpha > 0)
  Fs <- (1 + alpha ^ 2) * prcurve[, 1] * prcurve[, 2] /
    (alpha ^ 2 * prcurve[, 2] + prcurve[, 1])
  return(Fs)
}

#' Fscore_from_prediction
#'
#' @param prediction Vector of predictions
#' @param target Vector of targets
#' @param alpha Alpha coefficient for the computation of F-scores
#'
#' @return `double` \cr
#' F-score with coefficient alpha
Fscore_from_prediction <- function(prediction, target, alpha){
  pr_object <- PRROC::pr.curve(
    scores.class0 = prediction,
    weights.class0 =  target,
    curve = TRUE)
  res <- as.data.frame(pr_object$curve) %>%
    dplyr::mutate(Fscore = Fscore_from_prcurve(pr_object$curve, alpha)) %>%
    dplyr::filter(Fscore == max(Fscore, na.rm = TRUE)) %>%
    .[1, 3]
  return(res)
}

#' Evaluates the confusion matrix
#'
#' @param eval_frame as generated by an Assesser object
#' @param alpha F-score of level alpha
#'
#' @return `data.frame` \cr
#'   The confusion matrix
#' @export
confusion_matrix_eval <- function(eval_frame, alpha = 2) {

  aux_confusion_matrix <- function(df, threshold){
    return(
      MLmetrics::ConfusionMatrix(
        y_pred = (df$y_pred > threshold),
        y_true = df$y_true
      )
    )
  }

  eval_frame <- eval_frame %>%
    dplyr::group_by(prediction_type, segment, target_type) %>%
    dplyr::mutate(
      threshold = Fscore_from_prediction(prediction, target, alpha)
      ) %>%
    dplyr::ungroup()

  res <- eval_frame %>%
    dplyr::group_by(prediction_type, segment, target_type, threshold) %>%
    dplyr::rename(y_pred = prediction, y_true = target) %>%
    tidyr::nest(.key = "data") %>%
    dplyr::mutate(
      confusion_matrix = purrr::map(
        data,
        aux_confusion_matrix,
        threshold = dplyr::first(threshold)
      )
      ) %>%
    dplyr::select(-threshold, -data)

  return(res)
}