Design plots a clinical trial
Here we show how to create outcome and operating characteristic plots
for a clinical trial comparing a developmental drug against placebo. The
primary endpoint is binary (with event probability \(p\)) and we use an informative prior for
the placebo arm event rate. The experimental drug is believed to lower
the event rate, and the criteria for study outcome are hence as
follows:
\[
\begin{align*}
\textrm{Criterion 1:} \Pr(p_{trt} / p_{pbo} < 1) &> 0.9\\
\textrm{Criterion 2:} \Pr(p_{trt} / p_{pbo} < 0.5) &> 0.5
\end{align*}
\]
The outcome is success (GO) if both criteria are satisfied, futility
(STOP) if neither is satisfied, and indeterminate if only one or the
other is satisfied.
We now create a plot that shows the study conclusion, given any
combination of outcomes on the two treatment arms.
# Define prior distributions
prior_pbo <- mixbeta(inf1=c(0.60, 19, 29), inf2=c(0.30, 4, 5), rob=c(0.10, 1, 1))
prior_trt <- mixbeta(c(1, 1/3, 1/3))
# Study sample size
n_trt <- 50
n_pbo <- 20
# Create decision rules and designs to represent success and futility
success <- decision2S(pc=c(0.90, 0.50), qc=c(log(1), log(0.50)), lower.tail=TRUE, link="log")
futility <- decision2S(pc=c(0.10, 0.50), qc=c(log(1), log(0.50)), lower.tail=FALSE, link="log")
design_suc <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, success)
design_fut <- oc2S(prior_trt, prior_pbo, n_trt, n_pbo, futility)
crit_suc <- decision2S_boundary(prior_trt, prior_pbo, n_trt, n_pbo, success)
crit_fut <- decision2S_boundary(prior_trt, prior_pbo, n_trt, n_pbo, futility)
# Create a data frame that holds the outcomes for y1 (treatment) that define success and futility,
# conditional on the number of events on y2 (placebo)
outcomes <- data.frame(y2=c(0:n_pbo), suc=crit_suc(0:n_pbo), fut=crit_fut(0:n_pbo), max=n_trt)
outcomes$suc <- with(outcomes, ifelse(suc<0, 0, suc)) # don't allow negative number of events
# Finally put it all together in a plot.
o <- 0.5 # offset
ggplot(outcomes, aes(x=y2, ymin=-o, ymax=suc+o)) + geom_linerange(size=4, colour="green", alpha=0.6) +
geom_linerange(aes(ymin=suc+o, ymax=fut+o), colour="orange", size=4, alpha=0.6) +
geom_linerange(aes(ymin=fut+o, ymax=max+o), colour="red", size=4, alpha=0.6) +
annotate("text", x=c(2,14), y=c(36,8), label=c("STOP", "GO"), size=10) +
scale_x_continuous(breaks=seq(0,n_pbo,by=2)) +
scale_y_continuous(breaks=seq(0,n_trt,by=4)) +
labs(x="Events on placebo", y="Events on treatment", title="Study outcomes") +
coord_flip() + theme_bw(base_size=12)
## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
We can also use the design functions that were already derived
(design_suc and design_fut) to compute
operating characteristics.
# Define the grid of true event rates for which to evaluate OC
p_trt <- seq(0, 0.5, length=200)
p_pbo <- c(0.35, 0.40, 0.45, 0.50)
# Loop through the values for placebo and compute outcome probabilities
oc_list <- lapply(p_pbo, function(x) {
p_go <- design_suc(p_trt, x)
p_stop <- design_fut(p_trt, x)
data.frame(p_trt, p_pbo=x, Go=p_go, Stop=p_stop, Indeterminate=1-p_go-p_stop)
})
# The above returns a list, so we bind the elements together into one data frame
oc <- bind_rows(oc_list)
# And convert from wide to long format
oc <- gather(oc, "Outcome", "Probability", 3:5)
oc$facet_text <- as.factor(paste("True placebo rate = ", oc$p_pbo, sep=""))
# Finally we are ready to plot
ggplot(oc, aes(x=p_trt, y=Probability, colour=Outcome, linetype=Outcome)) +
facet_wrap(~facet_text) + geom_line(size=1) +
scale_colour_manual(values=c("green", "orange", "red"), name="Outcome") +
scale_linetype(guide=FALSE) +
geom_hline(yintercept=c(0.1, 0.8), linetype=3) +
scale_y_continuous(breaks=seq(0, 1, by=0.2)) +
labs(x="True event rate for treatment", y="Probability", title="Operating Characteristics") +
theme_bw(base_size=12)
## Warning: The `guide` argument in `scale_*()` cannot be `FALSE`. This was deprecated in
## ggplot2 3.3.4.
## ℹ Please use "none" instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
## R version 4.1.0 (2021-05-18)
## Platform: aarch64-apple-darwin20 (64-bit)
## Running under: macOS 13.5
##
## Matrix products: default
## BLAS: /Library/Frameworks/R.framework/Versions/4.1-arm64/Resources/lib/libRblas.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.1-arm64/Resources/lib/libRlapack.dylib
##
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] bayesplot_1.10.0 tidyr_1.2.1 dplyr_1.0.10 ggplot2_3.4.2
## [5] knitr_1.40 RBesT_1.7-2
##
## loaded via a namespace (and not attached):
## [1] Rcpp_1.0.9 mvtnorm_1.1-3 prettyunits_1.1.1
## [4] ps_1.7.1 assertthat_0.2.1 digest_0.6.30
## [7] utf8_1.2.2 R6_2.5.1 backports_1.4.1
## [10] stats4_4.1.0 evaluate_0.17 highr_0.9
## [13] pillar_1.8.1 rlang_1.1.1 callr_3.7.3
## [16] jquerylib_0.1.4 checkmate_2.1.0 rmarkdown_2.20
## [19] labeling_0.4.2 textshaping_0.3.6 stringr_1.4.1
## [22] loo_2.5.1 munsell_0.5.0 compiler_4.1.0
## [25] xfun_0.37 rstan_2.21.7 pkgconfig_2.0.3
## [28] systemfonts_1.0.4 pkgbuild_1.3.1 rstantools_2.3.1
## [31] htmltools_0.5.3 tidyselect_1.2.0 tibble_3.1.8
## [34] gridExtra_2.3 codetools_0.2-18 matrixStats_0.62.0
## [37] fansi_1.0.3 crayon_1.5.2 withr_2.5.0
## [40] grid_4.1.0 jsonlite_1.8.3 gtable_0.3.1
## [43] lifecycle_1.0.3 DBI_1.1.3 magrittr_2.0.3
## [46] StanHeaders_2.21.0-7 scales_1.2.1 RcppParallel_5.1.5
## [49] cli_3.4.1 stringi_1.7.8 cachem_1.0.6
## [52] farver_2.1.1 bslib_0.4.0 ellipsis_0.3.2
## [55] ragg_1.2.1 generics_0.1.3 vctrs_0.5.0
## [58] Formula_1.2-4 tools_4.1.0 glue_1.6.2
## [61] purrr_0.3.5 processx_3.7.0 abind_1.4-5
## [64] parallel_4.1.0 fastmap_1.1.0 yaml_2.3.6
## [67] inline_0.3.19 colorspace_2.0-3 sass_0.4.2
