Continuous Age Predictor

In the manuscript we examined whether images belonging to the same or different emotion categories were more likely to be placed near one another. Age was binned into 4 age groups. In the following analysis, we show sorting by emotion category across child age (as a continuous predictor) with a LOESS regression fit. We see a qualitative shift around 5 years of age in sorting by emotion category.

avg_dist_diff_cat_by_subj <- subj_dist_long %>%
  group_by(subject, Age, Gender, age_bin,age_group,sort,category_pair) %>%
  summarize(avg_dist=mean(dist,na.rm=T))  %>%
  ungroup() %>%
  group_by(subject, Age, Gender, age_bin,age_group,sort) %>%
  pivot_wider(names_from=category_pair,values_from=avg_dist) %>%
  mutate(avg_dist_diff=between-within) %>%
  mutate(sort_name=ifelse(sort=="Sort1","Same Individual",ifelse(sort=="Sort2","Different Individuals","Practice"))) %>%
  ungroup()

ggplot(filter(avg_dist_diff_cat_by_subj,age_group=="kids"&sort!="Practice"),aes(Age,avg_dist_diff))+
  geom_point()+
  geom_smooth(size=2)+
  geom_hline(yintercept=0)+
  facet_wrap(~sort_name)+
  ylab("Sorting by Emotion Categories \nLow<------------------------>High")+
  xlab("Age (in years)")

Basic Emotions

In the manuscript we examined whether images belonging to the same or different emotion categories were more likely to be placed near one another. However, since some individuals might object to including emotion categories like “neutral” or “calm”, we ran an additional analysis where we only included basic emotions: anger, disgust, fear, happiness, sadness, and surprise. We found the same pattern of results as when all emotion categories are included.

# Plot
p <- ggplot(filter(avg_dist_diff_cat_across_subj, sort!="Practice"),aes(x=sort_name,y=average_dist,fill=age_bin,color=age_bin, linetype=sort_name))+
  geom_errorbar(aes(ymin=average_dist-ci_dist,ymax=average_dist+ci_dist),width=0,size=1)+
  geom_point(size=2.5)+
  facet_wrap(~age_bin,nrow=1, labeller = age_labeller, strip.position = c("bottom"))+
  geom_hline(yintercept=0)+
  theme(legend.position=c(.1,.8), legend.title = element_blank(),
        legend.margin = margin(.5,.5,.5,.5,"cm"),
        legend.background = element_rect(fill="white",size=0.6,
                                         linetype="solid", colour ="black")) +
  scale_color_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  guides(color=FALSE) +
  guides(fill=FALSE) +
  ylab("Sorting by Emotion Categories \nLow<------------------------>High")+
  xlab("Age Group")+
  ylim(-.1,.3) +
  labs(linetype = "Sorting Phase") +
  theme(axis.line = element_blank(),
    axis.text.x  = element_blank(),
        axis.ticks.x= element_blank(),
        axis.title.x = element_text(size=20,face="bold"),
        axis.text.y =  element_text(size=18),
        axis.title.y= element_text(size=18,face="bold"),
        strip.text.x = element_text(size=18)) #+
p

Emotion Category

In the manuscript we examined whether images belonging to the same or different emotion categories were more likely to be placed near one another. Here we show this analysis in more detail by showing the effect for each individual emotion category, rather than collapsing across all categories. Overall, we see similar effects across each emotion category.

p <- ggplot(avg_dist_diff_cat_across_subj,aes(x=age_bin,y=average_dist,fill=age_bin,color=age_bin, linetype=sort_name))+
  geom_errorbar(aes(ymin=average_dist-ci_dist,ymax=average_dist+ci_dist),width=0,size=1, position=position_dodge(width=0.5))+
  geom_point(size=1.5, position=position_dodge(width=0.5))+
  facet_wrap(~shared_category_labels, nrow=3, strip.position = c("top"))+
  geom_hline(yintercept=0)+
  scale_color_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  ylab("Sorting by Emotion Category \nLow<------------------------>High")+
  xlab("Age Group")+
  labs(linetype = "Sorting Phase:", color = "Age:", fill = "Age:") +
  theme(legend.position="top", legend.box = "vertical", legend.justification = "center") +
  theme(axis.line = element_blank(),
    axis.text.x  = element_blank(),
        axis.ticks.x= element_blank(),
        axis.title.x = element_text(size=20,face="bold"),
        axis.text.y =  element_text(size=18),
        axis.title.y= element_text(size=18,face="bold"),
        strip.text.x = element_text(size=18))
p

Mouth Position

Each emotion category had one image with an open mouth and one image with a closed mouth. Since features of the mouth can sometimes influence emotion categorization in children (Caron, Caron & Myers, 1985) we investigated whether mouth position influenced sorting behaviors. Overall we did not find strong evidence that participants were using mouth position to guide their sorting behaviors.

# Plot
p <- ggplot(filter(avg_dist_diff_cat_across_subj, sort!="Practice"),aes(x=sort_name,y=average_dist,fill=age_bin,color=age_bin, linetype=sort_name))+
  geom_errorbar(aes(ymin=average_dist-ci_dist,ymax=average_dist+ci_dist),width=0,size=1)+
  geom_point(size=2.5)+
  facet_wrap(~age_bin,nrow=1,labeller = age_labeller, strip.position = c("bottom"))+
  geom_hline(yintercept=0)+
  theme(legend.position=c(.1,.8), legend.title = element_blank(),
        legend.margin = margin(.5,.5,.5,.5,"cm"),
        legend.background = element_rect(fill="white",size=0.6,
                                         linetype="solid", colour ="black")) +
  scale_color_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  guides(color=FALSE) +
  guides(fill=FALSE) +
  ylab("Sorting by Mouth Position\nLow<------------------------>High")+
  xlab("Age Group")+
  ylim(-.1,.3) +
  labs(linetype = "Sorting Phase") +
  theme(axis.line = element_blank(),
    axis.text.x  = element_blank(),
        axis.ticks.x= element_blank(),
        axis.title.x = element_text(size=20,face="bold"),
        axis.text.y =  element_text(size=18),
        axis.title.y= element_text(size=18,face="bold"),
        strip.text.x = element_text(size=18)) #+
p

Actor Gender

For actor gender, we only examine the Different Individuals Sort (the Same Individual Sort was all one individual). Here, we look at whether an image was more likely to be placed by another image of the same gender. For instance, participants may have been more likely to place a female face with other female faces.

Overall we don’t find that participants are using actor gender to guide their behaviors. Adults were actually more likely to put actors of the same gender further apart from one another. We believe this is because adults were more likely to use emotion category to guide behavior. During the Different Individuals Sort, each emotion category had one female exemplar and one male exemplar. Thus, using actor gender to guide sorting behavior would cause individuals to use emotion category less.

p <- ggplot(filter(avg_dist_diff_cat_across_subj, sort!="Practice"),aes(x=sort_name,y=average_dist,fill=age_bin,color=age_bin, linetype=sort_name))+
  geom_errorbar(aes(ymin=average_dist-ci_dist,ymax=average_dist+ci_dist),width=0,size=1)+
  geom_point(size=1.5)+
  facet_wrap(~age_bin,nrow=1, labeller = age_labeller, strip.position = c("bottom"))+
  geom_hline(yintercept=0)+
  theme(legend.position=c(.1,.8), legend.title = element_blank(),
        legend.margin = margin(.5,.5,.5,.5,"cm"),
        legend.background = element_rect(fill="white",size=0.6,
                                         linetype="solid", colour ="black")) +
  scale_color_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  guides(color=FALSE) +
  guides(fill=FALSE) +
  ylab("Sorting by Actor Gender \nLow<------------------------>High")+
  xlab("Age Group")+
  ylim(-.1,.3) +
  theme(axis.line = element_blank(),
    axis.text.x  = element_blank(),
        axis.ticks.x= element_blank(),
        axis.title.x = element_text(size=20,face="bold"),
        axis.text.y =  element_text(size=18),
        axis.title.y= element_text(size=18,face="bold"),
        strip.text.x = element_text(size=18)) #+
p

Resample w/ equal between and within observations

One possible concern with the above analyses is that there are an unequal numbers of distance observations for the same versus different category pairs: in particular, there are a far greater number of between-category than within-category distance observations. Does this bias the estimates of average distance between within- vs. between-category pairs systematically?

To investigate this question, we conducted an analysis in which we compared our original average distance estimates to estimates derived by resampling from the data such that only equal numbers of between and within observations were considered when computing average distance for within- vs. between-category pairs. For each resampled estimate, we randomly sampled (without replacement) 9 random between-category pairings (e.g., happy vs. sad) from each sort (Same Individual and Different Individual) and retained all 9 within-category pairings (e.g., happy vs. happy) from each sort. Thus, for each resampled dataset, there was an equal number of between-category and within-category observations among the 18 observations per participant and sort. For each age group and sorting condition, we then computed the difference between the average distance for between-category pairings and the average distance for within-category pairings to obtain a resampled estimate of the tendency to arrange images by category. We resampled from the dataset in this fashion 1000 times, thus obtaining 1000 resampled estimates of the category-based difference in sorting (see the analysis script 6_resample_category_difference_equal_obs.R for the precise code).

The plot below compares these resampled estimates to the original estimate of the category-based sorting effect (based on the entire dataset), as reported in the main manuscript. We show each resampled estimate of the category-based sorting difference, along with violin plots to visualize their distribution. The large colored dots represent the mean of the resampled estimates and the original mean category-based sorting effect. We also show the 95% CI for the original category-based sorting estimate. The main takeaway from the plot is that the original estimate and the resampled estimates (always computed with an equal number of between-category and within-category estimates) are virtually identical. This indicates that the unequal numbers of between vs. within observations contributing to the original estimate are not systematically biasing the estimate of the category-based sorting effect.

#load the resampled data
summarized_resample_data <- read.csv( here(root_path,"analysis","paper_2020","processed_data","resampled_equal_obs_avg_category_distance.csv"))

#generate plot
# for facet wrap naming
age_names <- list(
  '3 to 4'="3 y/o",
  '4 to 5'="4 y/o",
  '5 to 6'="5 y/o",
  '6 to 7'="6 y/o",
  'adults'="adults")
age_labeller <- function(variable,value){
  return(age_names[value])
}

#recreate data from original emotion category plot
#focus on differences in dist (same v. between categories)
avg_dist_diff_cat_by_subj <- subj_dist_long %>%
  group_by(subject, Age, Gender, age_bin,age_group,sort,category_pair) %>%
  summarize(avg_dist=mean(dist,na.rm=T))  %>%
  ungroup() %>%
  group_by(subject, Age, Gender, age_bin,age_group,sort) %>%
  pivot_wider(names_from=category_pair,values_from=avg_dist) %>%
  mutate(avg_dist_diff=between-within) %>%
  mutate(sort_name=ifelse(sort=="Sort1","Same Individual",ifelse(sort=="Sort2","Different Individuals","Practice"))) %>%
  ungroup()

#average across subjects  by age bin
avg_dist_diff_cat_across_subj <- avg_dist_diff_cat_by_subj %>%
  select(-between,-within) %>%
  group_by(age_bin,age_group,sort,sort_name) %>%
  summarize(N=n(),average_dist=mean(avg_dist_diff,na.rm=T),ci_dist=qt(0.975, N-1)*sd(avg_dist_diff,na.rm=T)/sqrt(N))

# combine with the resampled data
comparison_data <- summarized_resample_data %>%
  mutate(resample_group="resampled") %>%
  bind_rows(filter(avg_dist_diff_cat_across_subj,sort!="Practice") %>% mutate(resample_group="original"))

p1 <- ggplot(filter(comparison_data, sort_name=="Same Individual"),aes(x=resample_group,y=average_dist,fill=age_bin,color=age_bin))+
  geom_violin(data=filter(comparison_data,resample_group=="resampled"&sort_name=="Same Individual"),fill=NA)+
  geom_jitter(data=filter(comparison_data,resample_group=="resampled"&sort_name=="Same Individual"),alpha=0.01,width=0.1)+
  geom_errorbar(data=filter(comparison_data,resample_group=="original"&sort_name=="Same Individual"),aes(ymin=average_dist-ci_dist,ymax=average_dist+ci_dist),width=0,size=1)+
  geom_point(data=filter(comparison_data,resample_group=="original"&sort_name=="Same Individual"),size=4,alpha=1)+
  stat_summary(data=filter(comparison_data,resample_group=="resampled"&sort_name=="Same Individual"),fun = "mean", geom = "point",size=4)+
  facet_wrap(~age_bin,nrow=1, labeller = age_labeller, strip.position = c("top"))+
  geom_hline(yintercept=0)+
  theme(legend.position=c(.1,.8), legend.title = element_blank(),
        legend.margin = margin(.5,.5,.5,.5,"cm"),
        legend.background = element_rect(fill="white",size=0.6,
                                         linetype="solid", colour ="black")) +
  #theme(legend.position='top', legend.justification ='center')+
  scale_color_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  scale_fill_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  guides(color=FALSE) +
  guides(fill=FALSE) +
  #scale_y_continuous(breaks=c(0,0.1,0.2,0.3, 0.4, 0.5,0.6), limits=c(0,0.5))+
  ylab("Sorting by Emotion Categories \nLow<----------------------------------->High")+
  xlab("Estimates")+
  labs(linetype = "Sorting Phase") +
  ggtitle("Same Individual Sort")+
  theme(#axis.line = element_blank(),
    #axis.text.x  = element_blank(),
    #axis.ticks.x= element_blank(),
    axis.text.x  = element_text(angle=90, vjust=0.5, size=10),
    axis.title.x = element_text(size=14,face="bold"),
    axis.text.y =  element_text(size=12),
    axis.title.y= element_text(size=12,face="bold"),
    strip.text.x = element_text(size=12),
    plot.title = element_text(hjust = 0.5,size=14))
p2 <- ggplot(filter(comparison_data, sort_name=="Different Individuals"),aes(x=resample_group,y=average_dist,fill=age_bin,color=age_bin))+
  geom_violin(data=filter(comparison_data,resample_group=="resampled"&sort_name=="Different Individuals"),fill=NA)+
  geom_jitter(data=filter(comparison_data,resample_group=="resampled"&sort_name=="Different Individuals"),alpha=0.01,width=0.1)+
  geom_errorbar(data=filter(comparison_data,resample_group=="original"&sort_name=="Different Individuals"),aes(ymin=average_dist-ci_dist,ymax=average_dist+ci_dist),width=0,size=1)+
  geom_point(data=filter(comparison_data,resample_group=="original"&sort_name=="Different Individuals"),size=4,alpha=1)+
  stat_summary(data=filter(comparison_data,resample_group=="resampled"&sort_name=="Different Individuals"),fun = "mean", geom = "point",size=4)+
  facet_wrap(~age_bin,nrow=1, labeller = age_labeller, strip.position = c("top"))+
  geom_hline(yintercept=0)+
  theme(legend.position=c(.1,.8), legend.title = element_blank(),
        legend.margin = margin(.5,.5,.5,.5,"cm"),
        legend.background = element_rect(fill="white",size=0.6,
                                         linetype="solid", colour ="black")) +
  #theme(legend.position='top', legend.justification ='center')+
  scale_color_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  scale_fill_manual(values=c("#8c510a","#bf812d","#80cdc1","#35978f","#01665e"))+
  guides(color=FALSE) +
  guides(fill=FALSE) +
  #scale_y_continuous(breaks=c(0,0.1,0.2,0.3, 0.4, 0.5,0.6), limits=c(0,0.5))+
  ylab("Sorting by Emotion Categories \nLow<----------------------------------->High")+
  xlab("Estimates")+
  labs(linetype = "Sorting Phase") +
  ggtitle("Different Individuals Sort")+
  theme(#axis.line = element_blank(),
    #axis.text.x  = element_blank(),
    #axis.ticks.x= element_blank(),
    axis.text.x  = element_text(angle=90, vjust=0.5, size=10),
    axis.title.x = element_text(size=14,face="bold"),
    axis.text.y =  element_text(size=12),
    axis.title.y= element_text(size=12,face="bold"),
    strip.text.x = element_text(size=12),
    plot.title = element_text(hjust = 0.5,size=14))
plot_grid(p1,p2,nrow=1,labels=c("A","B"),label_size=14)

Valence

ggplot(aes(x=dist_valence,y=dist,color=age_group,fill=age_group,linetype=sort2), data=dimension_data) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Valence Ratings Between Images")+
  labs(color="Age Group", linetype = "Sort") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Arousal

ggplot(aes(x=dist_arousal,y=dist,color=age_group,fill=age_group,linetype=sort2), data=dimension_data) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Arousal Ratings Between Images")+
  labs(color="Age Group", linetype = "Sort") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Positivity

ggplot(aes(x=dist_pos,y=dist,color=age_group,fill=age_group,linetype=sort2), data=dimension_data) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Positivity Ratings Between Images")+
  labs(color="Age Group", linetype = "Sort") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Negativity

ggplot(aes(x=dist_neg,y=dist,color=age_group,fill=age_group,linetype=sort2), data=dimension_data) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Negativity Ratings Between Images")+
  labs(color="Age Group", linetype = "Sort") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Valence

ggplot(aes(x=dist_valence,y=dist,color=age_bin2,fill=age_bin2), data=filter(dimension_data,age_bin!="adults")) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Valence Ratings Between Images")+
  labs(color="Age Group") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Arousal

ggplot(aes(x=dist_arousal,y=dist,color=age_bin2,fill=age_bin2), data=filter(dimension_data,age_bin!="adults")) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Arousal Ratings Between Images")+
  labs(color="Age Group") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Positivity

ggplot(aes(x=dist_pos,y=dist,color=age_bin2,fill=age_bin2), data=filter(dimension_data,age_bin!="adults")) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Positivity Ratings Between Images")+
  labs(color="Age Group") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Negativity

ggplot(aes(x=dist_neg,y=dist,color=age_bin2,fill=age_bin2), data=filter(dimension_data,age_bin!="adults")) + 
  geom_smooth(method="glm") +
  ylab("Average Distance Between Images")+
  xlab("Diff. in Negativity Ratings Between Images")+
  labs(color="Age Group") +
  guides(fill="none") +
  theme(axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))

Valence plots

The left plot displays the full Model R-squared for each age group. The right plot displays the Delta R-squared for each predictor of sorting behavior. Error bars represent bootstrapped 95% confidence intervals.

pA <- ggplot(drsq_v_a_ec,aes(minus_model_name,delta_rsq,  fill=minus_model_name))+
  geom_bar(stat="identity",color="black")+
  geom_hline(yintercept=0,color="black")+
  geom_errorbar(aes(ymin=delta_rsq_lower,ymax=delta_rsq_upper),width=0.1)+
  scale_fill_viridis_d(
                    name = " ", #Model Predictor
                    limits=c("dist_valence","dist_arousal","emotion_pair_same"),
                    breaks=c("dist_valence","dist_arousal","emotion_pair_same"),
                    labels=c("Valence","Arousal","Emotion Category"))+
  scale_x_discrete(
    limits=c("dist_valence","dist_arousal","emotion_pair_same"),
    breaks=c("dist_valence","dist_arousal","emotion_pair_same"),
    labels=c("Valence","Arousal","Same Emotion Category"))+
  theme(axis.text.x  = element_text(angle=90, vjust=0.5,size=18),
        axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14),
        legend.text =element_text(size=14),
        legend.title =element_text(size=16,face="bold"))+
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())+
  ylab("Delta R Squared")+
  facet_wrap(~age_bin,nrow=1, strip.position = "top")+
  theme(legend.position=c(0.1,0.8))

pB <- ggplot(unique(select(drsq_v_a_ec,age_bin,full_model_rsq)),aes(age_bin,full_model_rsq,  fill=age_bin))+
  geom_bar(stat="identity",color="black")+
  geom_hline(yintercept=0,color="black")+
  theme(axis.text.x  = element_text(angle=90, vjust=0.5,size=14),
        axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))+
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())+
  ylab("Model R Squared")+
  xlab("Age Group")+
theme(legend.position=c(0.1,0.8))
plot_grid(pB,pA)

Pos-Neg plots

The left plot displays the full Model R-squared for each age group. The right plot displays the Delta R-squared for each predictor of sorting behavior. Error bars represent bootstrapped 95% confidence intervals.

pA <- ggplot(drsq_pn_a_ec,aes(minus_model_name,delta_rsq,  fill=minus_model_name))+
  geom_bar(stat="identity",color="black")+
  geom_hline(yintercept=0,color="black")+
  geom_errorbar(aes(ymin=delta_rsq_lower,ymax=delta_rsq_upper),width=0.1)+
  scale_fill_brewer(palette="Set1",
                    name = " ", #Model Predictor
                    limits=c("dist_pos","dist_neg","dist_arousal","emotion_pair_same"),
                    breaks=c("dist_pos","dist_neg","dist_arousal","emotion_pair_same"),
                    labels=c("Positive","Negative","Arousal","Same Emotion Category"))+
  scale_x_discrete(
    limits=c("dist_pos","dist_neg","dist_arousal","emotion_pair_same"),
    breaks=c("dist_pos","dist_neg","dist_arousal","emotion_pair_same"),
    labels=c("Positive","Negative","Arousal","Same Emotion Category"))+
  theme(axis.text.x  = element_text(angle=90, vjust=0.5,size=14),
        axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))+
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())+
  ylab("Delta R Squared")+
  facet_wrap(~age_bin,nrow=1)+
  theme(legend.position=c(0.1,0.9))

pB <- ggplot(unique(select(drsq_pn_a_ec,age_bin,full_model_rsq)),aes(age_bin,full_model_rsq,  fill=age_bin))+
  geom_bar(stat="identity",color="black")+
  geom_hline(yintercept=0,color="black")+
  theme(axis.text.x  = element_text(angle=90, vjust=0.5,size=18),
        axis.title.x = element_text(size=14,face="bold"),
        axis.text.y =  element_text(size=14),
        axis.title.y= element_text(size=14,face="bold"),
        strip.text.x = element_text(size=14))+
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())+
  ylab("Model R Squared")+
  xlab("Age Group")+
  theme(legend.position=c(0.1,0.8))
plot_grid(pB,pA)

Faces with image ratings

plot_grid(p1,p2,labels=c("A","B"),label_size=20)

Faces with Hierarchical Clustering solution

plot_grid(p1b,p2b,labels=c("A","B"),label_size=20)

Colors highlight k=3 hierarchical clustering solutions for each age group. We used the three colors to highlight commonalities among the different hierarchical clustering solutions. For instance, red clusters contain anger and disgust images, green clusters contain certain fear and neutral images, and blue images contain certain happy, calm, and surprise images. However, there was nothing statistically to indicate “this is the red cluster” across all dendrograms.

Labels with Hierarchical Clustering solution

plot_grid(p1c,p2c,labels=c("A","B"),label_size=20)

Colors highlight the three cluster solutions for each age-bin. We used the three colors to highlight commonalities among the different hierarchical clustering solutions. For instance, red clusters contain anger and disgust images, green clusters contain certain fear and neutral images, and blue images contain certain happy, calm, and surprise images. However, there was nothing statistically to indicate “this is the red cluster” across all dendrograms. The numbers 1 and 2 indicate that the images had open and closed mouths, respectively. Labels are slightly jittered for readability (indicated by lines).

Faces with image ratings

plot_grid(p1,p2,labels=c("C","D"),label_size=20)

Faces with Hierarchical Clustering solution

plot_grid(p1b,p2b,labels=c("C","D"),label_size=20)

Colors highlight k=3 hierarchical clustering solutions for each age group. We used the three colors to highlight commonalities among the different hierarchical clustering solutions. For instance, red clusters contain anger and disgust images, green clusters contain certain fear and neutral images, and blue images contain certain happy, calm, and surprise images. However, there was nothing statistically to indicate “this is the red cluster” across all dendrograms.

Labels with Hierarchical Clustering solution

plot_grid(p1c,p2c,labels=c("A","B"),label_size=20)

Colors highlight the three cluster solutions for each age-bin. We used the three colors to highlight commonalities among the different hierarchical clustering solutions. For instance, red clusters contain anger and disgust images, green clusters contain certain fear and neutral images, and blue images contain certain happy, calm, and surprise images. However, there was nothing statistically to indicate “this is the red cluster” across all dendrograms. The numbers 1 and 2 indicate that the images had open and closed mouths, respectively. Labels are slightly jittered for readability (indicated by lines).

Same Individual Sort: Adults and Children

#distance matrix objects
s1k_dist <- avg_dist_byGroup %>%
  dplyr::filter(sort=="Sort1"&age_group=="kids") %>%
  ungroup() %>%
  select(dist_obj)
s1k_dist <- s1k_dist$dist_obj[[1]]

s1a_dist <- avg_dist_byGroup %>%
  dplyr::filter(sort=="Sort1"&age_group=="adults") %>%
  ungroup() %>%
  select(dist_obj)
s1a_dist <- s1a_dist$dist_obj[[1]]

# hclust solution
s1k <- s1k_dist %>%
  hclust(method = "ward.D2")

s1a <- s1a_dist %>%
  hclust(method = "ward.D2")

#clean up labels
s1k[["labels"]] <- s1k[["labels"]] %>%
  str_replace_all(c("M07"="","_o"=" 1", "_c"=" 2", "ang"="angry","calm"="calm","disg"="disgust",
                    "exc"="excited","fear"="fear", "hap"="happy",
                    "neut"="neutral","sad"="sad", "surp"="surprise"))

s1a[["labels"]] <- s1a[["labels"]] %>%
  str_replace_all(c("M07"="","_o"=" 1", "_c"=" 2", "ang"="angry","calm"="calm","disg"="disgust",
                    "exc"="excited","fear"="fear", "hap"="happy",
                    "neut"="neutral","sad"="sad", "surp"="surprise"))

# dendrograms
s1k_dend <- s1k %>% as.dendrogram
s1a_dend <- s1a %>% as.dendrogram

# plots
par(mfrow = c(1,2))
s1a_dend %>% set("branches_lwd", 2) %>%  set("branches_k_color",value=c(4,3,2), k=3) %>% plot(main="Adults")
s1k_dend %>% set("branches_lwd", 2) %>%  set("branches_k_color",value=c(2,4,3), k=3)%>% plot(main="Children")

Different Individuals Sort: Adults and Children

s2k_dist <- avg_dist_byGroup %>%
  dplyr::filter(sort=="Sort2"&age_group=="kids") %>%
  ungroup() %>%
  select(dist_obj)
s2k_dist <- s2k_dist$dist_obj[[1]]

s2a_dist <- avg_dist_byGroup %>%
  dplyr::filter(sort=="Sort2"&age_group=="adults") %>%
  ungroup() %>%
  select(dist_obj)
s2a_dist <- s2a_dist$dist_obj[[1]]

#hclust objects
s2k <- s2k_dist %>%
  hclust(method = "ward.D2")

s2a <- s2a_dist %>%
  hclust(method = "ward.D2")


#clean up labels
s2k[["labels"]] <- s2k[["labels"]] %>%
  str_replace_all(c("F01"="","F04"="","F07"="","F10"="", "F13"="",
                    "F14"="","F15"="", "F17"="","F22"="","M02"="","M04"="",
                    "M03"="","M05"="","M08"="","M12"="","M14"="","M15"="",
                    "M17"="","_o"=" 1", "_c"=" 2", "ang"="angry", "calm"="calm",
                    "disg"="disgust", "exc"="excited", "fear"="fear",
                    "hap"="happy", "neut"="neutral", "sad"="sad",
                    "surp"="surprise"))

s2a[["labels"]] <- s2a[["labels"]] %>%
  str_replace_all(c("F01"="","F04"="","F07"="","F10"="", "F13"="",
                    "F14"="","F15"="", "F17"="","F22"="","M02"="","M04"="",
                    "M03"="","M05"="","M08"="","M12"="","M14"="","M15"="",
                    "M17"="","_o"=" 1", "_c"=" 2", "ang"="angry", "calm"="calm",
                    "disg"="disgust", "exc"="excited", "fear"="fear",
                    "hap"="happy", "neut"="neutral", "sad"="sad",
                    "surp"="surprise"))

s2k_dend <- s2k %>% as.dendrogram
s2a_dend <- s2a %>% as.dendrogram

#Dendrograms
par(mfrow = c(1,2))
s2a_dend %>% set("branches_lwd", 2) %>%  set("branches_k_color",value=c(4,2,3), k=3) %>% plot(main="Adults")
s2k_dend %>% set("branches_lwd", 2) %>%  set("branches_k_color",value=c(2,4,3), k=3) %>% plot(main="Children")

Adjusted Rand

An adjusted Rand index of 0 indicates two clusters have a Rand index that matches the expected value for random groupings (i.e., no similiarity), with higher and lower values indicating higher- or lower-than-chance level similarity between the two clusters.

In all graphs, we are making comparisons between Adults and different groups of children for all possible values of k.

# Same Individual: Children versus Adults
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s1a, k=x),cutree(s1k, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot1 <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot1 <- ar_plot1 + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("Same Individual: Children")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=20, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=20, face="plain",family="Times", vjust=.5))

#3-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s1a, k=x),cutree(s1_3, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot1a <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot1a <- ar_plot1a + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("3-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))

#4-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s1a, k=x),cutree(s1_4, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot1b <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot1b <- ar_plot1b + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("4-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))

#5-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s1a, k=x),cutree(s1_5, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot1c <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot1c <- ar_plot1c + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("5-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))

#6-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s1a, k=x),cutree(s1_6, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot1d <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot1d <- ar_plot1d + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("6-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))

# Diff Individual: Children versus Adults
calc_AR <- function(x) {
  adj.rand.index(cutree(s2a, k=x),cutree(s2k, k=x))
}

ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot2 <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot2 <- ar_plot2 + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("Diff. Individuals: Children")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=20, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=20, face="plain",family="Times", vjust=.5))

#3-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s2a, k=x),cutree(s2_3, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot2a <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot2a <- ar_plot2a + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("3-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))

#4-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s2a, k=x),cutree(s2_4, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot2b <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot2b <- ar_plot2b + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("4-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))

#5-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s2a, k=x),cutree(s2_5, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot2c <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot2c <- ar_plot2c + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("5-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))

#6-year-olds
m = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
calc_AR <- function(x) {
  adj.rand.index(cutree(s2a, k=x),cutree(s2_6, k=x))
}
# get adjusted rand for each cluster
ar <- map_dbl(m, calc_AR)
ar <- as.data.frame(ar)
ar <- as_tibble(rownames_to_column(ar))
ar <- ar %>% rename(cluster = rowname, adjusted_rand = ar) %>% mutate(cluster = as.numeric(cluster))
ar_plot2d <- ar %>% ggplot(mapping = aes(x = cluster, y = adjusted_rand))

ar_plot2d <- ar_plot2d + geom_point()+ geom_line(color="red")+
  xlab("k")+
  ylab("Adjusted Rand Index") +
  scale_x_continuous(breaks=c(2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), limits=c(2,17)) +
  scale_y_continuous(limits=c(0,1), breaks=c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0)) +
  theme_linedraw() +
  ggtitle("6-year-olds")+
  theme(text=element_text(size=16, family="Times"), plot.title = element_text(size=16, face="bold",family="Times", hjust=.5),
        axis.title.x = element_text(size=14, face="plain",family="Times", vjust=.5),
        axis.title.y = element_text(size=14, face="plain",family="Times", vjust=.5))


# All Children
plot_grid(ar_plot1,ar_plot2)

# Same Individual Sort
title1 <- ggdraw() +
  draw_label("Same Individual Sort",
    fontface = 'bold',
    x = 0,
    hjust = 0) +
  theme(plot.margin = margin(0, 0, 0, 7))
plot_row1 <- plot_grid(ar_plot1a,ar_plot1b,ar_plot1c,ar_plot1d)
plot_grid(
  title1, plot_row1,
  ncol = 1,
  rel_heights = c(0.1, 1)
)

# Different Individuals Sort
title2 <- ggdraw() +
  draw_label("Diff. Individuals Sort",
    fontface = 'bold',
    x = 0,
    hjust = 0) +
  theme(plot.margin = margin(0, 0, 0, 7))
plot_row2 <- plot_grid(ar_plot2a,ar_plot2b,ar_plot2c,ar_plot2d)
plot_grid(
  title2, plot_row2,
  ncol = 1,
  rel_heights = c(0.1, 1)
)

FM Index

The Fowlkes-Mallows (FM) Index measures the similarity between two hierarchical clusterings (Fowlkes & Mallow, 1983). It ranges from 0 (no similarity) to 1 (perfect similarity). The index aims to capture how likely it is that two clusters contain the same faces. Below we plot the FM-Index for all possible cluster solutions. Within this plot, the dashed black line indicates the null hypothesis (the similarity expected if the two dendrograms are “not similar”), the red line is the rejection line, above which we can say that the two dendrograms are similar, and the dotted black line is the FM-Index that we observe when comparing the children’s hierarchical clustering solution to that of adults. In all graphs, we are making comparisons between Adults and different groups of children.

# Same Individual Sort:
par(mfrow = c(2,3))
Bk_plot(s1k, s1a, main = "Same Individual Sort \nAll Children")
Bk_plot(s1a, s1_3, main = "Same Individual Sort \n3-year-olds")
Bk_plot(s1a, s1_4, main = "Same Individual Sort \n4-year-olds")
Bk_plot(s1a, s1_5, main = "Same Individual Sort \n5-year-olds")
Bk_plot(s1a, s1_6, main = "Same Individual Sort \n6-year-olds")

# Different Individuals Sort
par(mfrow = c(2,3))

Bk_plot(s2a, s2k, main = "Diff. Individual Sort \nAll Children")
Bk_plot(s2a, s2_3, main = "Diff. Individual Sort \n3-year-olds")
Bk_plot(s2a, s2_4, main = "Diff. Individual Sort \n4-year-olds")
Bk_plot(s2a, s2_5, main = "Diff. Individual Sort \n5-year-olds")
Bk_plot(s2a, s2_6, main = "Diff. Individual Sort \n6-year-olds")

Entanglement

Entanglement measures whether the labels at the bottom of two dendrograms are aligned with one another. A value of 0 indicates perfect alignment, while a value of 1 indicates no alignment. To optimize alignment, we first used the untangle method. For all values, we are making comparisons between Adults and different groups of children.

library(gt)
tang_tracker1 <- tibble(Age_Group = character(), entanglement= numeric())
tang_tracker2 <- tibble(Age_Group = character(), entanglement= numeric())

# Same Individual Sort
set.seed(51314)

p0 <- dendlist("Adults" = s1_a_dend, "Children" = s1k_dend)
p1 <- dendlist("Adults" = s1_a_dend, "Kids" = s1_3_dend)
p2 <- dendlist("Adults" = s1_a_dend, "Kids" = s1_4_dend)
p3 <- dendlist("Adults" = s1_a_dend, "Kids" = s1_5_dend)
p4 <- dendlist("Adults" = s1_a_dend, "Kids" = s1_6_dend)

x_untangle0 <- p0 %>% untangle(method = "random", R=1000)
x_untangle1 <- p1 %>% untangle(method = "random", R=1000)
x_untangle2 <- p2 %>% untangle(method = "random", R=1000)
x_untangle3 <- p3 %>% untangle(method = "random", R=1000)
x_untangle4 <- p4 %>% untangle(method = "random", R=1000)

tang_tracker1 <- bind_rows(tang_tracker1, tibble(Age_Group = "All Children", entanglement=entanglement(x_untangle0)))
tang_tracker1 <- bind_rows(tang_tracker1, tibble(Age_Group = "3-year-olds", entanglement=entanglement(x_untangle1)))
tang_tracker1 <- bind_rows(tang_tracker1, tibble(Age_Group = "4-year-olds", entanglement=entanglement(x_untangle2)))
tang_tracker1 <- bind_rows(tang_tracker1, tibble(Age_Group = "5-year-olds", entanglement=entanglement(x_untangle3)))
tang_tracker1 <- bind_rows(tang_tracker1, tibble(Age_Group = "6-year-olds", entanglement=entanglement(x_untangle4)))


# Different Individuals Sort
set.seed(51314)

p0 <- dendlist("Adults" = s2_a_dend, "Children" = s2k_dend)
p1 <- dendlist("Adults" = s2_a_dend, "Kids" = s2_3_dend)
p2 <- dendlist("Adults" = s2_a_dend, "Kids" = s2_4_dend)
p3 <- dendlist("Adults" = s2_a_dend, "Kids" = s2_5_dend)
p4 <- dendlist("Adults" = s2_a_dend, "Kids" = s2_6_dend)

x_untangle0 <- p0 %>% untangle(method = "random", R=1000)
x_untangle1 <- p1 %>% untangle(method = "random", R=1000)
x_untangle2 <- p2 %>% untangle(method = "random", R=1000)
x_untangle3 <- p3 %>% untangle(method = "random", R=1000)
x_untangle4 <- p4 %>% untangle(method = "random", R=1000)

tang_tracker2 <- bind_rows(tang_tracker2, tibble(Age_Group = "All Children", entanglement=entanglement(x_untangle0)))
tang_tracker2 <- bind_rows(tang_tracker2, tibble(Age_Group = "3-year-olds", entanglement=entanglement(x_untangle1)))
tang_tracker2 <- bind_rows(tang_tracker2, tibble(Age_Group = "4-year-olds", entanglement=entanglement(x_untangle2)))
tang_tracker2 <- bind_rows(tang_tracker2, tibble(Age_Group = "5-year-olds", entanglement=entanglement(x_untangle3)))
tang_tracker2 <- bind_rows(tang_tracker2, tibble(Age_Group = "6-year-olds", entanglement=entanglement(x_untangle4)))

tab1 <- bind_cols(tang_tracker1, tang_tracker2)
tab1 %>% gt(tab1) %>% cols_align(align="center") %>% cols_label(Age_Group...1 = "Age Groups", entanglement...2=md("Entanglement"),Age_Group...3 = "Age Groups", entanglement...4=md("Entanglement")) %>%   tab_header(
    title = md("Entanglement"),
    subtitle = md("**Same Individual versus Different Individuals Sort**")
  )

Cophenetic Correlation

c is the cophenetic correlation coefficient between the two dendrograms. This value ranges from -1 to 1 with values near 0 suggesting that the two dendrograms are not statistically similar. For all values, we are making comparisons between Adults and different groups of children.

cor_tracker1 <- tibble(Age_Group = character(),c = numeric())
cor_tracker2 <- tibble(Age_Group = character(),c = numeric())

#Same Individual Sort (Comparison to Adults)
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "All Children", c=cor_cophenetic(s1a, s1k)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "3-year-olds", c=cor_cophenetic(s1a, s1_3)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "4-year-olds", c=cor_cophenetic(s1a, s1_4)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "5-year-olds", c=cor_cophenetic(s1a, s1_5)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "6-year-olds", c=cor_cophenetic(s1a, s1_6)))

#Different Individuals Sort (Comparison to Adults)
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "All Children", c=cor_cophenetic(s2a, s2k)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "3-year-olds", c=cor_cophenetic(s2a, s2_3)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "4-year-olds", c=cor_cophenetic(s2a, s2_4)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "5-year-olds", c=cor_cophenetic(s2a, s2_5)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "6-year-olds", c=cor_cophenetic(s2a, s2_6)))

tab1 <- bind_cols(cor_tracker1, cor_tracker2)
tab1 %>% gt(tab1) %>% cols_align(align="center") %>% cols_label(Age_Group...1 = "Age Groups", c...2=md("*c*"),Age_Group...3 = "Age Groups", c...4=md("*c*")) %>%   tab_header(
    title = md("Cophenetic Correlation"),
    subtitle = md("**Same Individual versus Different Individuals Sort**")
  )

Baker’s Gamma

Baker’s Gamma Index is a measure of similarity between two dendrograms. This value ranges from -1 to 1 with values near 0 suggesting that the two dendrograms are not statistically similar. For all values, we are making comparisons between Adults and different groups of children.

cor_tracker1 <- tibble(Age_Group = character(), gamma = numeric())
cor_tracker2 <- tibble(Age_Group = character(), gamma = numeric())

#Same Individual Sort (Comparison to Adults)
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "All Children", gamma=cor_bakers_gamma(s1a, s1k)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "3-year-olds", gamma=cor_bakers_gamma(s1a, s1_3)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "4-year-olds", gamma=cor_bakers_gamma(s1a, s1_4)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "5-year-olds", gamma=cor_bakers_gamma(s1a, s1_5)))
cor_tracker1 <- bind_rows(cor_tracker1, tibble(Age_Group = "6-year-olds", gamma=cor_bakers_gamma(s1a, s1_6)))

#Different Individuals Sort (Comparison to Adults)
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "All Children", gamma=cor_bakers_gamma(s2a, s2k)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "3-year-olds", gamma=cor_bakers_gamma(s2a, s2_3)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "4-year-olds", gamma=cor_bakers_gamma(s2a, s2_4)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "5-year-olds", gamma=cor_bakers_gamma(s2a, s2_5)))
cor_tracker2 <- bind_rows(cor_tracker2, tibble(Age_Group = "6-year-olds", gamma=cor_bakers_gamma(s2a, s2_6)))

tab1 <- bind_cols(cor_tracker1, cor_tracker2)
tab1 %>% gt(tab1) %>% cols_align(align="center") %>% cols_label(Age_Group...1 = "Age Groups", gamma...2=md("Baker's Gamma"),Age_Group...3 = "Age Groups", gamma...4=md("Baker's Gamma")) %>%   tab_header(
    title = md("Baker's Gamma"),
    subtitle = md("**Same Individual versus Different Individuals Sort**")
  )

Method: Same Individual Sort

To select our hierarchical clustering method (average, single, complete, or Ward’s), we analyzed the agglomerative coefficient (AC). AC gives a measure of the strength of the clustering structure, and we found that Ward’s method gave the best solution. Furthermore, Ward’s is a generally preferred method for agglomerative (bottom-up) hierarchical clustering (Kaufman & Rousseeuw, 2009; Boehmke & Greenwell, 2020).

#methods
m <- c( "average", "single", "complete", "ward")

# Different Age Groups
names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s1a_dist, method = x)$ac
}
t1 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s1k_dist, method = x)$ac
}
t2 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s1_3_dist, method = x)$ac
}
t3 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s1_4_dist, method = x)$ac
}
t4 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s1_5_dist, method = x)$ac
}
t5 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s1_6_dist, method = x)$ac
}
t6 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

tab1 <- bind_cols(t1,t2,t3,t4,t5,t6)
gt(tab1) %>% cols_align(align="center") %>% tab_header(title = md("Selecting Hierarchical Clustering Method"), subtitle = md("**Same Individual Sort**"))%>% cols_align(align="center") %>% cols_label(method...1 = "Adults", AC...2=md("*AC*"), method...3 = "Children", AC...4=md("*AC*"),method...5 = "3-years",
AC...6=md("*AC*"),method...7 = "4-years", 
AC...8=md("*AC*"),method...9 = "5-years", AC...10=md("*AC*"),method...11 = "6-years", 
AC...12=md("*AC*")) 

Method: Different Individual Sort

To select our hierarchical clustering method (average, single, complete, or Ward’s), we analyzed the agglomerative coefficient (AC). AC gives a measure of the strength of the clustering structure, and we found that Ward’s method gave the best solution. Furthermore, Ward’s is a generally preferred method for agglomerative (bottom-up) hierarchical clustering (Kaufman & Rousseeuw, 2009; Boehmke & Greenwell, 2020).

#methods
m <- c( "average", "single", "complete", "ward")

# Different Age Groups
names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s2a_dist, method = x)$ac
}
t1 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s2k_dist, method = x)$ac
}
t2 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s2_3_dist, method = x)$ac
}
t3 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s2_4_dist, method = x)$ac
}
t4 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s2_5_dist, method = x)$ac
}
t5 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

names(m) <- c( "average", "single", "complete", "ward")
ac <- function(x) {
  agnes(s2_6_dist, method = x)$ac
}
t6 <- as.data.frame(map_dbl(m, ac)) %>% rownames_to_column() %>% rename(method="rowname",AC=`map_dbl(m, ac)`)

tab1 <- bind_cols(t1,t2,t3,t4,t5,t6)
gt(tab1) %>% cols_align(align="center") %>% tab_header(title = md("Selecting Hierarchical Clustering Method"), subtitle = md("**Different Individuals Sort**"))%>% cols_align(align="center") %>% cols_label(method...1 = "Adults", AC...2=md("*AC*"), method...3 = "Children", AC...4=md("*AC*"),method...5 = "3-years",
AC...6=md("*AC*"),method...7 = "4-years", 
AC...8=md("*AC*"),method...9 = "5-years", AC...10=md("*AC*"),method...11 = "6-years", 
AC...12=md("*AC*")) 

Selecting k: Same Individual Sort

As we used hierarchical clustering and presented dendrograms, we displayed all possible clusters in the manuscript. However, we did chose to highlight the three cluster solution (k=3) in the dendrograms we displayed. Below we present bar plots of the height of the different clusters in the dendrogram. Large changes in these heights can be helpful for determining the optimal number of clusters to display. Through observations of these graphs, subjective evaluation of the dendrograms, patterns of valence among the images, and a desire to be consistent across different age ranges, we opted to display the three cluster solution. However, for full transparency we also report similarity indices for all values of k in section 6b (above).

s1_cluster <- as.data.frame(s1a$height) %>% rename(adults="s1a$height") %>% mutate(children=s1k$height,three_years=s1_3$height,four_years=s1_4$height,five_years=s1_5$height,six_years=s1_6$height) %>% rownames_to_column() %>% rename(cluster=rowname) %>% mutate(cluster=abs(as.numeric(cluster)-18))

s1_cluster_dL <- s1_cluster %>% group_by(cluster) %>% gather(key = age_group, value = height, adults,children,three_years,four_years,five_years,six_years)

s1_cluster_dL <- s1_cluster_dL %>% mutate(age_group=case_when(
  age_group == "adults" ~ "adults",
  age_group =="children" ~ "children",
  age_group =="three_years" ~ "3-year-olds",
  age_group =="four_years" ~ "4-year-olds",
  age_group =="five_years" ~ "5-year-olds",
  age_group =="six_years" ~ "6-year-olds"))

ggplot(data=s1_cluster_dL,aes(x=cluster,y=height, fill=age_group)) + geom_bar(stat='identity', color="black") + facet_wrap(~age_group) +
  theme(legend.position="none")+
  scale_x_continuous(breaks=c(1,3,5,7,9,11,13,15,17))+
  ggtitle("Height of dendrogram for cluster k")

Selecting k: Different Individuals Sort

As we used hierarchical clustering and presented dendrograms, we displayed all possible clusters in the manuscript. However, we did chose to highlight the three cluster solution (k=3) in the dendrograms we displayed. Below we present bar plots of the height of the different clusters in the dendrogram. Large changes in these heights can be helpful for determining the optimal number of clusters to display. Through observations of these graphs, subjective evaluation of the dendrograms, patterns of valence among the images, and a desire to be consistent across different age ranges, we opted to display the three cluster solution. However, for full transparency we also report similarity indices for all values of k in section 6b (above).

s2_cluster <- as.data.frame(s2a$height) %>% rename(adults="s2a$height") %>% mutate(children=s2k$height,three_years=s2_3$height,four_years=s2_4$height,five_years=s2_5$height,six_years=s2_6$height) %>% rownames_to_column() %>% rename(cluster=rowname) %>% mutate(cluster=abs(as.numeric(cluster)-18))

s2_cluster_dL <- s2_cluster %>% group_by(cluster) %>% gather(key = age_group, value = height, adults,children,three_years,four_years,five_years,six_years)

s2_cluster_dL <- s2_cluster_dL %>% mutate(age_group=case_when(
  age_group == "adults" ~ "adults",
  age_group =="children" ~ "children",
  age_group =="three_years" ~ "3-year-olds",
  age_group =="four_years" ~ "4-year-olds",
  age_group =="five_years" ~ "5-year-olds",
  age_group =="six_years" ~ "6-year-olds"))

ggplot(data=s2_cluster_dL,aes(x=cluster,y=height, fill=age_group)) + geom_bar(stat='identity', color="black") + facet_wrap(~age_group) +
  theme(legend.position="none") +
  scale_x_continuous(breaks=c(1,3,5,7,9,11,13,15,17))+
  ggtitle("Height of dendrogram for cluster k")

Ratings: Same Individual Sort

r1 <- ratings_dL %>%
  filter(grepl('M07',image)) %>%
  group_by(image, rating_type) %>%
  summarise(rating=ci(response)[1], 
            lowCI = ci(response)[2],
            hiCI = ci(response)[3], 
            sd = ci (response)[4]) %>%
  ggplot(aes(x=image,y=rating)) + 
  geom_bar(stat="identity") +
  geom_errorbar(aes(ymin=lowCI,ymax=hiCI),width=0,color="black")+
  scale_fill_brewer(palette="Set1")+
  facet_wrap(~rating_type)+
  theme(legend.position="none")+
  ggtitle("Same Individual Ratings") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1,vjust=0.5))

r1

Ratings: Different Individuals Sort

r2 <- ratings_dL %>%
  filter(!grepl('M07',image)) %>%
  group_by(image, rating_type) %>%
  summarise(rating=ci(response)[1], 
            lowCI = ci(response)[2],
            hiCI = ci(response)[3], 
            sd = ci (response)[4]) %>%
  ggplot(aes(x=image,y=rating)) + 
  geom_bar(stat="identity") +
  geom_errorbar(aes(ymin=lowCI,ymax=hiCI),width=0,color="black")+
  scale_fill_brewer(palette="Set1")+
  facet_wrap(~rating_type)+
  theme(legend.position="none")+
  ggtitle("Different Individual Ratings") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1,vjust=0.5))

r2

Range of responses

ratings_dL %>%
  ggplot(aes(x=response,fill=rating_type)) + 
  geom_bar(width = 0.5, color="black") +
  facet_wrap(~rating_type, strip.position="bottom") +
  theme(legend.position="none") +
  ggtitle("Range of rating responses")

Correlation Tables of Dimension Ratings

cor1 <- ratings_pairs %>% filter(sort=="Sort1") %>% select(dist_valence,dist_arousal,dist_pos,dist_neg) %>% cor()
cor2 <- ratings_pairs %>% filter(sort=="Sort2") %>% select(dist_valence,dist_arousal,dist_pos,dist_neg) %>% cor()

cor1 <- as.data.frame(cor1) %>% rownames_to_column() %>% mutate(rowname=case_when(
  rowname=="dist_valence" ~ "Valence",
  rowname=="dist_arousal" ~ "Arousal",
  rowname=="dist_pos" ~ "Positivity",
  rowname=="dist_neg" ~ "Negativity")) %>% rename(" "=rowname)
cor1 %>% gt(cor1) %>% cols_align(align="center") %>% cols_label(dist_valence =md("Valence"), dist_arousal=md("Arousal"),dist_pos = md("Positivity"), dist_neg=md("Negativity")) %>%   
  tab_header(title = md("Same Individual Sort"))

cor2 <- as.data.frame(cor2) %>% rownames_to_column() %>% mutate(rowname=case_when(
  rowname=="dist_valence" ~ "Valence",
  rowname=="dist_arousal" ~ "Arousal",
  rowname=="dist_pos" ~ "Positivity",
  rowname=="dist_neg" ~ "Negativity")) %>% rename(" "=rowname)
cor2 %>% gt(cor2) %>% cols_align(align="center") %>% cols_label(dist_valence =md("Valence"), dist_arousal=md("Arousal"),dist_pos = md("Positivity"), dist_neg=md("Negativity")) %>%   
  tab_header(title = md("Different Individual Sort"))