Partly fix issue #330.

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
 

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, ...)

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]]),

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