/
hb_plot_borrow.R
111 lines (111 loc) · 2.93 KB
/
hb_plot_borrow.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
109
110
111
#' @title Plot a borrowing model response against the benchmark models.
#' @export
#' @family plot
#' @description Plot the response from a
#' borrowing model (hierarchical or mixture)
#' against the independent and pooled benchmark models.
#' @return A `ggplot` object
#' @inheritParams hb_metrics
#' @param outcome Character of length 1, either `"response"`
#' or `"diff"`, the quantity to plot on the vertical axis.
#' @examples
#' if (!identical(Sys.getenv("HB_TEST", unset = ""), "")) {
#' data <- hb_sim_independent(n_continuous = 2)$data
#' mcmc_borrow <- hb_mcmc_hierarchical(
#' data,
#' n_chains = 1,
#' n_adapt = 100,
#' n_warmup = 100,
#' n_iterations = 200
#' )
#' mcmc_pool <- hb_mcmc_pool(
#' data,
#' n_chains = 1,
#' n_adapt = 100,
#' n_warmup = 200,
#' n_iterations = 200
#' )
#' mcmc_independent <- hb_mcmc_independent(
#' data,
#' n_chains = 1,
#' n_adapt = 100,
#' n_warmup = 200,
#' n_iterations = 200
#' )
#' borrow <- hb_summary(mcmc_borrow, data)
#' pool <- hb_summary(mcmc_pool, data)
#' independent <- hb_summary(mcmc_independent, data)
#' hb_plot_borrow(
#' borrow = borrow,
#' pool = pool,
#' independent = independent
#' )
#' }
hb_plot_borrow <- function(
borrow,
pool,
independent,
outcome = c("response", "diff")
) {
outcome <- match.arg(outcome)
true(is.data.frame(borrow))
true(is.data.frame(pool))
true(is.data.frame(independent))
true(nrow(borrow) == nrow(pool))
true(nrow(borrow) == nrow(independent))
true("group" %in% colnames(borrow))
true(all(borrow$group == pool$group))
true(all(borrow$group == independent$group))
for (name in paste0(outcome, c("_mean", "_lower", "_upper"))) {
true(name %in% colnames(borrow))
true(name %in% colnames(pool))
true(name %in% colnames(independent))
}
borrow <- dplyr::select(
borrow,
group,
group_label,
tidyselect::starts_with(outcome)
)
pool <- dplyr::select(
pool,
group,
group_label,
tidyselect::starts_with(outcome)
)
independent <- dplyr::select(
independent,
group,
group_label,
tidyselect::starts_with(outcome)
)
out <- dplyr::bind_rows(
`1-independent` = independent,
`2-borrow` = borrow,
`3-pool` = pool,
.id = "Model"
)
out$group_label <- as.character(out$group_label)
out <- out[!is.na(out[[paste0(outcome, "_mean")]]),, drop = FALSE] # nolint
ggplot2::ggplot(out) +
ggplot2::geom_point(
ggplot2::aes_string(
x = "group_label",
y = paste0(outcome, "_mean"),
color = "Model"
),
position = ggplot2::position_dodge(width = 0.5)
) +
ggplot2::geom_errorbar(
ggplot2::aes_string(
x = "group_label",
ymin = paste0(outcome, "_lower"),
ymax = paste0(outcome, "_upper"),
color = "Model"
),
position = ggplot2::position_dodge(width = 0.5)
) +
ggplot2::xlab("Group") +
ggplot2::ylab("Posterior response") +
ggplot2::theme_gray(20)
}