Welfare in Experimental News Markets

Data Description and Analysis

Modified

October 31, 2023

The follow analysis is implemented in R [version 4.1.1 (2021-08-10) – “Kick Things”]

library(tidyverse)
library(gridExtra)
library(readxl)
library(ggthemes)
library(knitr)
library(kableExtra)
library(xtable)
library(texreg)
library(broom)
library(lme4)

1 Dataset

  • These are the choice data
Download CHOICES.csv.zip
  • These are the questionnaire data
Download QUESTIONNAIRE.csv.zip
  • These are the time on page data
Download TIMES.csv.zip
  • Load the datasets
# Main data source: choices
d <- read_csv("./CHOICES.csv") %>%  
      mutate(Correct_C=ifelse(State==Choice_C,"Correct","Wrong")) %>%
      mutate(Payoff=ifelse(Type=="A",
      ifelse(Choice_C=="black",1200,400),
      ifelse(Type=="B",ifelse(Choice_C=="red",1200,400),
      ifelse(Correct_C=="Correct",600,200)))) %>% 
      mutate(Cost=ifelse(Type=="A",abs(Drawn-Report_A)*25/3,ifelse(Type=="B",abs(Drawn-Report_B)*25/3,0))) %>%
      mutate(Net_payoff=(Payoff-Cost)) %>% 
      mutate(Net_payoff=ifelse((Treatment=="Monopoly" & Type=="B"),Payoff,Net_payoff))

# Questionnaire data
d.q <- read_csv("./QUESTIONNAIRE.csv")

# Time on page data
d.t <- read_csv("./TIMES.csv") %>% arrange(session_code,participant_code,epoch_time) %>%
  rename(participant.code=participant_code) %>% arrange(participant.code, round_number)

1.1 Main variables

  • Treatment: treatment identifier
    • Competition = COMP; Monopoly=MONO
  • session.code: session unique identifier
  • participant.code: participant’s unique identifier
  • Type: role
    • A = \(Sender_1\)
    • B = \(Sender_2\)
    • C = \(DM\)
  • Group: match identifier in session and round
  • Round: Round identifier (1–30)
  • Drawn: randomly drawn number (\(drawn\))
    • \(\{-100, ... 100\}\)
  • Report_A: number reported by \(Sender_1\)
    • \(\{-100, ... 100\}\)
  • Report_B: number reported by \(Sender_2\)
    • \(\{-100, ... 100\}\)
  • Choice_C: state chosen by
    • \(\{Red, Black\}\)
  • State : actual state
    • \(\{Red, Black\}\)
  • Bel_A1: the probability that Player A is going to report the value truthfully
    • 1: 0%-20%; 2:21%-40%; 3:41%-60%; 4:61%-80%; 5:81%-100%<
  • Bel_A2: the probability that Player C is going to choose Black
    • 1: 0%-20%; 2:21%-40%; 3:41%-60%; 4:61%-80%; 5:81%-100%<
  • Payoff: Earnings from the choice
  • Cost: Cost of signal
  • Net_payoff: Earnings from the choice - Cost of signal
  • Correct_C: whether the \(DM\) choiceis correct
    • \(\{Correct, Wrong\}\)

2 Sample descriptives

  • Number of sessions:
    n
    7
    • Number of sessions by treatment:
      Treatment n
      Competition 3
      Monopoly 4
  • Number of participants:
    n
    192
    • Number of participants by role
      Type n
      A 64
      B 64
      C 64
    • Number of participants by treatment
      Treatment n
      Competition 96
      Monopoly 96
    • Number of participants by treatment and role:
      Treatment Type n
      Competition A 32
      Competition B 32
      Competition C 32
      Monopoly A 32
      Monopoly B 32
      Monopoly C 32

3 Senders

3.1 Figure 1: Drawn and reported values by treatment.

3.1.1 MONO

marginal<- d %>%  filter(Treatment=="Monopoly") %>%
                  gather("Type","Value",8:8) %>%
                  group_by(Type, Drawn) %>%
                  count(Value) %>%
                  mutate(Type=ifelse(Type=="Report_A","Sender 1","Sender 2")) %>% 
                  mutate(Freq=-99)

d %>% filter(Treatment=="Monopoly") %>%
      gather("Type","Value",8:8) %>%
      group_by(Type, Drawn) %>%
      count(Value) %>%
      mutate(Type=ifelse(Type=="Report_A","Sender 1","Sender 2")) %>%
      mutate(Freq=prop.table(n)) %>%
      ggplot(aes(x = Drawn, y = Value,  size=Freq))+#
      geom_abline(intercept=0,slope=1,linetype=2)+
      geom_hline(yintercept=0,linetype=2)+
      geom_vline(xintercept=0,linetype=2)+
      geom_jitter(pch=21,alpha=.5,color="black",fill="slategray")+
      geom_smooth(color="red")+
      geom_rug(data=marginal,col="black",alpha=0.1, size=1)+
      theme_bw()+
      scale_x_continuous(limits=c(-102,102))+
      scale_y_continuous(limits=c(-102,102))+
      scale_fill_gradient(low="slategray1",high="slategray")+
      scale_size(guide = "none")+
      facet_wrap(.~Type)+
      theme_bw()+ # the theme
      labs(
      y = "Reported Value",
      x= "Drawn Value",
      fill="Freq", color="Freq",size= "Subject")+ # labels
      theme(legend.position="none",
      axis.text=element_text(size=8),
      axis.title=element_text(size=14,face="bold"),
      strip.text.x = element_text(size = 14)) #axis

ggsave("MONO_report.png",width=6, height=5,dpi=300)

3.1.2 COMP

marginal<- d %>%  filter(Treatment=="Competition" & (Type=="C")) %>%
                  select(Drawn,Report_A,Report_B) %>%
                  gather("Type","Value",2:3) %>%
                  group_by(Type) %>% 
                  mutate(Freq=-99)%>%
                  mutate(Type=ifelse(Type=="Report_A","Sender 1","Sender 2")) 

g <-
d %>% filter(Treatment=="Competition" & (Type=="C")) %>%
      gather("Type","Value",8:9) %>%
      group_by(Type, Drawn) %>%
      count(Value) %>%
      mutate(Freq=prop.table(n)) %>%
      mutate(Type=ifelse(Type=="Report_A","Sender 1","Sender 2")) %>%
      ggplot(aes(x = Drawn, y = Value, fill = Freq, size=Freq))+
      geom_abline(intercept=0,slope=1,linetype=2)+
      geom_hline(yintercept=0,linetype=2)+
      geom_vline(xintercept=0,linetype=2)+
      geom_point(pch=21,alpha=.5,color="black")+
      geom_smooth(color="red")+
      geom_rug(data=marginal,col="black",alpha=0.1, size=1)+
      theme_bw()+
      scale_x_continuous(limits=c(-102,102))+
      scale_y_continuous(limits=c(-102,102))+
      scale_fill_gradient(low="slategray1",high="slategray")+
      scale_size(guide = "none")+
      facet_wrap(.~Type, ncol=1)+
      theme_bw()+ 
      labs(
      y = "Reported Value",
      x= "Drawn Value",
      fill="Freq", color="Freq",size= "Subject")+
      theme(legend.position="none",
      axis.text=element_text(size=8),
      axis.title=element_text(size=14,face="bold"),
      strip.text.x = element_text(size = 14)
      ) #axis

# Only Type 1

d %>% filter(Treatment=="Competition" & (Type=="C")) %>%
      gather("Type","Value",8:9) %>%
      group_by(Type, Drawn) %>%
      count(Value) %>%
      mutate(Freq=prop.table(n)) %>%
      mutate(Type=ifelse(Type=="Report_A","Sender 1","Sender 2")) %>%
  filter(Type=="Sender 1") |>
    mutate(Type2="Sender 1") |>
      ggplot(aes(x = Drawn, y = Value,  size=Freq))+
      geom_abline(intercept=0,slope=1,linetype=2)+
      geom_hline(yintercept=0,linetype=2)+
      geom_vline(xintercept=0,linetype=2)+
      geom_point(pch=21,alpha=.5,color="black",fill="slategray")+
      geom_smooth(color="red")+
      geom_rug(data=marginal |> filter(Type=="Sender 1"),col="black",alpha=0.1, size=1)+
      theme_bw()+
      scale_x_continuous(limits=c(-102,102))+
      scale_y_continuous(limits=c(-102,102))+
      scale_fill_gradient(low="slategray1",high="slategray")+
      scale_size(guide = "none")+
      facet_wrap(.~Type2, ncol=1)+
      theme_bw()+ 
      labs(
      y = "Reported Value",
      x= "Drawn Value",
      fill="Freq", color="Freq",size= "Subject")+
      theme(legend.position="none",
      axis.text=element_text(size=8),
      axis.title=element_text(size=14,face="bold"),
      strip.text.x = element_text(size = 14)
      ) #axis

ggsave("COMP_report_1.png",width=6, height=5,dpi=300)

## Only Type 2

d %>% filter(Treatment=="Competition" & (Type=="C")) %>%
      gather("Type","Value",8:9) %>%
      group_by(Type, Drawn) %>%
      count(Value) %>%
      mutate(Freq=prop.table(n)) %>%
      mutate(Type=ifelse(Type=="Report_A","Sender 1","Sender 2")) %>%
  filter(Type=="Sender 2") |>
  mutate(Type2="Sender 2") |>
      ggplot(aes(x = Drawn, y = Value, size=Freq))+
      geom_abline(intercept=0,slope=1,linetype=2)+
      geom_hline(yintercept=0,linetype=2)+
      geom_vline(xintercept=0,linetype=2)+
      geom_point(pch=21,alpha=.5,color="black",fill="slategray")+
      geom_smooth(color="red")+
      geom_rug(data=marginal |> filter(Type=="Sender 2"),col="black",alpha=0.1, size=1)+
      theme_bw()+
      scale_x_continuous(limits=c(-102,102))+
      scale_y_continuous(limits=c(-102,102))+
      scale_fill_gradient(low="slategray1",high="slategray")+
      scale_size(guide = "none")+
      facet_wrap(.~Type2, ncol=1)+
      theme_bw()+ 
      labs(
      y = "Reported Value",
      x= "Drawn Value",
      fill="Freq", color="Freq",size= "Subject")+
      theme(legend.position="none",
      axis.text=element_text(size=8),
      axis.title=element_text(size=14,face="bold"),
      strip.text.x = element_text(size = 14)
      ) #axis

ggsave("COMP_report_2.png",width=6, height=5,dpi=300)

3.2 Descriptives

  • Truth telling
d %>% select(participant.code,Treatment,Type,Drawn, Report_A, Report_B) %>%
  mutate(truth_telling=ifelse(Type=="A",ifelse(Drawn == Report_A,1,0), ifelse(Type=="B",ifelse(Drawn == Report_B,1,0),NA))) %>%
  select(participant.code, Treatment, Type, truth_telling) %>%
    filter(Type=="A" | Type=="B") %>%
  group_by(Treatment) %>%
  count(truth_telling) %>%
  na.omit() %>%
  mutate(Freq=prop.table(n)) %>% 
  kable() %>% kable_minimal()
Treatment truth_telling n Freq
Competition 0 975 0.5078125
Competition 1 945 0.4921875
Monopoly 0 418 0.4354167
Monopoly 1 542 0.5645833
  • Deviation from true value
d %>% select(participant.code,Treatment,Type,Drawn, Report_A, Report_B) %>%
      gather("Key","Value",5:6) %>%
      mutate(Dist=ifelse(Key=="Report_A",(Value-Drawn),Drawn-Value)) %>%
      filter((Type=="A" & Key=="Report_A") | (Type=="B" & Key=="Report_B"))  %>%
      group_by(participant.code,Treatment) %>%
      summarise_at("Dist",mean) %>%
      group_by(Treatment) %>%
      summarize_at("Dist",list(N=~n(),Mean=~mean(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE))) %>% 
      kable() %>% kable_minimal()
Treatment N Mean SD Median
Competition 64 9.614062 9.904676 7.216667
Monopoly 64 9.634375 10.975948 6.700000
  • Deviation from true value when drawn is adverse
d %>% select(participant.code,Treatment,Type,Drawn, Report_A, Report_B) %>%
      gather("Key","Value",5:6) %>%
      mutate(Dist=ifelse(Key=="Report_A",(Value-Drawn),Drawn-Value)) %>%
      filter((Type=="A" & Key=="Report_A") | (Type=="B" & Key=="Report_B"))  %>%
      filter((Type=="A" & Drawn<0) | (Type=="B" & Drawn>0)) %>%
      group_by(participant.code,Treatment) %>%
      summarise_at("Dist",mean) %>%
      group_by(Treatment) %>%
      summarize_at("Dist",list(N=~n(),Mean=~mean(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE))) %>% 
  kable() %>% kable_minimal()
Treatment N Mean SD Median
Competition 64 13.38616 11.78028 10.33333
Monopoly 64 13.29056 14.04189 10.68125

3.3 Table 2: Signal Costs (individual observations).

  • Monopoly (average at individual level)
d %>% filter(Treatment=="Monopoly" & Type=="A") %>%
      group_by(Type) %>%
      summarize_at("Cost",list(N=~n(),Mean=~mean(.), SD=~sd(.), Median=~median(.))) %>% 
      kable() %>% kable_minimal()
Type N Mean SD Median
A 960 85.85938 134.6635 0
  • Competition (average at individual level)
d %>% filter(Treatment=="Competition" & (Type=="A"| Type=="B")) %>%
      group_by(Type) %>%
      summarize_at("Cost",list(N=~n(),Mean=~mean(.), SD=~sd(.), Median=~median(.))) %>% 
      kable() %>% kable_minimal()
Type N Mean SD Median
A 960 88.53299 127.3724 16.66667
B 960 93.09028 145.9500 0.00000
  • Tests
    • Take average at the individual level
d |> group_by(participant.code, Type, Treatment) %>%
  summarize_at("Cost",mean) -> dt 

wilcox.test(
dt |> filter(Treatment=="Competition" & Type=="A") |> pull(Cost),
dt |> filter(Treatment=="Monopoly" & Type=="A") |> pull(Cost),
) |> tidy() |> kable() %>% kable_minimal()
statistic p.value method alternative
577 0.3863423 Wilcoxon rank sum test with continuity correction two.sided 
wilcox.test(
dt |> filter(Treatment=="Competition" & Type=="B") |> pull(Cost),
dt |> filter(Treatment=="Competition" & Type=="A") |> pull(Cost),
) |> tidy() |> kable() %>% kable_minimal()
statistic p.value method alternative
482.5 0.6969665 Wilcoxon rank sum test with continuity correction two.sided 
wilcox.test(
dt |> filter(Treatment=="Competition" & Type=="B") |> pull(Cost),
dt |> filter(Treatment=="Monopoly" & Type=="A") |> pull(Cost),
) |> tidy() |> kable() %>% kable_minimal()
statistic p.value method alternative
557 0.5499899 Wilcoxon rank sum test with continuity correction two.sided 
#pull A and B together

wilcox.test(
dt |> filter(Treatment=="Competition" & Type!="C") |> pull(Cost),
dt |> filter(Treatment=="Monopoly" & Type=="A") |> pull(Cost),
) |> tidy() |> kable() %>% kable_minimal()
statistic p.value method alternative
1134 0.3946434 Wilcoxon rank sum test with continuity correction two.sided 
#pull A and B together at session elevel

d |> group_by(session.code, Type, Treatment) %>%
  summarize_at("Cost",mean) -> dt 

wilcox.test(
dt |> filter(Treatment=="Competition" & Type!="C") |> pull(Cost),
dt |> filter(Treatment=="Monopoly" & Type=="A") |> pull(Cost),
) |> tidy() |> kable() %>% kable_minimal()
statistic p.value method alternative
13 0.9142857 Wilcoxon rank sum exact test two.sided

4 Decision Maker

4.1 Figure 2: Decision-makers accuracy by treatment.

4.1.1 COMP

d %>% filter(Treatment=="Competition" & Type=="C") %>%
      select(Treatment, session.code, Group, Round, Drawn, Report_A, Report_B, Choice_C, Correct_C) %>%
      distinct() |> mutate(AVG_report=(Report_A+Report_B)/2)  -> dt.g
  

marginal<- dt.g %>%
    select(Drawn,AVG_report) %>%
  mutate(Correct_C=NA) %>% arrange(AVG_report)

      ggplot(dt.g  ,aes(y = AVG_report, x=Drawn, fill = as_factor(Correct_C)))+
      geom_hline(yintercept=0)+
      geom_vline(xintercept=0)+
      geom_abline(intercept=0,slope=1,linetype=2)+
      geom_jitter(alpha=.6,pch=21,size=3)+
      # geom_smooth()+
      geom_rug(data=marginal,col="black",alpha=0.1, size=1.5)+
      scale_x_continuous(limits=c(-102,102))+
      scale_y_continuous(limits=c(-102,102))+
      #scale_fill_brewer(palette="Paired")+
         scale_fill_manual(values=c("white","slategray"))+
      scale_size(guide = "none")+
      theme_bw()+ # the theme
      labs(
      # title="Guesses and reported values",
      #    subtitle="Monopoly",
      x = "Drawn",
      y= "Average Report",
      fill="", color="Subject",size= "Subject")+ # labels
      theme(legend.position="bottom",
      axis.text=element_text(size=8),
      axis.title=element_text(size=14,face="bold"),
      legend.text=element_text(size=12)) +
      guides(fill = guide_legend(override.aes = list(size=6))) #axis

      ggsave("COMP_guesses_AVERAGE.png",width=6, height=6,dpi=300)

4.1.2 MONO

marginal<- d %>%  filter(Treatment=="Competition" & (Type=="C")) %>%
                  select(Drawn,Report_A) %>%
                  mutate(Correct_C=NA)

# DM is better of if RED and DRAWN <=0 AND IF BLACK and DRAWN>=0


d %>% filter(Treatment=="Monopoly" & (Type=="C")) %>%
      select(Treatment, session.code, Group, Round, Drawn, Report_A, Correct_C) %>%
      distinct()  -> dt.g
  
      ggplot(dt.g,aes(y = Report_A, x=Drawn, fill = as_factor(Correct_C)))+
      geom_hline(yintercept=0)+
      geom_vline(xintercept=0)+
      geom_abline(intercept=0,slope=1,linetype=2)+
      geom_jitter(alpha=.6,pch=21,size=3)+
      # geom_smooth()+
      geom_rug(data=marginal,col="black",alpha=0.1, size=1.5)+
      scale_x_continuous(limits=c(-102,102))+
      scale_y_continuous(limits=c(-102,102))+
      #scale_fill_brewer(palette="Paired")+
         scale_fill_manual(values=c("white","slategray"))+
      scale_size(guide = "none")+
      theme_bw()+ # the theme
      labs(
      # title="Guesses and reported values",
      #    subtitle="Monopoly",
      x = "Drawn",
      y= "Report Sender 1",
      fill="", color="Subject",size= "Subject")+ # labels
      theme(legend.position="bottom",
      axis.text=element_text(size=8),
      axis.title=element_text(size=14,face="bold"),
      legend.text=element_text(size=12)) +
      guides(fill = guide_legend(override.aes = list(size=6))) #axis

      ggsave("MONO_guesses.png",width=6, height=6,dpi=300)       
      
# NEW (but not effective)
      
  #  dt.g |>
  #    count(Correct_C, Report_A, Drawn) %>%
  #     group_by(Drawn, Report_A) |>
  #     mutate(Freq=prop.table(n)) %>%
  #     ggplot(aes(y = Report_A, x=Drawn, fill = as_factor(Correct_C), size=Freq))+
  #     geom_hline(yintercept=0)+
  #     geom_vline(xintercept=0)+
  #     geom_abline(intercept=0,slope=1,linetype=2)+
  #     geom_point(alpha=.6,pch=21)+
  #     geom_rug(data=marginal,col="black",alpha=0.1, size=1.5)+
  #     scale_x_continuous(limits=c(-102,102))+
  #     scale_y_continuous(limits=c(-102,102))+
  #     scale_fill_brewer(palette="Okabe-Ito")+
  #        scale_fill_manual(values=c("white","slategray"))+
  #     scale_size(guide = "none")+
  #     theme_bw()+ # the theme
  #     labs(
  #     # title="Guesses and reported values",
  #     #    subtitle="Monopoly",
  #     x = "Drawn",
  #     y= "Report Sender 1",
  #     fill="", color="Subject",size= "Subject")+ # labels
  #     theme(legend.position="bottom",
  #     axis.text=element_text(size=8),
  #     axis.title=element_text(size=14,face="bold"),
  #     legend.text=element_text(size=12)) +
  #     guides(fill = guide_legend(override.aes = list(size=6))) #axis

4.1.3 Descriptives

d  %>%  group_by(Correct_C, Treatment) %>%
        count(Correct_C) %>% 
        ungroup() %>%
        group_by( Treatment) %>%
        mutate(Freq=prop.table(n)) %>% 
        kable() %>% kable_minimal()
Correct_C Treatment n Freq
Correct Competition 2130 0.7395833
Correct Monopoly 2079 0.7218750
Wrong Competition 750 0.2604167
Wrong Monopoly 801 0.2781250
  • Monopoly
d %>% filter(Treatment=="Monopoly" & Type=="C") %>%
      select(Treatment, session.code, Group, Round, Drawn, Report_A,Drawn, Choice_C, Correct_C) %>% 
      mutate(Deceitful=ifelse(Report_A>0 & Drawn<0,"Deceit",ifelse(Report_A>0 & Drawn>0,"Honest",NA))) %>% distinct() %>%
      group_by(Deceitful) %>%
      count(Correct_C) %>%
      mutate(Freq=prop.table(n)) %>% 
      kable() %>% kable_minimal()
Deceitful Correct_C n Freq
Deceit Correct 55 0.2925532
Deceit Wrong 133 0.7074468
Honest Correct 372 0.8322148
Honest Wrong 75 0.1677852
NA Correct 266 0.8184615
NA Wrong 59 0.1815385
  • Competition
d %>% filter(Treatment=="Competition" & (Type=="C")) %>%
      select(Treatment, session.code, Group, Round, Drawn, Report_A, Report_B, Choice_C, Correct_C) %>% mutate(Consistency=ifelse(Report_A*Report_B>0,"Same sign","Opposite signs")) %>% distinct() %>% mutate(Avg_report=(Report_A+Report_B)/2, dist=abs(Report_A-Report_B)) %>%
      group_by(Consistency) %>%
      count(Correct_C) %>%
      mutate(Freq=prop.table(n)) %>% 
      kable(caption = "Report S1 vs Report S2") %>% kable_minimal()
Report S1 vs Report S2
Consistency Correct_C n Freq
Opposite signs Correct 216 0.4886878
Opposite signs Wrong 226 0.5113122
Same sign Correct 494 0.9536680
Same sign Wrong 24 0.0463320
  • Compare average report with drawn value
d %>% filter(Treatment=="Competition" & (Type=="C")) %>%
      select(Treatment, session.code, Group, Round, Drawn, Report_A, Report_B, Choice_C, Correct_C) %>% mutate(Avg_report = (Report_A + Report_B) / 2, dist = abs(Report_A - Report_B)) |>
      mutate(Consistency=ifelse(Avg_report*Drawn>0,"Same sign","Opposite signs")) %>% distinct() %>% mutate(Avg_report=(Report_A+Report_B)/2, dist=abs(Report_A-Report_B)) %>%
      group_by(Consistency) %>%
      count(Correct_C) %>%
      mutate(Freq=prop.table(n)) %>% 
      kable(caption="Average report vs drawn value") %>% kable_minimal()
Average report vs drawn value
Consistency Correct_C n Freq
Opposite signs Correct 87 0.3140794
Opposite signs Wrong 190 0.6859206
Same sign Correct 623 0.9121523
Same sign Wrong 60 0.0878477

5 Welfare

5.1 Table 3: Net Payoffs (individual observations).

d %>% 
      group_by(Treatment,Type) %>%
      summarise_at("Net_payoff",list(N=~n(),Mean=~mean(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE)))%>% na.omit() %>%
      kable() %>% kable_minimal()
Treatment Type N Mean Median SD
Competition A 960 738.9670 862.5 404.1758
Competition B 960 679.4097 400.0 397.5772
Competition C 960 495.8333 600.0 175.6363
Monopoly A 960 778.3073 900.0 386.6147
Monopoly B 960 735.8333 400.0 395.0256
Monopoly C 960 488.7500 600.0 179.3235 
d %>% mutate(unique_group=paste(Group,Round,session.code,sep="_")) %>% group_by(Treatment,unique_group) %>% distinct() %>%
      summarise_at("Net_payoff",sum) %>%
      group_by(Treatment) %>%
      summarise_at("Net_payoff",list(N=~n(),Mean=~mean(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE)))%>% na.omit() %>% 
      kable() %>% kable_minimal()
Treatment N Mean Median SD
Competition 960 1914.210 2033.333 310.0672
Monopoly 960 2002.891 2191.667 263.2047

5.2 Table 4: Net Payoffs

d.reg <- 
  full_join(
    d,
    d.q %>% select(-Treatment),
    by="participant.code"
            ) %>% mutate(trust_scale=ifelse(trust=="No, bisogna sempre essere prudenti",0,ifelse(trust=="No, spesso bisogna essere prudenti",1,ifelse(trust=="Sì, ti puoi fidare quasi sempre",3,4)))) %>%
mutate(honesty_scale=ifelse(honesty=="No, le persone si comportano quasi sempre in modo corretto",2,ifelse(honesty=="Sì, cercano di approfittarsene quasi sempre",1,0))) %>%
mutate(gender=as_factor(gender)) %>% mutate(gender=factor(gender,levels=c("Femmina","Maschio","Non binario"))) %>% 
mutate(Treatment=as_factor(Treatment)) 

d.reg$Treatment <- factor(d.reg$Treatment, levels=c("Monopoly", "Competition"))
#--------------------------------------------------
fit.A <-  lmer(Net_payoff ~ Round + as_factor(Treatment)*Drawn+
               (gender) + age + risk_taker  + (trust_scale ) + (honesty_scale)
                + (1|session.code:participant.code),
             data=d.reg %>% filter(Type=="A"), control=lmerControl(optimizer= "bobyqa"))

fit.B <-  lmer(Net_payoff ~ Round + as_factor(Treatment)*Drawn+
               (gender) + age + risk_taker  + (trust_scale ) +(honesty_scale)
                + (1|session.code:participant.code),
             data=d.reg %>% filter(Type=="B" & gender!="Non binario"), control=lmerControl(optimizer= "bobyqa"))

fit.C <-  lmer(Net_payoff ~ Round + as_factor(Treatment) *abs(Drawn)+   
               (gender) + age + risk_taker  + (trust_scale ) +(honesty_scale)
                +(1|session.code:participant.code) ,
             data=d.reg %>% filter(Type=="C"), control=lmerControl(optimizer= "bobyqa"))

fit.all <- lmer(Net_payoff ~ Round  + as_factor(Treatment)*abs(Drawn)+   
               (gender) + age + risk_taker + (trust_scale ) +(honesty_scale)
              +(1|session.code:participant.code) ,
             data=d.reg %>% filter(gender!="Non binario"), control=lmerControl(optimizer= "bobyqa"))
#--------------------------------------------------

htmlreg(list(fit.A,fit.B,fit.C,fit.all),
                 custom.model.names = c("A","B","C","all"),
                     single.row = TRUE,
                     bold = 0.05,
                     booktabs = TRUE,
                     dcolumn = TRUE,
                     digits=3,
                     stars = c(0.001, 0.01, 0.05, 0.1))
Statistical models
  A B C all
(Intercept) 747.561 (103.270)*** 554.838 (74.679)*** 432.068 (50.382)*** 661.643 (87.167)***
Round -0.017 (0.849) -0.375 (0.887) 1.384 (0.444)** 0.481 (0.515)
as_factor(Treatment)Competition -58.166 (22.831)* -42.114 (18.838)* -25.561 (16.365) -59.807 (24.510)*
Drawn 10.456 (0.518)*** -8.765 (0.544)***    
genderMaschio -2.442 (22.002) -2.335 (16.808) -12.974 (12.597) -7.964 (20.593)
age 1.375 (4.534) 6.762 (3.230)* 0.569 (1.845) 0.016 (3.580)
risk_taker -4.285 (5.509) 8.078 (4.696)· 0.005 (3.148) 0.663 (5.270)
trust_scale -8.975 (12.549) 4.423 (10.901) -4.570 (5.906) -10.068 (11.359)
honesty_scale 28.465 (18.762) -10.934 (16.220) -6.104 (11.790) -6.314 (17.994)
as_factor(Treatment)Competition:Drawn 1.432 (0.734)· -3.200 (0.760)***    
abs(Drawn)     2.589 (0.452)*** 1.118 (0.525)*
as_factor(Treatment)Competition:abs(Drawn)     2.090 (0.636)** 1.790 (0.739)*
AIC 27169.835 27299.463 25149.084 82745.975
BIC 27236.367 27365.995 25215.805 82825.754
Log Likelihood -13572.918 -13637.732 -12562.542 -41360.988
Num. obs. 1890 1890 1920 5700
Num. groups: session.code:participant.code 63 63 64 190
Var: session.code:participant.code (Intercept) 3554.789 316.658 1327.957 15593.552
Var: Residual 101993.382 111379.052 28117.934 112436.068
***p < 0.001; **p < 0.01; *p < 0.05; ·p < 0.1
  • using sum at the group level (robustness check)
fit.all <- lmer(Net_payoff ~ Round  + as_factor(Treatment)*abs(Drawn)
              +(1|session.code) ,
             data=d.reg %>% mutate(Group_ID=paste(session.code,Group,Round,sep="_")) %>% group_by(session.code,Group_ID,Drawn,Round,Treatment) %>% summarise_at("Net_payoff",sum), control=lmerControl(optimizer= "bobyqa"))

htmlreg(list(fit.all),
                 custom.model.names = c("all"),
                     single.row = TRUE,
                     bold = 0.05,
                     booktabs = TRUE,
                     dcolumn = TRUE,
                     digits=3,
                     stars = c(0.001, 0.01, 0.05, 0.1))
Statistical models
  all
(Intercept) 1949.883 (36.388)***
Round 1.013 (0.719)
as_factor(Treatment)Competition -194.002 (52.085)***
abs(Drawn) 3.395 (0.727)***
as_factor(Treatment)Competition:abs(Drawn) 5.316 (1.020)***
AIC 26980.908
BIC 27019.829
Log Likelihood -13483.454
Num. obs. 1920
Num. groups: session.code 7
Var: session.code (Intercept) 3909.646
Var: Residual 73958.664
***p < 0.001; **p < 0.01; *p < 0.05; ·p < 0.1
  • Are payoffs of DM higher in the last 15 rounds?
#--------------------------------------------------

fit.C.rob <-  lmer(Net_payoff ~ ifelse(Round>15,1,0) + as_factor(Treatment) *abs(Drawn)+   
               (gender) + age + risk_taker  + (trust_scale ) +(honesty_scale)
                +(1|session.code:participant.code) ,
             data=d.reg %>% filter(Type=="C"), control=lmerControl(optimizer= "bobyqa"))

#--------------------------------------------------

htmlreg(list(fit.C.rob),
                 custom.model.names = c("C rob"),
                     single.row = TRUE,
                     bold = 0.05,
                     booktabs = TRUE,
                     dcolumn = TRUE,
                     digits=3,
                     stars = c(0.001, 0.01, 0.05, 0.1))
Statistical models
  C rob
(Intercept) 443.813 (50.055)***
ifelse(Round > 15, 1, 0) 19.922 (7.674)**
as_factor(Treatment)Competition -25.387 (16.371)
abs(Drawn) 2.562 (0.452)***
genderMaschio -12.955 (12.598)
age 0.577 (1.845)
risk_taker 0.010 (3.149)
trust_scale -4.570 (5.907)
honesty_scale -6.139 (11.791)
as_factor(Treatment)Competition:abs(Drawn) 2.079 (0.636)**
AIC 25146.368
BIC 25213.089
Log Likelihood -12561.184
Num. obs. 1920
Num. groups: session.code:participant.code 64
Var: session.code:participant.code (Intercept) 1326.815
Var: Residual 28163.109
***p < 0.001; **p < 0.01; *p < 0.05; ·p < 0.1

6 Additional Results

6.1 Benchmarks

# Typ: A, B (S1,S2) or C (DM)
# Treatm: Competition or Monopoly
#ref: the benchamrk
deviation <- function(Typ, Treatm,ref) {
x <- d |>
    filter((Type %in% Typ) & Treatment == Treatm) |>
    select(participant.code, Net_payoff) %>%
    group_by(participant.code) |>
    summarise_at("Net_payoff", ~ mean(.)) %>%
    pull(Net_payoff)

dev=x-ref

dev_perc <- dev / ref

return(
  paste(round(mean(dev_perc * 100), 3), " (", round(wilcox.test(dev_perc)$p.value, 3),")",sep="")
)
}
Benchmark DM S1 S2 TOT
Complete Info 600 800 800 2200
No Communication 400 800 800 2000
Cheap Talk 400 800 800 2000

Deviatons from benchmark in % terms

6.1.1 Competition

Benchmark DM S1 S2 TOT
Complete Info -17.361 (0) -7.629 (0.002) -15.074 (0) 2200
No Communication 23.958 (0) -7.629 (0.002) -15.074 (0) 2000
Cheap Talk 23.958 (0) -7.629 (0.002) -15.074 (0) 2000

6.1.2 Monopoly

Benchmark DM S1 S2 TOT
Complete Info -18.542 (0) -2.712 (0.214) -8.021 (0) 2200
No Communication 22.188 (0) -2.712 (0.214) -8.021 (0) 2000
Cheap Talk 22.188 (0) -2.712 (0.214) -8.021 (0) 2000

6.1.3 Equilibrium

SETTING - EQM DM S1 S2 TOT
MONO-MIE 600 483.09 800 1883.09
MONO-LIE 410.96 800 421.92 1694.05
COMP-MIE 600 483.09 Oor 800 800 or 483.09 1883.09
COMP-AE 449.08 561.84 561.84 1572.76
SETTING - EQM DM S1 S2 TOT
MONO-MIE -18.542 (0) 61.11 (0) -8.021 (0) 1883.09
MONO-LIE 18.929 (0) -2.712 (0.214) 74.401 (0) 1694.05
COMP-MIE -17.361 (0) 52.967 (0) or -7.629 (0.002) -15.074 (0) or 40.638 (0) 1883.09
COMP-AE 10.411 (0) 31.526 (0) 20.926 (0) 1572.76

6.2 Decision Times

# join choices and times
IDa <- d %>% filter(Type=="A") %>% distinct(participant.code) %>% pull() 
IDb <- d %>% filter(Type=="B") %>% distinct(participant.code) %>% pull() 
IDc <- d %>% filter(Type=="C") %>% distinct(participant.code) %>% pull() 

# codification error for session.code = 7lq6t6as, participant.code = yerm0n2w -> remove time on page =0 
d.j <- 
full_join(
d,
bind_rows(
d.t %>% filter(participant.code %in% IDa) %>% filter(page_name=="Slider_A") %>% filter(time_on_page!=0)%>% select(session_code, participant.code,time_on_page, round_number) %>% rename(Round=round_number,session.code=session_code),
d.t %>% filter(participant.code %in% IDb) %>% filter(page_name=="Slider_B") %>% filter(time_on_page!=0)%>% select(session_code, participant.code,time_on_page, round_number) %>% rename(Round=round_number,session.code=session_code),
d.t %>% filter(participant.code %in% IDc) %>% filter(page_name=="Slider_C") %>% filter(time_on_page!=0)%>% select(session_code, participant.code,time_on_page, round_number) %>% rename(Round=round_number,session.code=session_code)
),
by=c("session.code","participant.code","Round")
)

6.2.1 Sender

  • Times in Competition and Monopoly
d.j %>% filter(((Type == "A" | Type =="B") & Treatment=="Competition") | (Type == "A" & Treatment=="Monopoly")) %>% group_by(Treatment, participant.code) %>%
   summarise_at("time_on_page",mean) %>%
  summarise_at("time_on_page",list(N=~n(),Mean=~mean(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE))) %>% 
  kable() %>% kable_minimal()
Treatment N Mean SD Median
Competition 64 20.34948 9.681219 19.05000
Monopoly 32 20.53125 6.456521 19.61667
  • Test at the individual level
d.j %>% filter(((Type == "A" | Type =="B") & Treatment=="Competition") | (Type == "A" & Treatment=="Monopoly")) %>% group_by(Treatment, participant.code) %>%
  summarise_at("time_on_page",mean) %>% 
  with(wilcox.test(time_on_page~Treatment)) %>% tidy() %>%  
  kable() %>% kable_minimal()
statistic p.value method alternative
950.5 0.5704491 Wilcoxon rank sum test with continuity correction two.sided
  • Time to lie and tell the truth
d.j  %>% filter(((Type == "A" | Type =="B") & Treatment=="Competition") | (Type == "A" & Treatment=="Monopoly")) %>% 
  mutate(truth=ifelse((Type == "A" & Report_A == Drawn) | (Type == "B" & Report_B == Drawn), 1, 0)) %>%
  group_by(truth, participant.code) %>%
  summarise_at("time_on_page",mean) %>%
  summarise_at("time_on_page",list(N=~n(),Mean=~mean(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE))) %>% 
  kable()  %>% kable_minimal()
truth N Mean SD Median
0 89 26.20470 15.062432 22.58333
1 93 17.91894 6.732458 16.26087
  • Test at the individual level (average time when cheating and when not)
test <- 
d.j %>% filter(((Type == "A" | Type =="B") & Treatment=="Competition") | (Type == "A" & Treatment=="Monopoly")) %>% 
   mutate(truth=ifelse((Type == "A" & Report_A == Drawn) | (Type == "B" & Report_B == Drawn), 1, 0)) %>%
  group_by(truth, participant.code) %>%
  summarise_at("time_on_page",mean) 

wilcox.test(
full_join(test %>% filter(truth==0), test %>% filter(truth==1), by=c("participant.code")) %>% pull(time_on_page.x),
full_join(test %>% filter(truth==0), test %>% filter(truth==1), by=c("participant.code")) %>% pull(time_on_page.y),
paired=TRUE
) %>% tidy() %>%  
  kable() %>% kable_minimal()
statistic p.value method alternative
3254.5 0 Wilcoxon signed rank test with continuity correction two.sided

6.2.2 Decision Maker

  • Times in Competition and Monopoly
d.j %>% filter(Type=="C") %>% group_by(Treatment, participant.code) %>%
  summarise_at("time_on_page",mean) %>% 
  summarise_at("time_on_page",list(N=~n(),Mean=~mean(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE))) %>%  
  kable() %>% kable_minimal()
Treatment N Mean SD Median
Competition 32 13.45208 6.737085 12.03333
Monopoly 32 11.58229 4.656140 10.63333
  • Test at the individual level
statistic p.value method alternative
583 0.3438077 Wilcoxon rank sum test with continuity correction two.sided
  • Time to choose for conflicting values in Competition
d.j %>% filter(Type=="C"  & Treatment == "Competition") %>% mutate(conflicting=ifelse(Report_B!=0,ifelse((Report_A/Report_B)>0,0,1),ifelse(Report_A==0,0,1)))  %>%
  group_by(conflicting, participant.code) %>%
  summarise_at("time_on_page",mean) %>%
  summarise_at("time_on_page",list(N=~n(),Mean=~mean(.,na.rm=TRUE), SD=~sd(.,na.rm=TRUE), Median=~median(.,na.rm=TRUE))) %>%  
  kable() %>% kable_minimal()
conflicting N Mean SD Median
0 32 10.80826 5.888778 8.846154
1 32 16.50154 9.722316 14.444444
  • Test at the individual level (average time when conflicting and when not)
statistic p.value method alternative
57 3.18e-05 Wilcoxon signed rank exact test two.sided

6.3 Spectator Beliefs

Take median value of the intervals

# - Bel_A1: the probability that Player A is going to report the value truthfully
#1: 0%-20%; 2:21%-40%; 3:41%-60%; 4:61%-80%; 5:81%-100%<
# - Bel_A2: the probability that Player C is going to choose Black
#1: 0%-20%; 2:21%-40%; 3:41%-60%; 4:61%-80%; 5:81%-100%<
  
interval = list(.10, .30, .50, .70, .90) 

d.bel <- 
d %>% filter(Treatment=="Monopoly" & Type=="B") %>%
  select(Treatment,session.code,participant.code,Type,Round,Drawn,Report_A,Choice_C,  Bel_A1,  Bel_A2, Drawn, Report_A) %>%
  mutate(Bel_A1_perc=unlist(interval[Bel_A1])*100, Bel_A2_perc=unlist(interval[Bel_A2])*100)

6.3.1 Beliefs of truthful report (conditional upon signal)

positive N Mean SD Median
0 32 49.73235 11.35923 50.62500
1 32 67.27166 11.98553 66.30682
  • Test at the individual level (when drawning a positive and a negative value)
statistic p.value method alternative
20 2e-07 Wilcoxon signed rank exact test two.sided
  • Are beliefs correct?
truth_telling N Mean SD Median
0 418 55.16746 25.39087 50
1 542 60.88561 26.48108 70
statistic p.value method alternative
195 0.3035649 Wilcoxon signed rank test with continuity correction two.sided

6.3.2 Beliefs that DM chooses BLACK conditional upon reported value

positive N Mean SD Median
0 32 31.54433 16.38314 27.57143
1 32 68.96090 11.41990 70.00000
  • Test at the individual level (when the other reports a positive and a negative value)
statistic p.value method alternative
2.5 1.1e-06 Wilcoxon signed rank test with continuity correction two.sided
  • Are beliefs correct?
follows N Mean SD Median
0 447 41.09620 28.82462 30
1 513 69.61014 23.24807 70
statistic p.value method alternative
2 0 Wilcoxon signed rank exact test two.sided