fix(chaid): pass report_metrics for ROC AUC / PR AUC

tidy.exploratory_chaid ignored report_metrics, so the Analytics Report
metrics table kept plain AUC and omitted PR AUC / Balanced Accuracy /
Specificity despite the UI requesting report_metrics=TRUE. Wire the flag
through like tidy.rpart, store a training probability matrix for Macro /
One-vs-Rest AUCs, and score CHAID test rows in rf_evaluation_training_and_test.

Co-authored-by: Cursor <cursoragent@cursor.com>

Author: hidekoji

R/build_chaid.R

@@ -175,6 +175,11 @@ exp_chaid <- function(df,
         model, train_all, binary_classification_threshold
       )
       model$predicted_prob <- chaid_positive_probability(model, train_all)
+      # Full class-probability matrix for report_metrics (Macro / One-vs-Rest AUCs).
+      # Column names are the raw class levels so multiclass_auc_by_class() can use them.
+      model$predicted_prob_matrix <- chaid_as_probability_matrix(
+        train_all, model$class_levels
+      )
 
       # Metadata expected by the framework.
       model$terms_mapping <- names(group_name_map)
@@ -317,6 +322,37 @@ chaid_positive_probability <- function(model, all_prediction) {
   }
 }
 
+#' Convert CHAID probability output to a class-named matrix.
+#'
+#' `chaid_predict(type = "prob"|"all")` uses `.pred_prob_<class>` columns. The
+#' shared Decision Tree report helpers (`multiclass_auc_by_class`,
+#' `evaluate_by_class_report_metrics`) expect colnames to be the class levels.
+#'
+#' @param prediction A data frame / matrix from `chaid_predict`, or NULL.
+#' @param class_levels Optional class order; columns are reordered when present.
+#' @return A numeric matrix, or NULL when conversion is not possible.
+chaid_as_probability_matrix <- function(prediction, class_levels = NULL) {
+  if (is.null(prediction)) {
+    return(NULL)
+  }
+  if (is.data.frame(prediction) || is.matrix(prediction)) {
+    mat <- as.matrix(prediction)
+  } else {
+    return(NULL)
+  }
+  if (ncol(mat) == 0) {
+    return(NULL)
+  }
+  colnames(mat) <- sub("^\\.pred_prob_", "", colnames(mat))
+  if (!is.null(class_levels) && length(class_levels) > 0) {
+    if (!all(class_levels %in% colnames(mat))) {
+      return(NULL)
+    }
+    mat <- mat[, class_levels, drop = FALSE]
+  }
+  mat
+}
+
 #' Return an empty CHAID permutation-importance result.
 #'
 #' @return A data frame with the stable importance schema.
@@ -684,14 +720,17 @@ augment.exploratory_chaid <- function(x, data = NULL, newdata = NULL,
 #'
 #' @param x A fitted `exploratory_chaid` model.
 #' @param pretty.name Whether to use display-friendly column names.
+#' @param report_metrics Whether to include Decision Tree report extras
+#'   (ROC AUC / PR AUC / …).
 #' @param ... Unused.
 #' @return A one-row model summary data frame.
 #' @export
-glance.exploratory_chaid <- function(x, pretty.name = FALSE, ...) {
+glance.exploratory_chaid <- function(x, pretty.name = FALSE, report_metrics = FALSE, ...) {
   if ("error" %in% class(x)) {
     return(data.frame(Note = x$message))
   }
-  tidy.exploratory_chaid(x, type = "evaluation", pretty.name = pretty.name, ...)
+  tidy.exploratory_chaid(x, type = "evaluation", pretty.name = pretty.name,
+                         report_metrics = report_metrics, ...)
 }
 
 #' tidy for a CHAID model (broom S3 method).
@@ -703,6 +742,9 @@ glance.exploratory_chaid <- function(x, pretty.name = FALSE, ...) {
 #'   `partial_dependence`.
 #' @param pretty.name Whether to use display-friendly column names.
 #' @param binary_classification_threshold Positive-class threshold (binary).
+#' @param report_metrics Whether to include Decision Tree report extras
+#'   (ROC AUC / PR AUC / Balanced Accuracy / Specificity for binary;
+#'   Macro AUCs for multiclass; One-vs-Rest AUCs for evaluation_by_class).
 #' @param ... Unused.
 #' @return A data frame whose shape depends on `type`.
 #' @export
@@ -733,12 +775,23 @@ chaid_display_node_ids <- function(df) {
 }
 
 tidy.exploratory_chaid <- function(x, type = "evaluation", pretty.name = FALSE,
-                                   binary_classification_threshold = 0.5, ...) {
+                                   binary_classification_threshold = 0.5,
+                                   report_metrics = FALSE, ...) {
   if ("error" %in% class(x) && type != "evaluation") {
     return(data.frame())
   }
   actual <- x$y
-  predicted <- x$predicted_class
+  # Re-threshold binary labels so Settings → cut point updates F1 / Accuracy etc.
+  # (ROC / PR AUC use predicted_prob and are threshold-independent.)
+  predicted <- if (identical(x$classification_type, "binary") &&
+                     !is.null(x$predicted_prob)) {
+    factor(
+      ifelse(x$predicted_prob >= binary_classification_threshold, "TRUE", "FALSE"),
+      levels = x$class_levels
+    )
+  } else {
+    x$predicted_class
+  }
   chaid_display_node_ids(switch(
     type,
     evaluation = {
@@ -747,17 +800,41 @@ tidy.exploratory_chaid <- function(x, type = "evaluation", pretty.name = FALSE,
       }
       if (identical(x$classification_type, "binary")) {
         evaluate_binary_classification(actual, predicted, x$predicted_prob,
-                                       pretty.name = pretty.name, is_rpart = FALSE)
+                                       pretty.name = pretty.name, is_rpart = FALSE,
+                                       report_metrics = report_metrics)
       } else {
-        evaluate_multi_(data.frame(predicted = predicted, actual = actual),
-                        "predicted", "actual", pretty.name = pretty.name)
+        ret <- evaluate_multi_(data.frame(predicted = predicted, actual = actual),
+                               "predicted", "actual", pretty.name = pretty.name)
+        # Mirror tidy.rpart: Macro ROC/PR AUC for the Decision Tree report (#37156).
+        if (report_metrics) {
+          balanced_accuracy <- multiclass_balanced_accuracy(actual, predicted)
+          auc_by_class <- multiclass_auc_by_class(actual, x$predicted_prob_matrix)
+          macro_roc_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$roc_auc, na.rm = TRUE) else NA_real_
+          macro_pr_auc <- if (nrow(auc_by_class) > 0) mean(auc_by_class$pr_auc, na.rm = TRUE) else NA_real_
+          extra <- if (pretty.name) {
+            tibble::tibble(`Balanced Accuracy` = balanced_accuracy,
+                           `Macro ROC AUC` = macro_roc_auc,
+                           `Macro PR AUC` = macro_pr_auc)
+          } else {
+            tibble::tibble(balanced_accuracy = balanced_accuracy,
+                           macro_roc_auc = macro_roc_auc,
+                           macro_pr_auc = macro_pr_auc)
+          }
+          ret <- dplyr::bind_cols(ret, extra)
+        }
+        ret
       }
     },
     evaluation_by_class = {
       per_level <- function(level) {
         evaluate_classification(actual, predicted, level, pretty.name = pretty.name)
       }
-      dplyr::bind_rows(lapply(x$class_levels, per_level))
+      ret <- dplyr::bind_rows(lapply(x$class_levels, per_level))
+      if (report_metrics && nrow(ret) > 0) {
+        ret <- dplyr::bind_cols(ret, evaluate_by_class_report_metrics(
+          actual, predicted, x$class_levels, x$predicted_prob_matrix, pretty.name))
+      }
+      ret
     },
     conf_mat = {
       calc_conf_mat(actual, predicted)

R/randomForest_tidiers.R

@@ -1514,6 +1514,12 @@ rf_evaluation_training_and_test <- function(data, type = "evaluation", pretty.na
                     source_data <- df$source.data[[1]]
                     if (!is.null(source_data) && length(test_rows) > 0 && "rpart" %in% class(model_object)) {
                       predict(model_object, newdata = source_data[test_rows, , drop = FALSE], type = "prob")
+                    } else if (!is.null(source_data) && length(test_rows) > 0 &&
+                               inherits(model_object, "exploratory_chaid")) {
+                      chaid_as_probability_matrix(
+                        predict(model_object, newdata = source_data[test_rows, , drop = FALSE], type = "prob"),
+                        model_object$class_levels
+                      )
                     } else {
                       NULL
                     }
@@ -1556,6 +1562,12 @@ rf_evaluation_training_and_test <- function(data, type = "evaluation", pretty.na
                 source_data <- df$source.data[[1]]
                 if (!is.null(source_data) && length(test_rows) > 0 && "rpart" %in% class(model_object)) {
                   predict(model_object, newdata = source_data[test_rows, , drop = FALSE], type = "prob")
+                } else if (!is.null(source_data) && length(test_rows) > 0 &&
+                           inherits(model_object, "exploratory_chaid")) {
+                  chaid_as_probability_matrix(
+                    predict(model_object, newdata = source_data[test_rows, , drop = FALSE], type = "prob"),
+                    model_object$class_levels
+                  )
                 } else {
                   NULL
                 }

tests/testthat/test_build_chaid.R

@@ -113,6 +113,44 @@ test_that("rf_evaluation_training_and_test produces training and test metrics",
   expect_true("is_test_data" %in% colnames(summary) || any(grepl("Test", colnames(summary))) || nrow(summary) >= 2)
 })
 
+test_that("exp_chaid report_metrics adds ROC AUC / PR AUC like CART", {
+  expected_binary <- c("ROC AUC", "PR AUC", "Balanced Accuracy", "Specificity")
+  expected_multi <- c("Balanced Accuracy", "Macro ROC AUC", "Macro PR AUC")
+
+  for (test_rate in c(0, 0.3)) {
+    df <- make_binary_df(n = 500, seed = 21)
+    model_df <- suppressWarnings(exp_chaid(df, is_churn, plan, region, tenure,
+                                           test_rate = test_rate, min_split = 20, min_bucket = 5))
+    base <- rf_evaluation_training_and_test(model_df, pretty.name = TRUE)
+    with_metrics <- rf_evaluation_training_and_test(model_df, pretty.name = TRUE,
+                                                    report_metrics = TRUE)
+    label <- paste0("binary test_rate=", test_rate)
+    expect_true(all(expected_binary %in% colnames(with_metrics)), info = label)
+    expect_false(any(expected_binary %in% colnames(base)), info = label)
+    expect_false("AUC" %in% colnames(with_metrics), info = label)
+    expect_equal(nrow(with_metrics), if (test_rate > 0) 2 else 1, info = label)
+    expect_false(any(is.na(with_metrics[, expected_binary, drop = FALSE])), info = label)
+    expect_equal(
+      intersect(c("ROC AUC", "PR AUC", "F1 Score", "Balanced Accuracy", "Accuracy Rate",
+                  "Misclass. Rate", "Precision", "Recall", "Specificity"),
+                colnames(with_metrics)),
+      c("ROC AUC", "PR AUC", "F1 Score", "Balanced Accuracy", "Accuracy Rate",
+        "Misclass. Rate", "Precision", "Recall", "Specificity"),
+      info = label
+    )
+  }
+
+  df <- make_multi_df(n = 500, seed = 22)
+  model_df <- suppressWarnings(exp_chaid(df, segment, channel, age_group,
+                                         min_split = 20, min_bucket = 5))
+  with_metrics <- rf_evaluation_training_and_test(model_df, pretty.name = TRUE,
+                                                  report_metrics = TRUE)
+  expect_true(all(expected_multi %in% colnames(with_metrics)))
+  by_class <- rf_evaluation_training_and_test(model_df, type = "evaluation_by_class",
+                                              pretty.name = TRUE, report_metrics = TRUE)
+  expect_true(all(c("Balanced Accuracy", "ROC AUC", "PR AUC", "Overall Share") %in% colnames(by_class)))
+})
+
 test_that("confusion matrix tidy returns actual/predicted/count", {
   df <- make_binary_df()
   model_df <- suppressWarnings(exp_chaid(df, is_churn, plan, region,