diff --git a/R/misc.R b/R/misc.R index 4bb6c61d9..93c487b7d 100644 --- a/R/misc.R +++ b/R/misc.R @@ -31,13 +31,39 @@ auc <- function(x) { pred <- x[, 2] weights <- x[, 3] n <- nrow(x) + if (!all(weights == 1)) { + # Several checks which should in fact not be necessary because auc() is only + # used in case of the binomial family: + if (!all(.is.wholenumber(weights))) { + stop("Currently, projpred:::auc() does not support non-integer ", + "observation weights.") + } + if (!all(.is.wholenumber(resp))) { + stop("Currently, projpred:::auc() does not support non-integer response ", + "values in case of nontrivial observation weights.") + } + if (!all(0 <= resp & resp <= weights)) { + stop("Currently, projpred:::auc() does not support response values ", + "smaller than zero or larger than the observation weights.") + } + x <- do.call(rbind, lapply(seq_len(n), function(i_short) { + cbind(c(rep(0L, weights[i_short] - resp[i_short]), + rep(1L, resp[i_short])), + pred[i_short], + 1) + })) + resp <- x[, 1] + pred <- x[, 2] + weights <- x[, 3] + n <- nrow(x) + } ord <- order(pred, decreasing = TRUE) resp <- resp[ord] pred <- pred[ord] - weights <- weights[ord] - w0 <- w1 <- weights - w0[resp == 1] <- 0 # false positive weights - w1[resp == 0] <- 0 # true positive weights + w0 <- w1 <- rep(1, n) + stopifnot(all(resp %in% c(0, 1))) + w0[resp == 1] <- 0 # for calculating the false positive rate (fpr) + w1[resp == 0] <- 0 # for calculating the true positive rate (tpr) cum_w0 <- cumsum(w0) cum_w1 <- cumsum(w1)