/
evaluate_cutpoint.R
108 lines (97 loc) · 4.05 KB
/
evaluate_cutpoint.R
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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
#' Evaluates a cutpoint by returning the mean NMB per sample.
#'
#' @param predicted A vector of predicted probabilities.
#' @param actual A vector of actual outcomes.
#' @param pt The probability threshold to be evaluated.
#' @param nmb A named vector containing NMB assigned to each classification.
#'
#' @return Returns a \code{numeric} value representing the NMB for that
#' cutpoint and data.
#' @export
#'
#' @examples
#' evaluate_cutpoint_nmb(
#' predicted = runif(1000),
#' actual = sample(c(0, 1), size = 1000, replace = TRUE),
#' pt = 0.1,
#' nmb = c("TP" = -3, "TN" = 0, "FP" = -1, "FN" = -4)
#' )
evaluate_cutpoint_nmb <- function(predicted, actual, pt, nmb) {
d <- cbind(predicted, actual, NA)
colnames(d) <- c("predicted", "actual", "nmb")
d[d[, "predicted"] < pt & d[, "actual"] == 0, "nmb"] <- nmb["TN"]
d[d[, "predicted"] < pt & d[, "actual"] == 1, "nmb"] <- nmb["FN"]
d[d[, "predicted"] > pt & d[, "actual"] == 1, "nmb"] <- nmb["TP"]
d[d[, "predicted"] > pt & d[, "actual"] == 0, "nmb"] <- nmb["FP"]
mean(d[, "nmb"])
}
#' Evaluates a cutpoint by returning the mean QALYs lost per sample.
#'
#' @param predicted A vector of predicted probabilities.
#' @param actual A vector of actual outcomes.
#' @param pt The probability threshold to be evaluated.
#' @param nmb A named vector containing NMB assigned to each classification and
#' the treatment effects and QALYS lost due to the event of interest.
#'
#' @return Returns a \code{numeric} value representing the mean QALYs for that
#' cutpoint and data.
#' @export
#'
#' @examples
#' evaluate_cutpoint_qalys(
#' predicted = runif(1000),
#' actual = sample(c(0, 1), size = 1000, replace = TRUE),
#' pt = 0.1,
#' nmb = c(
#' "qalys_lost" = 5,
#' "low_risk_group_treatment_effect" = 0,
#' "high_risk_group_treatment_effect" = 0.5
#' )
#' )
evaluate_cutpoint_qalys <- function(predicted, actual, pt, nmb) {
d <- cbind(predicted, actual, NA)
colnames(d) <- c("predicted", "actual", "qalys")
d[d[, "predicted"] < pt & d[, "actual"] == 0, "qalys"] <- 0 # no qalys lost when event doesn't occur
d[d[, "predicted"] < pt & d[, "actual"] == 1, "qalys"] <- -nmb["qalys_lost"] * (1 - nmb["low_risk_group_treatment_effect"])
d[d[, "predicted"] > pt & d[, "actual"] == 1, "qalys"] <- -nmb["qalys_lost"] * (1 - nmb["high_risk_group_treatment_effect"])
d[d[, "predicted"] > pt & d[, "actual"] == 0, "qalys"] <- 0 # no qalys lost when event doesn't occur
mean(d[, "qalys"])
}
#' Evaluates a cutpoint by returning the mean treatment cost per sample.
#'
#' @param predicted A vector of predicted probabilities.
#' @param actual A vector of actual outcomes.
#' @param pt The probability threshold to be evaluated.
#' @param nmb A named vector containing NMB assigned to each classification and
#' the treatment costs.
#'
#' @return Returns a \code{numeric} value representing the mean cost for that
#' cutpoint and data.
#' @export
#'
#' @examples
#' evaluate_cutpoint_cost(
#' predicted = runif(1000),
#' actual = sample(c(0, 1), size = 1000, replace = TRUE),
#' pt = 0.1,
#' nmb = c(
#' "qalys_lost" = 5,
#' "low_risk_group_treatment_cost" = 0,
#' "high_risk_group_treatment_cost" = 1,
#' "low_risk_group_treatment_effect" = 0,
#' "high_risk_group_treatment_effect" = 0.3,
#' "outcome_cost" = 10
#' )
#' )
evaluate_cutpoint_cost <- function(predicted, actual, pt, nmb) {
d <- cbind(predicted, actual, NA, 0)
colnames(d) <- c("predicted", "actual", "treatment_cost", "outcome_cost")
# treatment cost
d[d[, "predicted"] < pt, "treatment_cost"] <- nmb["low_risk_group_treatment_cost"]
d[d[, "predicted"] > pt, "treatment_cost"] <- nmb["high_risk_group_treatment_cost"]
# outcome cost
d[d[, "predicted"] < pt & d[, "actual"] == 1, "outcome_cost"] <- nmb["outcome_cost"] * (1 - nmb["low_risk_group_treatment_effect"])
d[d[, "predicted"] > pt & d[, "actual"] == 1, "outcome_cost"] <- nmb["outcome_cost"] * (1 - nmb["high_risk_group_treatment_effect"])
# return the sum of the treatment cost and outcome cost (to be used in ce_plot())
mean(d[, "treatment_cost"] + d[, "outcome_cost"])
}