From 23e710185255e3258d8d5a908164a5e4964d8796 Mon Sep 17 00:00:00 2001
From: fweber144 <fweber144@protonmail.com>
Date: Sat, 16 Jul 2022 21:20:16 +0200
Subject: [PATCH] Partly fix issue #330.

---
 NEWS.md                            | 1 +
 R/summary_funs.R                   | 8 ++++++--
 tests/testthat/setup.R             | 4 ----
 tests/testthat/test_methods_vsel.R | 4 ----
 4 files changed, 7 insertions(+), 10 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index 384548694..fcec81823 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -20,6 +20,7 @@
 * Fix GitHub issue #339. (GitHub: #340)
 * Fix argument `d_test` of `varsel()`: Not only the predictive performance of the *reference model* needs to be evaluated on the test data, but also the predictive performance of the *submodels*. (GitHub: #341)
 * Fix GitHub issue #342.
+* Fix GitHub issue #330, at least partly.
 
 # projpred 2.1.2
 
diff --git a/R/summary_funs.R b/R/summary_funs.R
index 2ba61c093..8f2cccf3c 100644
--- a/R/summary_funs.R
+++ b/R/summary_funs.R
@@ -258,11 +258,15 @@ get_stat <- function(mu, lppd, d_test, stat, mu.bs = NULL, lppd.bs = NULL,
     }
   } else if (stat == "auc") {
     y <- d_test$y
-    auc.data <- cbind(y, mu, weights)
+    # TODO (see GitHub issue #330): The auc() function seems to expect the
+    # observation weights (`d_test$weights`) in the third column. But what about
+    # get_stat()'s argument `weights`? Currently, this is not taken into account
+    # here in the `stat == "auc"` case.
+    auc.data <- cbind(y, mu, weights = d_test$weights)
     if (!is.null(mu.bs)) {
       mu.bs[is.na(mu)] <- NA # compute the relative auc using only those points
       mu[is.na(mu.bs)] <- NA # for which both mu and mu.bs are non-NA
-      auc.data.bs <- cbind(y, mu.bs, weights)
+      auc.data.bs <- cbind(y, mu.bs, weights = d_test$weights)
       value <- auc(auc.data) - auc(auc.data.bs)
       value.bootstrap1 <- bootstrap(auc.data, auc, ...)
       value.bootstrap2 <- bootstrap(auc.data.bs, auc, ...)
diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R
index 11d5425ce..10d799175 100644
--- a/tests/testthat/setup.R
+++ b/tests/testthat/setup.R
@@ -1197,10 +1197,6 @@ cre_args_smmry_vsel <- function(args_obj) {
           nterms_tst <- nterms_max_smmry["default_nterms_max_smmry"]
         }
       }
-      if (fam_crr == "binom") {
-        # Due to issue #330:
-        stats_crr$stats <- setdiff(stats_crr$stats, "auc")
-      }
       lapply(nterms_tst, function(nterms_crr) {
         return(c(
           nlist(tstsetup_vsel), only_nonargs(args_obj[[tstsetup_vsel]]),
diff --git a/tests/testthat/test_methods_vsel.R b/tests/testthat/test_methods_vsel.R
index 8b3f7b050..8949aa874 100644
--- a/tests/testthat/test_methods_vsel.R
+++ b/tests/testthat/test_methods_vsel.R
@@ -295,10 +295,6 @@ test_that("`stat` works", {
                           "binom" = "binom_stats",
                           "common_stats")
     stat_vec <- stats_tst[[stat_crr_nm]]$stats
-    if (fam_crr == "binom") {
-      # Due to issue #330:
-      stat_vec <- setdiff(stat_vec, "auc")
-    }
     for (stat_crr in stat_vec) {
       if (stat_crr %in% c("rmse", "auc")) {
         suggsize_seed <- seed3_tst