Study 3: Extension w/ Participant-Generated Stimuli & Relationship Context

Data Preparation

In this pre-registered study, we collected data from 300 participants. After exluding duplicate IP addresses and participants who failed attention checks, we obtained an analyzable sample of 225 participants.

Loading Packages

Before running this chunk, please load “Study 3.csv” into the R environment.

# packages should be loaded in the following order to avoid function conflicts
options(scipen = 99) # turns off scientific notation
library(psych) # for describing data
library(effsize) # for mean difference effect sizes
library(sjstats) # for eta-squared effect sizes
library(correlation) # for cleaner correlation test output
library(rmcorr) # for repeated-measures correlation tests
library(cocor) # for comparing dependent correlation coefficients
library(tidyverse) # for data manipulation and plotting

Attention Check

Participants were instructed to select zero (i.e., the middle option in the 9-point scale) as their response for the primary virtuosity measures that followed a modified scenario. Additionally, they were instructed to select the middle response option for two exploratory measures (i.e., moderately bad & moderately clear). If a participant failed to select the instructed response for any of the three measures, they would be excluded from the analyses.

S3 <- Study_3 %>% 
  filter(AttnVirtuosity == "0" & AttnBad == "Moderately bad" & AttnClear =="Moderately clear")

Variable Creation

Here, we create the relevant variables necessary to begin analyses for both the “Stranger” and the “Close Others” vignettes.

# Create a variable for virtuosity average in "stranger" and "close others" conditions
S3<- S3 %>%
  mutate_at(vars(theftRV, cakehoardRV, smokingRV, playbookRV,
                 officebonusRV, steroidsRV, revengeRV, envyRV,
                 responsibilityRV, insultingRV, racismRV, criticizingRV,
                 violenceRV, speedingRV, pestRV, lyingRV, gossipRV,
                 shootRV, cheatingRV, sexismRV,
                 theftSV, cakehoardSV, smokingSV, playbookSV,
                 officebonusSV, steroidsSV, revengeSV, envySV,
                 responsibilitySV, insultingSV, racismSV, criticizingSV,
                 violenceSV, speedingSV, pestSV, lyingSV, gossipSV,
                 shootSV, cheatingSV, sexismSV), as.numeric)

S3$StrangerAverage <- rowMeans(S3[, c("theftSV", "cakehoardSV", "smokingSV", "playbookSV",
             "officebonusSV", "steroidsSV", "revengeSV", "envySV",
             "responsibilitySV", "insultingSV", "racismSV", "criticizingSV",
             "violenceSV", "speedingSV", "pestSV", "lyingSV", "gossipSV",
             "shootSV", "cheatingSV", "sexismSV")], na.rm = T) # SV = Stranger Vignette

S3$CloseOtherAverage <- rowMeans(S3[, c("theftRV", "cakehoardRV", "smokingRV", "playbookRV",
             "officebonusRV", "steroidsRV", "revengeRV", "envyRV",
             "responsibilityRV", "insultingRV", "racismRV", "criticizingRV",
             "violenceRV", "speedingRV", "pestRV", "lyingRV", "gossipRV",
             "shootRV", "cheatingRV", "sexismRV")], na.rm = T) # RV = Relationship Vignette

# Separate Stranger virtuosity data from the main dataset (for certain later analyses)
S3_s <- S3 %>% # SV = Stranger Vignette; RV = Relationship Vignette
  select (-c("theftRV", "cakehoardRV", "smokingRV", "playbookRV",
             "officebonusRV", "steroidsRV", "revengeRV", "envyRV",
             "responsibilityRV", "insultingRV", "racismRV", "criticizingRV",
             "violenceRV", "speedingRV", "pestRV", "lyingRV", "gossipRV",
             "shootRV", "cheatingRV", "sexismRV"))

# Separate Close Other virtuosity data from the main dataset (for certain later analyses)
S3_co <- S3 %>% # SV = Stranger Vignette; RV = Relationship Vignette
  select (-c("theftSV", "cakehoardSV", "smokingSV", "playbookSV",
             "officebonusSV", "steroidsSV", "revengeSV", "envySV",
             "responsibilitySV", "insultingSV", "racismSV", "criticizingSV",
             "violenceSV", "speedingSV", "pestSV", "lyingSV", "gossipSV",
             "shootSV", "cheatingSV", "sexismSV"))

# Create a variable per scenario that indicates if each participant chose the hypothesized agent or not (Stranger)
S3_s <- S3_s %>%
  mutate(theft_hyp = if_else(theftSV > 0, 1, 0)) %>%
  mutate(cakehoard_hyp = if_else(cakehoardSV > 0, 1, 0)) %>%
  mutate(smoking_hyp = if_else(smokingSV > 0, 1, 0)) %>%
  mutate(playbook_hyp = if_else(playbookSV > 0, 1, 0)) %>%
  mutate(officebonus_hyp = if_else(officebonusSV > 0, 1, 0)) %>%
  mutate(steroids_hyp = if_else(steroidsSV > 0, 1, 0)) %>%
  mutate(revenge_hyp = if_else(revengeSV > 0, 1, 0)) %>%
  mutate(envy_hyp = if_else(envySV > 0, 1, 0)) %>%
  mutate(responsibility_hyp = if_else(responsibilitySV > 0, 1, 0)) %>%
  mutate(insulting_hyp = if_else(insultingSV > 0, 1, 0)) %>%
  mutate(racism_hyp = if_else(racismSV > 0, 1, 0)) %>%
  mutate(criticizing_hyp = if_else(criticizingSV > 0, 1, 0)) %>%
  mutate(violence_hyp = if_else(violenceSV > 0, 1, 0)) %>%
  mutate(speeding_hyp = if_else(speedingSV > 0, 1, 0)) %>%
  mutate(pest_hyp = if_else(pestSV > 0, 1, 0)) %>%
  mutate(lying_hyp = if_else(lyingSV > 0, 1, 0)) %>%
  mutate(gossip_hyp = if_else(gossipSV > 0, 1, 0)) %>%
  mutate(shoot_hyp = if_else(shootSV > 0, 1, 0)) %>%
  mutate(cheating_hyp = if_else(cheatingSV > 0, 1, 0)) %>%
  mutate(sexism_hyp = if_else(sexismSV > 0, 1, 0))

S3_s <- S3_s %>% # opposite
  mutate(theft_opp = if_else(theftSV < 0, 1, 0)) %>%
  mutate(cakehoard_opp = if_else(cakehoardSV < 0, 1, 0)) %>%
  mutate(smoking_opp = if_else(smokingSV < 0, 1, 0)) %>%
  mutate(playbook_opp = if_else(playbookSV < 0, 1, 0)) %>%
  mutate(officebonus_opp = if_else(officebonusSV < 0, 1, 0)) %>%
  mutate(steroids_opp = if_else(steroidsSV < 0, 1, 0)) %>%
  mutate(revenge_opp = if_else(revengeSV < 0, 1, 0)) %>%
  mutate(envy_opp = if_else(envySV < 0, 1, 0)) %>%
  mutate(responsibility_opp = if_else(responsibilitySV < 0, 1, 0)) %>%
  mutate(insulting_opp = if_else(insultingSV < 0, 1, 0)) %>%
  mutate(racism_opp = if_else(racismSV < 0, 1, 0)) %>%
  mutate(criticizing_opp = if_else(criticizingSV < 0, 1, 0)) %>%
  mutate(violence_opp = if_else(violenceSV < 0, 1, 0)) %>%
  mutate(speeding_opp = if_else(speedingSV < 0, 1, 0)) %>%
  mutate(pest_opp = if_else(pestSV < 0, 1, 0)) %>%
  mutate(lying_opp = if_else(lyingSV < 0, 1, 0)) %>%
  mutate(gossip_opp = if_else(gossipSV < 0, 1, 0)) %>%
  mutate(shoot_opp = if_else(shootSV < 0, 1, 0)) %>%
  mutate(cheating_opp = if_else(cheatingSV < 0, 1, 0)) %>%
  mutate(sexism_opp = if_else(sexismSV < 0, 1, 0))

# Create a variable per scenario that indicates if each participant chose the hypothesized agent or not (Close Other)
S3_co <- S3_co %>%
  mutate(theft_hyp = if_else(theftRV > 0, 1, 0)) %>%
  mutate(cakehoard_hyp = if_else(cakehoardRV > 0, 1, 0)) %>%
  mutate(smoking_hyp = if_else(smokingRV > 0, 1, 0)) %>%
  mutate(playbook_hyp = if_else(playbookRV > 0, 1, 0)) %>%
  mutate(officebonus_hyp = if_else(officebonusRV > 0, 1, 0)) %>%
  mutate(steroids_hyp = if_else(steroidsRV > 0, 1, 0)) %>%
  mutate(revenge_hyp = if_else(revengeRV > 0, 1, 0)) %>%
  mutate(envy_hyp = if_else(envyRV > 0, 1, 0)) %>%
  mutate(responsibility_hyp = if_else(responsibilityRV > 0, 1, 0)) %>%
  mutate(insulting_hyp = if_else(insultingRV > 0, 1, 0)) %>%
  mutate(racism_hyp = if_else(racismRV > 0, 1, 0)) %>%
  mutate(criticizing_hyp = if_else(criticizingRV > 0, 1, 0)) %>%
  mutate(violence_hyp = if_else(violenceRV > 0, 1, 0)) %>%
  mutate(speeding_hyp = if_else(speedingRV > 0, 1, 0)) %>%
  mutate(pest_hyp = if_else(pestRV > 0, 1, 0)) %>%
  mutate(lying_hyp = if_else(lyingRV > 0, 1, 0)) %>%
  mutate(gossip_hyp = if_else(gossipRV > 0, 1, 0)) %>%
  mutate(shoot_hyp = if_else(shootRV > 0, 1, 0)) %>%
  mutate(cheating_hyp = if_else(cheatingRV > 0, 1, 0)) %>%
  mutate(sexism_hyp = if_else(sexismRV > 0, 1, 0))

S3_co <- S3_co %>% # opposite
  mutate(theft_opp = if_else(theftRV < 0, 1, 0)) %>%
  mutate(cakehoard_opp = if_else(cakehoardRV < 0, 1, 0)) %>%
  mutate(smoking_opp = if_else(smokingRV < 0, 1, 0)) %>%
  mutate(playbook_opp = if_else(playbookRV < 0, 1, 0)) %>%
  mutate(officebonus_opp = if_else(officebonusRV < 0, 1, 0)) %>%
  mutate(steroids_opp = if_else(steroidsRV < 0, 1, 0)) %>%
  mutate(revenge_opp = if_else(revengeRV < 0, 1, 0)) %>%
  mutate(envy_opp = if_else(envyRV < 0, 1, 0)) %>%
  mutate(responsibility_opp = if_else(responsibilityRV < 0, 1, 0)) %>%
  mutate(insulting_opp = if_else(insultingRV < 0, 1, 0)) %>%
  mutate(racism_opp = if_else(racismRV < 0, 1, 0)) %>%
  mutate(criticizing_opp = if_else(criticizingRV < 0, 1, 0)) %>%
  mutate(violence_opp = if_else(violenceRV < 0, 1, 0)) %>%
  mutate(speeding_opp = if_else(speedingRV < 0, 1, 0)) %>%
  mutate(pest_opp = if_else(pestRV < 0, 1, 0)) %>%
  mutate(lying_opp = if_else(lyingRV < 0, 1, 0)) %>%
  mutate(gossip_opp = if_else(gossipRV < 0, 1, 0)) %>%
  mutate(shoot_opp = if_else(shootRV < 0, 1, 0)) %>%
  mutate(cheating_opp = if_else(cheatingRV < 0, 1, 0)) %>%
  mutate(sexism_opp = if_else(sexismRV < 0, 1, 0))

Group-Lvl Analyses

Simple Effects

For all t-tests, we conduct both one-tailed and two-tailed tests. Our pre-registration specified directional hypotheses which therefore ought to be analyzed with one-tailed tests. However, in order for readers to know any estimate’s uncertainty in both directions, we also conduct two-tailed tests to get relevant CIs.

Stranger Vignettes

# t-test using person-level averages across Stranger vignettes
S3_stranger_t <- t.test(S3$StrangerAverage, mu = 0, alternative = "greater") 
## 'greater' is for one-tailed p-value because of the non-tempted > tempted hypothesis
print(S3_stranger_t)

    One Sample t-test

data:  S3$StrangerAverage
t = 12.175, df = 224, p-value < 0.00000000000000022
alternative hypothesis: true mean is greater than 0
95 percent confidence interval:
 0.8428247       Inf
sample estimates:
mean of x 
0.9751111 

S3_stranger_t_2side <- t.test(S3$StrangerAverage, mu = 0, alternative = "two.sided") 
## 'two.sided' is to get uncertainty estimates in both directions
print(S3_stranger_t_2side)

    One Sample t-test

data:  S3$StrangerAverage
t = 12.175, df = 224, p-value < 0.00000000000000022
alternative hypothesis: true mean is not equal to 0
95 percent confidence interval:
 0.8172814 1.1329409
sample estimates:
mean of x 
0.9751111 

# returns cohen's d
effsize::cohen.d(S3$StrangerAverage,
                 f = NA,
                 mu = 0,
                 data = data)

Cohen's d (single sample)

d estimate: 0.8116613 (large)
Reference mu: 0
95 percent confidence interval:
    lower     upper 
0.5383086 1.0850140 

Close Other Vignettes

# t-test using person-level averages across Close Other vignettes
S3_closeother_t <- t.test(S3$CloseOtherAverage, mu = 0, alternative = "greater") 
## 'greater' is for one-tailed p-value because of the non-tempted > tempted hypothesis
print(S3_closeother_t)

    One Sample t-test

data:  S3$CloseOtherAverage
t = 13.978, df = 224, p-value < 0.00000000000000022
alternative hypothesis: true mean is greater than 0
95 percent confidence interval:
 0.9484665       Inf
sample estimates:
mean of x 
 1.075556 

S3_closeother_t_2side <- t.test(S3$CloseOtherAverage, mu = 0, alternative = "two.sided") 
## 'two.sided' is to get uncertainty estimates in both directions
print(S3_closeother_t_2side)

    One Sample t-test

data:  S3$CloseOtherAverage
t = 13.978, df = 224, p-value < 0.00000000000000022
alternative hypothesis: true mean is not equal to 0
95 percent confidence interval:
 0.9239267 1.2271844
sample estimates:
mean of x 
 1.075556 

# returns cohen's d
effsize::cohen.d(S3$CloseOtherAverage,
                 f = NA,
                 mu = 0,
                 data = data)

Cohen's d (single sample)

d estimate: 0.9318815 (large)
Reference mu: 0
95 percent confidence interval:
   lower    upper 
0.655240 1.208523 

Interaction

Repeated-Measures ANOVA

The purpose of this test is to determine whether there is a difference in mean virtuosity depending on condition (i.e., stranger vs close other).

# Prepare data by using pivot_longer on a new dataset
S3_anova <- S3 %>%
  dplyr::select(c(ResponseId, StrangerAverage, CloseOtherAverage))%>% 
  group_by(ResponseId) %>%
  pivot_longer(cols = (c(StrangerAverage, CloseOtherAverage)),
               names_to = "Condition",
               values_to = "VirtuosityAverage")

# Repeated-Meausures ANOVA
S3_interaction_aov <- aov(VirtuosityAverage~Condition + Error(as.factor(ResponseId)), data = S3_anova)
summary(S3_interaction_aov)

Error: as.factor(ResponseId)
           Df Sum Sq Mean Sq F value Pr(>F)
Residuals 224    575   2.567               

Error: Within
           Df Sum Sq Mean Sq F value Pr(>F)  
Condition   1   1.14  1.1350   5.448 0.0205 *
Residuals 224  46.66  0.2083                 
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Paired-Samples t-Test

Replicates results of the repeated-measures ANOVA. These tests are statistically identical, but we conduct both in case researchers have preferences for one over the other.

S3_interaction_t <- t.test(VirtuosityAverage ~ Condition, data = S3_anova, alternative = "greater", paired = TRUE)
## 'less' is for one-tailed p-value because of the close other > stranger hypothesis
S3_interaction_t

    Paired t-test

data:  VirtuosityAverage by Condition
t = 2.3342, df = 224, p-value = 0.01024
alternative hypothesis: true mean difference is greater than 0
95 percent confidence interval:
 0.02936854        Inf
sample estimates:
mean difference 
      0.1004444 

S3_interaction_t_2side <- t.test(VirtuosityAverage ~ Condition, data = S3_anova, alternative = "two.sided", paired = TRUE) 
## 'two.sided' is to get uncertainty estimates in both directions
print(S3_interaction_t_2side)

    Paired t-test

data:  VirtuosityAverage by Condition
t = 2.3342, df = 224, p-value = 0.02047
alternative hypothesis: true mean difference is not equal to 0
95 percent confidence interval:
 0.01564439 0.18524450
sample estimates:
mean difference 
      0.1004444 

# returns dz effect size and 95% CIs
effsize::cohen.d(VirtuosityAverage ~ Condition | Subject(ResponseId),
                 data = S3_anova %>% droplevels(), 
                 paired = T,
                 within = F)

Cohen's d

d estimate: 0.1556107 (negligible)
95 percent confidence interval:
    lower     upper 
0.0238017 0.2874197 

# returns d-av effect size and 95% CIs
effsize::cohen.d(VirtuosityAverage ~ Condition | Subject(ResponseId),
                 data = S3_anova %>% droplevels(), 
                 paired = T,
                 within = T)

Cohen's d

d estimate: 0.08507187 (negligible)
95 percent confidence interval:
     lower      upper 
0.01331514 0.15682860 

Person-Lvl Analyses

# create variables for whether hypotheses fit for each participant
S3 <- S3 %>%
  mutate(fits_stranger_hypothesis = if_else(StrangerAverage > 0, 1, 0)) %>%
  mutate(fits_closeother_hypothesis = if_else(CloseOtherAverage > 0, 1, 0)) %>%
  mutate(interaction = case_when(
    (CloseOtherAverage == 0 & StrangerAverage == 0) ~ "Zero, Zero, Zero",
    (CloseOtherAverage == 0 & StrangerAverage < 0) ~ "Zero, Neg, Pos",
    (CloseOtherAverage == 0 & StrangerAverage > 0) ~ "Zero, Pos, Neg",
    (CloseOtherAverage < 0 &  StrangerAverage == 0) ~ "Neg, Zero, Neg",
    (CloseOtherAverage < 0 &  StrangerAverage < 0 & CloseOtherAverage == StrangerAverage) ~ "Neg, Neg, Zero",
    (CloseOtherAverage < 0 &  StrangerAverage > 0) ~ "Neg, Pos, Neg",
    (CloseOtherAverage < 0 &  StrangerAverage < 0 & CloseOtherAverage > StrangerAverage) ~ "Neg, Neg, Pos",
    (CloseOtherAverage < 0 &  StrangerAverage < 0 & CloseOtherAverage < StrangerAverage) ~ "Neg, Neg, Neg",
    (CloseOtherAverage > 0 &  StrangerAverage == 0) ~ "Pos, Zero, Pos",
    (CloseOtherAverage > 0 &  StrangerAverage < 0) ~ "Pos, Neg, Pos",
    (CloseOtherAverage > 0 &  StrangerAverage > 0 & CloseOtherAverage == StrangerAverage) ~ "Pos, Pos, Zero",
    (CloseOtherAverage > 0 &  StrangerAverage > 0 & CloseOtherAverage < StrangerAverage) ~ "Pos, Pos, Neg",
    (CloseOtherAverage > 0 &  StrangerAverage > 0 & CloseOtherAverage > StrangerAverage) ~ "Pos, Pos, Pos")) %>% # predicted pattern
  mutate(fits_interaction_hypothesis = if_else(interaction == "Pos, Pos, Pos", 1, 0))

Descriptive Pervasiveness

Stranger Vignettes

# How many participants fit hypothesis for Stranger vignettes
table(S3$fits_stranger_hypothesis) # 0 = no, 1 = yes

  0   1 
 50 175 

Close Other Vignettes

# How many participants fit hypothesis for Close Other vignettes
table(S3$fits_closeother_hypothesis) # 0 = no, 1 = yes

  0   1 
 42 183 

Interaction

# How many participants fit hypothesis for interaction (i.e., Stranger > 0, Close Other > 0, AND Close Other > Stranger)
table(S3$fits_interaction_hypothesis) # 0 = no, 1 = yes

  0   1 
138  87 

Randomization Test

This test is only possible for the complex interaction hypothesis, as randomly shuffling within-condition data would yield the same result across shufflings.

library(mosaic) # for randomly shuffling data

S3_random <- S3 %>% 
  dplyr::select(c(ResponseId, StrangerAverage, CloseOtherAverage))

S3_random <- S3_random %>% 
  mutate(interaction = case_when(
    (CloseOtherAverage == 0 & StrangerAverage == 0) ~ "Zero, Zero, Zero",
    (CloseOtherAverage == 0 & StrangerAverage < 0) ~ "Zero, Neg, Pos",
    (CloseOtherAverage == 0 & StrangerAverage > 0) ~ "Zero, Pos, Neg",
    (CloseOtherAverage < 0 &  StrangerAverage == 0) ~ "Neg, Zero, Neg",
    (CloseOtherAverage < 0 &  StrangerAverage < 0 & CloseOtherAverage == StrangerAverage) ~ "Neg, Neg, Zero",
    (CloseOtherAverage < 0 &  StrangerAverage > 0) ~ "Neg, Pos, Neg",
    (CloseOtherAverage < 0 &  StrangerAverage < 0 & CloseOtherAverage > StrangerAverage) ~ "Neg, Neg, Pos",
    (CloseOtherAverage < 0 &  StrangerAverage < 0 & CloseOtherAverage < StrangerAverage) ~ "Neg, Neg, Neg",
    (CloseOtherAverage > 0 &  StrangerAverage == 0) ~ "Pos, Zero, Pos",
    (CloseOtherAverage > 0 &  StrangerAverage < 0) ~ "Pos, Neg, Pos",
    (CloseOtherAverage > 0 &  StrangerAverage > 0 & CloseOtherAverage == StrangerAverage) ~ "Pos, Pos, Zero",
    (CloseOtherAverage > 0 &  StrangerAverage > 0 & CloseOtherAverage < StrangerAverage) ~ "Pos, Pos, Neg",
    (CloseOtherAverage > 0 &  StrangerAverage > 0 & CloseOtherAverage > StrangerAverage) ~ "Pos, Pos, Pos"))

prop_S3 <- prop( ~ interaction == "Pos, Pos, Pos", data = S3_random) # create descriptive proportion of claimed pattern from Berman & Small
prop_S3_dp <- unname(prop_S3[1]) # get descriptive proportion proportion for interaction

nsim <- 1000 # number of random datasets to generate
nullprop_S3 <- rep(NA, nsim) # creating empty bin

for (i in 1:nsim) { # for loop to do random shuffling across nsim datasets and calculate proportions in those randomly shuffled datasets
  #permutation, size equal to number of observations for each condition
  S3_random$StrangerAverageR <- shuffle(S3_random$StrangerAverage) # shuffling Stranger values  
  S3_random$CloseOtherAverageR <- shuffle(S3_random$CloseOtherAverage) # shuffling CloseOther values
  
  ## Creating variable that distinguishes Ps who showed predicted (claimed) pattern from Ps who did not
  S3_R <- S3_random %>%
  mutate(interactionR = case_when(
    (CloseOtherAverageR == 0 & StrangerAverageR == 0) ~ "Zero, Zero, Zero",
    (CloseOtherAverageR == 0 & StrangerAverageR < 0) ~ "Zero, Neg, Pos",
    (CloseOtherAverageR == 0 & StrangerAverageR > 0) ~ "Zero, Pos, Neg",
    (CloseOtherAverageR < 0 &  StrangerAverageR == 0) ~ "Neg, Zero, Neg",
    (CloseOtherAverageR < 0 &  StrangerAverageR < 0 & CloseOtherAverageR == StrangerAverageR) ~ "Neg, Neg, Zero",
    (CloseOtherAverageR < 0 &  StrangerAverageR > 0) ~ "Neg, Pos, Neg",
    (CloseOtherAverageR < 0 &  StrangerAverageR < 0 & CloseOtherAverageR > StrangerAverageR) ~ "Neg, Neg, Pos",
    (CloseOtherAverageR < 0 &  StrangerAverageR < 0 & CloseOtherAverageR < StrangerAverageR) ~ "Neg, Neg, Neg",
    (CloseOtherAverageR > 0 &  StrangerAverageR == 0) ~ "Pos, Zero, Pos",
    (CloseOtherAverageR > 0 &  StrangerAverageR < 0) ~ "Pos, Neg, Pos",
    (CloseOtherAverageR > 0 &  StrangerAverageR > 0 & CloseOtherAverageR == StrangerAverageR) ~ "Pos, Pos, Zero",
    (CloseOtherAverageR > 0 &  StrangerAverageR > 0 & CloseOtherAverageR < StrangerAverageR) ~ "Pos, Pos, Neg",
    (CloseOtherAverageR > 0 &  StrangerAverageR > 0 & CloseOtherAverageR > StrangerAverageR) ~ "Pos, Pos, Pos"))

  
  nullprop_TF_S3 <-prop( ~ interactionR == "Pos, Pos, Pos", data = S3_R) # create proportion value of claimed direction 
  nullprop_S3[i]<- unname(nullprop_TF_S3[1]) # get claimed pattern proportion for randomly shuffled data and repeat for each nsim dataset
}

gf_histogram( ~ nullprop_S3, fill = ~ (nullprop_S3 >= prop_S3_dp)) # create histogram of how many randomly shuffled datasets lead to a prop value similar to or greater than empirical prop

#c(chance)-value for empirical proportion (similar to Grice's c-values computed in his OOM software)
prop( ~ nullprop_S3 >= prop_S3_dp) # suggests that empirical interaction proportion is extremely unlikely to have occurred by chance

prop_TRUE 
        0 

Frequentist Prevalence

# CREATE NECESSARY FREQUENTIST FUNCTION (code adapted from Donhauser et al.'s (2018) MATLAB code)

prevalence_test <- function(observed, alpha_ind=0.05, beta_ind=1, alpha_group=0.05, gamma_0=0.5) {
  
  # Inputs:
  # observed    = vector of p-values OR vector with two values, e.g., 'c(positive cases, total cases)'
  # alpha_ind   = alpha threshold for person-level tests, if 'observed' = vector of p-values (typically set to .05)
  # beta_ind    = sensitivity of person-level tests (probably set to 1.00)
  # alpha_group = see "outputs"
  # gamma_0     = null gamma value for empirical prevalence to be tested against (defaults to majority null)
  
  # Outputs:
  # p_null      = p-value for majority null or whatever null you specify in the gamma_0 argument (e.g., to specify a global null set "gamma_0 = 0") 
  # gamma_0     = highest gamma_0 value that can be rejected at threshold of 'alpha_group' given positive cases. Note this output is not the same as the input argument
  if(sum(observed > 1) == 0) {
    pvals <- observed
  } else {
    pvals <- c(rep(0, observed[1]), rep(1, observed[2]-observed[1]))
  }
  
  n <- length(pvals)
  k_obs <- sum(pvals < alpha_ind)
  kvals <- 0:n
  dgamma <- 0.001
  gammavals <- seq(0, 1, dgamma)
  
  p_k_gamma <- matrix(0, nrow=length(gammavals), ncol=length(kvals))
  p_kk_gamma <- matrix(0, nrow=length(gammavals), ncol=length(kvals))
  
  for(iGam in 1:length(gammavals)) {
    p_pos <- gammavals[iGam] * beta_ind + (1 - gammavals[iGam]) * alpha_ind
    p_neg <- gammavals[iGam] * (1 - beta_ind) + (1 - gammavals[iGam]) * (1 - alpha_ind)
    for(iK in 1:length(kvals)) {
      k <- kvals[iK]
      tmp <- choose(n, k) * p_pos^k * p_neg^(n - k)
      p_k_gamma[iGam, iK] <- tmp
      p_kk_gamma[iGam, iK] <- 1 - sum(p_k_gamma[iGam, 1:iK]) + tmp
    }
  }
  
  iK <- which(kvals == k_obs)
  p_null <- p_kk_gamma[which(gammavals == gamma_0), iK]
  
  index <- sum(p_kk_gamma[, iK] < alpha_group)
  if(index != 0) {
    gamma_0 <- gammavals[index]
  } else {
    gamma_0 <- 0
  }
  
  return(list(p_null=p_null, gamma_0=gamma_0, p_kk_gamma=p_kk_gamma, gammavals=gammavals, p_k_gamma=p_k_gamma))
}

Stranger Vignettes

k <- 175  # number of persons matching hypothesized / group-level pattern
n <- 175+50 # total N
stranger_freqPrevalence <- prevalence_test(c(k, n)) # specify positive cases out of total cases for prev test function
stranger_freqPrevalence$p_null # print p-value testing against majority null

[1] 0.00000000000001045501

Close Other Vignettes

k <- 183  # number of persons matching hypothesized / group-level pattern
n <- 183+42 # total N
closeother_freqPrevalence <- prevalence_test(c(k, n)) # specify positive cases out of total cases for prev test function
closeother_freqPrevalence$p_null # print p-value testing against majority null

[1] 0.000000000000006550436

Interaction

k <- 87  # number of persons matching hypothesized / group-level pattern
n <- 87+138 # total N
interaction_freqPrevalence <- prevalence_test(c(k, n)) # specify positive cases out of total cases for prev test function
interaction_freqPrevalence$p_null # print p-value testing against majority null

[1] 0.9999883

Bayesian Prevalence

# CREATE NECESSARY BAYES FUNCTIONS (code from Ince et al., 2021)
library(nleqslv)

bayesprev_map <- function(k, n, a=0.05, b=1) {
  # Bayesian maximum a posteriori estimate of population prevalence gamma
  # under a uniform prior
  # 
  # Args:
  #  k: number of participants/tests significant out of 
  #  n: total number of participants/tests
  #  a: alpha value of within-participant test (default=0.05)
  #  b: sensitivity/beta of within-participant test (default=1)
  
  gm <- (k/n -a)/(b-a)
  if(gm <0) gm <- 0
  if(gm>1) gm <- 1
  return(gm)
} 

bayesprev_posterior <- function(x, k, n, a=0.05, b=1) {
  # Bayesian posterior of population prevalence gamma under a uniform prior
  #
  # Args:
  # x : values of gamma at which to evaluate the posterior density
  # k : number of participants significant out of 
  # n : total number of participants
  # a : alpha value of within-participant test (default=0.05)
  # b : sensitivity/beta of within-participant test (default=1)
  
  m1 <-  k + 1
  m2 <- n - k + 1
  theta <- a + (b-a)*x
  post <- (b -a)*dbeta(theta,m1, m2)
  post <- post/(pbeta(b, m1, m2) - pbeta(a, m1, m2))
  return(post)
}


bayesprev_bound <- function(p, k, n, a=0.05, b=1) {
  # Bayesian lower bound of population prevalence gamma under a uniform prior
  #
  # Args:
  #  p : density the lower bound should bound (e.g. 0.95)
  #  k : number of participants significant out of 
  #  n : total number of participants
  #  a : alpha value of within-participant test (default=0.05)
  #  b : sensitivity/beta of within-participant test (default=1)
  
  m1 <-  k + 1
  m2 <- n - k + 1
  th_c <- qbeta( p*pbeta(a, m1, m2) + (1-p)*pbeta(b, m1, m2), m1, m2 )
  g_c <- (th_c -a)/(b-a)
  return(g_c)
}


bayesprev_hpdi <- function(p, k, n, a=0.05, b=1) {
  # Bayesian highest posterior density interval of population prevalence gamma
  # under a uniform prior
  #
  # Args:
  #  p : HPDI to return (e.g. 0.95 for 95%)
  #  k : number of participants significant out of 
  #  n : total number of participants
  #  a : alpha value of within-participant test (default=0.05)
  #  b : sensitivity/beta of within-participant test (default=1)
  
  m1 <- k+1
  m2 <- n-k+1
  
  if(m1 ==1) {
    endpts <- c(a, qbeta( (1 -p)*pbeta(a, m1, m2) + p*pbeta(b, m1, m2), m1, m2 ) ) 
    return((endpts -a)/(b-a))
  }
  
  if(m2 ==1) {
    endpts <- c( qbeta( p*pbeta(a, m1, m2) + (1- p)* pbeta(b, m1, m2), m1, m2 ) , b) 
    return( (endpts-a)/(b-a))
  }
  
  if(k<= n*a) {
    endpts <- c(a, qbeta( (1 -p)*pbeta(a, m1, m2) + p*pbeta(b, m1, m2), m1, m2 ) ) 
    return((endpts -a)/(b-a))
  }
  
  if(k>= n*b) {
    endpts <- c( qbeta( p*pbeta(a, m1, m2) + (1- p)* pbeta(b, m1, m2), m1, m2 ) , b) 
    return( (endpts-a)/(b-a))
  }
  
  
  g <- function(x, m1, m2, a, b, p ) {
    y <- numeric(2)
    y[1] <-  pbeta(x[2], m1, m2) - pbeta(x[1], m1, m2) - p*(pbeta(b, m1, m2) - pbeta(a, m1, m2))
    y[2] <- log(dbeta(x[2], m1, m2)) - log(dbeta(x[1], m1, m2))
    return(y)
  }
  
  x_init <- numeric(2)
  
  p1 <- (1-p)/2 
  p2 <- (1 +p)/2
  
  x_init[1] <- qbeta( (1 -p1)*pbeta(a, m1, m2) + p1* pbeta(b, m1, m2), m1, m2 )
  x_init[2] <- qbeta( (1 -p2)*pbeta(a, m1, m2) + p2* pbeta(b, m1, m2), m1, m2 )
  
  opt <- nleqslv(x_init, g, method ="Newton", control=list(maxit=1000), m1=m1, m2=m2, a=a, b=b, p=p)
  
  if (opt$termcd ==1)  print("convergence achieved") 
  if (opt$termcd != 1)  print("failed to converge") 
  
  temp <- opt$x
  if (temp[1] <a) {
    temp[1] <- a
    temp[2] <- qbeta( (1 -p)*pbeta(a, m1, m2) + p* pbeta(b, m1, m2), m1, m2 )
  }
  if (temp[2] > b) {
    temp[1] <- qbeta( p*pbeta(a, m1, m2) + (1-p)* pbeta(b, m1, m2), m1, m2 )
    temp[2] <- b
  }
  endpts <- (temp -a)/(b-a)
  return(endpts) 
}


bayesprev_posteriorprob <- function(x, k, n, a=0.05, b=1) {
  # Bayesian posterior probability in favour of the population prevalence gamma being greater than x
  #
  # Args:
  # x : values of gamma at which to evaluate the posterior probability
  # k : number of participants significant out of 
  # n : total number of participants
  # a : alpha value of within-participant test (default=0.05)
  # b : sensitivity/beta of within-participant test (default=1)
  
  theta <- a + (b-a)*x
  m1 <-  k + 1
  m2 <- n - k + 1
  p <- (pbeta(b,m1,m2)-pbeta(theta,m1,m2)) / (pbeta(b,m1,m2)-pbeta(a,m1,m2))
  return(p)
  
}

bayesprev_posteriorlogodds <- function(x, k, n, a=0.05, b=1) {
  # Bayesian posterior log-odds in favour of the population prevalence gamma being greater than x
  #
  # Args:
  # x : log-odds threshold
  # k : number of participants significant out of 
  # n : total number of participants
  # a : alpha value of within-participant test (default=0.05)
  # b : sensitivity/beta of within-participant test (default=1)
  
  theta <- a + (b-a)*x
  m1 <-  k + 1
  m2 <- n - k + 1
  p <- (pbeta(b,m1,m2)-pbeta(theta,m1,m2)) / (pbeta(b,m1,m2)-pbeta(a,m1,m2))
  lo<- log(p / (1 - p))
  return(lo)
  
}

Stranger Vignettes

k <- 175  # number of persons matching hypothesized / group-level pattern
n <- 175+50 # total N
x <- 0.50 # minority cut-off of population prevalence gamma for Bayesian posterior probability
x_0 <- 0.00 # global null of population prevalence gamma for Bayesian posterior probability
map = bayesprev_map(k, n) # get maximum a posteriori (MAP) estimate (i.e., the likeliest person-level prevalence population value)
int = bayesprev_hpdi(0.96, k, n) # get 96% HPDIs

[1] "convergence achieved"

i1 = int[1] # get lower 96% HPDI
i2 = int[2] # get upper 96% HPDI
print(c(i1, map ,i2)) # print lower 96 HPDI, map estimate, and upper 96 HPDI

[1] 0.7029325 0.7660819 0.8220047

bayesprev_posteriorprob(x, k, n) # Bayesian posterior probability in favor of population prevalence being greater than x

[1] 1

bayesprev_posteriorprob(x_0, k, n) # Bayesian posterior probability in favor of population prevalence being greater than x_0

[1] 1

Close Other Vignettes

k <- 183  # number of persons matching hypothesized / group-level pattern
n <- 183+42 # total N
x <- 0.50 # minority cut-off of population prevalence gamma for Bayesian posterior probability
x_0 <- 0.00 # global null of population prevalence gamma for Bayesian posterior probability
map = bayesprev_map(k, n) # get maximum a posteriori (MAP) estimate (i.e., the likeliest person-level prevalence population value)
int = bayesprev_hpdi(0.96, k, n) # get 96% HPDIs

[1] "convergence achieved"

i1 = int[1] # get lower 96% HPDI
i2 = int[2] # get upper 96% HPDI
print(c(i1, map ,i2)) # print lower 96 HPDI, map estimate, and upper 96 HPDI

[1] 0.7435925 0.8035088 0.8552701

bayesprev_posteriorprob(x, k, n) # Bayesian posterior probability in favor of population prevalence being greater than x

[1] 1

bayesprev_posteriorprob(x_0, k, n) # Bayesian posterior probability in favor of population prevalence being greater than x_0

[1] 1

Interaction

k <- 87  # number of persons matching hypothesized / group-level pattern
n <- 87+138 # total N
x <- 0.50 # minority cut-off of population prevalence gamma for Bayesian posterior probability
x_0 <- 0.00 # global null of population prevalence gamma for Bayesian posterior probability
map = bayesprev_map(k, n) # get maximum a posteriori (MAP) estimate (i.e., the likeliest person-level prevalence population value)
int = bayesprev_hpdi(0.96, k, n) # get 96% HPDIs

[1] "convergence achieved"

i1 = int[1] # get lower 96% HPDI
i2 = int[2] # get upper 96% HPDI
print(c(i1, map ,i2)) # print lower 96 HPDI, map estimate, and upper 96 HPDI

[1] 0.2862171 0.3543860 0.4255007

bayesprev_posteriorprob(x, k, n) # Bayesian posterior probability in favor of population prevalence being greater than x

[1] 0.00001617156

bayesprev_posteriorprob(x_0, k, n) # Bayesian posterior probability in favor of population prevalence being greater than x_0

[1] 1

Primary Plots

# re-organize data to plot vignette-by-vignette variability

# stranger vignettes
S3_vignettes_s <- S3_s %>% 
  select(c(ResponseId,
           theft_hyp, cakehoard_hyp, smoking_hyp, playbook_hyp, officebonus_hyp, 
           steroids_hyp, revenge_hyp, envy_hyp, responsibility_hyp, insulting_hyp,
           racism_hyp, criticizing_hyp, violence_hyp, speeding_hyp, pest_hyp,
           lying_hyp, gossip_hyp, shoot_hyp, cheating_hyp, sexism_hyp,
           theft_opp, cakehoard_opp, smoking_opp, playbook_opp, officebonus_opp, 
           steroids_opp, revenge_opp, envy_opp, responsibility_opp, insulting_opp,
           racism_opp, criticizing_opp, violence_opp, speeding_opp, pest_opp,
           lying_opp, gossip_opp, shoot_opp, cheating_opp, sexism_opp)) %>% 
    mutate(theft = case_when(
    theft_hyp == 1 ~ "Yes",
    theft_opp == 1 ~ "No - Opposite",
    (theft_hyp == 0 & theft_opp == 0) ~ "No - Equal")) %>%
    mutate(cakehoard = case_when(
    cakehoard_hyp == 1 ~ "Yes",
    cakehoard_opp == 1 ~ "No - Opposite",
    (cakehoard_hyp == 0 & cakehoard_opp == 0) ~ "No - Equal")) %>%
    mutate(smoking = case_when(
    smoking_hyp == 1 ~ "Yes",
    smoking_opp == 1 ~ "No - Opposite",
    (smoking_hyp == 0 & smoking_opp == 0) ~ "No - Equal")) %>%
    mutate(playbook = case_when(
    playbook_hyp == 1 ~ "Yes",
    playbook_opp == 1 ~ "No - Opposite",
    (playbook_hyp == 0 & playbook_opp == 0) ~ "No - Equal")) %>%
    mutate(bonus = case_when(
    officebonus_hyp == 1 ~ "Yes",
    officebonus_opp == 1 ~ "No - Opposite",
    (officebonus_hyp == 0 & officebonus_opp == 0) ~ "No - Equal")) %>%
    mutate(steroids = case_when(
    steroids_hyp == 1 ~ "Yes",
    steroids_opp == 1 ~ "No - Opposite",
    (steroids_hyp == 0 & steroids_opp == 0) ~ "No - Equal")) %>%
    mutate(revenge = case_when(
    revenge_hyp == 1 ~ "Yes",
    revenge_opp == 1 ~ "No - Opposite",
    (revenge_hyp == 0 & revenge_opp == 0) ~ "No - Equal")) %>%
    mutate(envy = case_when(
    envy_hyp == 1 ~ "Yes",
    envy_opp == 1 ~ "No - Opposite",
    (envy_hyp == 0 & envy_opp == 0) ~ "No - Equal")) %>%
  mutate(responsibility = case_when(
    responsibility_hyp == 1 ~ "Yes",
    responsibility_opp == 1 ~ "No - Opposite",
    (responsibility_hyp == 0 & responsibility_opp == 0) ~ "No - Equal")) %>%
  mutate(insulting = case_when(
    insulting_hyp == 1 ~ "Yes",
    insulting_opp == 1 ~ "No - Opposite",
    (insulting_hyp == 0 & insulting_opp == 0) ~ "No - Equal")) %>%
  mutate(racism = case_when(
    racism_hyp == 1 ~ "Yes",
    racism_opp == 1 ~ "No - Opposite",
    (racism_hyp == 0 & racism_opp == 0) ~ "No - Equal")) %>%
  mutate(criticizing = case_when(
    criticizing_hyp == 1 ~ "Yes",
    criticizing_opp == 1 ~ "No - Opposite",
    (criticizing_hyp == 0 & criticizing_opp == 0) ~ "No - Equal")) %>%
    mutate(violence = case_when(
    violence_hyp == 1 ~ "Yes",
    violence_opp == 1 ~ "No - Opposite",
    (violence_hyp == 0 & violence_opp == 0) ~ "No - Equal")) %>%
  mutate(speeding = case_when(
    speeding_hyp == 1 ~ "Yes",
    speeding_opp == 1 ~ "No - Opposite",
    (speeding_hyp == 0 & speeding_opp == 0) ~ "No - Equal")) %>%
  mutate(pest = case_when(
    pest_hyp == 1 ~ "Yes",
    pest_opp == 1 ~ "No - Opposite",
    (pest_hyp == 0 & pest_opp == 0) ~ "No - Equal")) %>%
  mutate(lying = case_when(
    lying_hyp == 1 ~ "Yes",
    lying_opp == 1 ~ "No - Opposite",
    (lying_hyp == 0 & lying_opp == 0) ~ "No - Equal")) %>%
  mutate(gossip = case_when(
    gossip_hyp == 1 ~ "Yes",
    gossip_opp == 1 ~ "No - Opposite",
    (gossip_hyp == 0 & gossip_opp == 0) ~ "No - Equal")) %>%
  mutate(shoot = case_when(
    shoot_hyp == 1 ~ "Yes",
    shoot_opp == 1 ~ "No - Opposite",
    (shoot_hyp == 0 & shoot_opp == 0) ~ "No - Equal")) %>%
  mutate(cheating = case_when(
    cheating_hyp == 1 ~ "Yes",
    cheating_opp == 1 ~ "No - Opposite",
    (cheating_hyp == 0 & cheating_opp == 0) ~ "No - Equal")) %>%
  mutate(sexism = case_when(
    sexism_hyp == 1 ~ "Yes",
    sexism_opp == 1 ~ "No - Opposite",
    (sexism_hyp == 0 & sexism_opp == 0) ~ "No - Equal")) %>%
  group_by(ResponseId) %>%
  pivot_longer(cols = (c(theft, cakehoard, smoking, playbook, bonus,
                         steroids,revenge, envy, responsibility,
                         insulting, racism, criticizing,violence,
                         speeding, pest, lying, gossip, shoot,
                         cheating,sexism)),
               names_to = "vignette_name",
               values_to = "fits_hyp") %>%
  drop_na(fits_hyp)

stranger_labs <- c("Theft", "Cake Hoarding", "Smoking", "Playbook", "Bonus", "Steroids", "Revenge",
                   "Envy", "Responsibility","Insulting", "Racism", "Criticizing", "Violence", "Speeding",
                   "Pest", "Lying", "Gossip", "Shooting", "Cheating","Sexism")
names(stranger_labs) <- c("theft", "cakehoard", "smoking", "playbook",
                          "bonus","steroids", "revenge", "envy",
                          "responsibility", "insulting","racism",
                          "criticizing","violence", "speeding", "pest",
                          "lying", "gossip", "shoot","cheating",
                          "sexism")

# close other vignettes
S3_vignettes_co <- S3_co %>% 
  select(c(ResponseId,
           theft_hyp, cakehoard_hyp, smoking_hyp, playbook_hyp, officebonus_hyp, 
           steroids_hyp, revenge_hyp, envy_hyp, responsibility_hyp, insulting_hyp,
           racism_hyp, criticizing_hyp, violence_hyp, speeding_hyp, pest_hyp,
           lying_hyp, gossip_hyp, shoot_hyp, cheating_hyp, sexism_hyp,
           theft_opp, cakehoard_opp, smoking_opp, playbook_opp, officebonus_opp, 
           steroids_opp, revenge_opp, envy_opp, responsibility_opp, insulting_opp,
           racism_opp, criticizing_opp, violence_opp, speeding_opp, pest_opp,
           lying_opp, gossip_opp, shoot_opp, cheating_opp, sexism_opp)) %>% 
    mutate(theft = case_when(
    theft_hyp == 1 ~ "Yes",
    theft_opp == 1 ~ "No - Opposite",
    (theft_hyp == 0 & theft_opp == 0) ~ "No - Equal")) %>%
    mutate(cakehoard = case_when(
    cakehoard_hyp == 1 ~ "Yes",
    cakehoard_opp == 1 ~ "No - Opposite",
    (cakehoard_hyp == 0 & cakehoard_opp == 0) ~ "No - Equal")) %>%
    mutate(smoking = case_when(
    smoking_hyp == 1 ~ "Yes",
    smoking_opp == 1 ~ "No - Opposite",
    (smoking_hyp == 0 & smoking_opp == 0) ~ "No - Equal")) %>%
    mutate(playbook = case_when(
    playbook_hyp == 1 ~ "Yes",
    playbook_opp == 1 ~ "No - Opposite",
    (playbook_hyp == 0 & playbook_opp == 0) ~ "No - Equal")) %>%
    mutate(bonus = case_when(
    officebonus_hyp == 1 ~ "Yes",
    officebonus_opp == 1 ~ "No - Opposite",
    (officebonus_hyp == 0 & officebonus_opp == 0) ~ "No - Equal")) %>%
    mutate(steroids = case_when(
    steroids_hyp == 1 ~ "Yes",
    steroids_opp == 1 ~ "No - Opposite",
    (steroids_hyp == 0 & steroids_opp == 0) ~ "No - Equal")) %>%
    mutate(revenge = case_when(
    revenge_hyp == 1 ~ "Yes",
    revenge_opp == 1 ~ "No - Opposite",
    (revenge_hyp == 0 & revenge_opp == 0) ~ "No - Equal")) %>%
    mutate(envy = case_when(
    envy_hyp == 1 ~ "Yes",
    envy_opp == 1 ~ "No - Opposite",
    (envy_hyp == 0 & envy_opp == 0) ~ "No - Equal")) %>%
  mutate(responsibility = case_when(
    responsibility_hyp == 1 ~ "Yes",
    responsibility_opp == 1 ~ "No - Opposite",
    (responsibility_hyp == 0 & responsibility_opp == 0) ~ "No - Equal")) %>%
  mutate(insulting = case_when(
    insulting_hyp == 1 ~ "Yes",
    insulting_opp == 1 ~ "No - Opposite",
    (insulting_hyp == 0 & insulting_opp == 0) ~ "No - Equal")) %>%
  mutate(racism = case_when(
    racism_hyp == 1 ~ "Yes",
    racism_opp == 1 ~ "No - Opposite",
    (racism_hyp == 0 & racism_opp == 0) ~ "No - Equal")) %>%
  mutate(criticizing = case_when(
    criticizing_hyp == 1 ~ "Yes",
    criticizing_opp == 1 ~ "No - Opposite",
    (criticizing_hyp == 0 & criticizing_opp == 0) ~ "No - Equal")) %>%
    mutate(violence = case_when(
    violence_hyp == 1 ~ "Yes",
    violence_opp == 1 ~ "No - Opposite",
    (violence_hyp == 0 & violence_opp == 0) ~ "No - Equal")) %>%
  mutate(speeding = case_when(
    speeding_hyp == 1 ~ "Yes",
    speeding_opp == 1 ~ "No - Opposite",
    (speeding_hyp == 0 & speeding_opp == 0) ~ "No - Equal")) %>%
  mutate(pest = case_when(
    pest_hyp == 1 ~ "Yes",
    pest_opp == 1 ~ "No - Opposite",
    (pest_hyp == 0 & pest_opp == 0) ~ "No - Equal")) %>%
  mutate(lying = case_when(
    lying_hyp == 1 ~ "Yes",
    lying_opp == 1 ~ "No - Opposite",
    (lying_hyp == 0 & lying_opp == 0) ~ "No - Equal")) %>%
  mutate(gossip = case_when(
    gossip_hyp == 1 ~ "Yes",
    gossip_opp == 1 ~ "No - Opposite",
    (gossip_hyp == 0 & gossip_opp == 0) ~ "No - Equal")) %>%
  mutate(shoot = case_when(
    shoot_hyp == 1 ~ "Yes",
    shoot_opp == 1 ~ "No - Opposite",
    (shoot_hyp == 0 & shoot_opp == 0) ~ "No - Equal")) %>%
  mutate(cheating = case_when(
    cheating_hyp == 1 ~ "Yes",
    cheating_opp == 1 ~ "No - Opposite",
    (cheating_hyp == 0 & cheating_opp == 0) ~ "No - Equal")) %>%
  mutate(sexism = case_when(
    sexism_hyp == 1 ~ "Yes",
    sexism_opp == 1 ~ "No - Opposite",
    (sexism_hyp == 0 & sexism_opp == 0) ~ "No - Equal")) %>%
  group_by(ResponseId) %>%
  pivot_longer(cols = (c(theft, cakehoard, smoking, playbook, bonus,
                         steroids,revenge, envy, responsibility,
                         insulting, racism, criticizing,violence,
                         speeding, pest, lying, gossip, shoot,
                         cheating,sexism)),
               names_to = "vignette_name",
               values_to = "fits_hyp") %>%
  drop_na(fits_hyp)

closeother_labs <- c("Theft", "Cake Hoarding", "Smoking", "Playbook", "Bonus", "Steroids", "Revenge",
                   "Envy", "Responsibility","Insulting", "Racism", "Criticizing", "Violence", "Speeding",
                   "Pest", "Lying", "Gossip", "Shooting", "Cheating","Sexism")
names(closeother_labs) <- c("theft", "cakehoard", "smoking", "playbook",
                          "bonus","steroids", "revenge", "envy",
                          "responsibility", "insulting","racism",
                          "criticizing","violence", "speeding", "pest",
                          "lying", "gossip", "shoot","cheating",
                          "sexism")

Stranger Vignettes

print(S3_s_vigplot <- ggplot(S3_vignettes_s, 
                               aes(x = as.character(fits_hyp), 
                                  fill = as.character(fits_hyp))) +
  geom_bar() +
  scale_fill_manual(values = c("grey30","#8b1616", "#CEA335"), name = "Fits Hypothesis")+
  scale_y_continuous(limits = c(-0.1,100.1), breaks = c(0, 20, 40, 60, 80, 100)) +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~ vignette_name, ncol = 5, labeller = labeller(vignette_name = stranger_labs)) +
  theme(axis.title.x = element_blank(), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_blank(), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 16),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

ggsave("S3_s_vigplot.png")

Saving 14.1 x 9.04 in image

Close Other Vignettes

print(S3_co_vigplot <- ggplot(S3_vignettes_co, 
                               aes(x = as.character(fits_hyp), 
                                  fill = as.character(fits_hyp))) +
  geom_bar() +
  scale_fill_manual(values = c("grey30","#8b1616", "#CEA335"), name = "Fits Hypothesis")+
  scale_y_continuous(limits = c(-0.1,100.1), breaks = c(0, 20, 40, 60, 80, 100)) +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~ vignette_name, ncol = 5, labeller = labeller(vignette_name = closeother_labs)) +
  theme(axis.title.x = element_blank(), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_blank(), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 16),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

ggsave("S3_co_vigplot.png")

Saving 14.1 x 9.04 in image

Interaction

# Create a variable that determines which pattern out of every possible combination of results a particular participant followed 
S3 <- S3 %>%
  mutate("Interaction" = case_when(
    (CloseOtherAverage == 0 & StrangerAverage == 0) ~ "Zero, Zero, Zero",
    (CloseOtherAverage == 0 & StrangerAverage < 0) ~ "Zero, Neg, Pos",
    (CloseOtherAverage == 0 & StrangerAverage > 0) ~ "Zero, Pos, Neg",
    (CloseOtherAverage < 0 & StrangerAverage == 0) ~ "Neg, Zero, Neg",
    (CloseOtherAverage < 0 & StrangerAverage < 0 & CloseOtherAverage == StrangerAverage) ~ "Neg, Neg, Zero",
    (CloseOtherAverage < 0 & StrangerAverage > 0) ~ "Neg, Pos, Neg",
    (CloseOtherAverage < 0 & StrangerAverage < 0 & CloseOtherAverage > StrangerAverage) ~ "Neg, Neg, Pos",
    (CloseOtherAverage < 0 & StrangerAverage < 0 & CloseOtherAverage < StrangerAverage) ~ "Neg, Neg, Neg",
    (CloseOtherAverage > 0 & StrangerAverage == 0) ~ "Pos, Zero, Pos",
    (CloseOtherAverage > 0 & StrangerAverage < 0) ~ "Pos, Neg, Pos", 
    (CloseOtherAverage > 0 & StrangerAverage > 0 & CloseOtherAverage == StrangerAverage) ~ "Pos, Pos, Zero",
    (CloseOtherAverage > 0 & StrangerAverage > 0 & CloseOtherAverage < StrangerAverage) ~ "Pos, Pos, Neg",
    (CloseOtherAverage > 0 & StrangerAverage > 0 & CloseOtherAverage > StrangerAverage) ~ "Pos, Pos, Pos"))

# define levels
factor_levels <- c("Neg, Neg, Neg",
                   "Neg, Neg, Pos",
                   "Neg, Neg, Zero",
                   "Neg, Pos, Neg",
                   "Neg, Zero, Neg",
                   "Pos, Neg, Pos",
                   "Pos, Pos, Neg",
                   "Pos, Pos, Pos", # predicted pattern
                   "Pos, Pos, Zero",
                   "Pos, Zero, Pos",
                   "Zero, Neg, Pos",
                   "Zero, Pos, Neg",
                   "Zero, Zero, Zero")

# make variable a factor
S3$Interaction <- factor(S3$Interaction, levels = factor_levels)

# Visualize the frequency of every pattern
print(S3_int_plot <- ggplot(data = S3, aes(x = Interaction, fill = Interaction)) +
  geom_bar(position = "dodge", size = 0.5) +
        coord_cartesian(ylim = c(-0.5, 100.5)) +
        scale_x_discrete(drop = FALSE) +
        scale_fill_manual(drop = FALSE, values = c(
                                     "lightgrey", 
                                     "azure4",
                                     "lightgrey",
                                     "lightgrey",
                                     "lightgrey",
                                     "azure4", 
                                     "lightgrey",
                                     "black", # group-level pattern based on factor_levels,
                                     "lightgrey",
                                     "azure4", 
                                     "azure4", 
                                     "lightgrey",
                                     "lightgrey")) +
        theme_classic() +
        theme(legend.position = "none") + 
        xlab("\nInteraction Pattern (Stranger Judgment, Close Other Judgment, Close Other - Stranger)") +
        ylab("Participant Count\n") +  
        theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 20),
              axis.text.x = element_text(color = "black", size = 14, angle = 60, vjust = 0.5, hjust=0.5),
              axis.text.y = element_text(color = "black", size = 18),
              strip.text.x = element_text(color = "black", size = 20),
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

ggsave("S3_int_plot.png")

Saving 14.1 x 9.04 in image

Robustness Plots

Here, we investigate the number of participants matching predicted effects by demographics in order to catalog the generality (or lack thereof) of these effects across levels of various the demographics that we collected.

# create yes/no variable for simple hypotheses
S3_s <- S3_s %>%
  mutate(fits_hyp = if_else(StrangerAverage > 0, "Yes", "No"))

# create yes/no variable for simple hypotheses
S3_co <- S3_co %>%
  mutate(fits_hyp = if_else(CloseOtherAverage > 0, "Yes", "No"))

# create yes/no variable for interaction hypothesis
S3 <- S3 %>%
  mutate(fits_hyp = if_else(Interaction == "Pos, Pos, Pos", "Yes", "No"))

Education

Stranger Vignettes

print(S3_s_educ <- ggplot(S3_s, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Education) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Close Other Vignettes

print(S3_co_educ <- ggplot(S3_co, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Education) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Interaction

print(S3_educ <- ggplot(S3, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Interaction Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Education) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Political Party

Stranger Vignettes

print(S3_s_pol <- ggplot(S3_s, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~PoliticalParty) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Close Other Vignettes

print(S3_co_pol <- ggplot(S3_co, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~PoliticalParty) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Interaction

print(S3_pol <- ggplot(S3, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Interaction Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~PoliticalParty) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Religiosity

Stranger Vignettes

print(S3_s_relig <- ggplot(S3_s, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Religiosity) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Close Other Vignettes

print(S3_co_relig <- ggplot(S3_co, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Religiosity) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Interaction

print(S3_relig <- ggplot(S3, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Interaction Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Religiosity) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Urban vs Rural

Stranger Vignettes

print(S3_s_urb <- ggplot(S3_s, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~LivingArea) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Close Other Vignettes

print(S3_co_urb <- ggplot(S3_co, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~LivingArea) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Interaction

print(S3_urb <- ggplot(S3, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Interaction Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~LivingArea) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Gender

Stranger Vignettes

print(S3_s_gender <- ggplot(S3_s, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Gender) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Close Other Vignettes

print(S3_co_gender <- ggplot(S3_co, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Gender) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Interaction

print(S3_gender <- ggplot(S3, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Interaction Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Gender) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Race

# make race one variable
S3_s <- S3_s %>%
  mutate(Race = coalesce(`Race/Ethnicity_1`, `Race/Ethnicity_2`, `Race/Ethnicity_3`, `Race/Ethnicity_4`, 
                         `Race/Ethnicity_5`, `Race/Ethnicity_6`, `Race/Ethnicity_7`, `Race/Ethnicity_8`))

S3_co <- S3_co %>%
  mutate(Race = coalesce(`Race/Ethnicity_1`, `Race/Ethnicity_2`, `Race/Ethnicity_3`, `Race/Ethnicity_4`, 
                         `Race/Ethnicity_5`, `Race/Ethnicity_6`, `Race/Ethnicity_7`, `Race/Ethnicity_8`))

S3 <- S3 %>%
  mutate(Race = coalesce(`Race/Ethnicity_1`, `Race/Ethnicity_2`, `Race/Ethnicity_3`, `Race/Ethnicity_4`, 
                         `Race/Ethnicity_5`, `Race/Ethnicity_6`, `Race/Ethnicity_7`, `Race/Ethnicity_8`))

Stranger Vignettes

print(S3_s_race <- ggplot(S3_s, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Race) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Close Other Vignettes

print(S3_co_race <- ggplot(S3_co, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Race) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))

Interaction

print(S3_race <- ggplot(S3, aes(x = fits_hyp)) +
  geom_bar(fill = "grey30") +
  xlab("\nMatched Predicted Interaction Pattern") +
  ylab("Number of Participants\n") +
  theme_classic() +
  facet_wrap(~Race) +
  theme(axis.title.x = element_text(size = 18), 
              axis.title.y = element_text(size = 18),
              axis.text.x = element_text(color = "black", size = 16), 
              axis.text.y = element_text(color = "black", size = 16),
              strip.text.x = element_text(color = "black", size = 12),
              legend.position = "right",
              legend.title = element_text(color = "black", size = 18),
              legend.text = element_text(color = "black", size = 16)))