Summarizes the results from a color discriminability norming study reported in the paper “Nameability Supports Rule-based Category Learning in Children and Adults” (authors removed, 2023).

Read in and processing data

kn_data <- read_csv(here::here("..","data","processed_data","ckn_v1_processed.csv")) %>%
  mutate(age_group="children")
an_data <- read_csv(here::here("..","data","processed_data","can_v1_processed.csv")) %>%
  mutate(age_group="adults")

#read in the color discriminability data from Zettersten & Lupyan (2020)
color_properties_zl <- read_csv(here::here("..","data","processed_data","color_properties.csv")) %>%
  filter(colorSet=="colorset1")
colorpair_discrim_rt_zl <- read_csv(here::here("..","data","processed_data","color_properties_discriminability.csv")) %>%
  filter(colorSet=="colorset1") %>%
  rename(zl_average_rt=average_rt) %>%
  mutate(
    pair = case_when(
      colorPair=="bluebrown" ~ "blue - brown"
    )
  )

kn_subj <- read_csv(here::here("..","data","subj_data","ckn_subjlog_anonymized.csv")) %>%
  clean_names()

kn_data <- kn_data %>%
  left_join(kn_subj,by=c("subject_id"="participant_id"))

Read demographics

kn_demographics <- read_csv(here::here("..","data","processed_data","colorrulekid_demographics.csv")) %>%
  clean_names() %>%
  rename(subject_id=participant_id) %>%
  mutate(age_months=as.numeric(age_months)) %>%
  mutate(
    gender = case_when(
      gender==0 ~ "female",
      gender==1 ~ "male",
      TRUE ~ NA_character_),
    race = case_when(
      race==1 ~ "American Indian or Alaska Native",
      race==2 ~ "Asian",
      race==3 ~ "Black or African American",
      race==4 ~ "Native Hawaiian or Other Pacific Islander",
      race==5 ~ "White",
      race==6 ~ "More than one race",
      race==7 ~ "Prefer not to disclose",
      TRUE ~ NA_character_
    ),
    ethnicity=case_when(
      ethnicity == 1 ~ "Hispanic or Latino",
      ethnicity == 2 ~ "Not Hispanic or Latino",
      ethnicity == 3 ~ "Prefer not to disclose",
      TRUE ~ NA_character_
    ),
    parental_education_category = case_when(
      parental_education == 1 ~ "Some high school",
       parental_education == 2 ~ "High school graduate", 
       parental_education == 3 ~ "Some college", 
       parental_education == 4 ~ "Trade/technical/vocational training", 
       parental_education == 5 ~ "College graduate",
      parental_education == 6 ~ "Postgraduate",
      parental_education == 7 ~ "Prefer not to disclose"
    ),
    household_income_category = case_when(
      home_income == 1 ~ "less than $24,999",
       home_income == 2 ~ "$25,000 to $49,999", 
       home_income == 3 ~ "$50,000 to 99,999", 
       home_income == 4 ~ "$100,000 or more", 
       home_income == 5 ~ "Prefer not to disclose"
    ))
an_demographics <- read_csv(here::here("..","data","processed_data","colorruleadults_demographics.csv")) %>%
  clean_names()%>%
  rename(subject_id=participant_id)%>%
  mutate(age=as.numeric(age)) %>%
  mutate(
    gender = case_when(
      gender==0 ~ "female",
      gender==1 ~ "male",
      TRUE ~ NA_character_),
    race = case_when(
      race==1 ~ "American Indian or Alaska Native",
      race==2 ~ "Asian",
      race==3 ~ "Black or African American",
      race==4 ~ "Native Hawaiian or Other Pacific Islander",
      race==5 ~ "White",
      race==6 ~ "More than one race",
      race==7 ~ "Prefer not to disclose",
      TRUE ~ NA_character_
    ),
    ethnicity=case_when(
      ethnicity == 1 ~ "Hispanic or Latino",
      ethnicity == 2 ~ "Not Hispanic or Latino",
      ethnicity == 3 ~ "Prefer not to disclose",
      TRUE ~ NA_character_
    ),
    parental_education_category = case_when(
      parental_education == 1 ~ "Some high school",
       parental_education == 2 ~ "High school graduate", 
       parental_education == 3 ~ "Some college", 
       parental_education == 4 ~ "Trade/technical/vocational training", 
       parental_education == 5 ~ "College graduate",
      parental_education == 6 ~ "Postgraduate",
      parental_education == 7 ~ "Prefer not to disclose"
    ),
    household_income_category = case_when(
      home_income == 1 ~ "less than $24,999",
       home_income == 2 ~ "$25,000 to $49,999", 
       home_income == 3 ~ "$50,000 to 99,999", 
       home_income == 4 ~ "$100,000 or more", 
       home_income == 5 ~ "Prefer not to disclose"
    ))

Processing data

kn_data <- kn_data %>%
  rowwise() %>%
  mutate(pair = paste(sort(c(target, foil)), collapse = " - "),colorPair=paste(sort(c(target, foil)), collapse = "")) %>%
  ungroup() %>%
  left_join(kn_demographics) %>%
  mutate(
    condition_c=case_when(
      condition=="high nameability" ~ 0.5,
      condition=="low nameability" ~ -0.5,
      TRUE ~ NA
    )
  )

an_data <- an_data %>%
  rowwise() %>%
  mutate(pair = paste(sort(c(target, foil)), collapse = " - "),colorPair=paste(sort(c(target, foil)), collapse = "")) %>%
  ungroup() %>%
  left_join(an_demographics)%>%
  mutate(
    condition_c=case_when(
      condition=="high nameability" ~ 0.5,
      condition=="low nameability" ~ -0.5,
      TRUE ~ NA
    )
  )

Exclude participants

kn_data <- kn_data %>%
  filter(exclude=="n")
#excluding the following participants
#exclude_participants <- c("CKN_101","CKN_112","CKN_114a","CKN_121","CKN_126","CKN_120")

Demographics

Children

Age, Gender

####summarize by subject####
kid_subj <- kn_data %>%
  select(subject_id,age_months,gender,race, ethnicity,language_history,household_income_category,parental_education_category,family_history_color_blindness,color_blindness_dx) %>%
  distinct()

####summarize demographics####
kid_demographics <-  kid_subj %>%
  ungroup() %>%
  summarize(N=n(), 
            mean_age = round(mean(age_months,na.rm=TRUE),1), 
            sd_age = round(sd(age_months,na.rm=TRUE),1), 
            min_age = min(age_months,na.rm=TRUE), 
            max_age = max(age_months,na.rm=TRUE),
            count_female = sum(gender=='female',na.rm=TRUE),
            english_l1=paste(100*sum(str_detect(language_history,"1"))/sum(language_history!=""),"%",sep=""),
            bilingual=sum(language_history!="1"&language_history!="")
            )
kable(kid_demographics)

N	mean_age	sd_age	min_age	max_age	count_female	english_l1	bilingual
40	56.4	6.5	45	69	16	92.5%	6

Race

kid_subj %>%
  group_by(race) %>%
  summarize(count=n(),
            percent=count/nrow(kid_subj)) %>%
  kable()

race	count	percent
Asian	2	0.050
More than one race	2	0.050
White	35	0.875
NA	1	0.025

Ethnicity

kid_subj %>%
  group_by(ethnicity) %>%
  summarize(count=n(),
            percent=count/nrow(kid_subj)) %>%
  kable()

ethnicity	count	percent
Hispanic or Latino	2	0.050
Not Hispanic or Latino	37	0.925
NA	1	0.025

Household Income

kid_subj %>%
  mutate(household_income_category = factor(household_income_category,levels=c("$100,000 or more","$50,000 to 99,999","$25,000 to $49,999","less than $24,999","Prefer not to disclose"))) %>%
  group_by(household_income_category) %>%
  summarize(count=n(),
            percent=count/nrow(kid_subj)) %>%
  kable()

household_income_category	count	percent
$100,000 or more	30	0.75
$50,000 to 99,999	6	0.15
Prefer not to disclose	2	0.05
NA	2	0.05

Parental Education

kid_subj %>%
  mutate(parental_education_category = factor(parental_education_category,levels=c("Some high school","High school graduate","Some college","Trade/technical/vocational training","College graduate","Postgraduate","Prefer not to disclose"))) %>%
  group_by(parental_education_category) %>%
  summarize(count=n(),
            percent=count/nrow(kid_subj)) %>%
  kable()

parental_education_category	count	percent
Some college	4	0.100
College graduate	7	0.175
Postgraduate	27	0.675
NA	2	0.050

Adults

Age, Gender

####summarize by subject####
adult_subj <-  an_data %>%
  select(subject_id,age,gender,race, ethnicity,language_history,family_history_color_blindness,color_blindness_dx) %>%
  distinct()
####summarize demographics####
adult_demographics <-  adult_subj %>%
  ungroup() %>%
  summarize(N=n(), 
            mean_age = round(mean(age,na.rm=TRUE),1), 
            sd_age = round(sd(age,na.rm=TRUE),1), 
            min_age = min(age,na.rm=TRUE), 
            max_age = max(age,na.rm=TRUE),
            count_female = sum(gender=='female'),
            english_l1=paste(100*sum(str_detect(language_history,"1"))/sum(language_history!=""),"%",sep=""),
            bilingual=sum(language_history!="1"&language_history!=""))
kable(adult_demographics)

N	mean_age	sd_age	min_age	max_age	count_female	english_l1	bilingual
50	19.8	1.2	18	23	48	98%	10

Race

adult_subj %>%
  group_by(race) %>%
  summarize(count=n(),
            percent=count/nrow(kid_subj)) %>%
  kable()

race	count	percent
American Indian or Alaska Native	1	0.025
Asian	8	0.200
Black or African American	2	0.050
More than one race	2	0.050
Prefer not to disclose	1	0.025
White	36	0.900

Ethnicity

adult_subj %>%
  group_by(ethnicity) %>%
  summarize(count=n(),
            percent=count/nrow(kid_subj)) %>%
  kable()

ethnicity	count	percent
Hispanic or Latino	4	0.10
Not Hispanic or Latino	46	1.15

Single-color analysis

These analyses are similar in structure to the analyses of color norming data in Zettersten & Lupyan (2020). We compute average reaction times (for correct trials only) and accuracies for each individual color, averaging across participants and foil pairings.

Reaction Times

Children

# participant reaction times for each color
kid_participant_color_rt <- kn_data %>%
  filter(correct==1&condition!="practice"&rt<=5000&rt>=200) %>%
  group_by(subject_id,condition,target) %>% 
  summarize(
    N=sum(!is.na(rt)),
    avg_rt=mean(rt,na.rm=T)
  )

#average reaction times for each color
kid_color_rt <- kid_participant_color_rt %>%
  ungroup() %>%
  select(-N) %>%
  summarySEwithin("avg_rt",withinvars=c("condition","target"),idvar="subject_id",na.rm=TRUE)

#join with color property data (from Zettersten & Lupyan, 2020)
kid_color_rt <- kid_color_rt %>%
  left_join(
    color_properties_zl,by=join_by(target==colorName)
  )

Plot

kid_color_rt <- kid_color_rt %>%
  mutate(
    target_label = case_when(
      target=="red" ~ "(220, 20, 0) - red",
    target=="brown"~"(120, 80, 40) - brown",
    target=="blue"~"(30, 90, 210) - blue",
    target=="yellow"~"(250, 240, 0) - yellow",
    target=="purple"~"(130, 30, 180) - purple",
    target=="orange"~"(250, 120, 30) - orange",
    target=="pink"~"(200, 170, 170) - mauve",
    target=="mustard"~"(170, 160, 40) - chartreuse",
    target=="turquoise"~"(150, 200, 180) - turquoise",
    target=="neonyellow"~"(220, 240, 150) - honeydew",
    target=="darkgreenblue"~"(70, 100, 90) - teal",
    target=="lightred"~"(200, 100, 70) - sienna")
  )
ggplot(kid_color_rt, aes(reorder(target_label,-avg_rt,mean),avg_rt, color=condition))+
  geom_bar(aes(fill=condition,alpha=condition),stat="identity",size=1.5, position=position_dodge(.95))+
  geom_errorbar(aes(ymin=avg_rt-ci,ymax=avg_rt+ci), width=0.3,size=1.2, position=position_dodge(.95))+
  #coord_cartesian(ylim=c(500,700))+
  #ggtitle("Child Discriminability")+
  ylab("Reaction Time (in ms)")+
  xlab("Color")+
  scale_color_brewer(palette="Set1",name="Nameability")+
  scale_fill_brewer(palette="Set1",name="Nameability")+
  scale_alpha_manual(name="Nameability",values=c(0,0.5))+
  theme_cowplot()+
  theme(legend.position=c(0.05,0.2),legend.background=element_rect(fill="white")) + 
  theme(axis.text.x  = element_text(angle=90, vjust=0.5),plot.title = element_text(hjust = 0.5))+
  theme(text=element_text(size=18))+
  theme(strip.text.x = element_text(size=16), plot.background = element_rect(fill="white",color="white"))

ggsave(here::here("figures","kid_color_rt.png"),width=9, height=6,dpi=600)

Overall Results

Evaluating whether high nameability colors and low nameability colors differ in their average discriminability (RT-based)

#overall average
kid_color_rt %>%
  group_by(condition) %>%
  summarize(
    N = n(),
    mean_rt = mean(avg_rt),
    sd = sd(avg_rt),
    ci = qt(0.975, N-1)*sd/sqrt(N),
    lower_ci = mean_rt-ci,
    upper_ci = mean_rt+ci
  ) %>%
  kable()

condition	N	mean_rt	sd	ci	lower_ci	upper_ci
high nameability	6	1997.987	70.77964	74.27868	1923.709	2072.266
low nameability	6	2025.859	43.00997	45.13620	1980.723	2070.996

# t-test
t.test(avg_rt ~ condition, data = kid_color_rt, paired = FALSE)

## 
##  Welch Two Sample t-test
## 
## data:  avg_rt by condition
## t = -0.82432, df = 8.2495, p-value = 0.4329
## alternative hypothesis: true difference in means between group high nameability and group low nameability is not equal to 0
## 95 percent confidence interval:
##  -105.43492   49.69051
## sample estimates:
## mean in group high nameability  mean in group low nameability 
##                       1997.987                       2025.859

#Bayes Factor
#evidence for the null hypothesis
1/ttestBF(kid_color_rt$avg_rt[kid_color_rt$condition=="high nameability"],kid_color_rt$avg_rt[kid_color_rt$condition=="low nameability"],paired=TRUE)

## Bayes factor analysis
## --------------
## [1] Null, mu=0 : 2.26596 ±0%
## 
## Against denominator:
##   Alternative, r = 0.707106781186548, mu =/= 0 
## ---
## Bayes factor type: BFoneSample, JZS

Adults

# participant reaction times for each color
adult_participant_color_rt <- an_data %>%
  filter(correct==1&condition!="practice"&rt<=2000&rt>=200) %>%
  group_by(subject_id,condition,target) %>% 
  summarize(
    N=sum(!is.na(rt)),
    avg_rt=mean(rt,na.rm=T)
  )

#average reaction times for each color
adult_color_rt <- adult_participant_color_rt %>%
  ungroup() %>%
  select(-N) %>%
  summarySEwithin("avg_rt",withinvars=c("condition","target"),idvar="subject_id",na.rm=TRUE)

#join with color property data (from Zettersten & Lupyan, 2020)
adult_color_rt <- adult_color_rt %>%
  left_join(
    color_properties_zl,by=join_by(target==colorName)
  )

Plot

adult_color_rt <- adult_color_rt %>%
  mutate(
    target_label = case_when(
      target=="red" ~ "(220, 20, 0) - red",
    target=="brown"~"(120, 80, 40) - brown",
    target=="blue"~"(30, 90, 210) - blue",
    target=="yellow"~"(250, 240, 0) - yellow",
    target=="purple"~"(130, 30, 180) - purple",
    target=="orange"~"(250, 120, 30) - orange",
    target=="pink"~"(200, 170, 170) - mauve",
    target=="mustard"~"(170, 160, 40) - chartreuse",
    target=="turquoise"~"(150, 200, 180) - turquoise",
    target=="neonyellow"~"(220, 240, 150) - honeydew",
    target=="darkgreenblue"~"(70, 100, 90) - teal",
    target=="lightred"~"(200, 100, 70) - sienna")
  )
ggplot(adult_color_rt, aes(reorder(target_label,-avg_rt,mean),avg_rt, color=condition))+
  geom_bar(aes(fill=condition,alpha=condition),stat="identity",size=1.5, position=position_dodge(.95))+
  geom_errorbar(aes(ymin=avg_rt-ci,ymax=avg_rt+ci), width=0.3,size=1.2, position=position_dodge(.95))+
  #coord_cartesian(ylim=c(500,700))+
  #ggtitle("Adult Discriminability")+
  ylab("Reaction Time (in ms)")+
  xlab("Color")+
  scale_color_brewer(palette="Set1",name="Nameability")+
  scale_fill_brewer(palette="Set1",name="Nameability")+
  scale_alpha_manual(name="Nameability",values=c(0,0.5))+
  theme_cowplot()+
  theme(legend.position=c(0.05,0.2),legend.background=element_rect(fill="white")) + 
  theme(axis.text.x  = element_text(angle=90, vjust=0.5),plot.title = element_text(hjust = 0.5))+
  theme(text=element_text(size=18))+
  theme(strip.text.x = element_text(size=16), plot.background = element_rect(fill="white",color="white"))

ggsave(here::here("figures","adult_color_rt.png"),width=9, height=6,dpi=600)

Overall Results

Evaluating whether high nameability colors and low nameability colors differ in their average discriminability (RT-based)

#overall average
adult_color_rt %>%
  group_by(condition) %>%
  summarize(
    N = n(),
    mean_rt = mean(avg_rt),
    sd = sd(avg_rt),
    ci = qt(0.975, N-1)*sd/sqrt(N),
    lower_ci = mean_rt-ci,
    upper_ci = mean_rt+ci
  ) %>%
  kable()

condition	N	mean_rt	sd	ci	lower_ci	upper_ci
high nameability	6	697.4225	12.83103	13.46535	683.9572	710.8878
low nameability	6	707.9727	12.61858	13.24238	694.7303	721.2151

# t-test
t.test(avg_rt ~ condition, data = adult_color_rt, paired = FALSE)

## 
##  Welch Two Sample t-test
## 
## data:  avg_rt by condition
## t = -1.436, df = 9.9972, p-value = 0.1815
## alternative hypothesis: true difference in means between group high nameability and group low nameability is not equal to 0
## 95 percent confidence interval:
##  -26.920756   5.820423
## sample estimates:
## mean in group high nameability  mean in group low nameability 
##                       697.4225                       707.9727

#Bayes Factor
#evidence for the null hypothesis
1/ttestBF(adult_color_rt$avg_rt[adult_color_rt$condition=="high nameability"],adult_color_rt$avg_rt[adult_color_rt$condition=="low nameability"],paired=TRUE)

## Bayes factor analysis
## --------------
## [1] Null, mu=0 : 1.686861 ±0.01%
## 
## Against denominator:
##   Alternative, r = 0.707106781186548, mu =/= 0 
## ---
## Bayes factor type: BFoneSample, JZS

Correlations

adult_color_rt_to_join <- adult_color_rt %>%
  select(target,avg_rt) %>%
  rename(adult_avg_rt=avg_rt)
kid_color_rt <- kid_color_rt %>%
  left_join(adult_color_rt_to_join)

ggplot(kid_color_rt,aes(avg_rt,adult_avg_rt))+
  geom_point(aes(color=condition))+
  geom_smooth(method="lm")+
  xlab("Average Color Reaction Time (ms) - Children")+
  ylab("Average Color Reaction Time (ms) - Adults")+
  theme(legend.position=c(0.1,0.2))

#Correlations
cor.test(
  kid_color_rt$avg_rt,
  kid_color_rt$adult_avg_rt,
)

## 
##  Pearson's product-moment correlation
## 
## data:  kid_color_rt$avg_rt and kid_color_rt$adult_avg_rt
## t = 1.4858, df = 10, p-value = 0.1682
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.1966373  0.8031451
## sample estimates:
##       cor 
## 0.4252545

Accuracy

Children

# participant accuracy for each color
kid_participant_color_acc <- kn_data %>%
  filter(condition!="practice") %>%
  group_by(subject_id,condition,target) %>% 
  summarize(
    N=sum(!is.na(correct)),
    avg_accuracy=mean(correct,na.rm=T)
  )

#average accuracy for each color
kid_color_acc <- kid_participant_color_acc %>%
  ungroup() %>%
  select(-N) %>%
  summarySEwithin("avg_accuracy",withinvars=c("condition","target"),idvar="subject_id",na.rm=TRUE)

Evaluating whether high nameability colors and low nameability colors differ in their average accuracy

#overall average
kid_color_acc %>%
  group_by(condition) %>%
  summarize(
    N = n(),
    mean_accuracy = mean(avg_accuracy),
    sd = sd(avg_accuracy),
    ci = qt(0.975, N-1)*sd/sqrt(N),
    lower_ci = mean_accuracy-ci,
    upper_ci = mean_accuracy+ci
  ) %>%
  kable()

condition	N	mean_accuracy	sd	ci	lower_ci	upper_ci
high nameability	6	0.9622684	0.0169353	0.0177725	0.9444959	0.9800409
low nameability	6	0.9685219	0.0106186	0.0111435	0.9573784	0.9796655

# t-test
t.test(avg_accuracy ~ condition, data = kid_color_acc, paired = FALSE)

## 
##  Welch Two Sample t-test
## 
## data:  avg_accuracy by condition
## t = -0.76632, df = 8.4051, p-value = 0.4645
## alternative hypothesis: true difference in means between group high nameability and group low nameability is not equal to 0
## 95 percent confidence interval:
##  -0.02491487  0.01240776
## sample estimates:
## mean in group high nameability  mean in group low nameability 
##                      0.9622684                      0.9685219

#Bayes Factor
#evidence for the null hypothesis
1/ttestBF(kid_color_acc$avg_accuracy[kid_color_acc$condition=="high nameability"],kid_color_acc$avg_accuracy[kid_color_acc$condition=="low nameability"],paired=TRUE)

## Bayes factor analysis
## --------------
## [1] Null, mu=0 : 1.809168 ±0.01%
## 
## Against denominator:
##   Alternative, r = 0.707106781186548, mu =/= 0 
## ---
## Bayes factor type: BFoneSample, JZS

Adults

# participant accuracy for each color
adult_participant_color_acc <- an_data %>%
  filter(condition!="practice") %>%
  group_by(subject_id,condition,target) %>% 
  summarize(
    N=sum(!is.na(correct)),
    avg_accuracy=mean(correct,na.rm=T)
  )

#average accuracy for each color
adult_color_acc <- adult_participant_color_acc %>%
  ungroup() %>%
  select(-N) %>%
  summarySEwithin("avg_accuracy",withinvars=c("condition","target"),idvar="subject_id",na.rm=TRUE)

Evaluating whether high nameability colors and low nameability colors differ in their average accuracy

#overall average
adult_color_acc %>%
  group_by(condition) %>%
  summarize(
    N = n(),
    mean_accuracy = mean(avg_accuracy),
    sd = sd(avg_accuracy),
    ci = qt(0.975, N-1)*sd/sqrt(N),
    lower_ci = mean_accuracy-ci,
    upper_ci = mean_accuracy+ci
  ) %>%
  kable()

condition	N	mean_accuracy	sd	ci	lower_ci	upper_ci
high nameability	6	0.9972222	0.0038968	0.0040895	0.9931328	1.001312
low nameability	6	0.9966667	0.0051640	0.0054193	0.9912474	1.002086

# t-test
t.test(avg_accuracy ~ condition, data = adult_color_acc, paired = FALSE)

## 
##  Welch Two Sample t-test
## 
## data:  avg_accuracy by condition
## t = 0.21035, df = 9.3001, p-value = 0.8379
## alternative hypothesis: true difference in means between group high nameability and group low nameability is not equal to 0
## 95 percent confidence interval:
##  -0.005389728  0.006500839
## sample estimates:
## mean in group high nameability  mean in group low nameability 
##                      0.9972222                      0.9966667

#Bayes Factor
#evidence for the null hypothesis
1/ttestBF(adult_color_acc$avg_accuracy[adult_color_acc$condition=="high nameability"],adult_color_acc$avg_accuracy[adult_color_acc$condition=="low nameability"],paired=TRUE)

## Bayes factor analysis
## --------------
## [1] Null, mu=0 : 2.630433 ±0%
## 
## Against denominator:
##   Alternative, r = 0.707106781186548, mu =/= 0 
## ---
## Bayes factor type: BFoneSample, JZS

Color Pair Analysis

Children

# participant reaction times for each color pair
kid_participant_color_pair_rt <- kn_data %>%
  filter(correct==1&condition!="practice"&rt<=5000&rt>=200) %>%
  group_by(subject_id,condition,pair,colorPair) %>% 
  summarize(
    N=sum(!is.na(rt)),
    avg_rt=mean(rt,na.rm=T)
  )

color_pairing <- kid_participant_color_pair_rt %>%
  ungroup() %>%
  select(pair,colorPair) %>%
  distinct()

#average reaction times for each color
kid_color_pair_rt <- kid_participant_color_pair_rt %>%
  ungroup() %>%
  select(-N) %>%
  summarySEwithin("avg_rt",withinvars=c("condition","pair"),idvar="subject_id",na.rm=TRUE) %>%
  left_join(color_pairing)

#join with color property data (from Zettersten & Lupyan, 2020)
kid_color_pair_rt <- kid_color_pair_rt %>%
  left_join(
    select(colorpair_discrim_rt_zl,colorPair,zl_average_rt,dE2000)
  ) %>%
  mutate(group="children")

Plot

ggplot(kid_color_pair_rt, aes(reorder(pair,-avg_rt,mean),avg_rt, color=condition))+
  geom_bar(aes(fill=condition,alpha=condition),stat="identity",size=1.5, position=position_dodge(.95))+
  geom_errorbar(aes(ymin=avg_rt-ci,ymax=avg_rt+ci), width=0.3,size=1.2, position=position_dodge(.95))+
  #coord_cartesian(ylim=c(500,700))+
  #ggtitle("Child Discriminability")+
  ylab("Reaction Time (in ms)")+
  xlab("Color Pair")+
  scale_color_brewer(palette="Set1",name="Nameability")+
  scale_fill_brewer(palette="Set1",name="Nameability")+
  scale_alpha_manual(name="Nameability",values=c(0,0.5))+
  theme(legend.position=c(0.05,0.2),legend.background=element_rect(fill="white")) + 
  theme(axis.text.x  = element_text(angle=90, vjust=0.5),plot.title = element_text(hjust = 0.5))

ggplot(kid_color_pair_rt, aes(condition,avg_rt, color=condition))+
  geom_boxplot()+
  geom_jitter(width=0.1)+
  xlab("Condition")+
  theme(legend.position="none")+
  ylab("Average Reaction Time (in ms)")+
  scale_color_brewer(palette="Set1",name="Nameability")

Overall Results

Evaluating whether high nameability colors and low nameability colors differ in their average discriminability (RT-based)

#overall average
kid_color_pair_rt %>%
  group_by(condition) %>%
  summarize(
    N = n(),
    mean_rt = mean(avg_rt),
    sd = sd(avg_rt),
    ci = qt(0.975, N-1)*sd/sqrt(N),
    lower_ci = mean_rt-ci,
    upper_ci = mean_rt+ci
  ) %>%
  kable()

condition	N	mean_rt	sd	ci	lower_ci	upper_ci
high nameability	15	1955.478	141.06121	78.11709	1877.361	2033.595
low nameability	15	2010.638	86.81263	48.07523	1962.563	2058.713

# t-test
t.test(avg_rt ~ condition, data = kid_color_pair_rt, paired = FALSE)

## 
##  Welch Two Sample t-test
## 
## data:  avg_rt by condition
## t = -1.2898, df = 23.275, p-value = 0.2098
## alternative hypothesis: true difference in means between group high nameability and group low nameability is not equal to 0
## 95 percent confidence interval:
##  -143.57177   33.25162
## sample estimates:
## mean in group high nameability  mean in group low nameability 
##                       1955.478                       2010.638

#Bayes Factor
#evidence for the null hypothesis
1/ttestBF(kid_color_pair_rt$avg_rt[kid_color_pair_rt$condition=="high nameability"],kid_color_pair_rt$avg_rt[kid_color_pair_rt$condition=="low nameability"],paired=TRUE)

## Bayes factor analysis
## --------------
## [1] Null, mu=0 : 2.08854 ±0.02%
## 
## Against denominator:
##   Alternative, r = 0.707106781186548, mu =/= 0 
## ---
## Bayes factor type: BFoneSample, JZS

Adults

# participant reaction times for each color pair
adult_participant_color_pair_rt <- an_data %>%
  filter(correct==1&condition!="practice"&rt<=2000&rt>=200) %>%
  group_by(subject_id,condition,pair,colorPair) %>% 
  summarize(
    N=sum(!is.na(rt)),
    avg_rt=mean(rt,na.rm=T)
  )

color_pairing <- adult_participant_color_pair_rt %>%
  ungroup() %>%
  select(pair,colorPair) %>%
  distinct()

#average reaction times for each color
adult_color_pair_rt <- adult_participant_color_pair_rt %>%
  ungroup() %>%
  select(-N) %>%
  summarySEwithin("avg_rt",withinvars=c("condition","pair"),idvar="subject_id",na.rm=TRUE) %>%
  left_join(color_pairing)

#join with color property data (from Zettersten & Lupyan, 2020)
adult_color_pair_rt <- adult_color_pair_rt %>%
  left_join(
    select(colorpair_discrim_rt_zl,colorPair,zl_average_rt,dE2000)
  )%>%
  mutate(group="adults")

Plot

ggplot(adult_color_pair_rt, aes(reorder(pair,-avg_rt,mean),avg_rt, color=condition))+
  geom_bar(aes(fill=condition,alpha=condition),stat="identity",size=1.5, position=position_dodge(.95))+
  geom_errorbar(aes(ymin=avg_rt-ci,ymax=avg_rt+ci), width=0.3,size=1.2, position=position_dodge(.95))+
  #coord_cartesian(ylim=c(500,700))+
  #ggtitle("Adult Discriminability")+
  ylab("Reaction Time (in ms)")+
  xlab("Color Pair")+
  scale_color_brewer(palette="Set1",name="Nameability")+
  scale_fill_brewer(palette="Set1",name="Nameability")+
  scale_alpha_manual(name="Nameability",values=c(0,0.5))+
  theme(legend.position=c(0.05,0.2),legend.background=element_rect(fill="white")) + 
  theme(axis.text.x  = element_text(angle=90, vjust=0.5),plot.title = element_text(hjust = 0.5))

ggplot(adult_color_pair_rt, aes(condition,avg_rt, color=condition))+
  geom_boxplot()+
  geom_jitter(width=0.1)+
  xlab("Condition")+
  theme(legend.position="none")+
  ylab("Average Reaction Time (in ms)")+
  scale_color_brewer(palette="Set1",name="Nameability")

Overall Results

Evaluating whether high nameability colors and low nameability colors differ in their average discriminability (RT-based)

#overall average
adult_color_pair_rt %>%
  group_by(condition) %>%
  summarize(
    N = n(),
    mean_rt = mean(avg_rt),
    sd = sd(avg_rt),
    ci = qt(0.975, N-1)*sd/sqrt(N),
    lower_ci = mean_rt-ci,
    upper_ci = mean_rt+ci
  ) %>%
  kable()

condition	N	mean_rt	sd	ci	lower_ci	upper_ci
high nameability	15	697.2153	19.12245	10.58966	686.6257	707.805
low nameability	15	708.1060	22.21639	12.30302	695.8030	720.409

# t-test
t.test(avg_rt ~ condition, data = adult_color_pair_rt, paired = FALSE)

## 
##  Welch Two Sample t-test
## 
## data:  avg_rt by condition
## t = -1.4389, df = 27.393, p-value = 0.1615
## alternative hypothesis: true difference in means between group high nameability and group low nameability is not equal to 0
## 95 percent confidence interval:
##  -26.40955   4.62822
## sample estimates:
## mean in group high nameability  mean in group low nameability 
##                       697.2153                       708.1060

#Bayes Factor
#evidence for the null hypothesis
1/ttestBF(adult_color_pair_rt$avg_rt[adult_color_pair_rt$condition=="high nameability"],adult_color_pair_rt$avg_rt[adult_color_pair_rt$condition=="low nameability"],paired=TRUE)

## Bayes factor analysis
## --------------
## [1] Null, mu=0 : 2.062726 ±0.02%
## 
## Against denominator:
##   Alternative, r = 0.707106781186548, mu =/= 0 
## ---
## Bayes factor type: BFoneSample, JZS

Correlations

Kids vs. Adults

color_pair_rt <- kid_color_pair_rt %>%
  bind_rows(adult_color_pair_rt)

color_pair_rt_wide <- color_pair_rt %>%
  select(-N,-se,-sd,-ci,-avg_rt_norm,-zl_average_rt,-dE2000,-colorPair) %>%
  pivot_wider(
    names_from="group",
    values_from="avg_rt"
  ) 

ggplot(color_pair_rt_wide, aes(children, adults))+
  geom_point()+
  geom_smooth(method="lm")

cor.test(
  color_pair_rt_wide$children,
  color_pair_rt_wide$adults,
)

## 
##  Pearson's product-moment correlation
## 
## data:  color_pair_rt_wide$children and color_pair_rt_wide$adults
## t = 1.2974, df = 28, p-value = 0.2051
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.1335968  0.5511213
## sample estimates:
##      cor 
## 0.238134

Main Linear Mixed-effects Model

Children

Reaction Time

We fit a trial-by-trial linear mixed effects model prediction reaction time from condition, including a by-participant random intercept and random slope for condition and a by-color-pair random intercept.

kn_data <- kn_data %>%
  mutate(condition_c=ifelse(condition=="high nameability",0.5,-0.5))
m <- lmer(rt ~ condition_c+(1+condition_c|subject_id)+(1|pair),data=filter(kn_data,rt<=5000&correct==1&condition!="practice"))
summary(m)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: rt ~ condition_c + (1 + condition_c | subject_id) + (1 | pair)
##    Data: filter(kn_data, rt <= 5000 & correct == 1 & condition != "practice")
## 
## REML criterion at convergence: 33074.9
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -2.7784 -0.6871 -0.2523  0.4923  3.6202 
## 
## Random effects:
##  Groups     Name        Variance Std.Dev. Corr
##  subject_id (Intercept) 205517.0 453.34       
##             condition_c    535.5  23.14   1.00
##  pair       (Intercept)      0.0   0.00       
##  Residual               749434.7 865.70       
## Number of obs: 2016, groups:  subject_id, 40; pair, 30
## 
## Fixed effects:
##             Estimate Std. Error      df t value Pr(>|t|)    
## (Intercept)  2017.35      74.99   36.87  26.903   <2e-16 ***
## condition_c   -57.23      38.77 1011.59  -1.476     0.14    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##             (Intr)
## condition_c 0.086 
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')

Reaction times decline with age, but there is no interaction with condition

m <- lmer(rt ~ condition_c*age_months+(1+condition_c|subject_id)+(1|pair),data=filter(kn_data,rt<=5000&correct==1&condition!="practice"))
summary(m)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: rt ~ condition_c * age_months + (1 + condition_c | subject_id) +  
##     (1 | pair)
##    Data: filter(kn_data, rt <= 5000 & correct == 1 & condition != "practice")
## 
## REML criterion at convergence: 33057.8
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -2.7907 -0.6853 -0.2493  0.4874  3.6249 
## 
## Random effects:
##  Groups     Name        Variance Std.Dev. Corr
##  subject_id (Intercept) 187864.9 433.4        
##             condition_c    449.6  21.2    1.00
##  pair       (Intercept)      0.0   0.0        
##  Residual               749544.8 865.8        
## Number of obs: 2016, groups:  subject_id, 40; pair, 30
## 
## Fixed effects:
##                        Estimate Std. Error       df t value Pr(>|t|)    
## (Intercept)            3441.009    640.205   38.044   5.375 4.08e-06 ***
## condition_c              37.359    356.604 1250.831   0.105   0.9166    
## age_months              -25.223     11.261   37.786  -2.240   0.0311 *  
## condition_c:age_months   -1.680      6.228 1223.142  -0.270   0.7874    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##             (Intr) cndtn_ ag_mnt
## condition_c  0.067              
## age_months  -0.994 -0.067       
## cndtn_c:g_m -0.067 -0.994  0.068
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')

Accuracy

We fit a trial-by-trial logistic mixed effects model prediction reaction time from condition, including a by-participant random intercept and random slope for condition and a by-color-pair random intercept.

m <- glmer(correct ~ condition_c+(1+condition_c|subject_id)+(1|pair),data=filter(kn_data,rt<=5000&condition!="practice"),family="binomial")
summary(m)

## Generalized linear mixed model fit by maximum likelihood (Laplace
##   Approximation) [glmerMod]
##  Family: binomial  ( logit )
## Formula: correct ~ condition_c + (1 + condition_c | subject_id) + (1 |  
##     pair)
##    Data: filter(kn_data, rt <= 5000 & condition != "practice")
## 
##      AIC      BIC   logLik deviance df.resid 
##    745.6    779.5   -366.8    733.6     2102 
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -6.2162  0.1443  0.1684  0.2226  0.4932 
## 
## Random effects:
##  Groups     Name        Variance Std.Dev. Corr
##  subject_id (Intercept) 0.63815  0.7988       
##             condition_c 0.41025  0.6405   0.39
##  pair       (Intercept) 0.08115  0.2849       
## Number of obs: 2108, groups:  subject_id, 40; pair, 30
## 
## Fixed effects:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  3.46654    0.21950  15.793   <2e-16 ***
## condition_c -0.00809    0.35555  -0.023    0.982    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##             (Intr)
## condition_c 0.075

No interaction between condition and age

m <- glmer(correct ~ condition_c*age_months+(1+condition_c|subject_id)+(1|pair),data=filter(kn_data,rt<=5000&condition!="practice"),family="binomial",glmerControl(optimizer="bobyqa"))
summary(m)

## Generalized linear mixed model fit by maximum likelihood (Laplace
##   Approximation) [glmerMod]
##  Family: binomial  ( logit )
## Formula: correct ~ condition_c * age_months + (1 + condition_c | subject_id) +  
##     (1 | pair)
##    Data: filter(kn_data, rt <= 5000 & condition != "practice")
## Control: glmerControl(optimizer = "bobyqa")
## 
##      AIC      BIC   logLik deviance df.resid 
##    747.9    793.1   -366.0    731.9     2100 
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -6.7754  0.1408  0.1704  0.2208  0.4996 
## 
## Random effects:
##  Groups     Name        Variance Std.Dev. Corr
##  subject_id (Intercept) 0.60217  0.7760       
##             condition_c 0.44166  0.6646   0.39
##  pair       (Intercept) 0.08392  0.2897       
## Number of obs: 2108, groups:  subject_id, 40; pair, 30
## 
## Fixed effects:
##                         Estimate Std. Error z value Pr(>|z|)
## (Intercept)             1.446082   1.572422   0.920    0.358
## condition_c             0.222853   2.320342   0.096    0.923
## age_months              0.035772   0.027936   1.281    0.200
## condition_c:age_months -0.004072   0.041511  -0.098    0.922
## 
## Correlation of Fixed Effects:
##             (Intr) cndtn_ ag_mnt
## condition_c  0.056              
## age_months  -0.990 -0.051       
## cndtn_c:g_m -0.052 -0.988  0.050

Adults

Reaction Time

an_data <- an_data %>%
  mutate(condition_c=ifelse(condition=="high nameability",0.5,-0.5))
m <- lmer(rt ~ condition_c+(1+condition_c|subject_id)+(1|pair),data=filter(an_data,rt<=2000&correct==1&condition!="practice"))
summary(m)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: rt ~ condition_c + (1 + condition_c | subject_id) + (1 | pair)
##    Data: filter(an_data, rt <= 2000 & correct == 1 & condition != "practice")
## 
## REML criterion at convergence: 38714.3
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -2.5430 -0.4753 -0.1596  0.1982  8.2731 
## 
## Random effects:
##  Groups     Name        Variance Std.Dev. Corr 
##  subject_id (Intercept) 14002.26 118.331       
##             condition_c    52.53   7.248  -1.00
##  pair       (Intercept)   202.73  14.238       
##  Residual               22720.14 150.732       
## Number of obs: 2994, groups:  subject_id, 50; pair, 30
## 
## Fixed effects:
##             Estimate Std. Error      df t value Pr(>|t|)    
## (Intercept)  702.720     17.158  51.113  40.956   <2e-16 ***
## condition_c  -10.822      7.644  28.638  -1.416    0.168    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##             (Intr)
## condition_c -0.131
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')

Accuracy

m <- glmer(correct ~ condition_c+(1+condition_c|subject_id)+(1|pair),data=filter(kn_data,rt<=2000&condition!="practice"),family="binomial",glmerControl(optimizer="bobyqa"))
summary(m)

## Generalized linear mixed model fit by maximum likelihood (Laplace
##   Approximation) [glmerMod]
##  Family: binomial  ( logit )
## Formula: correct ~ condition_c + (1 + condition_c | subject_id) + (1 |  
##     pair)
##    Data: filter(kn_data, rt <= 2000 & condition != "practice")
## Control: glmerControl(optimizer = "bobyqa")
## 
##      AIC      BIC   logLik deviance df.resid 
##    581.4    612.6   -284.7    569.4     1332 
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -5.4457  0.1836  0.2062  0.2512  0.4147 
## 
## Random effects:
##  Groups     Name        Variance Std.Dev. Corr 
##  subject_id (Intercept) 0.412434 0.64221       
##             condition_c 0.136987 0.37012  -0.41
##  pair       (Intercept) 0.006471 0.08044       
## Number of obs: 1338, groups:  subject_id, 40; pair, 30
## 
## Fixed effects:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  3.03797    0.20974   14.48   <2e-16 ***
## condition_c  0.06529    0.34277    0.19    0.849    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##             (Intr)
## condition_c 0.005

Child - Adult Interaction

We also found no significant interaction between age group and condition in a linear mixed-effects model.

overall_data <- kn_data %>%
  select(-home_income,-parental_education,-family_history_color_blindness,-color_blindness_dx) %>%
  bind_rows(select(an_data,-home_income,-parental_education,-family_history_color_blindness,-color_blindness_dx)) %>%
  mutate(age_group_c=ifelse(age_group=="children",-0.5,0.5))
m <- lmer(rt~ condition_c*age_group_c+(1+condition_c|subject_id)+(1|pair),data=filter(overall_data,rt<=5000&correct==1&condition!="practice"))
summary(m)

## Linear mixed model fit by REML. t-tests use Satterthwaite's method [
## lmerModLmerTest]
## Formula: rt ~ condition_c * age_group_c + (1 + condition_c | subject_id) +  
##     (1 | pair)
##    Data: filter(overall_data, rt <= 5000 & correct == 1 & condition !=  
##     "practice")
## 
## REML criterion at convergence: 78019.9
## 
## Scaled residuals: 
##     Min      1Q  Median      3Q     Max 
## -4.2645 -0.2661 -0.0709  0.1011  5.5680 
## 
## Random effects:
##  Groups     Name        Variance Std.Dev. Corr
##  subject_id (Intercept)  98948.5 314.56       
##             condition_c    152.8  12.36   1.00
##  pair       (Intercept)    114.1  10.68       
##  Residual               318823.5 564.64       
## Number of obs: 5016, groups:  subject_id, 90; pair, 30
## 
## Fixed effects:
##                         Estimate Std. Error       df t value Pr(>|t|)    
## (Intercept)              1362.67      34.58    82.36  39.409   <2e-16 ***
## condition_c               -33.42      16.78    30.38  -1.991   0.0555 .  
## age_group_c             -1312.36      69.04    82.39 -19.007   <2e-16 ***
## condition_c:age_group_c    49.41      32.65  2707.68   1.513   0.1303    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Correlation of Fixed Effects:
##             (Intr) cndtn_ ag_gr_
## condition_c  0.073              
## age_group_c -0.125 -0.006       
## cndtn_c:g__ -0.006 -0.191  0.075
## optimizer (nloptwrap) convergence code: 0 (OK)
## boundary (singular) fit: see help('isSingular')

Relation with Zettersten & Lupyan (2020) norming data

ZL discriminability - Single Color

Children & ZL discriminability

Correlation Plot

p1 <- ggplot(kid_color_rt,aes(avg_rt,rt_different))+
  geom_point(aes(color=condition))+
  geom_smooth(method="lm")+
  xlab("Average Color Reaction Time (ms) - Children")+
  ylab("Average Color Reaction Time (ms) - Different Trials\nZettersten & Lupyan (2020)")+
  theme(legend.position=c(0.1,0.2))

p2 <- ggplot(kid_color_rt,aes(avg_rt,rt_same))+
  geom_point(aes(color=condition))+
  geom_smooth(method="lm")+
  xlab("Average Color Reaction Time (ms) - Children")+
  ylab("Average Color Reaction Time (ms) - Same Trials\nZettersten & Lupyan (2020)")+
  theme(legend.position=c(0.1,0.2))

plot_grid(p1,p2)

Correlation - Different Trials

#Correlations
cor.test(
  kid_color_rt$avg_rt,
  kid_color_rt$rt_different,
)

## 
##  Pearson's product-moment correlation
## 
## data:  kid_color_rt$avg_rt and kid_color_rt$rt_different
## t = 0.83735, df = 10, p-value = 0.422
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.3726785  0.7235771
## sample estimates:
##       cor 
## 0.2559703

Correlation - Same Trials

cor.test(
  kid_color_rt$avg_rt,
  kid_color_rt$rt_same,
)

## 
##  Pearson's product-moment correlation
## 
## data:  kid_color_rt$avg_rt and kid_color_rt$rt_same
## t = 0.99379, df = 10, p-value = 0.3438
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.3310550  0.7454477
## sample estimates:
##       cor 
## 0.2998081

Adults & ZL discriminability

Correlation Plot

p1 <- ggplot(adult_color_rt,aes(avg_rt,rt_different))+
  geom_point(aes(color=condition))+
  geom_smooth(method="lm")+
  xlab("Average Color Reaction Time (ms) - Adults")+
  ylab("Average Color Reaction Time (ms) - Different Trials\nZettersten & Lupyan (2020)")+
  theme(legend.position=c(0.1,0.2))

p2 <- ggplot(adult_color_rt,aes(avg_rt,rt_same))+
  geom_point(aes(color=condition))+
  geom_smooth(method="lm")+
  xlab("Average Color Reaction Time (ms) - Adults")+
  ylab("Average Color Reaction Time (ms) - Same Trials\nZettersten & Lupyan (2020)")+
  theme(legend.position=c(0.1,0.2))

plot_grid(p1,p2)

Correlation - Different Trials

#Correlations
cor.test(
  adult_color_rt$avg_rt,
  adult_color_rt$rt_different,
)

## 
##  Pearson's product-moment correlation
## 
## data:  adult_color_rt$avg_rt and adult_color_rt$rt_different
## t = 1.4791, df = 10, p-value = 0.1699
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.1984921  0.8024590
## sample estimates:
##       cor 
## 0.4236721

Correlation - Same Trials

cor.test(
  adult_color_rt$avg_rt,
  adult_color_rt$rt_same,
)

## 
##  Pearson's product-moment correlation
## 
## data:  adult_color_rt$avg_rt and adult_color_rt$rt_same
## t = 1.3664, df = 10, p-value = 0.2018
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.2294993  0.7905820
## sample estimates:
##       cor 
## 0.3966443

ZL discriminability - Color Pairs

Children & ZL discriminability

ggplot(kid_color_pair_rt,aes(avg_rt,zl_average_rt))+
  geom_point(aes(color=condition,shape=condition),size=3)+
  geom_smooth(method="lm",color="black")+
  scale_color_brewer(palette = "Set1") +
  xlab("Average Color Reaction Time (ms) - Children")+
  ylab("Average Color Reaction Time (ms) - Color Pairs\nZettersten & Lupyan (2020)")+
  theme(legend.position=c(0.1,0.7))

#Correlations
cor.test(
  kid_color_pair_rt$avg_rt,
  kid_color_pair_rt$zl_average_rt,
)

## 
##  Pearson's product-moment correlation
## 
## data:  kid_color_pair_rt$avg_rt and kid_color_pair_rt$zl_average_rt
## t = 0.27549, df = 28, p-value = 0.785
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.3141613  0.4046816
## sample estimates:
##        cor 
## 0.05199258

Adults & ZL discriminability

ggplot(adult_color_pair_rt,aes(avg_rt,zl_average_rt))+
  geom_point(aes(color=condition,shape=condition),size=3)+
  geom_smooth(method="lm",color="black")+
  scale_color_brewer(palette = "Set1") +
  xlab("Average Color Reaction Time (ms) - Children")+
  ylab("Average Color Reaction Time (ms) - Color Pairs\nZettersten & Lupyan (2020)")+
  theme(legend.position=c(0.1,0.8))+
  theme(text=element_text(size=18))+
  theme(strip.text.x = element_text(size=16), plot.background = element_rect(fill="white",color="white"))

ggsave(here::here("figures","adult_zl2020.png"),width=9, height=6,dpi=600)

#Correlations
cor.test(
  adult_color_pair_rt$avg_rt,
  adult_color_pair_rt$zl_average_rt,
)

## 
##  Pearson's product-moment correlation
## 
## data:  adult_color_pair_rt$avg_rt and adult_color_pair_rt$zl_average_rt
## t = 3.5351, df = 28, p-value = 0.001439
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  0.2440871 0.7630627
## sample estimates:
##       cor 
## 0.5555067

deltaE 2000

Children & deltaE2000

ggplot(kid_color_pair_rt,aes(avg_rt,dE2000))+
  geom_point(aes(color=condition,shape=condition),size=3)+
  geom_smooth(method="lm",color="black")+
  scale_color_brewer(palette = "Set1") +
  xlab("Average Color Reaction Time (ms) - Children")+
  ylab("deltaE2000")+
  theme(legend.position=c(0.05,0.15))+
  theme(text=element_text(size=18))+
  theme(strip.text.x = element_text(size=16), plot.background = element_rect(fill="white",color="white"))

ggsave(here::here("figures","kid_dE2000.png"),width=9, height=6,dpi=600)

Children’s reaction times correlated with deltaE2000 values.

#Correlations
cor.test(
  kid_color_pair_rt$avg_rt,
  kid_color_pair_rt$dE2000,
)

## 
##  Pearson's product-moment correlation
## 
## data:  kid_color_pair_rt$avg_rt and kid_color_pair_rt$dE2000
## t = -2.7797, df = 28, p-value = 0.009614
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.7068843 -0.1258672
## sample estimates:
##        cor 
## -0.4650483

Adults & deltaE2000

ggplot(adult_color_pair_rt,aes(avg_rt,dE2000))+
  geom_point(aes(color=condition,shape=condition),size=3)+
  geom_smooth(method="lm",color="black")+
  scale_color_brewer(palette = "Set1") +
  xlab("Average Color Reaction Time (ms) - Adults")+
  ylab("deltaE2000")+
  theme(legend.position=c(0.6,0.8))+
  theme(text=element_text(size=18))+
  theme(strip.text.x = element_text(size=16), plot.background = element_rect(fill="white",color="white"))

ggsave(here::here("figures","adult_dE2000.png"),width=9, height=6,dpi=600)

Adults’ reaction times correlated with deltaE2000 values.

#Correlations
cor.test(
  adult_color_pair_rt$avg_rt,
  adult_color_pair_rt$dE2000,
)

## 
##  Pearson's product-moment correlation
## 
## data:  adult_color_pair_rt$avg_rt and adult_color_pair_rt$dE2000
## t = -2.2736, df = 28, p-value = 0.03086
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.66102293 -0.04021603
## sample estimates:
##        cor 
## -0.3947657

ZL discriminability (adults) & deltaE2000

ggplot(adult_color_pair_rt,aes(zl_average_rt,dE2000))+
  geom_point(aes(color=condition,shape=condition),size=3)+
  geom_smooth(method="lm",color="black")+
  scale_color_brewer(palette = "Set1") +
  xlab("Average Color Reaction Time (ms) - Adults\n(Zettersten & Lupyan (2020)")+
  ylab("deltaE2000")+
  theme(legend.position=c(0.7,0.8))

Adults’ reaction times correlated with deltaE2000 values.

#Correlations
cor.test(
  adult_color_pair_rt$zl_average_rt,
  adult_color_pair_rt$dE2000,
)

## 
##  Pearson's product-moment correlation
## 
## data:  adult_color_pair_rt$zl_average_rt and adult_color_pair_rt$dE2000
## t = -2.3761, df = 28, p-value = 0.02457
## alternative hypothesis: true correlation is not equal to 0
## 95 percent confidence interval:
##  -0.67089704 -0.05791726
## sample estimates:
##       cor 
## -0.409639

Session Info

sessionInfo()

## R version 4.2.2 (2022-10-31)
## Platform: aarch64-apple-darwin20 (64-bit)
## Running under: macOS Monterey 12.6.8
## 
## Matrix products: default
## BLAS:   /Library/Frameworks/R.framework/Versions/4.2-arm64/Resources/lib/libRblas.0.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.2-arm64/Resources/lib/libRlapack.dylib
## 
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
## 
## attached base packages:
## [1] stats     graphics  grDevices utils     datasets  methods   base     
## 
## other attached packages:
##  [1] effectsize_0.8.3       BayesFactor_0.9.12-4.4 coda_0.19-4           
##  [4] jsonlite_1.8.4         ggpirate_0.1.2         janitor_2.2.0         
##  [7] lmerTest_3.1-3         car_3.1-1              carData_3.0-5         
## [10] lme4_1.1-31            Matrix_1.5-1           cowplot_1.1.1         
## [13] forcats_0.5.2          stringr_1.5.0          purrr_1.0.1           
## [16] readr_2.1.3            tidyr_1.3.0            tibble_3.2.1          
## [19] ggplot2_3.4.2          tidyverse_1.3.2        here_1.0.1            
## [22] dplyr_1.1.2            plyr_1.8.8             knitr_1.41            
## 
## loaded via a namespace (and not attached):
##  [1] TH.data_1.1-2       googledrive_2.0.0   minqa_1.2.5        
##  [4] colorspace_2.0-3    ellipsis_0.3.2      rprojroot_2.0.3    
##  [7] estimability_1.4.1  snakecase_0.11.0    parameters_0.20.2  
## [10] fs_1.5.2            rstudioapi_0.14     farver_2.1.1       
## [13] MatrixModels_0.5-1  bit64_4.0.5         fansi_1.0.3        
## [16] mvtnorm_1.1-3       lubridate_1.9.0     xml2_1.3.3         
## [19] codetools_0.2-18    splines_4.2.2       cachem_1.0.6       
## [22] nloptr_2.0.3        broom_1.0.4         dbplyr_2.2.1       
## [25] compiler_4.2.2      httr_1.4.4          emmeans_1.8.4-1    
## [28] backports_1.4.1     assertthat_0.2.1    fastmap_1.1.0      
## [31] gargle_1.2.1        cli_3.6.1           htmltools_0.5.4    
## [34] tools_4.2.2         gtable_0.3.1        glue_1.6.2         
## [37] Rcpp_1.0.9          cellranger_1.1.0    jquerylib_0.1.4    
## [40] vctrs_0.6.2         nlme_3.1-160        insight_0.19.0     
## [43] xfun_0.36           rvest_1.0.3         timechange_0.1.1   
## [46] lifecycle_1.0.3     googlesheets4_1.0.1 MASS_7.3-58.1      
## [49] zoo_1.8-11          scales_1.2.1        vroom_1.6.0        
## [52] ragg_1.2.5          hms_1.1.2           parallel_4.2.2     
## [55] sandwich_3.0-2      RColorBrewer_1.1-3  yaml_2.3.6         
## [58] pbapply_1.7-0       sass_0.4.4          stringi_1.7.8      
## [61] highr_0.10          bayestestR_0.13.0   boot_1.3-28        
## [64] systemfonts_1.0.4   rlang_1.1.0         pkgconfig_2.0.3    
## [67] evaluate_0.19       lattice_0.20-45     labeling_0.4.2     
## [70] bit_4.0.5           tidyselect_1.2.0    magrittr_2.0.3     
## [73] R6_2.5.1            generics_0.1.3      multcomp_1.4-23    
## [76] DBI_1.1.3           mgcv_1.8-41         pillar_1.9.0       
## [79] haven_2.5.1         withr_2.5.0         survival_3.4-0     
## [82] datawizard_0.6.5    abind_1.4-5         modelr_0.1.10      
## [85] crayon_1.5.2        utf8_1.2.2          tzdb_0.3.0         
## [88] rmarkdown_2.19      grid_4.2.2          readxl_1.4.1       
## [91] reprex_2.0.2        digest_0.6.31       xtable_1.8-4       
## [94] numDeriv_2016.8-1.1 textshaping_0.3.6   munsell_0.5.0      
## [97] bslib_0.4.2

Color Rule Kid - Norming Data

Anonymized for peer review

02 August, 2023

Read in and processing data

Read demographics

Processing data

Exclude participants

Demographics

Children

Age, Gender

Race

Ethnicity

Household Income

Parental Education

Adults

Age, Gender

Race

Ethnicity

Single-color analysis

Reaction Times

Children

Plot

Overall Results

Adults

Plot

Overall Results

Correlations

Accuracy

Children

Adults

Color Pair Analysis

Children

Plot

Overall Results

Adults

Plot

Overall Results

Correlations

Kids vs. Adults

Main Linear Mixed-effects Model

Children

Reaction Time

Accuracy

Adults

Reaction Time

Accuracy

Child - Adult Interaction

Relation with Zettersten & Lupyan (2020) norming data

ZL discriminability - Single Color

Children & ZL discriminability

Correlation Plot

Correlation - Different Trials

Correlation - Same Trials

Adults & ZL discriminability

Correlation Plot

Correlation - Different Trials

Correlation - Same Trials

ZL discriminability - Color Pairs

Children & ZL discriminability

Adults & ZL discriminability

deltaE 2000

Children & deltaE2000

Adults & deltaE2000

ZL discriminability (adults) & deltaE2000

Session Info