Summary statistics

knitr::opts_chunk$set(cache = FALSE, fig.retina = 2,
                      tidy.opts = list(width.cutoff = 120),  # For code
                      width = 120)  # For output

library(tidyverse)
library(pander)
library(psych)
library(here)

source(file.path(here(), "lib", "pander_options.R"))

survey_clean <- readRDS(file.path(here(), "Data", "survey_clean.rds"))

Survey distribution across groups

dem.groups <- survey_clean %>%
  group_by(condition) %>%
  summarise(total = n())

The 809 participants were distributed amongst three slightly different surveys (Group 1 N = 267, Group 2 N = 273, Group 3 N = 269).

Participant demographics

summarize_demographic <- function(variable) {
  enquo_variable <- enquo(variable)
  
  survey_clean %>% 
    group_by(!!enquo_variable) %>% 
    summarize(Frequency = n()) %>%
    mutate(Percentage = Frequency / sum(Frequency),
           `Cumulative %` = cumsum(Percentage)) %>%
    mutate(Demographics = as.character(!!enquo_variable)) %>% 
    select(Demographics, everything(), -!!enquo_variable)
}

title.row <- function(x) {
  data_frame(Demographics = as.character(x), Frequency = NA,
             Percentage = NA, `Cumulative %` = NA)
}

dem.sex <- summarize_demographic(variable = sex)
dem.age <- summarize_demographic(variable = age_cat)
dem.race <- summarize_demographic(variable = race)
dem.education <- summarize_demographic(variable = education)
dem.republican <- summarize_demographic(variable = republican) %>%
  mutate(Demographics = ifelse(is.na(Demographics), "Missing", Demographics))
dem.democrat <- summarize_demographic(variable = democrat) %>%
  mutate(Demographics = ifelse(is.na(Demographics), "Missing", Demographics))

dem.full <- bind_rows(title.row("Sex"), dem.sex, 
                      title.row("Age"), dem.age, 
                      title.row("Race/Ethnicity"), dem.race,
                      title.row("Education"), dem.education,
                      title.row("Republican"), dem.republican,
                      title.row("Democrat"), dem.democrat) %>%
  mutate(Percentage = ifelse(!is.na(Frequency), 
                             scales::percent(Percentage), NA),
         `Cumulative %` = ifelse(!is.na(Frequency), 
                                 scales::percent(`Cumulative %`), NA),
         Demographics = ifelse(is.na(Frequency), 
                               pandoc.strong.return(Demographics),
                               Demographics))

caption <- "Participant demographics"
tbl.demographics <- pandoc.table.return(dem.full, caption = caption,
                                        justify = "lccc")

cat(tbl.demographics)

Participant demographics
Demographics	Frequency	Percentage	Cumulative %
Sex
Male	396	48.9%	48.9%
Female	413	51.1%	100.0%
Age
18–29	123	15.2%	15.2%
30–44	204	25.2%	40.4%
45–59	241	29.8%	70.2%
60+	241	29.8%	100.0%
Race/Ethnicity
White/non-Hispanic	579	71.6%	71.6%
Other race specified	230	28.4%	100.0%
Education
Less than high school	97	12.0%	12.0%
High school	256	31.6%	43.6%
Some college	223	27.6%	71.2%
Bachelor’s degree or above	233	28.8%	100.0%
Republican
Republican	321	39.7%	39.7%
Not Republican	468	57.8%	97.5%
Missing	20	2.5%	100.0%
Democrat
Democrat	438	54.1%	54.1%
Not Democrat	351	43.4%	97.5%
Missing	20	2.5%	100.0%

cat(tbl.demographics, file = file.path(here(), "Output", "table_demographics.md"))

Personality means for entire sample

df_personality_raw <- survey_clean %>%
  select(OPENNESS, CONSCIENTIOUSNESS, EXTRAVERSION, AGREEABLENESS, NEUROTICISM)

personality_alphas <- psych::alpha(as.data.frame(df_personality_raw),
                                   check.keys = TRUE, warnings = FALSE)$alpha.drop %>%
  select(raw_alpha) %>%
  mutate(Trait = gsub("-", "", rownames(.)))

df_personality <- df_personality_raw %>%
  summarise_all(funs(mean = mean(., na.rm = TRUE),
                     SD = sd(., na.rm = TRUE),
                     N = sum(!is.na(.)))) %>%
  mutate_all(as.numeric) %>%
  gather(key, value) %>%
  separate(key, c("Trait", "key"), sep = "_") %>%
  spread(key, value) %>%
  left_join(personality_alphas, by = "Trait") %>%
  mutate(Trait = str_to_title(Trait)) %>%
  mutate(Trait = factor(Trait, levels = c("Openness", "Conscientiousness", 
                                          "Extraversion", "Agreeableness", 
                                          "Neuroticism"), 
                        ordered = TRUE)) %>%
  arrange(Trait) %>%
  select(Trait, `Sample mean` = mean, SD, `Cronbach’s α` = raw_alpha, N)

caption <- "Personality mean scores for entire sample"
tbl_personality <- pandoc.table.return(df_personality, caption = caption,
                                       justify = "lcccc", digits = 2)

cat(tbl_personality)

Personality mean scores for entire sample
Trait	Sample mean	SD	Cronbach’s α	N
Openness	0.72	0.13	0.65	760
Conscientiousness	0.78	0.13	0.61	763
Extraversion	0.63	0.16	0.68	755
Agreeableness	0.79	0.12	0.62	753
Neuroticism	0.54	0.16	0.59	771

cat(tbl_personality, file = file.path(here(), "Output", "table_personality.md"))

LS0tCnRpdGxlOiAiU3VtbWFyeSBzdGF0aXN0aWNzIgphdXRob3I6ICJNZXJlZGl0aCBDb25yb3kgYW5kIEFuZHJldyBIZWlzcyIKZGF0ZTogImByIGZvcm1hdChTeXMudGltZSgpLCAnJUIgJWUsICVZJylgIgplZGl0b3Jfb3B0aW9uczogCiAgY2h1bmtfb3V0cHV0X3R5cGU6IGNvbnNvbGUKLS0tCgpgYGB7ciBzZXR1cCwgbWVzc2FnZT1GQUxTRX0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KGNhY2hlID0gRkFMU0UsIGZpZy5yZXRpbmEgPSAyLAogICAgICAgICAgICAgICAgICAgICAgdGlkeS5vcHRzID0gbGlzdCh3aWR0aC5jdXRvZmYgPSAxMjApLCAgIyBGb3IgY29kZQogICAgICAgICAgICAgICAgICAgICAgd2lkdGggPSAxMjApICAjIEZvciBvdXRwdXQKYGBgCgpgYGB7ciBsb2FkLWxpYnJhcmllcy1kYXRhLCBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQpsaWJyYXJ5KHRpZHl2ZXJzZSkKbGlicmFyeShwYW5kZXIpCmxpYnJhcnkocHN5Y2gpCmxpYnJhcnkoaGVyZSkKCnNvdXJjZShmaWxlLnBhdGgoaGVyZSgpLCAibGliIiwgInBhbmRlcl9vcHRpb25zLlIiKSkKCnN1cnZleV9jbGVhbiA8LSByZWFkUkRTKGZpbGUucGF0aChoZXJlKCksICJEYXRhIiwgInN1cnZleV9jbGVhbi5yZHMiKSkKYGBgCgoKIyMgU3VydmV5IGRpc3RyaWJ1dGlvbiBhY3Jvc3MgZ3JvdXBzCgpgYGB7ciBncm91cC1pbmZvfQpkZW0uZ3JvdXBzIDwtIHN1cnZleV9jbGVhbiAlPiUKICBncm91cF9ieShjb25kaXRpb24pICU+JQogIHN1bW1hcmlzZSh0b3RhbCA9IG4oKSkKYGBgCgo+IFRoZSBgciBucm93KHN1cnZleV9jbGVhbilgIHBhcnRpY2lwYW50cyB3ZXJlIGRpc3RyaWJ1dGVkIGFtb25nc3QgdGhyZWUgc2xpZ2h0bHkgZGlmZmVyZW50IHN1cnZleXMgKEdyb3VwIDEgTiA9IGByIGZpbHRlcihkZW0uZ3JvdXBzLCBjb25kaXRpb24gPT0gMSkkdG90YWxgLCBHcm91cCAyIE4gPSBgciBmaWx0ZXIoZGVtLmdyb3VwcywgY29uZGl0aW9uID09IDIpJHRvdGFsYCwgR3JvdXAgMyBOID0gYHIgZmlsdGVyKGRlbS5ncm91cHMsIGNvbmRpdGlvbiA9PSAzKSR0b3RhbGApLgoKCiMjIFBhcnRpY2lwYW50IGRlbW9ncmFwaGljcwoKYGBge3IgcHJvY2Vzcy1kZW1vZ3JhcGhpY3N9CnN1bW1hcml6ZV9kZW1vZ3JhcGhpYyA8LSBmdW5jdGlvbih2YXJpYWJsZSkgewogIGVucXVvX3ZhcmlhYmxlIDwtIGVucXVvKHZhcmlhYmxlKQogIAogIHN1cnZleV9jbGVhbiAlPiUgCiAgICBncm91cF9ieSghIWVucXVvX3ZhcmlhYmxlKSAlPiUgCiAgICBzdW1tYXJpemUoRnJlcXVlbmN5ID0gbigpKSAlPiUKICAgIG11dGF0ZShQZXJjZW50YWdlID0gRnJlcXVlbmN5IC8gc3VtKEZyZXF1ZW5jeSksCiAgICAgICAgICAgYEN1bXVsYXRpdmUgJWAgPSBjdW1zdW0oUGVyY2VudGFnZSkpICU+JQogICAgbXV0YXRlKERlbW9ncmFwaGljcyA9IGFzLmNoYXJhY3RlcighIWVucXVvX3ZhcmlhYmxlKSkgJT4lIAogICAgc2VsZWN0KERlbW9ncmFwaGljcywgZXZlcnl0aGluZygpLCAtISFlbnF1b192YXJpYWJsZSkKfQoKdGl0bGUucm93IDwtIGZ1bmN0aW9uKHgpIHsKICBkYXRhX2ZyYW1lKERlbW9ncmFwaGljcyA9IGFzLmNoYXJhY3Rlcih4KSwgRnJlcXVlbmN5ID0gTkEsCiAgICAgICAgICAgICBQZXJjZW50YWdlID0gTkEsIGBDdW11bGF0aXZlICVgID0gTkEpCn0KCmRlbS5zZXggPC0gc3VtbWFyaXplX2RlbW9ncmFwaGljKHZhcmlhYmxlID0gc2V4KQpkZW0uYWdlIDwtIHN1bW1hcml6ZV9kZW1vZ3JhcGhpYyh2YXJpYWJsZSA9IGFnZV9jYXQpCmRlbS5yYWNlIDwtIHN1bW1hcml6ZV9kZW1vZ3JhcGhpYyh2YXJpYWJsZSA9IHJhY2UpCmRlbS5lZHVjYXRpb24gPC0gc3VtbWFyaXplX2RlbW9ncmFwaGljKHZhcmlhYmxlID0gZWR1Y2F0aW9uKQpkZW0ucmVwdWJsaWNhbiA8LSBzdW1tYXJpemVfZGVtb2dyYXBoaWModmFyaWFibGUgPSByZXB1YmxpY2FuKSAlPiUKICBtdXRhdGUoRGVtb2dyYXBoaWNzID0gaWZlbHNlKGlzLm5hKERlbW9ncmFwaGljcyksICJNaXNzaW5nIiwgRGVtb2dyYXBoaWNzKSkKZGVtLmRlbW9jcmF0IDwtIHN1bW1hcml6ZV9kZW1vZ3JhcGhpYyh2YXJpYWJsZSA9IGRlbW9jcmF0KSAlPiUKICBtdXRhdGUoRGVtb2dyYXBoaWNzID0gaWZlbHNlKGlzLm5hKERlbW9ncmFwaGljcyksICJNaXNzaW5nIiwgRGVtb2dyYXBoaWNzKSkKCmRlbS5mdWxsIDwtIGJpbmRfcm93cyh0aXRsZS5yb3coIlNleCIpLCBkZW0uc2V4LCAKICAgICAgICAgICAgICAgICAgICAgIHRpdGxlLnJvdygiQWdlIiksIGRlbS5hZ2UsIAogICAgICAgICAgICAgICAgICAgICAgdGl0bGUucm93KCJSYWNlL0V0aG5pY2l0eSIpLCBkZW0ucmFjZSwKICAgICAgICAgICAgICAgICAgICAgIHRpdGxlLnJvdygiRWR1Y2F0aW9uIiksIGRlbS5lZHVjYXRpb24sCiAgICAgICAgICAgICAgICAgICAgICB0aXRsZS5yb3coIlJlcHVibGljYW4iKSwgZGVtLnJlcHVibGljYW4sCiAgICAgICAgICAgICAgICAgICAgICB0aXRsZS5yb3coIkRlbW9jcmF0IiksIGRlbS5kZW1vY3JhdCkgJT4lCiAgbXV0YXRlKFBlcmNlbnRhZ2UgPSBpZmVsc2UoIWlzLm5hKEZyZXF1ZW5jeSksIAogICAgICAgICAgICAgICAgICAgICAgICAgICAgIHNjYWxlczo6cGVyY2VudChQZXJjZW50YWdlKSwgTkEpLAogICAgICAgICBgQ3VtdWxhdGl2ZSAlYCA9IGlmZWxzZSghaXMubmEoRnJlcXVlbmN5KSwgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIHNjYWxlczo6cGVyY2VudChgQ3VtdWxhdGl2ZSAlYCksIE5BKSwKICAgICAgICAgRGVtb2dyYXBoaWNzID0gaWZlbHNlKGlzLm5hKEZyZXF1ZW5jeSksIAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgcGFuZG9jLnN0cm9uZy5yZXR1cm4oRGVtb2dyYXBoaWNzKSwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIERlbW9ncmFwaGljcykpCmBgYAoKYGBge3Igc2hvdy1kZW1vZ3JhcGhpY3MsIHJlc3VsdHM9ImFzaXMifQpjYXB0aW9uIDwtICJQYXJ0aWNpcGFudCBkZW1vZ3JhcGhpY3MiCnRibC5kZW1vZ3JhcGhpY3MgPC0gcGFuZG9jLnRhYmxlLnJldHVybihkZW0uZnVsbCwgY2FwdGlvbiA9IGNhcHRpb24sCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBqdXN0aWZ5ID0gImxjY2MiKQoKY2F0KHRibC5kZW1vZ3JhcGhpY3MpCmNhdCh0YmwuZGVtb2dyYXBoaWNzLCBmaWxlID0gZmlsZS5wYXRoKGhlcmUoKSwgIk91dHB1dCIsICJ0YWJsZV9kZW1vZ3JhcGhpY3MubWQiKSkKYGBgCgoKIyMgUGVyc29uYWxpdHkgbWVhbnMgZm9yIGVudGlyZSBzYW1wbGUKCmBgYHtyIHByb2Nlc3MtcGVyc29uYWxpdHktbWVhbi1zY29yZXN9CmRmX3BlcnNvbmFsaXR5X3JhdyA8LSBzdXJ2ZXlfY2xlYW4gJT4lCiAgc2VsZWN0KE9QRU5ORVNTLCBDT05TQ0lFTlRJT1VTTkVTUywgRVhUUkFWRVJTSU9OLCBBR1JFRUFCTEVORVNTLCBORVVST1RJQ0lTTSkKCnBlcnNvbmFsaXR5X2FscGhhcyA8LSBwc3ljaDo6YWxwaGEoYXMuZGF0YS5mcmFtZShkZl9wZXJzb25hbGl0eV9yYXcpLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIGNoZWNrLmtleXMgPSBUUlVFLCB3YXJuaW5ncyA9IEZBTFNFKSRhbHBoYS5kcm9wICU+JQogIHNlbGVjdChyYXdfYWxwaGEpICU+JQogIG11dGF0ZShUcmFpdCA9IGdzdWIoIi0iLCAiIiwgcm93bmFtZXMoLikpKQoKZGZfcGVyc29uYWxpdHkgPC0gZGZfcGVyc29uYWxpdHlfcmF3ICU+JQogIHN1bW1hcmlzZV9hbGwoZnVucyhtZWFuID0gbWVhbiguLCBuYS5ybSA9IFRSVUUpLAogICAgICAgICAgICAgICAgICAgICBTRCA9IHNkKC4sIG5hLnJtID0gVFJVRSksCiAgICAgICAgICAgICAgICAgICAgIE4gPSBzdW0oIWlzLm5hKC4pKSkpICU+JQogIG11dGF0ZV9hbGwoYXMubnVtZXJpYykgJT4lCiAgZ2F0aGVyKGtleSwgdmFsdWUpICU+JQogIHNlcGFyYXRlKGtleSwgYygiVHJhaXQiLCAia2V5IiksIHNlcCA9ICJfIikgJT4lCiAgc3ByZWFkKGtleSwgdmFsdWUpICU+JQogIGxlZnRfam9pbihwZXJzb25hbGl0eV9hbHBoYXMsIGJ5ID0gIlRyYWl0IikgJT4lCiAgbXV0YXRlKFRyYWl0ID0gc3RyX3RvX3RpdGxlKFRyYWl0KSkgJT4lCiAgbXV0YXRlKFRyYWl0ID0gZmFjdG9yKFRyYWl0LCBsZXZlbHMgPSBjKCJPcGVubmVzcyIsICJDb25zY2llbnRpb3VzbmVzcyIsIAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAiRXh0cmF2ZXJzaW9uIiwgIkFncmVlYWJsZW5lc3MiLCAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIk5ldXJvdGljaXNtIiksIAogICAgICAgICAgICAgICAgICAgICAgICBvcmRlcmVkID0gVFJVRSkpICU+JQogIGFycmFuZ2UoVHJhaXQpICU+JQogIHNlbGVjdChUcmFpdCwgYFNhbXBsZSBtZWFuYCA9IG1lYW4sIFNELCBgQ3JvbmJhY2jigJlzIM6xYCA9IHJhd19hbHBoYSwgTikKYGBgCgpgYGB7ciBzaG93LXBlcnNvbmFsaXR5LW1lYW4tc2NvcmVzLCByZXN1bHRzPSJhc2lzIn0KY2FwdGlvbiA8LSAiUGVyc29uYWxpdHkgbWVhbiBzY29yZXMgZm9yIGVudGlyZSBzYW1wbGUiCnRibF9wZXJzb25hbGl0eSA8LSBwYW5kb2MudGFibGUucmV0dXJuKGRmX3BlcnNvbmFsaXR5LCBjYXB0aW9uID0gY2FwdGlvbiwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAganVzdGlmeSA9ICJsY2NjYyIsIGRpZ2l0cyA9IDIpCgpjYXQodGJsX3BlcnNvbmFsaXR5KQpjYXQodGJsX3BlcnNvbmFsaXR5LCBmaWxlID0gZmlsZS5wYXRoKGhlcmUoKSwgIk91dHB1dCIsICJ0YWJsZV9wZXJzb25hbGl0eS5tZCIpKQpgYGAK

Summary statistics

Meredith Conroy and Andrew Heiss

February 21, 2018

Survey distribution across groups

Participant demographics

Personality means for entire sample