Analysis of Experiment 3
Last updated: 2021-12-10
Checks: 7 0
Knit directory: social_immunity/
This reproducible R Markdown analysis was created with workflowr (version 1.6.2). The Checks tab describes the reproducibility checks that were applied when the results were created. The Past versions tab lists the development history.
Great! Since the R Markdown file has been committed to the Git repository, you know the exact version of the code that produced these results.
Great job! The global environment was empty. Objects defined in the global environment can affect the analysis in your R Markdown file in unknown ways. For reproduciblity it’s best to always run the code in an empty environment.
The command set.seed(20191017) was run prior to running the code in the R Markdown file. Setting a seed ensures that any results that rely on randomness, e.g. subsampling or permutations, are reproducible.
Great job! Recording the operating system, R version, and package versions is critical for reproducibility.
Nice! There were no cached chunks for this analysis, so you can be confident that you successfully produced the results during this run.
Great job! Using relative paths to the files within your workflowr project makes it easier to run your code on other machines.
These are the previous versions of the repository in which changes were made to the R Markdown (analysis/experiment3.Rmd) and HTML (docs/experiment3.html) files. If you’ve configured a remote Git repository (see ?wflow_git_remote), click on the hyperlinks in the table below to view the files as they were in that past version.
| File | Version | Author | Date | Message |
|---|---|---|---|---|
| Rmd | ae74b45 | lukeholman | 2021-12-10 | wflow_publish(“analysis/experiment3.Rmd”) |
| html | 8eb5a1c | lukeholman | 2021-12-10 | Build site. |
| Rmd | 4326586 | lukeholman | 2021-12-10 | wflow_publish(“analysis/experiment3.Rmd”) |
| html | fbfc820 | lukeholman | 2021-04-28 | Build site. |
| Rmd | be8266d | lukeholman | 2021-04-28 | wflow_publish("analysis/*") |
| html | af7a3ea | lukeholman | 2021-04-27 | Build site. |
| Rmd | fac2952 | lukeholman | 2021-04-27 | wflow_publish("analysis/*") |
| html | 3e419d1 | lukeholman | 2021-04-27 | Build site. |
| Rmd | 43d5c2f | lukeholman | 2021-04-27 | Behav Ecol version |
| html | 5bd1725 | lukeholman | 2021-01-12 | Build site. |
| Rmd | 62a950c | lukeholman | 2021-01-12 | mostly ready |
| html | 9ebe5df | lukeholman | 2021-01-12 | Build site. |
| Rmd | 9c79d22 | lukeholman | 2021-01-12 | mostly ready |
| html | a9799c8 | lukeholman | 2021-01-11 | Build site. |
| html | 939ecd0 | lukeholman | 2021-01-11 | Build site. |
| html | eeb5a09 | lukeholman | 2020-11-30 | Build site. |
| Rmd | 7aa69df | lukeholman | 2020-11-30 | Added simple models |
| html | 7131f65 | lukeholman | 2020-08-21 | Build site. |
| Rmd | c80c978 | lukeholman | 2020-08-21 | Fix summarise() warnings |
| html | 4f23e70 | lukeholman | 2020-08-21 | Build site. |
| Rmd | c5c8df4 | lukeholman | 2020-08-21 | Minor fixes |
| html | c5c8df4 | lukeholman | 2020-08-21 | Minor fixes |
| html | 1bea769 | lukeholman | 2020-08-21 | Build site. |
| Rmd | d1dade3 | lukeholman | 2020-08-21 | added supp material |
| html | 6ee79e9 | lukeholman | 2020-08-21 | Build site. |
| Rmd | 7ec6dde | lukeholman | 2020-08-21 | remake before submission |
| html | 7bf607f | lukeholman | 2020-05-02 | Build site. |
| html | 3df58c2 | lukeholman | 2020-05-02 | Build site. |
| Rmd | cdcb0d6 | lukeholman | 2020-05-02 | tweaks |
| html | 2994a41 | lukeholman | 2020-05-02 | Build site. |
| html | d166566 | lukeholman | 2020-05-02 | Build site. |
| Rmd | ec0bd88 | lukeholman | 2020-05-02 | tweak colours |
| html | fedef8f | lukeholman | 2020-05-02 | Build site. |
| html | 4cb9bc1 | lukeholman | 2020-05-02 | Build site. |
| Rmd | 14377be | lukeholman | 2020-05-02 | tweak colours |
| html | fa8c179 | lukeholman | 2020-05-02 | Build site. |
| Rmd | f188968 | lukeholman | 2020-05-02 | tweak colours |
| html | f188968 | lukeholman | 2020-05-02 | tweak colours |
| html | 2227713 | lukeholman | 2020-05-02 | Build site. |
| html | 1c9a1c3 | lukeholman | 2020-05-02 | Build site. |
| Rmd | 3d21d6a | lukeholman | 2020-05-02 | wflow_publish("*", republish = T) |
| html | 3d21d6a | lukeholman | 2020-05-02 | wflow_publish("*", republish = T) |
| html | d56c18f | lukeholman | 2020-04-30 | Build site. |
| Rmd | c895d8d | lukeholman | 2020-04-30 | new font |
| html | 93c487a | lukeholman | 2020-04-30 | Build site. |
| html | 5c45197 | lukeholman | 2020-04-30 | Build site. |
| html | 4bd75dc | lukeholman | 2020-04-30 | Build site. |
| Rmd | 12953af | lukeholman | 2020-04-30 | test new theme |
| html | d6437a5 | lukeholman | 2020-04-25 | Build site. |
| html | e58e720 | lukeholman | 2020-04-25 | Build site. |
| html | 71b6160 | lukeholman | 2020-04-25 | Build site. |
| Rmd | 76a317d | lukeholman | 2020-04-25 | tweaks |
| html | 2235ae4 | lukeholman | 2020-04-25 | Build site. |
| Rmd | 99649a7 | lukeholman | 2020-04-25 | tweaks |
| html | 99649a7 | lukeholman | 2020-04-25 | tweaks |
| html | 0ede6e3 | lukeholman | 2020-04-24 | Build site. |
| Rmd | a1f8dc2 | lukeholman | 2020-04-24 | tweaks |
| html | a1f8dc2 | lukeholman | 2020-04-24 | tweaks |
| html | 8c3b471 | lukeholman | 2020-04-21 | Build site. |
| Rmd | 1ce9e19 | lukeholman | 2020-04-21 | First commit 2020 |
| html | 1ce9e19 | lukeholman | 2020-04-21 | First commit 2020 |
| Rmd | aae65cf | lukeholman | 2019-10-17 | First commit |
| html | aae65cf | lukeholman | 2019-10-17 | First commit |
Load data and R packages
library(showtext)
library(brms)
library(bayesplot)
library(tidyverse)
library(gridExtra)
library(kableExtra)
library(bayestestR)
library(cowplot)
library(tidybayes)
library(scales)
library(car)
source("code/helper_functions.R")
# set up nice font for figure
nice_font <- "Lora"
font_add_google(name = nice_font, family = nice_font, regular.wt = 400, bold.wt = 700)
showtext_auto()
experiment3 <- read_csv("data/clean_data/experiment_3.csv")
expt3_counts <- experiment3 %>%
group_by(treatment, pairID, hive) %>%
summarise(n_touching = sum(touching),
n_not_touching = sum(touching== 0),
percent = n_touching / (n_touching + n_not_touching),
.groups = "drop") %>%
ungroup() %>%
filter(!is.na(n_touching)) %>%
mutate(treatment = factor(treatment, c("Ringers", "LPS"))) %>%
mutate(hive = C(factor(hive), sum)) # sum coding for hiveInspect the raw data
Sample sizes by treatment
sample_sizes <- expt3_counts %>%
group_by(treatment) %>%
summarise(n = n(), .groups = "drop")
sample_sizes %>%
kable() %>% kable_styling(full_width = FALSE)| treatment | n |
|---|---|
| Ringers | 220 |
| LPS | 219 |
Sample sizes by treatment and hive
expt3_counts %>%
group_by(hive, treatment) %>%
summarise(n = n(), .groups = "drop") %>%
kable() %>% kable_styling(full_width = FALSE)| hive | treatment | n |
|---|---|---|
| Arts | Ringers | 50 |
| Arts | LPS | 50 |
| Garden | Ringers | 70 |
| Garden | LPS | 70 |
| Skylab | Ringers | 50 |
| Skylab | LPS | 49 |
| Zoology | Ringers | 50 |
| Zoology | LPS | 50 |
Means and standard errors
expt3_counts %>%
group_by(hive, treatment) %>%
summarise(pc = mean(100 * percent),
SE = sd(percent) /sqrt(n()),
n = n(), .groups = "drop") %>%
rename(`% observations in which bees were in close contact` = pc,
Hive = hive, Treatment = treatment) %>%
kable(digits = 3) %>% kable_styling(full_width = FALSE) %>%
column_spec(3, width = "2in")| Hive | Treatment | % observations in which bees were in close contact | SE | n |
|---|---|---|---|---|
| Arts | Ringers | 69.509 | 0.036 | 50 |
| Arts | LPS | 72.547 | 0.033 | 50 |
| Garden | Ringers | 76.752 | 0.033 | 70 |
| Garden | LPS | 68.895 | 0.037 | 70 |
| Skylab | Ringers | 70.509 | 0.040 | 50 |
| Skylab | LPS | 65.653 | 0.034 | 49 |
| Zoology | Ringers | 84.075 | 0.021 | 50 |
| Zoology | LPS | 73.019 | 0.037 | 50 |
Histogram of the results
Note that bees more often spent close to 100% of the observation period in contact in the control group, relative to the group treated with LPS.
histo_data <- expt3_counts %>%
left_join(sample_sizes, by = "treatment") %>%
arrange(treatment)
raw_histogram <- histo_data %>%
filter(grepl("Ringers", treatment)) %>%
ggplot(aes(100 * percent,
fill = treatment)) +
geom_histogram(data = histo_data %>%
filter(grepl("LPS", treatment)),
mapping = aes(y = ..density..),
alpha = 0.5, bins = 11, colour = "black", linetype = 2) +
geom_histogram(mapping = aes(y = ..density..),
alpha = 0.5, bins = 11,
colour = "black") +
scale_fill_brewer(palette = "Set1",
direction = 1, name = "Treatment") +
xlab("% Time in close contact") + ylab("Frequency") +
theme_bw() +
theme(legend.position = c(0.17, 0.82),
legend.background = element_rect(fill = scales::alpha('white', 0.7)),
text = element_text(family = nice_font))
rm(histo_data)
raw_histogram
Bayesian binomial model of time spent in contact
Run the models
Fit a binomial GLMM where the response is either a 0 (if bees were not in contact) or 1 (if they were). Hive is treated as a fixed factor (to aid model convergence) and the ID of each pair of bees is treated as a random factor (to account for repeated measurements of each pair).
if(!file.exists("output/exp3_model.rds")){
prior <- c(set_prior("normal(0, 3)", class = "b"),
set_prior("normal(0, 1)", class = "sd", group = "pairID"))
exp3_model <- brm(
n_touching | trials(n) ~ treatment + hive + (1 | pairID),
data = expt3_counts %>% mutate(n = n_touching + n_not_touching),
prior = prior,
family = "binomial",
chains = 4, cores = 1, iter = 20000, seed = 1)
saveRDS(exp3_model, "output/exp3_model.rds")
}
exp3_model <- readRDS("output/exp3_model.rds")Posterior predictive check
This plot shows ten predictions from the posterior (pale blue) as well as the original data (dark blue), for the proportion of time spent in close contact (0-100%). The predicted time in contact is similar to the real data, illustrating that the model is able to recapitulate the original data fairly closely (a necessary requirement for making inferences from the model).
pp_check(exp3_model, nsamples = 20)
Fixed effects from the top model
Raw output of the treatment + hive model
summary(exp3_model) Family: binomial
Links: mu = logit
Formula: n_touching | trials(n) ~ treatment + hive + (1 | pairID)
Data: expt3_counts %>% mutate(n = n_touching + n_not_tou (Number of observations: 439)
Samples: 4 chains, each with iter = 20000; warmup = 10000; thin = 1;
total post-warmup samples = 40000
Group-Level Effects:
~pairID (Number of levels: 439)
Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept) 2.01 0.08 1.86 2.17 1.00 4273 7021
Population-Level Effects:
Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept 1.67 0.14 1.39 1.94 1.00 1542 3127
treatmentLPS -0.37 0.20 -0.75 0.02 1.00 1559 3300
hive1 -0.20 0.18 -0.55 0.15 1.00 1585 3238
hive2 0.14 0.16 -0.17 0.46 1.00 1357 3388
hive3 -0.23 0.18 -0.58 0.12 1.00 1438 2609
Samples were drawn using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).Formatted brms output for Table S5
The code chunk below wrangles the raw output of the summary() function for brms models into a more readable table of results, and also adds ‘Bayesian p-values’ (i.e. the posterior probability that the true effect size has the same sign as the reported effect).
Table S5: Table summarising the posterior estimates of each fixed effect in the model of Experiment 3 (a binomial GLMM where the response variable was 0 when bees were not in close contact, and 1 when they were). ‘Treatment’ is a fixed factor with two levels, and the effect of LPS shown here is expressed relative to the ‘Ringers’ treatment. ‘Hive’ was a fixed factor with four levels (modelled using deviation coding). The model also included one random effect, ‘pair ID’, which grouped observations made on each pair of bees, preventing pseudoreplication. The \(PP\) column gives the posterior probability that the true effect size is opposite in sign to what is reported in the Estimate column, similarly to a \(p\)-value.
tableS5 <- get_fixed_effects_with_p_values(exp3_model) %>%
mutate(mu = map_chr(str_extract_all(Parameter, "mu[:digit:]"), ~ .x[1]),
Parameter = str_remove_all(Parameter, "mu[:digit:]_"),
Parameter = str_replace_all(Parameter, "treatment", "Treatment: "),
Parameter = str_replace_all(Parameter, "observation_time_minutes", "Observation duration (minutes)")) %>%
arrange(mu) %>%
select(-mu, -Rhat, -Bulk_ESS, -Tail_ESS) %>%
mutate(PP = format(round(PP, 4), nsmall = 4))
names(tableS5)[3:5] <- c("Est. Error", "Lower 95% CI", "Upper 95% CI")
saveRDS(tableS5, file = "figures/tableS5.rds")
tableS5 %>%
kable(digits = 3) %>%
kable_styling(full_width = FALSE) | Parameter | Estimate | Est. Error | Lower 95% CI | Upper 95% CI | PP | |
|---|---|---|---|---|---|---|
| Intercept | 1.669 | 0.141 | 1.392 | 1.945 | 0.0000 | *** |
| Treatment: LPS | -0.368 | 0.197 | -0.752 | 0.024 | 0.0322 | * |
| hive1 | -0.197 | 0.178 | -0.549 | 0.147 | 0.1343 | |
| hive2 | 0.143 | 0.162 | -0.175 | 0.464 | 0.1860 | |
| hive3 | -0.227 | 0.178 | -0.579 | 0.116 | 0.0999 | ~ |
Plotting estimates from the model
new <- expt3_counts %>%
select(treatment) %>% distinct() %>%
mutate(n = 100, key = paste("V", 1:n(), sep = ""),
hive = NA)
plotting_data <- as.data.frame(
fitted(exp3_model,
newdata=new, re_formula = NA, summary = FALSE))
names(plotting_data) <- c("LPS", "Ringers")
plotting_data <- plotting_data %>% gather(treatment, percent_time_in_contact)
panel_c_colour <- "#CC79A7"
dot_plot <- plotting_data %>%
mutate(treatment = factor(treatment, c("Ringers", "LPS"))) %>%
ggplot(aes(percent_time_in_contact, treatment)) +
stat_dotsh(quantiles = 100, fill = "grey40", colour = "grey40") +
stat_pointintervalh(
mapping = aes(colour = treatment, fill = treatment),
.width = c(0.5, 0.95),
position = position_nudge(y = -0.07),
point_colour = "grey26", pch = 21, stroke = 0.4) +
xlab("Mean % time in close contact") + ylab("Treatment") +
scale_colour_brewer(palette = "Pastel1",
direction = -1, name = "Treatment") +
scale_fill_brewer(palette = "Pastel1",
direction = -1, name = "Treatment") +
theme_bw() +
coord_cartesian(ylim=c(1.4, 2.4)) +
theme(
text = element_text(family = nice_font),
strip.background = element_rect(fill = "#eff0f1"),
panel.grid.major.y = element_blank(),
legend.position = "none"
)
# positive effect = odds of this outcome are higher for trt2 than trt1 (put control as trt1)
get_log_odds <- function(trt1, trt2){
log((trt2 / (1 - trt2) / (trt1 / (1 - trt1))))
}
p <- cowplot::plot_grid(raw_histogram,
dot_plot, labels = c("A", "B"),
nrow = 1, align = 'h', axis = 'l')
ggsave(plot = p, filename = "figures/fig3.pdf", height = 3.4, width = 9)
p
Figure 3: Results of Experiment 3 (n = 439 bees). Panel A shows the frequency distribution of the % time in close contact, for pairs of bees from the LPS treatment and the Ringers control. Panel B shows the posterior estimates of the mean % time spent in close contact; the details of the quantile dot plot and error bars are the same as described for Figure 1.
Hypothesis testing and effect sizes
Table S6: Pairs in which one bee had received LPS were observed in close contact less frequently than pairs in which one bee had received Ringers. The \(PP\) column gives the posterior probability that the true effect size is opposite in sign to what is reported in the Estimate column, similarly to a \(p\)-value.
get_log_odds <- function(trt1, trt2){
log((trt2 / (1 - trt2) / (trt1 / (1 - trt1))))
}
my_summary <- function(df) {
diff <- (df %>% pull(Ringers)) - (df %>% pull(LPS))
LOR <- get_log_odds((df %>% pull(Ringers))/100,
(df %>% pull(LPS))/100)
p <- 1 - (diff %>% bayestestR::p_direction() %>% as.numeric())
diff <- diff %>% posterior_summary() %>% as_tibble()
LOR <- LOR %>% posterior_summary() %>% as_tibble()
output <- rbind(diff, LOR) %>%
mutate(PP=p,
Metric = c("Absolute difference in % time in close contact",
"Log odds ratio")) %>%
select(Metric, everything()) %>%
mutate(PP = format(round(PP, 4), nsmall = 4))
output$PP[1] <- " "
output
}
tableS6 <- plotting_data %>%
as_tibble() %>%
mutate(sample = rep(1:(n() / 2), 2)) %>%
spread(treatment, percent_time_in_contact) %>%
mutate(difference = LPS - Ringers) %>%
my_summary() %>%
mutate(` ` = ifelse(PP < 0.05, "\\*", ""),
` ` = replace(` `, PP < 0.01, "**"),
` ` = replace(` `, PP < 0.001, "***"),
` ` = replace(` `, PP == " ", ""))
saveRDS(tableS6, "figures/tableS6.rds")
tableS6 %>%
kable(digits = 3) %>% kable_styling() | Metric | Estimate | Est.Error | Q2.5 | Q97.5 | PP | |
|---|---|---|---|---|---|---|
| Absolute difference in % time in close contact | 5.548 | 2.997 | -0.352 | 11.454 | ||
| Log odds ratio | -0.368 | 0.197 | -0.752 | 0.024 | 0.0322 | * |
sessionInfo()R version 4.0.3 (2020-10-10)
Platform: x86_64-apple-darwin17.0 (64-bit)
Running under: macOS Catalina 10.15.7
Matrix products: default
BLAS: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRblas.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib
locale:
[1] en_GB.UTF-8/en_GB.UTF-8/en_GB.UTF-8/C/en_GB.UTF-8/en_GB.UTF-8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] car_3.0-8 carData_3.0-4 scales_1.1.1 tidybayes_2.0.3 cowplot_1.0.0 bayestestR_0.11.5
[7] kableExtra_1.3.4 gridExtra_2.3 forcats_0.5.0 stringr_1.4.0 dplyr_1.0.0 purrr_0.3.4
[13] readr_2.0.0 tidyr_1.1.0 tibble_3.0.1 ggplot2_3.3.2 tidyverse_1.3.0 bayesplot_1.7.2
[19] brms_2.14.4 Rcpp_1.0.4.6 showtext_0.9-2 showtextdb_3.0 sysfonts_0.8.3 workflowr_1.6.2
loaded via a namespace (and not attached):
[1] readxl_1.3.1 backports_1.1.7 systemfonts_0.2.2 plyr_1.8.6 igraph_1.2.5
[6] svUnit_1.0.3 splines_4.0.3 crosstalk_1.1.0.1 TH.data_1.0-10 rstantools_2.1.1
[11] inline_0.3.15 digest_0.6.25 htmltools_0.5.0 rsconnect_0.8.16 fansi_0.4.1
[16] magrittr_2.0.1 openxlsx_4.1.5 tzdb_0.1.2 modelr_0.1.8 RcppParallel_5.0.1
[21] matrixStats_0.56.0 vroom_1.5.3 svglite_1.2.3 xts_0.12-0 sandwich_2.5-1
[26] prettyunits_1.1.1 colorspace_1.4-1 blob_1.2.1 rvest_0.3.5 haven_2.3.1
[31] xfun_0.26 callr_3.4.3 crayon_1.3.4 jsonlite_1.7.0 lme4_1.1-23
[36] survival_3.2-7 zoo_1.8-8 glue_1.4.2 gtable_0.3.0 emmeans_1.4.7
[41] webshot_0.5.2 V8_3.4.0 pkgbuild_1.0.8 rstan_2.21.2 abind_1.4-5
[46] mvtnorm_1.1-0 DBI_1.1.0 miniUI_0.1.1.1 viridisLite_0.3.0 xtable_1.8-4
[51] bit_1.1-15.2 foreign_0.8-80 stats4_4.0.3 StanHeaders_2.21.0-3 DT_0.13
[56] datawizard_0.2.1 htmlwidgets_1.5.1 httr_1.4.1 threejs_0.3.3 RColorBrewer_1.1-2
[61] arrayhelpers_1.1-0 ellipsis_0.3.1 farver_2.0.3 pkgconfig_2.0.3 loo_2.3.1
[66] dbplyr_1.4.4 labeling_0.3 tidyselect_1.1.0 rlang_0.4.6 reshape2_1.4.4
[71] later_1.0.0 munsell_0.5.0 cellranger_1.1.0 tools_4.0.3 cli_2.0.2
[76] generics_0.0.2 broom_0.5.6 ggridges_0.5.2 evaluate_0.14 fastmap_1.0.1
[81] yaml_2.2.1 bit64_0.9-7 processx_3.4.2 knitr_1.32 fs_1.4.1
[86] zip_2.1.1 nlme_3.1-149 whisker_0.4 mime_0.9 projpred_2.0.2
[91] xml2_1.3.2 rstudioapi_0.11 compiler_4.0.3 shinythemes_1.1.2 curl_4.3
[96] gamm4_0.2-6 reprex_0.3.0 statmod_1.4.34 stringi_1.5.3 highr_0.8
[101] ps_1.3.3 Brobdingnag_1.2-6 gdtools_0.2.2 lattice_0.20-41 Matrix_1.2-18
[106] nloptr_1.2.2.1 markdown_1.1 shinyjs_1.1 vctrs_0.3.0 pillar_1.4.4
[111] lifecycle_0.2.0 jquerylib_0.1.1 bridgesampling_1.0-0 estimability_1.3 data.table_1.12.8
[116] insight_0.14.5 httpuv_1.5.3.1 R6_2.4.1 promises_1.1.0 rio_0.5.16
[121] codetools_0.2-16 boot_1.3-25 colourpicker_1.0 MASS_7.3-53 gtools_3.8.2
[126] assertthat_0.2.1 rprojroot_1.3-2 withr_2.2.0 shinystan_2.5.0 multcomp_1.4-13
[131] mgcv_1.8-33 parallel_4.0.3 hms_0.5.3 grid_4.0.3 coda_0.19-3
[136] minqa_1.2.4 rmarkdown_2.11 git2r_0.27.1 shiny_1.4.0.2 lubridate_1.7.10
[141] base64enc_0.1-3 dygraphs_1.1.1.6