Relative class effects
We can produce a plot showing relative class effects against
Waitlist using plot() with
pars = "class_mean" to select these parameters.
plot(sa_fit_EXclass_RE,
pars = "class_mean",
ref_line = 0)
We can combine the treatment and class effects into a single plot as
follows:
# Relative treatment effects
trt_eff <- as_tibble(relative_effects(sa_fit_EXclass_RE)) %>%
# Add in class details
mutate(Class = sa_net$classes[as.numeric(.trtb)],
level = "treatment")
# Class effects
class_eff <- as_tibble(summary(sa_fit_EXclass_RE, pars = "class_mean")) %>%
# Extract class details
mutate(Class = factor(gsub(".*\\[(.+)\\]", "\\1", parameter), levels = levels(sa_net$classes)),
level = "class",
.trtb = factor("Class Mean", levels = c(levels(sa_net$classes), "Class Mean")))
# Combine and plot
bind_rows(trt_eff, class_eff) %>%
ggplot(aes(y = .trtb,
x = mean, xmin = `2.5%`, xmax = `97.5%`,
colour = level, shape = level)) +
geom_vline(xintercept = 0, colour = "grey60") +
geom_pointrange() +
facet_grid(rows = "Class", scales = "free", space = "free", labeller = label_wrap_gen(22)) +
scale_shape_manual(values = c(15, 16), guide = guide_none()) +
scale_colour_manual(values = c("#113259", "#55A480"), guide = guide_none()) +
xlab("SMD") + ylab("") +
theme_multinma() +
theme(strip.text.y = element_text(angle = 0))
We aim to visualize the class ranks and rank probabilities by
summarizing their distributions. To achieve this, we extract the
posterior draws for class means, add a reference treatment, and compute
the rank of each treatment at every iteration. We then summarize these
ranks by calculating the median and 95% credible intervals to generate a
point-range plot and derive the rank probability distributions for each
treatment class, which we then plot.
# Class means
EXclass_mean <- as.matrix(sa_fit_EXclass_RE, pars = "class_mean")
EXclass_mean <- cbind(`d[Reference]` = 0, EXclass_mean)
# Take ranks at each iteration
EXranks <- t(apply(EXclass_mean, 1, rank))
# Get median rank and 95% credible interval
EXresults <- t(apply(EXranks, 2, quantile, probs = c(0.025, 0.5, 0.975)))
# Convert to data frame
EXresults_df <- as.data.frame(EXresults)
EXresults_df$class <- rownames(EXresults_df)
EXresults_df$class <- factor(EXresults_df$class,
levels = sort(unique(EXresults_df$class), decreasing = TRUE))
ggplot(EXresults_df, aes(x=class, y=`50%`, ymin=`2.5%`, ymax=`97.5%`)) +
geom_pointrange(size = 0.5) +
coord_flip() +
xlab("Class") + ylab("Posterior Ranks") +
theme_multinma()
Treatment classes with higher ranks have median values closer to 1,
positioned toward the left of the x-axis. The Combined treatment class
has the highest median rank, followed by CBT individual. In contrast,
Exercise promotion appears to have the lowest rank among the treatment
classes, aside from the reference.
We now calculate and plot the class rank probabilities.
EXranks_df <- as.data.frame(EXranks)
# Rank probabilities for class
rank_probs_EX <- apply(EXranks_df, 2, function(x) table(factor(x, levels = 1:ncol(EXranks_df))) / nrow(EXranks_df))
# Convert to data frame
rank_probs_df_EX <- as.data.frame(rank_probs_EX)
# Convert the data frame to a long format
rank_probs_long_EX <- rank_probs_df_EX %>%
mutate(Rank = row_number()) %>%
pivot_longer(
cols = -Rank,
names_to = "Class",
values_to = "Probability"
)
# Plot density
ggplot(rank_probs_long_EX, aes(x = Rank, y = Probability)) +
geom_line() +
facet_wrap(~ Class) +
theme_multinma() +
labs(x = "Rank",
y = "Probability")
Higher-ranked classes have a greater density on the left side of the
x-axis, indicating a higher probability of achieving a top rank across
posterior samples. The Combined class shows the highest density on the
left, suggesting it is most likely to be ranked among the top
treatments, followed by CBT individual. In contrast, most other classes
have relatively flat distributions, reflecting greater uncertainty in
their rankings. Exercise promotion, Other psychological therapies, and
the reference class have densities skewed toward the right, indicating a
higher probability of lower rankings.
