simpimp ana - eye-tracking and iPad data
Erica Yoon
February 4, 2016
rm(list = ls())
setwd("/Users/ericang/Documents/Research/simpimp_GIT/")
source("useful.R")
source("et_helper.R")
library(ggplot2)
library(data.table)
d_et <- fread("/Users/ericang/Documents/Research/simpimp_GIT/simpimp_et_all.csv")##
Read 0.0% of 3822758 rows
Read 32.2% of 3822758 rows
Read 68.0% of 3822758 rows
Read 3822758 rows and 10 (of 10) columns from 0.287 GB file in 00:00:06head(d_et)## expt subid stimulus order trial_type age_group correct
## 1: et_2vs1 140217-02 simpkidsL1.012 1 cs 3 TRUE
## 2: et_2vs1 140217-02 simpkidsL1.012 1 cs 3 TRUE
## 3: et_2vs1 140217-02 simpkidsL1.012 1 cs 3 TRUE
## 4: et_2vs1 140217-02 simpkidsL1.012 1 cs 3 TRUE
## 5: et_2vs1 140217-02 simpkidsL1.012 1 cs 3 TRUE
## 6: et_2vs1 140217-02 simpkidsL1.012 1 cs 3 TRUE
## t.crit targetAtOnset t.crit.binned
## 1: -6.233667 FALSE -6.233
## 2: -6.225333 FALSE -6.233
## 3: -6.217000 FALSE -6.233
## 4: -6.208667 FALSE -6.200
## 5: -6.200333 FALSE -6.200
## 6: -6.192000 FALSE -6.200d_ip <- fread("/Users/ericang/Documents/Research/simpimp_GIT/simpimp_ipad_short.csv")
d_ip$expt <- "ipad"
head(d_ip)## subid age_group trial_type item_num correct rt expt
## 1: 141204-01-sc 3 practice NA 1 7545 ipad
## 2: 141204-01-sc 3 practice NA 1 1610 ipad
## 3: 141204-01-sc 3 control_single 2vs2 1 1997 ipad
## 4: 141204-01-sc 3 inference 3vs1 1 1897 ipad
## 5: 141204-01-sc 3 control_double 3vs1 1 3739 ipad
## 6: 141204-01-sc 3 control_single 1vs1 1 1517 ipadlook at distribution of rt for ipad data
# ipad rt
ggplot(subset(d_ip, trial_type != "practice"), aes(x=rt, fill=trial_type)) +
geom_histogram(binwidth=200, position="dodge") +
geom_vline(aes(xintercept=mean(rt, na.rm=T)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(d_ip$rt) + 2*sd(d_ip$rt, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(d_ip$rt) + 3*sd(d_ip$rt, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
facet_grid(item_num~.) +
ggtitle("ipad RT: accurate + inaccurate responses")
# only accurate
ggplot(subset(d_ip, trial_type != "practice" & correct == TRUE), aes(x=rt, fill=trial_type)) +
geom_histogram(binwidth=200, position="dodge") +
geom_vline(aes(xintercept=mean(rt, na.rm=T)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(d_ip$rt) + 2*sd(d_ip$rt, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(d_ip$rt) + 3*sd(d_ip$rt, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
facet_grid(item_num~.) +
ggtitle("ipad RT: only accurate responses")
Similar spread for control and inference trials, across different numbers of items.
Max is within 15 seconds. Cut 3 SD from the mean:
# remove outliers, by rt
dropcrit <- mean(d_ip$rt) + 3*sd(d_ip$rt, na.rm=TRUE)
d_ip <- d_ip %>%
filter(rt < dropcrit)look at distribution of rt for eye-tracking data
# et rt
# information on when the first switch was made (distractor -> target or target -> distractor, after word onset)
d_et1 <- d_et %>%
filter(t.crit > 0) %>%
filter((targetAtOnset == FALSE & correct == TRUE) | (targetAtOnset == TRUE & correct == FALSE)) %>%
group_by(subid, stimulus) %>%
summarize(switch_t = min(t.crit))
d_et <- inner_join(d_et, d_et1)## Joining by: c("subid", "stimulus")# distribution of rt
ggplot(subset(d_et, targetAtOnset == FALSE), aes(x=switch_t, fill=trial_type)) +
geom_histogram(binwidth=0.05, position="dodge") +
geom_vline(aes(xintercept=mean(switch_t, na.rm=T)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(switch_t) + 2*sd(switch_t, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(switch_t) + 3*sd(switch_t, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
facet_grid(expt~.) +
ggtitle("RT for switching from distractor to target")
Very interestingly, rt’s much less spread out for 3-vs-1 experiment, control-double and inference trials. (And a hint of difference between control-single trials in 2-vs-1 vs. 3-vs-1 expt, but not so much?)
Look at the distribution of rt for switching from TARGET to DISTRACTOR too:
# distribution of rt
ggplot(subset(d_et, targetAtOnset == TRUE), aes(x=switch_t, fill=trial_type)) +
geom_histogram(binwidth=0.05, position="dodge") +
geom_vline(aes(xintercept=mean(switch_t, na.rm=T)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(switch_t) + 2*sd(switch_t, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
geom_vline(aes(xintercept=mean(switch_t) + 3*sd(switch_t, na.rm=TRUE)), # Ignore NA values for mean
color="red", linetype="dashed", size=1) +
facet_grid(expt~.) +
ggtitle("RT for switching from target to distractor")
The same pattern shows up, where the control-single looks similar across the 2 expts but control-double and inference have very quick reaction times.
eye-tracking
## correct ~ t.crit.binned + trial_type + age_group
mss <- d_et %>%
filter(age_group == "2" | age_group == "3" | age_group == "4" | age_group == "5" | age_group == "adult") %>%
# filter(expt == "0") %>%
filter(t.crit > -1 & t.crit <= 3) %>%
group_by(expt,trial_type, age_group, t.crit.binned, subid) %>%
summarise(correct = mean(correct, na.rm = TRUE)) %>%
ungroup() %>%
mutate(subid = as.factor(subid),
age_group = as.factor(age_group),
age_group = factor(age_group, levels = c("2","3","4", "5", "adult")),
expt = as.factor(expt))
levels(mss$expt) = c("2-vs-1", "3-vs-1")
ms <- mss %>%
mutate(trial_type = as.factor(trial_type)) %>%
group_by(expt, t.crit.binned, trial_type, age_group) %>%
summarise(correct = mean(correct, na.rm=TRUE))
# compare age groups
p <- ggplot(subset(ms, age_group != "adult"), aes(x = t.crit.binned, y = correct, colour = age_group)) +
geom_line() +
facet_grid(expt~trial_type) +
geom_vline(xintercept=0,lty=3) +
geom_vline(xintercept=0.78,lty=3) +
geom_hline(yintercept=.50,lty=4) +
xlab("Time (s)") + ylab("Proportion correct looking") +
scale_x_continuous(expand = c(0,0)) +
scale_y_continuous(limits=c(0,1),expand = c(0,0))
p
Children are better at finding the correct answer for control trials than inference. They also get increasingly better at any trials with increasing age.
But there doesn’t seem to be an advantage/disadvantage of having 3 items instead of 2 for the distractor.
What if we compare 2-vs-1 and 3-vs-1 directly, facetting by condition and age-group?
# compare 2-vs-1 vs. 3-vs-1
p <- ggplot(subset(ms, age_group != "adult"), aes(x = t.crit.binned, y = correct, colour = expt)) +
geom_line() +
facet_grid(age_group~trial_type) +
geom_vline(xintercept=0,lty=3) +
geom_vline(xintercept=0.78,lty=3) +
geom_hline(yintercept=.50,lty=4) +
xlab("Time (s)") + ylab("Proportion correct looking") +
scale_x_continuous(expand = c(0,0)) +
scale_y_continuous(limits=c(0,1),expand = c(0,0))
p
(control-single trials were the same in the two experiments)
There does not seem to be any difference between the two experiments.
onset-contingency for inference trials
ms <- d_et %>%
filter(age_group == "2" | age_group == "3" | age_group == "4" | age_group == "5") %>%
filter(trial_type == "inf") %>%
group_by(expt, age_group, targetAtOnset, t.crit.binned) %>%
summarize(correct = mean(correct, na.rm=TRUE)) %>%
filter(targetAtOnset != "NA") %>%
ungroup() %>%
mutate(targetAtOnset = as.numeric(targetAtOnset),
correct = ifelse(targetAtOnset==1, 1-correct, correct),
targetAtOnset = as.factor(targetAtOnset),
age_group = factor(age_group, levels = c("2","3","4", "5", "adult")))
levels(ms$targetAtOnset) <- c("distractor first", "target first")
qplot(as.numeric(as.character(t.crit.binned)),correct,
colour=factor(targetAtOnset),
geom="line", #lty=factor(targetAtOnset), # alpha=.5,
data=ms) +
facet_wrap(expt~age_group, ncol=4) +
scale_fill_brewer(palette="Set1") +
geom_hline(yintercept=.5,lty=4) +
geom_vline(xintercept=.78,lty=3) +
geom_vline(xintercept=0,lty=3) +
scale_y_continuous(expand = c(0, 0), limits=c(0,20)) +
xlab("Time (s)") + ylab("Proportion switching") +
scale_x_continuous(limits=c(0,2.9),expand = c(0,0)) +
scale_y_continuous(limits=c(0,1),expand = c(0,0)) # make the axes start at 0## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.## Warning: Removed 452 rows containing missing values (geom_path).
We see difference between 2-year-olds vs. 3, 4, 5-year-olds, but again no difference between 2-vs-1 and 3-vs-1.
iPad
We tested the same stimuli on an iPad paradigm. The difference was that each participant saw both kinds of trials for control-double and inference: 2-vs-1 and 3-vs-1. We also included another variation for control-single trials (1-vs-1 and 2-vs-2).
mss <- d_ip %>%
filter(trial_type != "practice" & age_group != "2" & age_group != "6") %>%
group_by(age_group, trial_type, item_num, subid) %>%
summarize(correct = mean(correct, na.rm=TRUE),
rt = mean(rt, na.rm=TRUE))
# accuracy
ms <- mss %>%
group_by(age_group, trial_type, item_num) %>%
summarise(correct = mean(correct, na.rm=TRUE),
cih = ci.high(correct, na.rm=TRUE),
cil = ci.low(correct, na.rm=TRUE))
ggplot(ms,
aes(fill=item_num, y=correct, x=age_group)) +
geom_bar(position="dodge", stat="identity") +
ylab("accuracy rate") +
facet_grid(.~trial_type) +
guides(fill=guide_legend(title=NULL)) +
geom_hline(yintercept=.50,lty=4) +
geom_errorbar(aes(ymin=correct-cil,ymax=correct+cih,width=.2),position=position_dodge(width = 0.90))
There does not seem to be any difference between the item numbers.
However, it is really striking that the accuracy rate on the iPad paradigm is much higher compared to eye-tracking paradigm, especially for the inference trials!
Comparing control-double and inference trials across experiments
Here we compare only the control-double and inference trials across the eye-tracking and ipad paradigms.
# rearrange eye-tracking data
d_et_comp <- d_et %>%
filter(t.crit > 0.78 & t.crit <= 3) %>%
mutate(item_num = substring(expt, 4)) %>%
select(item_num, age_group, trial_type, t.crit, correct, subid) %>%
mutate(correct = as.factor(correct))
levels(d_et_comp$correct) <- c(0,1)
d_et_comp$correct <- as.numeric(as.character(d_et_comp$correct))
d_et_comp <- d_et_comp %>%
mutate(trial_type = as.factor(trial_type)) %>%
group_by(age_group, trial_type, item_num, subid) %>%
summarise(correct = mean(correct, na.rm = TRUE))
levels(d_et_comp$trial_type) <- c("control_double", "control_single", "inference")
d_et_comp$expt <- "eye-tracking"
# rearrange iPad data
d_ip_comp <- d_ip %>%
select(age_group, trial_type, item_num, correct, subid) %>%
group_by(age_group, trial_type, item_num, subid) %>%
summarise(correct = mean(correct, na.rm = TRUE))
d_ip_comp$expt <- "iPad"
# combine the two
d_comp <- rbind(d_et_comp, d_ip_comp)
d_comp <- d_comp %>%
mutate_each(funs(factor), c(expt, age_group, trial_type, item_num, subid)) %>%
filter(age_group != "6" & age_group != "adult") %>%
droplevels()
# inference
d_comp_inf <- d_comp %>%
filter(trial_type == "inference")
ms <- d_comp_inf %>%
group_by(expt, age_group, item_num) %>%
summarise(correct = mean(correct, na.rm = TRUE),
cih = ci.high(correct, na.rm = TRUE),
cil = ci.low(correct, na.rm = TRUE))
# bar graph
ggplot(ms,
aes(fill=item_num, y=correct, x=age_group)) +
geom_bar(position="dodge", stat="identity") +
facet_wrap(~expt, ncol=4) +
ylab("Proportion correct looking") +
guides(fill=guide_legend(title=NULL)) +
geom_hline(yintercept=.50,lty=4) +
geom_errorbar(aes(ymin=correct-cil,ymax=correct+cih,width=.2),position=position_dodge(width = 0.90)) +
ggtitle("Inference trials: eye-t vs. iPad")
(ignore 2-year-olds for iPad, there were only a couple of participants)
For inference trials in eye-tracking, 3-year-olds are at chance and 4- and 5-year-olds are barely above chance for inference trials, while in iPad paradigm, even 3-year-olds are well above chance, nearing 80% accuracy rate.
Is this true of other trials too (control-double and control-single)?
# control-double
d_comp_cd <- d_comp %>%
filter(trial_type == "control_double")
ms <- d_comp_cd %>%
group_by(expt, age_group, item_num) %>%
summarise(correct = mean(correct, na.rm = TRUE),
cih = ci.high(correct, na.rm = TRUE),
cil = ci.low(correct, na.rm = TRUE))
# bar graph
ggplot(ms,
aes(fill=item_num, y=correct, x=age_group)) +
geom_bar(position="dodge", stat="identity") +
facet_wrap(~expt, ncol=4) +
ylab("Proportion correct looking") +
guides(fill=guide_legend(title=NULL)) +
geom_hline(yintercept=.50,lty=4) +
geom_errorbar(aes(ymin=correct-cil,ymax=correct+cih,width=.2),position=position_dodge(width = 0.90)) +
ggtitle("Control-double trials: eye-t vs. iPad")
# control-single
d_comp_cs <- d_comp %>%
filter(trial_type == "control_single")
ms <- d_comp_cs %>%
group_by(expt, age_group) %>%
summarise(correct = mean(correct, na.rm = TRUE),
cih = ci.high(correct, na.rm = TRUE),
cil = ci.low(correct, na.rm = TRUE))
# bar graph
ggplot(ms,
aes(fill=age_group, y=correct, x=age_group)) +
geom_bar(position="dodge", stat="identity") +
ylab("Proportion correct looking") +
guides(fill=guide_legend(title=NULL)) +
facet_grid(.~expt) +
geom_hline(yintercept=.50,lty=4) +
geom_errorbar(aes(ymin=correct-cil,ymax=correct+cih,width=.2),position=position_dodge(width = 0.90)) +
ggtitle("Control-single trials: eye-t vs. iPad")
Yes – the difference is not as great as between inference trials in eye-tracking and iPad, but even on control trials children show greater accuracy rate.
rt ana - on ipad
mss <- d_ip %>%
filter(trial_type != "practice" & age_group != "2" & age_group != "6") %>%
group_by(age_group, trial_type, item_num, subid) %>%
summarize(correct = mean(correct, na.rm=TRUE),
rt = mean(rt, na.rm=TRUE))
ms <- mss %>%
group_by(age_group, trial_type, item_num) %>%
summarise(rt = mean(rt, na.rm = TRUE),
cih = ci.high(rt, na.rm = TRUE),
cil = ci.low(rt, na.rm = TRUE))
ggplot(ms,
aes(color=item_num, y=rt, x=age_group)) +
geom_line(aes(group=item_num)) +
ylab("rt") +
facet_grid(.~trial_type) +
guides(fill=guide_legend(title=NULL)) +
geom_hline(yintercept=.50,lty=4) +
geom_errorbar(aes(ymin=rt-cil,ymax=rt+cih,width=.1))
ms <- mss %>%
group_by(age_group, trial_type) %>%
summarise(rt = mean(rt, na.rm = TRUE),
cih = ci.high(rt, na.rm = TRUE),
cil = ci.low(rt, na.rm = TRUE))
ggplot(subset(ms, trial_type != "practice"),
aes(color=trial_type, y=rt, x=age_group)) +
geom_line(aes(group=trial_type)) +
ylab("rt") +
guides(fill=guide_legend(title=NULL)) +
geom_hline(yintercept=.50,lty=4) +
geom_errorbar(aes(ymin=rt-cil,ymax=rt+cih,width=.1))
# comparing across different number of items present
ms <- mss %>%
group_by(age_group, item_num) %>%
summarise(rt = mean(rt, na.rm = TRUE),
cih = ci.high(rt, na.rm = TRUE),
cil = ci.low(rt, na.rm = TRUE))
ggplot(ms,
aes(color=item_num, y=rt, x=age_group)) +
geom_line(aes(group=item_num)) +
ylab("rt") +
guides(fill=guide_legend(title=NULL)) +
geom_hline(yintercept=.50,lty=4) +
geom_errorbar(aes(ymin=rt-cil,ymax=rt+cih,width=.1))
RT on inference trial is generally higher, but not as much as might be expected from the difference in the effects seen in et vs. ipad.
RT on trials with more items is higher, which confirms that children do spend more time on trials with more things to look at before making a decision.
rt ana - eye-tracking
mss_et <- d_et %>%
filter(age_group != "adult" & age_group != "6") %>%
filter(targetAtOnset == FALSE) %>%
group_by(expt, age_group, trial_type, subid) %>%
summarize(rt = mean(switch_t, na.rm=TRUE))
ms_et <- mss_et %>%
mutate(expt = substring(expt, 4)) %>%
group_by(expt, age_group, trial_type) %>%
summarize(rt = mean(rt, na.rm=TRUE),
cih = ci.high(rt, na.rm=TRUE),
cil = ci.low(rt, na.rm=TRUE))
ms_et$trial_type <- as.factor(ms_et$trial_type)
levels(ms_et$trial_type) <- c("control_double", "control_single", "inference")
qplot(age_group, rt, group=trial_type, label=trial_type,
colour=trial_type,
geom="line",
data=subset(ms_et, age_group != "1" & age_group != "Adults")) +
geom_linerange(aes(ymin=rt-cil,ymax=rt+cih,width=.2),
position=position_dodge(width=.1)) +
ylab("Reaction time (s) for first switch to target") +
xlab(NULL) +
scale_colour_discrete(name="Trial Type") +
facet_grid(.~expt)
Compare ipad and et rt
# rearranging to compare ipad and et
#ipad data
mss_ip <- d_ip %>%
filter(age_group != "2" & age_group != "6") %>%
group_by(age_group, trial_type, item_num, subid) %>%
summarize(correct = mean(correct, na.rm=TRUE),
rt = mean(rt, na.rm=TRUE))
ms_ip <- mss_ip %>%
group_by(age_group, trial_type, item_num) %>%
summarize(rt = mean(rt, na.rm=TRUE),
cih = ci.high(rt, na.rm=TRUE),
cil = ci.low(rt, na.rm=TRUE)) %>%
mutate(expt = "ipad") %>%
mutate(rt = rt/1000,
cih = cih/1000,
cil = cil/1000)
#et data
ms_et <- ms_et %>%
mutate(item_num = expt) %>%
mutate(expt = "eye-tracking")
ms <- rbind(ms_et, ms_ip)
ms <- ms %>%
filter(trial_type != "control_single" & trial_type != "practice") %>%
mutate(expt = as.factor(expt),
trial_type = as.factor(trial_type),
age_group = as.factor(age_group),
item_num = as.factor(item_num)
)
qplot(age_group, rt, group=trial_type, label=trial_type,
colour=trial_type,
geom="line",
data=ms) +
geom_linerange(aes(ymin=rt-cil,ymax=rt+cih,width=.2),
position=position_dodge(width=.1)) +
ylab("Reaction time (s) for first switch to target") +
xlab(NULL) +
scale_colour_discrete(name="Trial Type") +
facet_grid(expt~item_num)