You can rip out the underlying predictions and then use yardstick to compute the full PR AUC curve using pr_curve(). You can actually compute the area under the curve using pr_auc() which uses the data from pr_curve().
library(caret)
library(tidyverse)
library(yardstick)
# to see lots of decimal places in a tibble
options(pillar.sigfig = 8)
# for reproducibility
set.seed(123)
# example data
sampledata <- diamonds %>% mutate(target = ifelse(cut == "Premium", 1, 0) %>% make.names() %>% as.factor())
# fit a XGB model
train_control <- trainControl(
method = "cv",
number = 5,
classProbs = TRUE,
verboseIter = TRUE,
summaryFunction = prSummary,
savePredictions = TRUE,
allowParallel = TRUE
)
## tuning grid
tune_grid <- expand.grid(nrounds = 200,
max_depth = 5,
eta = 0.05,
gamma = 0.01,
colsample_bytree = 0.75,
min_child_weight = 0,
subsample = 0.5)
## xgb
xgb_model <- train(
x = select(sampledata, -c(cut, target, clarity, color)),
y = sampledata$target,
method = "xgbTree",
metric = "AUC", #actually prAUC sinc eusing prSummary
trControl = train_control,
tuneGrid = tune_grid,
tuneLength = 10)
# Take a look at the model
xgb_model
#> eXtreme Gradient Boosting
#>
#> 53940 samples
#> 7 predictor
#> 2 classes: 'X0', 'X1'
#>
#> No pre-processing
#> Resampling: Cross-Validated (5 fold)
#> Summary of sample sizes: 43153, 43151, 43152, 43152, 43152
#> Resampling results:
#>
#> AUC Precision Recall F
#> 0.9702641 0.925353 0.8808189 0.9025308
#>
#> Tuning parameter 'nrounds' was held constant at a value of 200
#> 0.75
#> Tuning parameter 'min_child_weight' was held constant at a value
#> of 0
#> Tuning parameter 'subsample' was held constant at a value of 0.5
# Inside $pred is all the info we need
# to compute the full pr auc curve
xgb_model$pred %>%
select(obs, X0, Resample) %>%
slice(1:5)
#> obs X0 Resample
#> 1 X0 0.9783865 Fold1
#> 2 X0 0.9885217 Fold1
#> 3 X1 0.2936884 Fold1
#> 4 X0 0.9990451 Fold1
#> 5 X0 0.7013983 Fold1
# calculate the full pr curve with thresholds
xgb_pr_curve <- xgb_model$pred %>%
group_by(Resample) %>%
pr_curve(obs, X0)
head(xgb_pr_curve)
#> # A tibble: 6 x 4
#> # Groups: Resample [1]
#> Resample .threshold recall precision
#> <chr> <dbl> <dbl> <dbl>
#> 1 Fold1 Inf 0 NA
#> 2 Fold1 0.99938977 0.00012459507 1
#> 3 Fold1 0.99936575 0.00024919013 1
#> 4 Fold1 0.99936062 0.00037378520 1
#> 5 Fold1 0.99935418 0.00049838026 1
#> 6 Fold1 0.99935120 0.00062297533 1
# plot it!
autoplot(xgb_pr_curve)
#> Warning: Removed 5 rows containing missing values (geom_path).

# To show that this is basically the same information
# caret uses to compute the pr auc score,
# compute the PR AUC per resample using yardstick
pr_auc_per_resample <- xgb_model$pred %>%
group_by(Resample) %>%
pr_auc(obs, X0)
pr_auc_per_resample
#> # A tibble: 5 x 4
#> Resample .metric .estimator .estimate
#> <chr> <chr> <chr> <dbl>
#> 1 Fold1 pr_auc binary 0.96888428
#> 2 Fold2 pr_auc binary 0.97038900
#> 3 Fold3 pr_auc binary 0.97103242
#> 4 Fold4 pr_auc binary 0.97116810
#> 5 Fold5 pr_auc binary 0.96971711
# Average them to get the resampled pr auc score
pr_auc_per_resample %>%
summarise(
resampled_pr_auc = mean(.estimate)
)
#> # A tibble: 1 x 1
#> resampled_pr_auc
#> <dbl>
#> 1 0.97023818
# There is a slight difference between this
# and the PR AUC result from MLmetrics, but im not
# sure why at the moment. This is the PR AUC you get from
# MLmetrics, which aligns with what caret shows you
xgb_model$pred %>%
group_by(Resample) %>%
summarise(
pr_auc = MLmetrics::PRAUC(X0, ifelse(obs == "X0", 1, 0))
) %>%
summarise(
resampled_pr_auc = mean(pr_auc)
)
#> # A tibble: 1 x 1
#> resampled_pr_auc
#> <dbl>
#> 1 0.97026406
Created on 2019-01-04 by the reprex package (v0.2.1.9000)