Skip to content

Commit 643906e

Browse files
hidekojicursoragent
hidekoji
and
cursoragent
committed
feat(logistic): add report_metrics to evaluate_binary / glance.glm (#37256)
Opt-in ROC AUC rename plus PR AUC / Balanced Accuracy / Specificity on Logistic Summary while keeping AIC/BIC/P-value/deviance statistical columns. Co-authored-by: Cursor <cursoragent@cursor.com>
1 parent 166e06a commit 643906e

3 files changed

Lines changed: 126 additions & 10 deletions

File tree

‎R/build_lm.R‎

Lines changed: 44 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1345,7 +1345,7 @@ glance.lm_exploratory <- function(x, pretty.name = FALSE, ...) { #TODO: add test
13451345

13461346
#' special version of glance.lm function to use with build_lm.fast.
13471347
#' @export
1348-
glance.glm_exploratory <- function(x, pretty.name = FALSE, binary_classification_threshold = 0.5, ...) { #TODO: add test
1348+
glance.glm_exploratory <- function(x, pretty.name = FALSE, binary_classification_threshold = 0.5, report_metrics = FALSE, ...) { #TODO: add test
13491349
if ("error" %in% class(x)) {
13501350
ret <- data.frame(Note = x$message)
13511351
return(ret)
@@ -1406,6 +1406,32 @@ glance.glm_exploratory <- function(x, pretty.name = FALSE, binary_classification
14061406
# Show number of rows for positive case and negative case, especially so that result of SMOTE is visible.
14071407
ret$positives <- sum(x$y == 1, na.rm = TRUE)
14081408
ret$negatives <- sum(x$y != 1, na.rm = TRUE)
1409+
1410+
# Opt-in Analytics Report metrics (#37256 / #37156). Same extras as
1411+
# evaluate_binary_classification(report_metrics=TRUE); default stays FALSE so
1412+
# existing Logistic Summary tables are unchanged.
1413+
if (isTRUE(report_metrics)) {
1414+
actual_for_roc <- as.integer(x$y) == 1
1415+
pr_auc <- aupr(x$fitted.value, actual_for_roc)
1416+
predicted_positive <- as.integer(predicted) == 1
1417+
valid <- !(is.na(actual_for_roc) | is.na(predicted_positive))
1418+
tn <- sum(!actual_for_roc[valid] & !predicted_positive[valid], na.rm = TRUE)
1419+
fp <- sum(!actual_for_roc[valid] & predicted_positive[valid], na.rm = TRUE)
1420+
tp <- sum(actual_for_roc[valid] & predicted_positive[valid], na.rm = TRUE)
1421+
fn <- sum(actual_for_roc[valid] & !predicted_positive[valid], na.rm = TRUE)
1422+
specificity <- if ((tn + fp) > 0) tn / (tn + fp) else NA_real_
1423+
sensitivity <- if ((tp + fn) > 0) tp / (tp + fn) else NA_real_
1424+
balanced_accuracy <- if (is.na(specificity) || is.na(sensitivity)) NA_real_ else (specificity + sensitivity) / 2
1425+
if (pretty.name) {
1426+
ret$`PR AUC` <- pr_auc
1427+
ret$`Balanced Accuracy` <- balanced_accuracy
1428+
ret$`Specificity` <- specificity
1429+
} else {
1430+
ret$pr_auc <- pr_auc
1431+
ret$balanced_accuracy <- balanced_accuracy
1432+
ret$specificity <- specificity
1433+
}
1434+
}
14091435
}
14101436

14111437
# Add Max VIF if VIF is available.
@@ -1424,9 +1450,23 @@ glance.glm_exploratory <- function(x, pretty.name = FALSE, binary_classification
14241450
colnames(ret)[colnames(ret) == "logLik"] <- "Log Likelihood"
14251451
colnames(ret)[colnames(ret) == "deviance"] <- "Residual Deviance"
14261452
colnames(ret)[colnames(ret) == "df.residual"] <- "Residual DF"
1427-
colnames(ret)[colnames(ret) == "auc"] <- "AUC"
1428-
1429-
ret <- ret %>% dplyr::select(AUC, `F1 Score`, `Accuracy Rate`, `Misclass. Rate`, `Precision`, `Recall`, `P Value`, `Rows`, positives, negatives, `Log Likelihood`, `AIC`, `BIC`, `Residual Deviance`, `Residual DF`, `Null Deviance`, `Null Model DF`, everything())
1453+
if (isTRUE(report_metrics) && "auc" %in% colnames(ret)) {
1454+
# Pair with PR AUC like evaluate_binary_classification (#37252 order).
1455+
colnames(ret)[colnames(ret) == "auc"] <- "ROC AUC"
1456+
pred_cols <- intersect(
1457+
c("ROC AUC", "PR AUC", "F1 Score", "Balanced Accuracy", "Accuracy Rate",
1458+
"Misclass. Rate", "Precision", "Recall", "Specificity"),
1459+
colnames(ret))
1460+
stat_cols <- intersect(
1461+
c("P Value", "Rows", "positives", "negatives", "Log Likelihood", "AIC", "BIC",
1462+
"Residual Deviance", "Residual DF", "Null Deviance", "Null Model DF"),
1463+
colnames(ret))
1464+
other_cols <- setdiff(colnames(ret), c(pred_cols, stat_cols))
1465+
ret <- ret[, c(pred_cols, stat_cols, other_cols), drop = FALSE]
1466+
} else {
1467+
colnames(ret)[colnames(ret) == "auc"] <- "AUC"
1468+
ret <- ret %>% dplyr::select(AUC, `F1 Score`, `Accuracy Rate`, `Misclass. Rate`, `Precision`, `Recall`, `P Value`, `Rows`, positives, negatives, `Log Likelihood`, `AIC`, `BIC`, `Residual Deviance`, `Residual DF`, `Null Deviance`, `Null Model DF`, everything())
1469+
}
14301470

14311471
if (!is.null(x$orig_levels)) {
14321472
pos_label <- x$orig_levels[2]

‎R/model_eval.R‎

Lines changed: 47 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -350,9 +350,9 @@ evaluate_multi_ <- function(df, pred_label_col, actual_val_col, pretty.name = FA
350350

351351
# Generates Analytics View Summary Table for logistic/binomial regression. Handles Test Mode.
352352
#' @export
353-
evaluate_binary_training_and_test <- function(df, actual_val, threshold = "f_score", pretty.name = FALSE){
353+
evaluate_binary_training_and_test <- function(df, actual_val, threshold = "f_score", pretty.name = FALSE, report_metrics = FALSE){
354354
actual_val_col <- col_name(substitute(actual_val)) # Get name of column as string.
355-
training_ret <- df %>% glance_rowwise(model, binary_classification_threshold = threshold)
355+
training_ret <- df %>% glance_rowwise(model, binary_classification_threshold = threshold, report_metrics = report_metrics)
356356
ret <- training_ret
357357

358358
grouped_col <- colnames(df)[!colnames(df) %in% c("model", ".test_index", "source.data")]
@@ -378,6 +378,31 @@ evaluate_binary_training_and_test <- function(df, actual_val, threshold = "f_sco
378378
dplyr::select(auc = AUC, f_score, accuracy_rate,
379379
misclassification_rate, precision, recall,
380380
n, positives, negatives)
381+
# Match training-side report_metrics extras so bind_rows keeps real values
382+
# on the test row (#37256; same invariant as rf_evaluation_training_and_test).
383+
if (isTRUE(report_metrics)) {
384+
actual_raw <- test_pred_ret[[actual_val_col]]
385+
actual_for_roc <- binary_label(actual_raw)
386+
pred_prob <- test_pred_ret[["predicted_probability"]]
387+
threshold_value <- if (is.numeric(threshold)) {
388+
threshold
389+
} else if (!is.null(eret$threshold)) {
390+
eret$threshold[[1]]
391+
} else {
392+
0.5
393+
}
394+
predicted_positive <- pred_prob >= threshold_value
395+
valid <- !(is.na(actual_for_roc) | is.na(predicted_positive) | is.na(pred_prob))
396+
tn <- sum(!actual_for_roc[valid] & !predicted_positive[valid], na.rm = TRUE)
397+
fp <- sum(!actual_for_roc[valid] & predicted_positive[valid], na.rm = TRUE)
398+
tp <- sum(actual_for_roc[valid] & predicted_positive[valid], na.rm = TRUE)
399+
fn <- sum(actual_for_roc[valid] & !predicted_positive[valid], na.rm = TRUE)
400+
specificity <- if ((tn + fp) > 0) tn / (tn + fp) else NA_real_
401+
sensitivity <- if ((tp + fn) > 0) tp / (tp + fn) else NA_real_
402+
test_ret$pr_auc <- aupr(pred_prob, actual_for_roc)
403+
test_ret$balanced_accuracy <- if (is.na(specificity) || is.na(sensitivity)) NA_real_ else (specificity + sensitivity) / 2
404+
test_ret$specificity <- specificity
405+
}
381406
test_ret$is_test_data <- TRUE
382407
test_ret
383408
}, error = function(e){
@@ -396,9 +421,18 @@ evaluate_binary_training_and_test <- function(df, actual_val, threshold = "f_sco
396421
}
397422

398423
# sort column order
399-
ret <- ret %>% dplyr::select(auc, f_score, accuracy_rate, misclassification_rate, precision,
400-
recall, p.value, positives, negatives, n, logLik, AIC, BIC, # The order of positives, negatives, n is made the same as random forest and decision tree.
401-
deviance, null.deviance, df.null, df.residual, everything())
424+
if (isTRUE(report_metrics)) {
425+
ret <- ret %>% dplyr::select(dplyr::any_of(c(
426+
"auc", "roc_auc", "pr_auc", "f_score", "balanced_accuracy", "accuracy_rate",
427+
"misclassification_rate", "precision", "recall", "specificity",
428+
"p.value", "positives", "negatives", "n", "logLik", "AIC", "BIC",
429+
"deviance", "null.deviance", "df.null", "df.residual")),
430+
everything())
431+
} else {
432+
ret <- ret %>% dplyr::select(auc, f_score, accuracy_rate, misclassification_rate, precision,
433+
recall, p.value, positives, negatives, n, logLik, AIC, BIC, # The order of positives, negatives, n is made the same as random forest and decision tree.
434+
deviance, null.deviance, df.null, df.residual, everything())
435+
}
402436

403437
# Reorder columns. Bring group_by column first, and then is_test_data column, if it exists.
404438
if (!is.null(ret$is_test_data)) {
@@ -421,7 +455,14 @@ evaluate_binary_training_and_test <- function(df, actual_val, threshold = "f_sco
421455
colnames(ret)[colnames(ret) == "misclassification_rate"] <- "Misclass. Rate"
422456
colnames(ret)[colnames(ret) == "precision"] <- "Precision"
423457
colnames(ret)[colnames(ret) == "recall"] <- "Recall"
424-
colnames(ret)[colnames(ret) == "auc"] <- "AUC"
458+
if (isTRUE(report_metrics)) {
459+
colnames(ret)[colnames(ret) == "auc"] <- "ROC AUC"
460+
colnames(ret)[colnames(ret) == "pr_auc"] <- "PR AUC"
461+
colnames(ret)[colnames(ret) == "balanced_accuracy"] <- "Balanced Accuracy"
462+
colnames(ret)[colnames(ret) == "specificity"] <- "Specificity"
463+
} else {
464+
colnames(ret)[colnames(ret) == "auc"] <- "AUC"
465+
}
425466
colnames(ret)[colnames(ret) == "n"] <- "Rows"
426467
colnames(ret)[colnames(ret) == "positives"] <- "Rows (TRUE)"
427468
colnames(ret)[colnames(ret) == "negatives"] <- "Rows (FALSE)"

‎tests/testthat/test_model_eval.R‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -310,6 +310,41 @@ test_that("evaluate binary classification model by training and test", {
310310
})
311311
})
312312

313+
test_that("evaluate_binary_training_and_test report_metrics adds ROC/PR/Balanced/Specificity (#37256)", {
314+
test_data <- structure(
315+
list(
316+
`CANCELLED X` = c(0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0),
317+
ARR_TIME = c(1:20) * 10,
318+
DERAY_TIME = c(1:20),
319+
`Carrier Name` = c("Delta Air Lines", "American Eagle", "American Airlines", "Southwest Airlines", "SkyWest Airlines", "Southwest Airlines", "Southwest Airlines", "Delta Air Lines", "Southwest Airlines", "Atlantic Southeast Airlines", "American Airlines", "Southwest Airlines", "US Airways", "US Airways", "Delta Air Lines", "Atlantic Southeast Airlines", "Atlantic Southeast Airlines", "Atlantic Southeast Airlines", "Delta Air Lines", "Delta Air Lines")
320+
),
321+
row.names = c(NA, -20L),
322+
class = c("tbl_df", "tbl", "data.frame")
323+
)
324+
ret <- test_data %>% build_lm.fast(`CANCELLED X`,
325+
`ARR_TIME`,
326+
`DERAY_TIME`,
327+
`Carrier Name`,
328+
family = "binomial",
329+
model_type = "glm",
330+
test_rate = 0.5)
331+
suppressWarnings({
332+
base <- evaluate_binary_training_and_test(ret, "CANCELLED X", pretty.name = TRUE)
333+
with_metrics <- evaluate_binary_training_and_test(ret, "CANCELLED X", pretty.name = TRUE, report_metrics = TRUE)
334+
})
335+
expect_false(any(c("PR AUC", "Balanced Accuracy", "Specificity", "ROC AUC") %in% colnames(base)))
336+
expect_true(all(c("ROC AUC", "PR AUC", "Balanced Accuracy", "Specificity") %in% colnames(with_metrics)))
337+
expect_false("AUC" %in% colnames(with_metrics))
338+
# Statistical model metrics stay present alongside the new prediction metrics.
339+
expect_true(all(c("P Value", "AIC", "BIC", "Log Likelihood") %in% colnames(with_metrics)))
340+
expect_equal(nrow(with_metrics), 2)
341+
expect_false(any(is.na(with_metrics[, c("ROC AUC", "PR AUC", "Balanced Accuracy", "Specificity"), drop = FALSE])))
342+
# Default output columns keep the same values.
343+
kept <- intersect(colnames(base), colnames(with_metrics))
344+
expect_equal(as.data.frame(base)[, kept, drop = FALSE],
345+
as.data.frame(with_metrics)[, kept, drop = FALSE])
346+
})
347+
313348

314349
test_that("Group evaluate binary classification model by training and test", {
315350
group_data <- test_data %>% group_by(klass)

0 commit comments

Comments
 (0)