Financial Impact Metric

Financial Impact Metric zur Auswertung von Klassifikationsmodellen

Der folgende Code definiert eine benutzerdefinierte Metrik für yardstick, mit der Sie den durchschnittlichen finanziellen Nutzen bzw. Schaden eines binären Klassifikationsmodells berechnen können.

Die Idee:

truth: wahre Klassen (z. B. FALSE vs. TRUE oder no_fraud vs. fraud)
estimate: vorhergesagte Klassen (z. B. .pred_class)
costs: benannter numerischer Vektor der Form
c(tp = ..., fp = ..., fn = ..., tn = ...),
wobei
- tp = Gewinn/Kostenbeitrag eines True Positive
- fp = Gewinn/Kostenbeitrag eines False Positive
- fn = Gewinn/Kostenbeitrag eines False Negative
- tn = Gewinn/Kostenbeitrag eines True Negative

Positive Werte können als finanzieller Nutzen, negative Werte als Kosten interpretiert werden. Die Metrik gibt den durchschnittlichen finanziellen Impact pro Beobachtung zurück.

Wichtig:

truth und estimate sollten binäre Faktoren mit denselben Levels sein (z. B. c(FALSE, TRUE)).
In deinem Setting ist die Zielvariable ursprünglich TRUE/FALSE (boolean) und wurde in einen Faktor umgewandelt – das ist genau richtig.
Die Metrik erwartet eine binäre Vorhersage (also Klassen wie .pred_class), keine Wahrscheinlichkeiten.
Falls Sie Wahrscheinlichkeiten (z. B. .pred_TRUE = vorhergesagte Wahrscheinlichkeit für TRUE) vorliegen haben, werden diese über einen Threshold (z. B. 0.5) in Klassen umgewandelt.
- In dieser Schwelle steckt zusätzliches Optimierungspotenzial: Man kann den Threshold so wählen, dass der Financial Impact maximiert wird.
Wenn der positive Fall (event) die Stufe TRUE ist und die Faktorlevels c(FALSE, TRUE) sind, ist TRUE die zweite Stufe. In diesem Fall sollten Sie event_level = "second" setzen, damit TRUE als “positiver” Fall behandelt wird.

Speichern Sie den folgenden Code als Datei financial_impact_metric.R ab (📥 R-Datei herunterladen). Anschließend können Sie die Funktion in Ihrem Skript verfügbar machen mit:

source("financial_impact_metric.R")

financial_impact_metric.R

financial_impact_metric.R

library(yardstick)
library(rlang)

# -------------------------
# interne Implementierung
# -------------------------
fin_impact_impl <- function(truth,
                            estimate,
                            event_level = "first",
                            costs = c(tp = 0, fp = 0, fn = 0, tn = 0)) {
  
  # Basic checks on `costs`
  required_names <- c("tp", "fp", "fn", "tn")
  if (!all(required_names %in% names(costs))) {
    abort("`costs` must be a named numeric vector with names 'tp', 'fp', 'fn', 'tn'.")
  }
  costs <- costs[required_names]  # ensure correct order
  
  # Confusion matrix (rows = estimate, cols = truth)
  xtab <- table(estimate, truth)
  
  if (nrow(xtab) != 2 || ncol(xtab) != 2) {
    abort("`fin_impact` is a binary metric. `truth` and `estimate` must have 2 levels.")
  }
  
  # Determine which column is the event (positive class)
  event_col <- if (identical(event_level, "first")) {
    colnames(xtab)[1]
  } else {
    colnames(xtab)[2]
  }
  nonevent_col <- setdiff(colnames(xtab), event_col)
  
  # Extract counts
  tp <- xtab[event_col, event_col]
  fp <- xtab[event_col, nonevent_col]
  fn <- xtab[nonevent_col, event_col]
  tn <- xtab[nonevent_col, nonevent_col]
  
  # Financial impact
  total_financial <-
    tp * costs["tp"] +
    fp * costs["fp"] +
    fn * costs["fn"] +
    tn * costs["tn"]
  
  # mean impact per observation
  total_financial / length(truth)
}

# -------------------------
# Vektor-Methode
# -------------------------
fin_impact_vec <- function(truth,
                           estimate,
                           estimator = NULL,
                           na_rm = TRUE,
                           case_weights = NULL,
                           event_level = "first",
                           costs = c(tp = 0, fp = 0, fn = 0, tn = 0),
                           ...) {
  
  estimator <- finalize_estimator(truth, estimator)
  check_class_metric(truth, estimate, case_weights, estimator)
  
  if (na_rm) {
    rm <- yardstick_remove_missing(truth, estimate, case_weights)
    truth <- rm$truth
    estimate <- rm$estimate
    case_weights <- rm$case_weights
  } else if (yardstick_any_missing(truth, estimate, case_weights)) {
    return(NA_real_)
  }
  
  # NOTE: `case_weights` werden aktuell nicht in der Berechnung verwendet.
  fin_impact_impl(
    truth = truth,
    estimate = estimate,
    event_level = event_level,
    costs = costs
  )
}

# -------------------------
# Generics + Registrierung
# -------------------------
fin_impact <- function(data, ...) {
  UseMethod("fin_impact")
}

# Als yardstick-Klassifikationsmetrik registrieren
fin_impact <- new_class_metric(fin_impact, direction = "maximize")

# -------------------------
# data.frame-Methode
# -------------------------
fin_impact.data.frame <- function(data,
                                  truth,
                                  estimate,
                                  estimator = NULL,
                                  na_rm = TRUE,
                                  case_weights = NULL,
                                  event_level = "first",
                                  costs = c(tp = 0, fp = 0, fn = 0, tn = 0),
                                  ...) {
  
  class_metric_summarizer(
    name = "fin_impact",
    fn = fin_impact_vec,
    data = data,
    truth = !!enquo(truth),
    estimate = !!enquo(estimate),
    estimator = estimator,
    na_rm = na_rm,
    case_weights = !!enquo(case_weights),
    event_level = event_level,
    costs = costs,
    ...
  )
}

Verwendungsbeispiel: direkte Berechnung der Metrik

Im folgenden Beispiel wird angenommen, dass results ein Tibble mit

der Spalte fraud als wahrer Klasse (truth, Faktor mit Levels FALSE und TRUE) und
der Spalte .pred_class als vorhergesagter Klasse (estimate)

enthält. Die costs spiegeln eine mögliche geschäftliche Annahme wider (z. B. entgangener Gewinn bei fn, Bearbeitungskosten bei fp usw.).

results %>% 
  fin_impact(truth = fraud,
             estimate = .pred_class,
             costs = c(tp = 65, fp = -25, fn = -100, tn = 0))

Verwendungsbeispiel: Verwendung innerhalb eines `metric_set()`

In vielen tidymodels-Workflows werden mehrere Metriken gemeinsam ausgewertet.
Hier wird fin_impact gemeinsam mit accuracy und roc_auc als Metrik-Set definiert.
So können Sie z. B. bei der Modellauswahl oder beim Tuning direkt sehen, welches Modell den höchsten finanziellen Nutzen liefert – nicht nur die beste Genauigkeit.

my_metrics <- metric_set(accuracy, roc_auc, fin_impact)

my_metrics(
  results,
  truth = fraud,
  estimate = .pred_class,
  event_level = "second",
  costs = c(tp = 65, fp = -25, fn = -100, tn = 0)
)

Schwellenwert-Optimierung mit Wahrscheinlichkeitsvorhersagen

Häufig liegen aus dem Modell zuerst Wahrscheinlichkeiten vor, z. B. eine Spalte .pred_TRUE, die für jede Beobachtung die vorhergesagte Wahrscheinlichkeit angibt, dass fraud == TRUE ist.

Um daraus Klassen zu machen, wird ein Threshold verwendet, z. B.:

Wenn .pred_TRUE >= 0.5 → Vorhersage: TRUE
Sonst → Vorhersage: FALSE

Je nach Kostenstruktur kann ein anderer Threshold (z. B. 0.3 oder 0.7) den Financial Impact verbessern.

Im folgenden Beispiel:

fraud ist ein Faktor mit Levels FALSE, TRUE
.pred_TRUE ist die vorhergesagte Wahrscheinlichkeit für TRUE
wir testen verschiedene Thresholds und berechnen jeweils den Financial Impact

library(dplyr)
library(tibble)

# Beispiel-Thresholds, z. B. von 0.01 bis 0.99 in 0.01-Schritten
thresholds <- seq(0.01, 0.99, by = 0.01)

# Vektor für Ergebnisse vorbereiten
fin_values <- numeric(length(thresholds))

for (i in seq_along(thresholds)) {
  
  th <- thresholds[i]
  
  # Aus Wahrscheinlichkeiten Klassen ableiten
  data_thresh <- results %>% 
    mutate(
      .pred_class = .pred_TRUE >= th,
    )
  
  # Financial Impact für diesen Threshold berechnen
  metric_tbl <- fin_impact(
    data_thresh,
    truth   = fraud,
    estimate = .pred_class,
    costs = c(tp = 65, fp = -25, fn = -100, tn = 0)
  )
  
  # fin_impact gibt ein tibble zurück, wir speichern die Zahl aus .estimate
  fin_values[i] <- metric_tbl$.estimate
}

threshold_results <- tibble(
  threshold  = thresholds,
  fin_impact = fin_values
)

threshold_results

threshold_results enthält nun für jeden Threshold den zugehörigen durchschnittlichen finanziellen Impact.
Sie können z. B. den optimalen Threshold bestimmen:

best_threshold <- threshold_results %>% 
  arrange(desc(fin_impact)) %>% 
  slice(1)

best_threshold

Optional können Sie die Ergebnisse auch visualisieren, um den Zusammenhang zwischen Threshold und Financial Impact zu zeigen:

library(ggplot2)

ggplot(threshold_results, aes(x = threshold, y = fin_impact)) +
  geom_line() +
  geom_point() +
  labs(
    x = "Threshold für .pred_TRUE",
    y = "Finanzieller Impact (Durchschnitt pro Beobachtung)",
    title = "Financial Impact in Abhängigkeit vom Klassifikations-Threshold"
  )

Zurück nach oben