How to plot ROC curve confidence intervals with cutpointr

[Thie1e]

Here is an example on how to plot confidence intervals around ROC curves with cutpointr when subgroups are used. We currently do not have that functionality built into the plot_roc function.

The intervals are simple empirical quantiles of the bootstrap distribution.

The code is adapted from the plot_roc and plot_metric functions.

library(cutpointr)
library(tidyverse)

# Example data with subgroups and bootstrapping
cp <- cutpointr(data = suicide, x = dsi, class = suicide, subgroup = gender, 
                method = maximize_metric, metric = sum_sens_spec,
                boot_runs = 500)
#> Assuming the positive class is yes
#> Assuming the positive class has higher x values
#> Running bootstrap...

# Unnest ROC curve
res_unnested <- cp %>%
    dplyr::select(roc_curve, subgroup) %>%
    tidyr::unnest(.data$roc_curve)

# Coordinates of optimal cutpoints
optcut_coords <- purrr::pmap_df(cp, function(...) {
    args <- list(...)
    opt_ind <- cutpointr:::get_opt_ind(roc_curve = args$roc_curve,
                           oc = args$optimal_cutpoint,
                           direction = args$direction)
    data.frame(tpr = args$roc_curve$tpr[opt_ind],
               tnr = args$roc_curve$tnr[opt_ind])
    
})

# Calculate confidence intervals
conf_lvl <- 0.95
roc_b_unnested <- cp %>%
    dplyr::select(c("boot", "subgroup")) %>%
    dplyr::mutate(boot = cutpointr:::prepare_bind_rows(.data$boot)) %>%
    tidyr::unnest(.data$boot) %>%
    dplyr::select(c("subgroup", "roc_curve_b")) %>%
    tidyr::unnest(.data$roc_curve_b)
roc_b_unnested <- roc_b_unnested[is.finite(roc_b_unnested$x.sorted), ]
roc_b_unnested <- roc_b_unnested %>%
    dplyr::select(c("x.sorted", "tpr", "subgroup")) %>%
    dplyr::group_by(.data$x.sorted, .data$subgroup) %>% 
    dplyr::summarise(ymin = stats::quantile(.data$tpr, (1 - conf_lvl) / 2, na.rm = T),
                     ymax = stats::quantile(.data$tpr, 1 - (1 - conf_lvl) / 2, na.rm = T))
#> `summarise()` has grouped output by 'x.sorted'. You can override using the `.groups` argument.

res_unnested <- merge(res_unnested,
                      roc_b_unnested[, c("subgroup", "x.sorted", "ymin", "ymax")],
                      by = c("x.sorted", "subgroup"))

roc <- ggplot2::ggplot(res_unnested,
                       ggplot2::aes(x = 1 - tnr, 
                                    y = tpr, 
                                    color = subgroup,
                                    fill = subgroup,
                                    ymin = ymin,
                                    ymax = ymax)) +
    ggtitle("ROC curve") +
    ggplot2::xlab("1 - Specificity") +
    ggplot2::ylab("Sensitivity") +
    theme_bw() +
    ggplot2::theme(aspect.ratio = 1) +
    ggplot2::geom_ribbon(alpha = 0.1, size = 0)

roc <- roc + ggplot2::geom_line(size = 1)
optcut_coords$ymin <- 0
optcut_coords$ymax <- 0 
optcut_coords$tnr <- 1 - optcut_coords$tnr
roc <- roc + ggplot2::geom_point(data = optcut_coords, color = "black", fill = "black",
                                 aes(x = tnr, y = tpr))
plot(roc)

^{Created on 2021-08-04 by the reprex package (v2.0.0)}