Week 6 Learning Log

Hi PSYC3361, welcome to my week 6 learning log!

Week 6 Goals

to finish reproducing Figure 1 from Tybur et al. (2020)
to finish reproducing Figure 2 from Tybur et al. (2020)

Challenges and Successes

It wasn’t too difficult to finish reproducing the figures this week. However,there were some parts that we just couldn’t work out.
Figure 1:
- We managed to manually add dashed lines in between the 3 study plots.
- We got the y-axis on the same intervals as the original plot.
- For some reason, my code isn’t working with the code that works for my teammates. Below is my plot, my teammates plot, and the original plot. The main thing is that it works for at least one of us, right? :D
- My plot also doesn’t have the figure 1: caption..I’m not sure what’s happened there…
- I also can’t seem to get rid of my study 2 y-axis. We tried the code that worked for my teammates and it just didn’t run, so my code is a work in progress, but as a team we successfully reproduced it.
- My x axis are also very squished together
- My Plot & Code:

Load Libraries

library(tidyverse)
library(patchwork)
library(ggplot2)
library(cowplot)

Load Data 1,2, & 3

data_1_raw <- read_csv('WTR_Comfort_S1.csv')
data_2 <- read_csv('WTR_Comfort_S2.csv')
data_3 <- read_csv('WTR_Comfort_S3.csv')

Plot Figure 1 for Study 1

data_1 <- data_1_raw %>%
  mutate(
    avg_cc = rowMeans(select(., comf1:comf10) -4)
    )

data_1$relationship_category <- as.factor(data_1$relationship_category)

Figure1_data_1 <- ggplot(data_1, 
                         aes(relationship_category, avg_cc)
                         ) +
                  geom_violin(
                    aes(
                      fill = relationship_category, 
                      alpha = .9)
                        ) +
                   geom_boxplot(
                     aes(
                       colour = NULL), 
                         outlier.colour = NULL,
                         outlier.shape = 16, 
                         outlier.size = 1, 
                         notch = FALSE,
                         width = 0.1, 
                         border=c(NULL),
  ) + 
  scale_x_discrete(
    name = NULL,
    labels = c('Romantic Partner', 'Friend', 'Acquaintance', 'Enemy')
  ) +
  scale_y_continuous(
    name = 'Contact Comfort', 
    n.breaks = 7) +
    labs(title = "Study 1") +
  theme(
    panel.background = element_rect(
      fill = "transparent", 
      color = NA),
        legend.position = "none", 
    plot.title = element_text(hjust = 0.5)
    ) +
  scale_fill_manual(
    values = c("#3F6485","#B17276", "#829966", "#FFDB6D")
    ) + 
  scale_colour_manual(values = c("#3F6485","#B17276", "#829966", "#FFDB6D")
                      )
                    
print(Figure1_data_1)

Plot Figure 1 for Study 2

data_2 <- data_2 %>%
  mutate(
    avg_cc = rowMeans(select(., comf1:comf10)-4)
    )

data_2$target_category <- as.factor(data_2$target_category)

Figure2_data_2 <- ggplot(data_2, 
                         aes(target_category, avg_cc)
                         ) +
  geom_violin(aes
              (fill = target_category, 
                alpha = .9)
              ) +
  geom_boxplot(aes
               (colour = NULL), 
               outlier.colour = NULL,
               outlier.shape = 16, 
               outlier.size = 1, 
               notch = FALSE,
               width = 0.1, 
               border=c(NULL),
               ) + 
  scale_x_discrete(
    name = NULL,
    labels = c('Friend', 'Acquaintance', 'Enemy')
    )+
  scale_y_continuous(NULL) +
  labs(title = "Study 2") +
  theme(
    panel.background = element_rect(
      fill = "transparent", color = NA),
    legend.position = "none", 
    plot.title = element_text(hjust = 0.5)
    ) +
  scale_fill_manual(
    values = c("#B17276", "#829966", "#FFDB6D")
    ) +
  scale_colour_manual(values = c("#B17276", "#829966", "#FFDB6D")
                      )
print(Figure2_data_2)

Plot Figure 1 for Study 3

data_3 <- data_3 %>%
  mutate(avg_cc = rowMeans(select(., comf1:comf10)-4))

data_3$Value = as.factor(data_3$Value)
data_3$Value = factor(data_3$Value, levels = c(1, 0))
                      
Figure3_data_3 <- ggplot(data_3, aes(Value, avg_cc)) +
  geom_violin(aes(fill = Value, alpha = .9)) +
  geom_boxplot(aes(colour = NULL), outlier.colour = NULL,
               outlier.shape = 16, outlier.size = 1, notch = FALSE,
               width = 0.1
  ) + scale_x_discrete(name = NULL,
                       labels = c('High-Value Stranger', 'Low-Value Stranger'
                                  ))+
  scale_y_continuous(name = 'Contact Comfort', n.breaks = 7) +
  labs(title = "Study 3") +
  theme(panel.background = element_rect(fill = "transparent", color = NA),
        legend.position = "none",
        plot.title = element_text(hjust = 0.5)) +
  scale_fill_manual(values = c("#B17276", "#3F6485" ))

print(Figure3_data_3)

Patch Study 1, 2 and 3 violin plots together

Figure1_data_1 + Figure2_data_2 + Figure3_data_3 +
  theme(
        axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        axis.title.y = element_blank()
        )

ggdraw() +
  draw_plot(Figure1_data_1 + Figure2_data_2 + Figure3_data_3 +
              theme(
                axis.text.y = element_blank(),
                axis.ticks.y = element_blank(),
                axis.title.y = element_blank()
                )) +
              draw_line(
                x=c(0.37, 0.37),
                y=c(0, 0.975),  
                colour = "dark grey", size = 1, linetype = 2
              ) +
              draw_line(
                x=c(0.7, 0.7),
                y=c(0, .975),  
                colour = "dark grey", size = 1, linetype = 2)

My teammates Figure 1:

Tybur et al. (2020) Figure 1:

Figure 2:
- We have almost totally replicated the Figure 2 plots
- We had some trouble with the scaling of the y-axis but managed to rectify that so that it matches the article.
- We just need to add “Target” above study 1 in the legend
- We would also like to figure out a way to have the circle in each box of the legend that matches the colour of the box and also for the dashed lines to match the background of the box. Not sure if that makes sense but if you compare our legend to the legend in the article, you may see it. This is very minor but it’s worth a try!
- Our legend is also very big compared to the original, and it’s overlapping the study 2 plot
- My Plot & Code:

Load Libraries

library(tidyverse)
library(patchwork)
library(ggplot2)
library(cowplot)

Load Data 1,2, & 3

data_1_raw = read_csv('WTR_Comfort_S1.csv')
data_2 = read_csv('WTR_Comfort_S2.csv')
data_3 = read_csv('WTR_Comfort_S3.csv')

Plot Figure 2 for Study 1

data_1<-filter(data_1,English_exclude==0)

rawCC<-data_1[,30:39]
rawCC<-as.data.frame(as.matrix(rawCC)-4)

rawWTR_1<-data_1[,c(49:40,59:50,69:60,79:70,89:80,99:90)]
rawWTR_1$'37_-13'[which(rawWTR_1$'37_-13'==-.45)]<-0
rawWTR_1$'23_-8'[which(rawWTR_1$'23_-8'==-.45)]<-0
rawWTR_1$'75_-26'[which(rawWTR_1$'75_-26'==-.45)]<-0
rawWTR_1$'19_-7'[which(rawWTR_1$'19_-7'==-.45)]<-0
rawWTR_1$'46_-16'[which(rawWTR_1$'46_-16'==-.45)]<-0
rawWTR_1$'68_-24'[which(rawWTR_1$'68_-24'==-.45)]<-0
rawWTRdummy<-as.matrix(rawWTR_1)
rawWTRdummy[rawWTRdummy!=0]<-1
rawWTR_1<-as.data.frame(rawWTRdummy)
rm(rawWTRdummy)
participantnumber <- 1
Caulsum <- matrix(,,ncol=9)
Caulsum <- Caulsum[-1,]
colnames(Caulsum) <- c("WTR37","WTR23","WTR75","WTR19","WTR46","WTR68","WTRTOTAL",'DS','HH')
wtrcal <- function(rawWTR) {
  rawWTR <- as.numeric(rawWTR)
  m <- seq(-35, 145, by = 20)
  if(sum(rawWTR) == 10){
    anchorWTR = 1.55
  }else if(sum(rawWTR) == 0){
    anchorWTR = -0.45
  }else{
    shiftcount = 0
    shiftpoint = 0
    for(i in 1:9){
      if((rawWTR[i] - rawWTR[i + 1]) == 1){
        shiftcount = shiftcount + 1
        shiftpoint <- (m[i] + m[i + 1])/2 + shiftpoint
      }
    }
    if (shiftcount > 2) {
      anchorWTR = NA
    } else {
      anchorWTR <- 0.01*shiftpoint/shiftcount
    }
  }
}
while (participantnumber <= nrow(data_1)) {
  dumx <- rawWTR_1[participantnumber,]
  dummysheetWTR <- matrix(data = dumx, ncol = 10, byrow = TRUE)
  colnames(dummysheetWTR) <- seq(-35, 145, by = 20)
  WTRAnchor <- apply(dummysheetWTR, 1, wtrcal)
  if(NA%in%WTRAnchor){
    WTRTotal<-NA
  }else{
    WTRTotal<-mean(WTRAnchor)
  }
  Caulperson <- matrix(c(WTRAnchor,WTRTotal), ncol = 9)
  Caulsum <- rbind(Caulsum,Caulperson)
  participantnumber<-participantnumber+1
}
Caulsum<-as.data.frame(Caulsum)
Caulsum<-round(Caulsum, digits = 3)
Caulsum<-mutate(Caulsum,dummy=c(1:501))
rawCC<-mutate(rawCC,dummy=c(1:501))
Caulsum<-merge.data.frame(Caulsum,rawCC,by='dummy')
Finaldata_1<-as.data.frame(filter(mutate(Caulsum,sex=data_1$sex,age=data_1$age,part_sex=data_1$part_sex,relation=data_1$relationship_category,
                                         income=data_1$income,part_age=data_1$part_age,part_leng=data_1$part_leng,spa=data_1$poli_soc,epa=data_1$poli_econ,
                                         trust=data_1$trust_gen), sex!=3))
Finaldata_1<-Finaldata_1[complete.cases(Finaldata_1$WTRTOTAL),]
Finaldata_1<-mutate(Finaldata_1,CC=unname(rowMeans(select(Finaldata_1,comf1:comf10))))

plot_1 = ggplot(Finaldata_1, aes(WTRTOTAL, CC)) +
  geom_point(aes(group=relation, color=as.factor(relation), alpha =.5), size=1.2, shape = 16, show.legend = FALSE) +
  geom_smooth(aes(group = relation, color=as.factor(relation), fill=as.factor(relation)), size=0.6, alpha =0.2, method = 'lm',  linetype = 'dashed') +
  geom_smooth(aes(color="black"), alpha =.7, size=.5, method = 'lm') +
  scale_colour_manual(values = c("#3F6485", "#B17276", "#829966", "#FFDB6D", "black")) +
  scale_fill_manual(labels = c('Romantic Partner', 'Friend', 'Acquaintance', 'Enemy'), values = c("#3F6485", "#B17276", "#829966", "#FFDB6D", "black")) +
  scale_y_continuous(
    name= 'Contact Comfort',
    n.breaks = 7
  ) +
  scale_x_continuous(
    name = 'WTR',
    breaks = c(-0.45, 0.05, 0.55, 1.05, 1.55)
  ) +
  theme(
    panel.background = element_rect(fill = NA),
    plot.background = element_rect(fill = NA, color = NA),
    panel.border = element_rect(fill = "transparent", colour = NA),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    plot.title = element_text(hjust = 0.5),
    axis.line.x.bottom = element_line(color = 'black'),
    axis.line.y.left = element_line(color = 'black'),
  ) +
  guides(
    colour = FALSE
  ) +
  labs(
    fill = 'Study 1'
  ) +
  ggtitle("Study 1")

Plot Figure 2 for Study 2

data_2<-filter(data_2,English_exclude==0)
rawCC<-data_2[,45:54]
rawCC<-as.data.frame(as.matrix(rawCC)-4)
rawWTR_2<-data_2[,c(64:55,74:65,84:75)]
rawWTR_2$'75_-26'[which(rawWTR_2$'75_-26'==-.45)]<-0
rawWTR_2$'19_-7'[which(rawWTR_2$'19_-7'==-.45)]<-0
rawWTR_2$'46_-16'[which(rawWTR_2$'46_-16'==-.45)]<-0
rawWTRdummy<-as.matrix(rawWTR_2)
rawWTRdummy[rawWTRdummy!=0]<-1
rawWTR_2<-as.data.frame(rawWTRdummy)
rm(rawWTRdummy)
participantnumber <- 1
Caulsum <- matrix(,,ncol=7)
Caulsum <- Caulsum[-1,]
colnames(Caulsum) <- c("WTR75","WTR19","WTR46","WTRTOTAL",'DS','HH','AG')
wtrcal <- function(rawWTR) {
  rawWTR <- as.numeric(rawWTR)
  m <- seq(-35, 145, by = 20)
  if(sum(rawWTR) == 10){
    anchorWTR = 1.55
  }else if(sum(rawWTR) == 0){
    anchorWTR = -0.45
  }else{
    shiftcount = 0
    shiftpoint = 0
    for(i in 1:9){
      if((rawWTR[i] - rawWTR[i + 1]) == 1){
        shiftcount = shiftcount + 1
        shiftpoint <- (m[i] + m[i + 1])/2 + shiftpoint
      }
    }
    if (shiftcount > 2) {
      anchorWTR = NA
    } else {
      anchorWTR <- 0.01*shiftpoint/shiftcount
    }
  }
}
while (participantnumber <= nrow(data_2)) {
  dumx <- rawWTR_2[participantnumber,]
  dummysheetWTR <- matrix(data = dumx, ncol = 10, byrow = TRUE)
  colnames(dummysheetWTR) <- seq(-35, 145, by = 20)
  WTRAnchor <- apply(dummysheetWTR, 1, wtrcal)
  if(NA%in%WTRAnchor){
    WTRTotal<-NA
  }else{
    WTRTotal<-mean(WTRAnchor)
  }
  Caulperson <- matrix(c(WTRAnchor,WTRTotal), ncol = 7)
  Caulsum <- rbind(Caulsum,Caulperson)
  participantnumber<-participantnumber+1
}
Caulsum<-as.data.frame(Caulsum)
Caulsum<-round(Caulsum, digits = 3)
Caulsum<-mutate(Caulsum,dummy=c(1:nrow(Caulsum)))
rawCC<-mutate(rawCC,dummy=c(1:nrow(Caulsum)))
Caulsum<-merge.data.frame(Caulsum,rawCC,by='dummy')
rawCombine<-mutate(as.data.frame(data_2[,c(2:8,36:44)]),dummy=c(1:nrow(data_2)))
Finaldata_2<-merge.data.frame(Caulsum,rawCombine,by='dummy')
Finaldata_2<-as.data.frame(filter(Finaldata_2, sex!=3))
Finaldata_2<-Finaldata_2[complete.cases(Finaldata_2$WTRTOTAL),]
Finaldata_2<-mutate(Finaldata_2,CC=unname(rowMeans(select(Finaldata_2,comf1:comf10))))

plot_2 = ggplot(Finaldata_2, aes(WTRTOTAL, CC)) +
  geom_point(aes(group = target_category, colour = as.factor(target_category), alpha = 0.5), shape = 16, size = 1.2, show.legend = FALSE) +
  geom_smooth(aes(group = target_category, colour = as.factor(target_category), fill = as.factor(target_category)), size = 0.6, alpha = 0.2, method = 'lm', linetype = 'dashed') +
  geom_smooth(aes(colour = 'black'), size = 0.6, alpha = 0.7, method = 'lm') +
  scale_y_continuous(
    name = 'Contact Comfort',
    n.breaks = 7
  ) +
  scale_x_continuous(
    name = 'WTR',
    breaks = c(-0.45, 0.05, 0.55, 1.05, 1.55)
  ) +
  scale_colour_manual(values = c('#B17276', '#829966', '#E89B39', 'black')) +
  scale_fill_manual(labels = c('Friend', 'Acquaintance', 'Enemy'), values = c('#B17276', '#829966', '#E89B39', 'black')) +
  theme(
    panel.background = element_rect(fill = NA),
    plot.background = element_rect(fill = NA, color = NA),
    panel.border = element_rect(fill = "transparent", colour = NA),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    plot.title = element_text(hjust = 0.5),
    axis.line.x.bottom = element_line(color = 'black'),
    axis.line.y.left = element_line(color = 'black')
  ) +
  guides(
    colour = FALSE
  ) +
  labs(
    fill = 'Study 2'
  ) +
  ggtitle('Study 2')

Plot Figure 2 for Study 3

rawCC<-data_3[,27:36]
rawCC<-as.data.frame(as.matrix(rawCC)-4)
part_sex<-ifelse(data_3$Target<20.5,yes =1,no=2)
part_att<-ifelse(data_3$Target<20.5,yes = data_3$Target,no=data_3$Target-20)
rawWTR_3<-data_3[,c(47:38,57:48,67:58)]
rawWTR_3$'75_-26'[which(rawWTR_3$'75_-26'==-.45)]<-0
rawWTR_3$'19_-7'[which(rawWTR_3$'19_-7'==-.45)]<-0
rawWTR_3$'46_-16'[which(rawWTR_3$'46_-16'==-.45)]<-0
rawWTRdummy<-as.matrix(rawWTR_3)
rawWTRdummy[rawWTRdummy!=0]<-1
rawWTR_3<-as.data.frame(rawWTRdummy)
rm(rawWTRdummy)
participantnumber <- 1
Caulsum <- matrix(,,ncol=5)
Caulsum <- Caulsum[-1,]
colnames(Caulsum) <- c("WTR75","WTR19","WTR46","WTRTOTAL",'DS')
wtrcal <- function(rawWTR) {
  rawWTR <- as.numeric(rawWTR)
  m <- seq(-35, 145, by = 20)
  if (sum(rawWTR) == 10) {
    anchorWTR = 1.55
  } else if (sum(rawWTR) == 0){
    anchorWTR = -0.45
  } else {
    shiftcount = 0
    shiftpoint = 0
    for (i in 1:9) {
      if ((rawWTR[i] - rawWTR[i + 1]) == 1) {
        shiftcount = shiftcount + 1
        shiftpoint <- (m[i] + m[i + 1])/2 + shiftpoint
      }
    }
    if (shiftcount > 2) {
      anchorWTR = NA
    } else {
      anchorWTR <- 0.01*shiftpoint/shiftcount
    }
  }
}
while (participantnumber <= nrow(data_3)) {
  dumx <- rawWTR_3[participantnumber,]
  dummysheetWTR <- matrix(data = dumx, ncol = 10, byrow = TRUE)
  colnames(dummysheetWTR) <- seq(-35, 145, by = 20)
  WTRAnchor <- apply(dummysheetWTR, 1, wtrcal)
  if(NA%in%WTRAnchor){
    WTRTotal<-NA
  }else{
    WTRTotal<-mean(WTRAnchor)
  }
  Caulperson <- matrix(c(WTRAnchor,WTRTotal), ncol = 5)
  Caulsum <- rbind(Caulsum,Caulperson)
  participantnumber<-participantnumber+1
}
Caulsum<-as.data.frame(Caulsum)
Caulsum<-round(Caulsum, digits = 3)
Caulsum<-mutate(Caulsum,dummy=c(1:nrow(Caulsum)))
rawCC<-mutate(rawCC,dummy=c(1:nrow(Caulsum)))
Caulsum<-merge.data.frame(Caulsum,rawCC,by='dummy')
Finaldata_3<-mutate(Caulsum,sex=data_3$sex,age=data_3$age,value=data_3$Value,part_sex,part_att,faces=data_3$Target)
Finaldata_3<-as.data.frame(filter(Finaldata_3, sex!=3))
Finaldata_3<-Finaldata_3[complete.cases(Finaldata_3$WTRTOTAL),]
Finaldata_3<-mutate(Finaldata_3,CC=unname(rowMeans(select(Finaldata_3,comf1:comf10))))

plot_3 = ggplot(Finaldata_3, aes(WTRTOTAL, CC)) +
  geom_point(aes(group = value, colour = as.factor(value), alpha = 0.5), shape = 16, size = 0.7, show.legend = FALSE) +
  geom_smooth(aes(group = value, colour = as.factor(value), fill = as.factor(value)), size = 0.6, alpha = 0.2, method = 'lm', linetype = 'dashed') +
  geom_smooth(aes(colour = 'black'), size = 0.6, alpha = 0.7, method = 'lm') +
  scale_y_continuous(
    name = 'Contact Comfort',
    limits = c(-3, 3),
    n.breaks = 7,
  ) +
  scale_x_continuous(
    name = 'WTR',
    breaks = c(-0.45, 0.05, 0.55, 1.05, 1.55)
  ) +
  scale_colour_manual(values = c('#86699A', '#6494A3', 'black')) +
  scale_fill_manual(labels = c('High-Value Stranger', 'Low-Value Stranger'), values = c('#86699A', '#6494A3', 'black')) +  theme(
    panel.background = element_rect(fill = NA),
    plot.background = element_rect(fill = NA, color = NA),
    panel.border = element_rect(fill = "transparent", colour = NA),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    plot.title = element_text(hjust = 0.5),
    axis.line.x.bottom = element_line(color = 'black'),
    axis.line.y.left = element_line(color = 'black')
  ) + 
  guides(
    colour = FALSE
  ) +
  labs(
    fill = 'Study 3'
  ) +
  ggtitle('Study 3')

Stitch the plots together

plot_1 + plot_2 + plot_3 + guide_area() + plot_layout(nrow = 2, guides = "collect")

Tybur et al. (2020) Figure 2:

## Week 7 Goals - To complete the last bits of aesthetics for our plots - To begin our verification report - To successfully transfer our code from R to R Markdown

Week 7 Questions for Q&A

How to have the circle in each box of the legend that matches the colour of the box and also for the dashed lines to match the background of the box. Not sure if that makes sense but if you compare our legend to the legend in the article, you may see it. This is very minor but it’s worth a try!