1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
#' Plot ROC curve from a cutpointr object
#'
#' Given a \code{cutpointr} object this function plots the ROC curve(s)
#' per subgroup, if given. Also plots a ROC curve from the output of \code{roc()}.
#' @param x A cutpointr or roc_cutpointr object.
#' @param display_cutpoint (logical) Whether or not to display the optimal
#' cutpoint as a dot on the ROC curve for cutpointr objects.
#' @param ... Additional arguments (unused).
#' @examples
#' opt_cut <- cutpointr(suicide, dsi, suicide)
#' plot_roc(opt_cut, display_cutpoint = FALSE)
#'
#' opt_cut_2groups <- cutpointr(suicide, dsi, suicide, gender)
#' plot_roc(opt_cut_2groups, display_cutpoint = TRUE)
#' @family cutpointr plotting functions
#' @export
plot_roc <- function(x, display_cutpoint = TRUE, ...) {
    args <- list(...)
    if ("cutpointr" %in% class(x)) {
        plot_roc_cp(x = x, display_cutpoint = display_cutpoint, args)
    } else if ("roc_cutpointr" %in% class(x)) {
        plot_roc_rcp(x = x, args)
    } else {
        stop(paste("Can not plot ROC curve form object of type",
                   paste(class(x), collapse = ", ")))
    }
}

plot_roc_cp <- function(x, display_cutpoint, ...) {
    predictor <- as.name(x$predictor[1])
    outcome <- as.name(x$outcome[1])

    if (!(has_column(x, "subgroup"))) {
        dts_roc <- "roc_curve"
        fll <- NULL
        clr <- NULL
        clr_roc <- NULL
        transparency <- 1
    } else {
        dts_roc <- c("roc_curve", "subgroup")
        fll <- "subgroup"
        clr <- "subgroup"
        clr_roc <- ~ subgroup
        transparency <- 0.6
    }

    if (!(has_column(x, "subgroup"))) {
        roc_title <- ggplot2::ggtitle("ROC curve")
    } else {
        roc_title <- ggplot2::ggtitle("ROC curve", "by class")
    }
    if (display_cutpoint) {
        optcut_coords <- apply(x, 1, function(r) {
            opt_ind <- get_opt_ind(roc_curve = r$roc_curve,
                                   oc = r$optimal_cutpoint,
                                   direction = r$direction)
            data.frame(tpr = r$roc_curve$tpr[opt_ind],
                       tnr = r$roc_curve$tnr[opt_ind])
        })
        optcut_coords <- do.call(rbind, optcut_coords)
    }
    res_unnested <- x %>%
        dplyr::select_(.dots = dts_roc) %>%
        tidyr::unnest_(unnest_cols = "roc_curve")
    roc <- ggplot2::ggplot(res_unnested,
                           ggplot2::aes_(x = ~ 1 - tnr, y = ~ tpr, color = clr_roc)) +
        ggplot2::geom_step() +
        roc_title +
        ggplot2::xlab("1 - Specificity") +
        ggplot2::ylab("Sensitivity") +
        ggplot2::theme(aspect.ratio = 1)
    if (display_cutpoint) {
        roc <- roc + ggplot2::geom_point(data = optcut_coords, color = "black")
    }
    return(roc)
}

plot_roc_rcp <- function(x, ...) {
    roc_title <- ggplot2::ggtitle("ROC curve")
    roc <- ggplot2::ggplot(x, ggplot2::aes_(x = ~ 1 - tnr, y = ~ tpr)) +
        ggplot2::geom_step() +
        roc_title +
        ggplot2::xlab("1 - Specificity") +
        ggplot2::ylab("Sensitivity") +
        ggplot2::theme(aspect.ratio = 1)
    return(roc)
}