09 Feb Plots

Plots

The following code generates the plots

Setup

library(data.table)
library(ggplot2)
library(themejj); theme_set(themejj(base_size=12)) # install_github(janajarecki/themejj)
# Helper functions: download the utils folder and maybe change the path path argument
sapply(list.files(path="utils/", pattern="*.R", full.names = TRUE), source, .GlobalEnv) # Throws some code, don't worry about this.

Figure 1

Before you run the first command, make sure you have received the data of the current article and received the data of Study 1 and Study 2 of Wilke et al (2014), since this code loads both data filed.

#Load the data and preprocess it
# This code assumes your data is in a folder called ../4-Data
# Open this file and change the location of your data file if necessary
source("Replication_Wilke_2014.R") # Source this code
# It may take a while since this file is running regression model.extract
# You can comment the command 'clmm()' out then this will read faster
d <- d[source != "Study 2 by Wilke et al. (2014)"] # exclude study 2

d.agg   <- d[, as.list(prop.table(table(lik))), by = list(source,dom)]
d.agg.m <- melt(d.agg, id.vars = 1:2, value.name = "Proportion", variable.name = "lik")
d.agg.m[, dom.long := factor(expanddomains(dom), levels = expanddomains(domains))]

ggplot(d, aes(lik, group=source)) +geom_bar(data = d.agg.m, aes(y = Proportion, fill = source), stat = "identity", position = "dodge", alpha = .8, width = .8, color = "black") +stat_density(geom = "line", position = "identity", aes(y = ..scaled../2, color = source, linetype = source), size = .7, bw = .6) +facet_wrap(~factor(gsub(" ","\n", expanddomains(dom)), levels = gsub(" ","\n", expanddomains(rskDom))), nrow = 2) +scale_fill_manual("Proportions", values = c("grey10", "white")) +scale_color_manual("Density", values = c("black", "black")) +scale_y_continuous("Response proportions", sec.axis = sec_axis(name = "Density Estimates", ~.*2, breaks = c(0,.7,1.4)), expand = c(0,0), limits = c(0,.71), breaks = c(0,.3,.7)) +scale_linetype_manual("Density",values=c(1,3)) +themejj(facet = T) +theme(legend.position = "top", legend.direction = "vertical", aspect.ratio = 1/1.4, panel.spacing.y = unit(.5, "line"), axis.line.x = element_blank(), plot.margin = unit(c(-.2,-.44,-.2,-.17), "lines"), strip.placement = "inside") +scale_x_discrete("Risk propensity", expand = c(.07,0))+ guides(fill = guide_legend(order = 1), color = "none", linetype = guide_legend(order = 2))
ggsave("figure1.tiff", h = 3.7, w = 7)

Figure 2

#####################################################################
# Mean effects
# We use normal mean effects help.request
library(lme4) # for general linear models
library(lsmeans) # for marginal effects
setwd("../5-Code")
source("Replication_Wilke_2014.R") # Source this code
# It may take a while since this file is running regression model.extract
# You can comment all but the first command 'clmm()' out then this will read faster
d.me <- summary(lsmeans(res.d.dom.fem, c("dom","fem"))) # data with mean effects
d.me <- as.data.table(d.me)
d.me[, lsmean.scaled := .((lsmean - mean(lsmean))/(max(lsmean)-min(lsmean)) + 0.45)]


#####################################################################
source("Situational_Attributes_of_Risk_Taking.R", chdir = TRUE) # This generates three datasets
# d.tally
# d.most.cues
# d.lex

plot.setup <- ggplot(NULL) +theme(
    panel.grid.major=element_line(color="grey80",linetype=3), 
    plot.margin=margin(1,0,1,0, "lines"),
    axis.title.x=element_blank(), 
    axis.ticks.x=element_blank(), 
    axis.text.x = element_text(angle=90,hjust=1,vjust=0.3), 
    legend.position = c(0.005,.97),
    legend.direction = "vertical",
    legend.margin=margin(t = -.1, r = .5, l = .1, b = .1, unit='cm'),
    legend.justification = "left") +
    facet_grid(~fem)

# Helper function to scale the data
do.datatables <- function(gender, domainlevels)
{
    # TALLY
    d.tally[, dom.f := factor(toupper(dom), levels = domainlevels)]
    d.tally.agg <- d.tally[fem==gender, .(y = mean(percent_more)), by = list(dom.f,fem)]
    # LEX
    d.lex[, dom.f := factor(toupper(dom), levels = domainlevels)]
    d.lex.agg <- d.lex[fem==gender, .(y = mean(is.more)), by = list(dom.f,fem)]
    # MOST COMMMON
    d.most[, dom.f := factor(toupper(dom), levels = domainlevels)]
    d.type.agg <- d.most[fem==gender, .(y = mean(mentions.most, na.rm = TRUE)), by=list(dom.f,fem)]

    return(list(
        d.tally.agg,
        d.lex.agg,
        d.type.agg))  
}

# Plot by gender that re-orders the x-axis values
do.plot.gender <- function(gender, i)
{
    domainlevels <- d.me[fem==gender][order(lsmean), dom, by=fem]$dom
    d.me.tmp <- d.me[, dom.f := factor(dom, levels = domainlevels)][]
    d.me.tmp <- d.me.tmp[fem==gender, c("dom.f", "fem", "lsmean.scaled")]
    setnames(d.me.tmp, "lsmean.scaled", "y")
    d.me.tmp[, Source := "Mean effect size (scaled, N = 120)" ]

    shapelegend.gender <- ifelse(gender == "Female",
        paste(shapelegends[i], "20-29)"),
        paste(shapelegends[i], "18-26)"))
    print(shapelegend.gender)

    datatables <- do.datatables(gender, domainlevels)
    dt.tmp <- datatables[[i]]
    dt.tmp[, Source := shapelegend.gender]

    d.combined <- rbind(dt.tmp, d.me.tmp)
    d.combined[, Source := factor(Source, levels = c(shapelegend.gender, "Mean effect size (scaled, N = 120)"))]

    p <- plot.setup +
        scale_y_continuous(limits=c(-.04,1), expand=c(0,0)) +
        geom_line( data=d.combined, aes(x=dom.f, y=y, color = Source, group = Source)) +
        geom_point(data=d.combined, aes(x=dom.f, y=y, shape = Source, color = Source), fill = "white") +
        scale_shape_manual(NULL, values=c(21,16)) +
        scale_colour_manual(NULL, values=c("grey30", "black"))

    return(p)
}

genders <- c("Female", "Male")

titles <- c(
    "A) Tally: More positive attributes increase risk seeking",
    "B) Take The First: First attribute positive increases risk seeking",
    "C) Most Relevant: Retrieving most-common attribute increases risk seeking")
yaxes <- c(
    "% positive attributes\nper domain",
    "% positive first attributes\nper domain",
    "% most-frequent attribute\nper domain")
shapelegends <- c(
    "Percent positive attributes (N =",
    "Percent positive first attributes (N =",
    "Percent people with most common attribute (of N ="
    )

pf1 <- do.plot.gender("Female", 1) +ylab(yaxes[1])
pf2 <- do.plot.gender("Female", 2) +ylab(yaxes[2])
pf3 <- do.plot.gender("Female", 3) +ylab(yaxes[3])
pm1 <- do.plot.gender("Male", 1) +ylab("")
pm2 <- do.plot.gender("Male", 2) +ylab("")
pm3 <- do.plot.gender("Male", 3) +ylab("")

library(gridExtra) # to combine plots
t1 <- textGrob(titles[1], x = unit(0, "lines"), y = unit(0, "lines"), hjust = 0, vjust = 0, gp=gpar(fontsize=14, fontfamily = "Roboto"))
t2 <- textGrob(titles[2], x = unit(0, "lines"), y = unit(0, "lines"), hjust = 0, vjust = 0, gp=gpar(fontsize=14, fontfamily = "Roboto")) 
t3 <- textGrob(titles[3], x = unit(0, "lines"), y = unit(0, "lines"), hjust = 0, vjust = 0, gp=gpar(fontsize=14, fontfamily = "Roboto"))


combined <- arrangeGrob(
    arrangeGrob(pf1,pm1, nrow=1, top=t1),
    arrangeGrob(pf2,pm2, nrow=1, top=t2),
    arrangeGrob(pf3,pm3, nrow=1, top=t3)
    )
plot(combined)

# Save the plot
ggsave(plot=combined, "combined.tiff", w = 9, h = 10, s = .8)