Skip to content

Commit 3323095

Browse files
hidekojicursoragent
hidekoji
and
cursoragent
committed
fix(ml): pass report_metrics through tidy.ranger/xgboost/lightgbm/catboost
Training Summary for RF/GBDT used tidy.* without forwarding report_metrics, so Analytics Report kept showing AUC instead of ROC AUC / PR AUC (#37256). Co-authored-by: Cursor <cursoragent@cursor.com>
1 parent 643906e commit 3323095

5 files changed

Lines changed: 198 additions & 26 deletions

File tree

‎R/build_catboost.R‎

Lines changed: 33 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1377,7 +1377,7 @@ exp_catboost <- function(df,
13771377
}
13781378

13791379
#' @export
1380-
glance.catboost_exp <- function(x, pretty.name = FALSE, ...) {
1380+
glance.catboost_exp <- function(x, pretty.name = FALSE, report_metrics = FALSE, ...) {
13811381
if ("error" %in% class(x)) {
13821382
return(data.frame(Note = x$message))
13831383
}
@@ -1390,9 +1390,15 @@ glance.catboost_exp <- function(x, pretty.name = FALSE, ...) {
13901390
rsq <- r_squared(actual, predicted)
13911391
n <- length(actual)
13921392
ret <- data.frame(r_squared = rsq, root_mean_square_error = root_mean_square_error, n = n)
1393+
if (isTRUE(report_metrics)) {
1394+
ret <- ret %>% dplyr::mutate(mean_absolute_error = mae(actual, predicted))
1395+
}
13931396
if (pretty.name) {
13941397
map <- list(`R Squared` = as.symbol("r_squared"), `RMSE` = as.symbol("root_mean_square_error"), `Rows` = as.symbol("n"))
13951398
ret <- ret %>% dplyr::rename(!!!map)
1399+
if (isTRUE(report_metrics)) {
1400+
ret <- ret %>% dplyr::rename(`MAE` = mean_absolute_error)
1401+
}
13961402
}
13971403
if (!is.null(x$inf_removed_rows) && x$inf_removed_rows > 0) {
13981404
ret$Note <- x$inf_removed_message
@@ -1444,7 +1450,7 @@ catboost_prediction_training_and_test <- function(x, binary_classification_thres
14441450

14451451
#' @export
14461452
#' @param type "importance", "evaluation", "conf_mat", "partial_dependence", "partial_binning", "evaluation_log"
1447-
tidy.catboost_exp <- function(x, type = "importance", pretty.name = FALSE, binary_classification_threshold = 0.5, ...) {
1453+
tidy.catboost_exp <- function(x, type = "importance", pretty.name = FALSE, binary_classification_threshold = 0.5, report_metrics = FALSE, ...) {
14481454
if ("error" %in% class(x) && type != "evaluation") {
14491455
return(data.frame())
14501456
}
@@ -1463,14 +1469,31 @@ tidy.catboost_exp <- function(x, type = "importance", pretty.name = FALSE, binar
14631469
}
14641470
actual <- extract_actual(x)
14651471
if ("catboost_reg" %in% class(x) || identical(x$classification_type, "regression")) {
1466-
ret <- glance(x, pretty.name = pretty.name, ...)
1472+
ret <- glance(x, pretty.name = pretty.name, report_metrics = report_metrics, ...)
14671473
} else if ("catboost_binary" %in% class(x) || identical(x$classification_type, "binary")) {
14681474
predicted <- extract_predicted_binary_labels(x, threshold = binary_classification_threshold)
14691475
predicted_probability <- extract_predicted(x)
1470-
ret <- evaluate_binary_classification(actual, predicted, predicted_probability, pretty.name = pretty.name)
1476+
# Pass report_metrics for Analytics Report Summary ROC AUC / PR AUC (#37256).
1477+
ret <- evaluate_binary_classification(actual, predicted, predicted_probability, pretty.name = pretty.name, report_metrics = report_metrics)
14711478
} else {
14721479
predicted <- extract_predicted_multiclass_labels(x)
14731480
ret <- evaluate_multi_(data.frame(predicted = predicted, actual = actual), "predicted", "actual", pretty.name = pretty.name)
1481+
if (report_metrics) {
1482+
balanced_accuracy <- multiclass_balanced_accuracy(actual, predicted)
1483+
auc_by_class <- multiclass_auc_by_class(actual, tryCatch(extract_predicted(x), error = function(e) NULL))
1484+
macro_roc_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$roc_auc, na.rm = TRUE) else NA_real_
1485+
macro_pr_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$pr_auc, na.rm = TRUE) else NA_real_
1486+
extra <- if (pretty.name) {
1487+
tibble::tibble(`Balanced Accuracy` = balanced_accuracy,
1488+
`Macro ROC AUC` = macro_roc_auc,
1489+
`Macro PR AUC` = macro_pr_auc)
1490+
} else {
1491+
tibble::tibble(balanced_accuracy = balanced_accuracy,
1492+
macro_roc_auc = macro_roc_auc,
1493+
macro_pr_auc = macro_pr_auc)
1494+
}
1495+
ret <- dplyr::bind_cols(ret, extra)
1496+
}
14741497
}
14751498
if (!is.null(x$inf_removed_rows) && x$inf_removed_rows > 0) {
14761499
ret$Note <- if ("Note" %in% colnames(ret)) paste(ret$Note, x$inf_removed_message, sep = " ") else x$inf_removed_message
@@ -1487,7 +1510,12 @@ tidy.catboost_exp <- function(x, type = "importance", pretty.name = FALSE, binar
14871510
per_level <- function(level) {
14881511
evaluate_classification(actual, predicted, level, pretty.name = pretty.name)
14891512
}
1490-
dplyr::bind_rows(lapply(levels(actual), per_level))
1513+
ret <- dplyr::bind_rows(lapply(levels(actual), per_level))
1514+
if (report_metrics && nrow(ret) > 0) {
1515+
ret <- dplyr::bind_cols(ret, evaluate_by_class_report_metrics(
1516+
actual, predicted, levels(actual), tryCatch(extract_predicted(x), error = function(e) NULL), pretty.name))
1517+
}
1518+
ret
14911519
},
14921520
conf_mat = ,
14931521
confusion_matrix = {

‎R/build_lightgbm.R‎

Lines changed: 35 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -2037,7 +2037,7 @@ exp_lightgbm <- function(df,
20372037

20382038
# This is used from Analytics View only when classification type is regression.
20392039
#' @export
2040-
glance.lightgbm_exp <- function(x, pretty.name = FALSE, ...) {
2040+
glance.lightgbm_exp <- function(x, pretty.name = FALSE, report_metrics = FALSE, ...) {
20412041
if ("error" %in% class(x)) {
20422042
ret <- data.frame(Note = x$message)
20432043
return(ret)
@@ -2047,7 +2047,7 @@ glance.lightgbm_exp <- function(x, pretty.name = FALSE, ...) {
20472047
} else {
20482048
stop("glance.lightgbm_exp should not be called for classification")
20492049
}
2050-
ret <- glance.method(x, pretty.name = pretty.name, ...)
2050+
ret <- glance.method(x, pretty.name = pretty.name, report_metrics = report_metrics, ...)
20512051

20522052
# Add note about Inf removal if applicable
20532053
if (!is.null(x$inf_removed_rows) && x$inf_removed_rows > 0) {
@@ -2062,23 +2062,29 @@ glance.lightgbm_exp <- function(x, pretty.name = FALSE, ...) {
20622062
}
20632063

20642064
#' @export
2065-
glance.lightgbm_exp.regression <- function(x, pretty.name, ...) {
2065+
glance.lightgbm_exp.regression <- function(x, pretty.name, report_metrics = FALSE, ...) {
20662066
predicted <- extract_predicted(x)
20672067
actual <- extract_actual(x)
20682068
root_mean_square_error <- rmse(predicted, actual)
20692069
rsq <- r_squared(actual, predicted)
20702070
n <- length(actual)
20712071
ret <- data.frame(r_squared = rsq, root_mean_square_error = root_mean_square_error, n = n)
2072+
if (isTRUE(report_metrics)) {
2073+
ret <- ret %>% dplyr::mutate(mean_absolute_error = mae(actual, predicted))
2074+
}
20722075
if (pretty.name) {
20732076
map <- list(`R Squared` = as.symbol("r_squared"), `RMSE` = as.symbol("root_mean_square_error"), `Rows` = as.symbol("n"))
20742077
ret <- ret %>% dplyr::rename(!!!map)
2078+
if (isTRUE(report_metrics)) {
2079+
ret <- ret %>% dplyr::rename(`MAE` = mean_absolute_error)
2080+
}
20752081
}
20762082
ret
20772083
}
20782084

20792085
#' @export
20802086
#' @param type "importance", "evaluation", "conf_mat", "partial_dependence", "evaluation_log"
2081-
tidy.lightgbm_exp <- function(x, type = "importance", pretty.name = FALSE, binary_classification_threshold = 0.5, ...) {
2087+
tidy.lightgbm_exp <- function(x, type = "importance", pretty.name = FALSE, binary_classification_threshold = 0.5, report_metrics = FALSE, ...) {
20822088
if ("error" %in% class(x) && type != "evaluation") {
20832089
return(data.frame())
20842090
}
@@ -2098,15 +2104,32 @@ tidy.lightgbm_exp <- function(x, type = "importance", pretty.name = FALSE, binar
20982104
}
20992105
actual <- extract_actual(x)
21002106
if (is.numeric(actual)) {
2101-
glance(x, pretty.name = pretty.name, ...)
2107+
glance(x, pretty.name = pretty.name, report_metrics = report_metrics, ...)
21022108
} else {
21032109
if (x$classification_type == "binary") {
21042110
predicted <- extract_predicted_binary_labels(x, threshold = binary_classification_threshold)
21052111
predicted_probability <- extract_predicted(x)
2106-
ret <- evaluate_binary_classification(actual, predicted, predicted_probability, pretty.name = pretty.name)
2112+
# Pass report_metrics for Analytics Report Summary ROC AUC / PR AUC (#37256).
2113+
ret <- evaluate_binary_classification(actual, predicted, predicted_probability, pretty.name = pretty.name, report_metrics = report_metrics)
21072114
} else {
21082115
predicted <- extract_predicted_multiclass_labels(x)
21092116
ret <- evaluate_multi_(data.frame(predicted = predicted, actual = actual), "predicted", "actual", pretty.name = pretty.name)
2117+
if (report_metrics) {
2118+
balanced_accuracy <- multiclass_balanced_accuracy(actual, predicted)
2119+
auc_by_class <- multiclass_auc_by_class(actual, tryCatch(extract_predicted(x), error = function(e) NULL))
2120+
macro_roc_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$roc_auc, na.rm = TRUE) else NA_real_
2121+
macro_pr_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$pr_auc, na.rm = TRUE) else NA_real_
2122+
extra <- if (pretty.name) {
2123+
tibble::tibble(`Balanced Accuracy` = balanced_accuracy,
2124+
`Macro ROC AUC` = macro_roc_auc,
2125+
`Macro PR AUC` = macro_pr_auc)
2126+
} else {
2127+
tibble::tibble(balanced_accuracy = balanced_accuracy,
2128+
macro_roc_auc = macro_roc_auc,
2129+
macro_pr_auc = macro_pr_auc)
2130+
}
2131+
ret <- dplyr::bind_cols(ret, extra)
2132+
}
21102133
}
21112134
# Add note about Inf removal if applicable
21122135
if (!is.null(x$inf_removed_rows) && x$inf_removed_rows > 0) {
@@ -2128,7 +2151,12 @@ tidy.lightgbm_exp <- function(x, type = "importance", pretty.name = FALSE, binar
21282151
per_level <- function(level) {
21292152
evaluate_classification(actual, predicted, level, pretty.name = pretty.name)
21302153
}
2131-
dplyr::bind_rows(lapply(levels(actual), per_level))
2154+
ret <- dplyr::bind_rows(lapply(levels(actual), per_level))
2155+
if (report_metrics && nrow(ret) > 0) {
2156+
ret <- dplyr::bind_cols(ret, evaluate_by_class_report_metrics(
2157+
actual, predicted, levels(actual), tryCatch(extract_predicted(x), error = function(e) NULL), pretty.name))
2158+
}
2159+
ret
21322160
},
21332161
conf_mat = {
21342162
actual <- extract_actual(x)

‎R/build_xgboost.R‎

Lines changed: 36 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1593,7 +1593,7 @@ exp_xgboost <- function(df,
15931593

15941594
# This is used from Analytics View only when classification type is regression.
15951595
#' @export
1596-
glance.xgboost_exp <- function(x, pretty.name = FALSE, ...) {
1596+
glance.xgboost_exp <- function(x, pretty.name = FALSE, report_metrics = FALSE, ...) {
15971597
if ("error" %in% class(x)) {
15981598
ret <- data.frame(Note = x$message)
15991599
return(ret)
@@ -1604,7 +1604,7 @@ glance.xgboost_exp <- function(x, pretty.name = FALSE, ...) {
16041604
else {
16051605
stop("glance.xgboost_exp should not be called for classification")
16061606
}
1607-
ret <- glance.ranger.method(x, pretty.name = pretty.name, ...)
1607+
ret <- glance.ranger.method(x, pretty.name = pretty.name, report_metrics = report_metrics, ...)
16081608

16091609
# Add note about Inf removal if applicable
16101610
if (!is.null(x$inf_removed_rows) && x$inf_removed_rows > 0) {
@@ -1619,7 +1619,7 @@ glance.xgboost_exp <- function(x, pretty.name = FALSE, ...) {
16191619
}
16201620

16211621
#' @export
1622-
glance.xgboost_exp.regression <- function(x, pretty.name, ...) {
1622+
glance.xgboost_exp.regression <- function(x, pretty.name, report_metrics = FALSE, ...) {
16231623
predicted <- extract_predicted(x)
16241624
actual <- extract_actual(x)
16251625
root_mean_square_error <- rmse(predicted, actual)
@@ -1632,6 +1632,9 @@ glance.xgboost_exp.regression <- function(x, pretty.name, ...) {
16321632
root_mean_square_error = root_mean_square_error,
16331633
n = n
16341634
)
1635+
if (isTRUE(report_metrics)) {
1636+
ret <- ret %>% dplyr::mutate(mean_absolute_error = mae(actual, predicted))
1637+
}
16351638

16361639
if(pretty.name){
16371640
map = list(
@@ -1641,13 +1644,16 @@ glance.xgboost_exp.regression <- function(x, pretty.name, ...) {
16411644
)
16421645
ret <- ret %>%
16431646
dplyr::rename(!!!map)
1647+
if (isTRUE(report_metrics)) {
1648+
ret <- ret %>% dplyr::rename(`MAE` = mean_absolute_error)
1649+
}
16441650
}
16451651
ret
16461652
}
16471653

16481654
#' @export
16491655
#' @param type "importance", "evaluation" or "conf_mat". Feature importance, evaluated scores or confusion matrix of training data.
1650-
tidy.xgboost_exp <- function(x, type = "importance", pretty.name = FALSE, binary_classification_threshold = 0.5, ...) {
1656+
tidy.xgboost_exp <- function(x, type = "importance", pretty.name = FALSE, binary_classification_threshold = 0.5, report_metrics = FALSE, ...) {
16511657
if ("error" %in% class(x) && type != "evaluation") {
16521658
ret <- data.frame()
16531659
return(ret)
@@ -1672,16 +1678,34 @@ tidy.xgboost_exp <- function(x, type = "importance", pretty.name = FALSE, binary
16721678
# get evaluation scores from training data
16731679
actual <- extract_actual(x)
16741680
if(is.numeric(actual)){
1675-
glance(x, pretty.name = pretty.name, ...)
1681+
glance(x, pretty.name = pretty.name, report_metrics = report_metrics, ...)
16761682
} else {
16771683
if (x$classification_type == "binary") {
16781684
predicted <- extract_predicted_binary_labels(x, threshold = binary_classification_threshold)
16791685
predicted_probability <- extract_predicted(x)
1680-
ret <- evaluate_binary_classification(actual, predicted, predicted_probability, pretty.name = pretty.name)
1686+
# Pass report_metrics for Analytics Report Summary ROC AUC / PR AUC (#37256).
1687+
ret <- evaluate_binary_classification(actual, predicted, predicted_probability, pretty.name = pretty.name, report_metrics = report_metrics)
16811688
}
16821689
else {
16831690
predicted <- extract_predicted_multiclass_labels(x)
16841691
ret <- evaluate_multi_(data.frame(predicted=predicted, actual=actual), "predicted", "actual", pretty.name = pretty.name)
1692+
if (report_metrics) {
1693+
balanced_accuracy <- multiclass_balanced_accuracy(actual, predicted)
1694+
# prediction_training for multiclass is a probability matrix with class colnames.
1695+
auc_by_class <- multiclass_auc_by_class(actual, tryCatch(extract_predicted(x), error = function(e) NULL))
1696+
macro_roc_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$roc_auc, na.rm = TRUE) else NA_real_
1697+
macro_pr_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$pr_auc, na.rm = TRUE) else NA_real_
1698+
extra <- if (pretty.name) {
1699+
tibble::tibble(`Balanced Accuracy` = balanced_accuracy,
1700+
`Macro ROC AUC` = macro_roc_auc,
1701+
`Macro PR AUC` = macro_pr_auc)
1702+
} else {
1703+
tibble::tibble(balanced_accuracy = balanced_accuracy,
1704+
macro_roc_auc = macro_roc_auc,
1705+
macro_pr_auc = macro_pr_auc)
1706+
}
1707+
ret <- dplyr::bind_cols(ret, extra)
1708+
}
16851709
}
16861710
# Add note about Inf removal if applicable
16871711
if (!is.null(x$inf_removed_rows) && x$inf_removed_rows > 0) {
@@ -1707,7 +1731,12 @@ tidy.xgboost_exp <- function(x, type = "importance", pretty.name = FALSE, binary
17071731
ret <- evaluate_classification(actual, predicted, level, pretty.name = pretty.name)
17081732
ret
17091733
}
1710-
dplyr::bind_rows(lapply(levels(actual), per_level))
1734+
ret <- dplyr::bind_rows(lapply(levels(actual), per_level))
1735+
if (report_metrics && nrow(ret) > 0) {
1736+
ret <- dplyr::bind_cols(ret, evaluate_by_class_report_metrics(
1737+
actual, predicted, levels(actual), tryCatch(extract_predicted(x), error = function(e) NULL), pretty.name))
1738+
}
1739+
ret
17111740
},
17121741
conf_mat = {
17131742
# return confusion matrix

0 commit comments

Comments
 (0)