a. Disutility of each strategy
Define disease probability
gca.prob <- c(present = 0.6, absent = 0.4)
Define disutility under each strategy
treat.all <- c(present = 0.2, absent = 0.1)
biopsy <- c(present = 0.2, absent = 0)
treat.none <- c(present = 0.4, absent = 0)
Define mortality probability and mortality from biopsy
bx.mortal.prob <- 0.01
bx.mortal <- 1
Calculate for each strategy by vector arithmetic.
result.a <- list(treat.all = sum(gca.prob * treat.all), biopsy = sum(gca.prob *
biopsy) * (1 - bx.mortal.prob) + bx.mortal.prob * bx.mortal, treat.none = sum(gca.prob *
treat.none))
result.a
## $treat.all
## [1] 0.16
##
## $biopsy
## [1] 0.1288
##
## $treat.none
## [1] 0.24
##
The biopsy-first strategy has the least disutility.
b. EVCI for biopsy
Gross EVCI: If there was no mortality associated with biopsy, EVCI (gross) is disutility of treat all (next best strategy) - disutility of biopsy (without risk) stragegy.
result.a$treat.all - sum(gca.prob * biopsy)
## [1] 0.04
Net EVCI: If the mortality is considered, it is EVCI (net) is disutility of treat all (next best strategy) - disutility of biopsy (with risk) stragegy.
result.a$treat.all - result.a$biopsy
## [1] 0.0312
c. One-way sensitivity analysis for different prevalences
Let p be the prior probability of GCA.
disutility of treat all strategy = \( p * 0.2 + (1 - p) * 0.1 \).
disutility of biopsy strategy = \( 0.01 * 1 + 0.99 * (p * 0.2 + (1 - p) * 0) \).
disutility of treat none strategy = \( p * 0.4 + (1 - p) * 0 \).
Define these as functions
f.treat.all <- function(p) p * 0.2 + (1 - p) * 0.1
f.biopsy <- function(p) 0.01 * 1 + 0.99 * (p * 0.2 + (1 - p) * 0)
f.treat.none <- function(p) p * 0.4 + (1 - p) * 0
Now solve for each threshold:
## No Treat - test threshold
f.treat.none.or.test <- function(p) f.treat.none(p) - f.biopsy(p)
no.treat.test <- uniroot(f.treat.none.or.test, c(0, 1))$root
## Test - Treat threshold
f.treat.all.or.test <- function(p) f.treat.all(p) - f.biopsy(p)
test.treat <- uniroot(f.treat.all.or.test, c(0, 1))$root
## No treat - treat threshold
f.treat.all.or.treat.none <- function(p) f.treat.none(p) - f.treat.all(p)
no.treat.treat <- uniroot(f.treat.all.or.treat.none, c(0, 1))$root
result.c <- list(no.treat.test = no.treat.test, test.treat = test.treat,
no.treat.treat = no.treat.treat)
result.c
## $no.treat.test
## [1] 0.0495
##
## $test.treat
## [1] 0.9184
##
## $no.treat.treat
## [1] 0.3333
##
Graphical representation: Green treat all, red treat none, and blue biopsy.
library(ggplot2)
ggplot(data = data.frame(x = 0:1), aes(x)) + stat_function(fun = f.treat.all,
aes(color = "Treat all"), lwd = 2) + stat_function(fun = f.biopsy, aes(color = "Biopsy"),
lwd = 2) + stat_function(fun = f.treat.none, aes(color = "Treat none"),
lwd = 2) + xlab("prior probability of GCA") + ylab("disutility") + scale_color_manual(name = "Strategy",
values = c("green", "blue", "red"), breaks = c("Treat all", "Biopsy", "Treat none"))
Thus, if the prior probability of GCA is between 0.0495 and 0.9184, biopsy is worth performing.
d. One-way sensitivity analysis for surgical risk
Let m be the mortality from biopsy in this case.
The disutility of biopsy strategy is m * 1 + (1 - m) * (0.6 * 0.2 + 0.4 * 0).
f.biopsy.2 <- function(m) m * 1 + (1 - m) * (0.6 * 0.2 + 0.4 * 0)
f.treat.all.2 <- function(m) 0.6 * 0.2 + (1 - 0.6) * 0.1
f.treat.none.2 <- function(m) 0.6 * 0.4 + (1 - 0.6) * 0
f.biopsy.treat.all <- function(m) f.biopsy.2(m) - f.treat.all.2(m)
uniroot(f.biopsy.treat.all, c(0, 1))$root
## [1] 0.04545
e. Disutility of imperfect test
First define a function for each arm using m = mortality from biopsy, p = pretest probability, sens = sensivitiy, and spec = specificity. Then solve for m = 0.01, p = 0.6, sens = 0.8, and spec = 1.0.
f.biopsy.3 <- function(m, p, sens, spec) m * 1 + (1 - m) * (p * (sens *
0.2 + (1 - sens) * 0.4) + (1 - p) * ((1 - spec) * 0.1 + spec * 0))
f.treat.all.3 <- function(m, p, sens, spec) p * 0.2 + (1 - p) * 0.1
f.treat.none.3 <- function(m, p, sens, spec) p * 0.4 + (1 - p) *
0
m <- 0.01
p <- 0.6
sens <- 0.8
spec <- 1
result.e <- list(biopsy = f.biopsy.3(m, p, sens, spec), treat.all = f.treat.all.3(m,
p, sens, spec), treat.none = f.treat.none.3(m, p, sens, spec))
result.e
## $biopsy
## [1] 0.1526
##
## $treat.all
## [1] 0.16
##
## $treat.none
## [1] 0.24
##
At 0.1526, biopsy still has the lowest disutility.
f. Disutility of imperfect test at a lower sensitivity
Do the same with sens = 0.7.
sens <- 0.7 # m, p, and spec remain the same.
result.f <- list(biopsy = f.biopsy.3(m, p, sens, spec), treat.all = f.treat.all.3(m,
p, sens, spec), treat.none = f.treat.none.3(m, p, sens, spec))
result.f
## $biopsy
## [1] 0.1644
##
## $treat.all
## [1] 0.16
##
## $treat.none
## [1] 0.24
##
Now biopsy has a disutility of 0.1644, and the treat-all strategy is better.
g. One-way sensitivity analysis for different prevalence: imperfect test
Repeat question c with sens = 0.8 and spec = 1.0. Using functions defined for strategies, find the cut-off point where two of the functions become equal.
m <- 0.01
p <- NA # variable
sens <- 0.8
spec <- 1
## No Treat - test threshold: Disutility of treat none = disutility of
## biopsy
f.treat.none.or.test <- function(p) f.treat.none.3(m, p, sens, spec) -
f.biopsy.3(m, p, sens, spec)
no.treat.test <- uniroot(f.treat.none.or.test, c(0, 1))$root
## Test - Treat threshold: Disutility of treat all = disutility of biopsy
f.treat.all.or.test <- function(p) f.treat.all.3(m, p, sens, spec) -
f.biopsy.3(m, p, sens, spec)
test.treat <- uniroot(f.treat.all.or.test, c(0, 1))$root
## No treat - treat threshold: Disutility of treat all = disutility of
## treat none
f.treat.all.or.treat.none <- function(p) f.treat.none.3(m, p, sens,
spec) - f.treat.all.3(m, p, sens, spec)
no.treat.treat <- uniroot(f.treat.all.or.treat.none, c(0, 1))$root
result.g <- list(no.treat.test = no.treat.test, test.treat = test.treat,
no.treat.treat = no.treat.treat)
result.g
## $no.treat.test
## [1] 0.06158
##
## $test.treat
## [1] 0.6541
##
## $no.treat.treat
## [1] 0.3333
##
Graphical representation: Green treat all, red treat none, and blue biopsy. Redefine functions so that only p remains undefined.
m <- 0.01
p <- NA # variable
sens <- 0.8
spec <- 1
f.treat.all.4 <- function(p) f.treat.all.3(m, p, sens, spec)
f.biopsy.4 <- function(p) f.biopsy.3(m, p, sens, spec)
f.treat.none.4 <- function(p) f.treat.none.3(m, p, sens, spec)
## ggplot(data = data.frame(x = 0:1), aes(x)) + stat_function(fun =
## f.treat.all.4, color = 'green', lwd = 2) + stat_function(fun =
## f.biopsy.4, color = 'blue', lwd = 2) + stat_function(fun =
## f.treat.none.4, color = 'red', lwd = 2)+ xlab('prior probability of
## GCA') + ylab('disutility')
ggplot(data = data.frame(x = 0:1), aes(x)) + stat_function(fun = f.treat.all.4,
aes(color = "Treat all"), lwd = 2) + stat_function(fun = f.biopsy.4, aes(color = "Biopsy"),
lwd = 2) + stat_function(fun = f.treat.none.4, aes(color = "Treat none"),
lwd = 2) + xlab("prior probability of GCA") + ylab("disutility") + scale_color_manual(name = "Strategy",
values = c("green", "blue", "red"), breaks = c("Treat all", "Biopsy", "Treat none"))
Thus, if the prior probability of GCA is between 0.0616 and 0.6541, biopsy is worth performing.
h. Optional
h.1
h.2
h.3
For other information: http://rpubs.com/kaz_yos/
If you find errors: kazky AT mac.com