Baby toolbox ET data
Mike Frank
11/30/2021
#setup
library(tidyverse) ## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──## ✓ ggplot2 3.3.5 ✓ purrr 0.3.4
## ✓ tibble 3.1.3 ✓ dplyr 1.0.7
## ✓ tidyr 1.1.3 ✓ stringr 1.4.0
## ✓ readr 1.4.0 ✓ forcats 0.5.1## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()library(readxl)
library(langcog)##
## Attaching package: 'langcog'## The following object is masked from 'package:base':
##
## scale2020
Data reading
Looking data
Read in individual looking excel files with data. Note: there is some file format inconsistency.
files <- dir(path = "data_2020")
files |>
map_df(function (fname) {
if (str_sub(fname, -3, -1) == "lsx" | str_sub(fname, -3, -1) == "lsm") {
#print(paste("reading",fname,"as XLSX"))
d <- read_xlsx(paste0("data_2020/",fname))
} else if (str_sub(fname, -3, -1) == "xls") {
#print(paste("reading",fname,"as XLS"))
d <- read_xls(paste0("data_2020/",fname))
} else {
print(paste("FAIL ON",fname))
d <- tibble()
}
d |> mutate(subid = fname)
}) -> raw_data
raw_calibration_data <- read_csv("handcoding_calibration_2020.csv") %>% rename(subid = filename)##
## ── Column specification ────────────────────────────────────────────────────────
## cols(
## filename = col_character(),
## `#ofCornersGazeDetected` = col_double(),
## `#ScreensidesDetected` = col_character(),
## topLeft = col_character(),
## topRight = col_character(),
## bottomRight = col_character(),
## bottomLeft = col_character()
## )Some basic data munging to rename and clean data that we want.
looking_d <- raw_data |>
filter(testState == "testing",
str_detect(soundFilename, "mp3")) |>
select(subid, timestamp, itemNumber, leftImageFilename, rightImageFilename,
soundFilename, gazeLocationName, testHandcoding) |>
mutate(target_word = str_replace_all(str_extract(soundFilename,
"_[a-z]+_"),
"_", ""),
left_image = str_replace(leftImageFilename, ".jpg", ""),
right_image = str_replace(rightImageFilename, ".jpg", ""),
correct_side = ifelse(target_word == left_image, "left", "right")) |>
group_by(subid, itemNumber) |>
mutate(t = floor(40*(timestamp - min(timestamp)))/40) |>
rename(item_number = itemNumber,
gaze_location = gazeLocationName,
gaze_handcode = testHandcoding) |>
select(subid, t, timestamp, item_number, target_word, left_image, right_image,
correct_side, gaze_location, gaze_handcode) Demographic & Calibration Data
demog <- raw_data |>
filter(dataKey %in% c("gender","age", "race", "ethnicity")) |>
select(subid, dataKey, dataValue) |>
pivot_wider(names_from = dataKey, values_from = dataValue) |>
mutate(age_months = as.numeric(sapply(str_split(age, " "),`[`,1)) * 12 +
as.numeric(sapply(str_split(age, " "),`[`,3))) |>
mutate(age_group = cut(age_months, breaks = c(0,12,24,36))) |>
select(subid, gender, age_months,age_group, race, ethnicity)
looking_d <- left_join(looking_d, demog)## Joining, by = "subid"calibration_d <- raw_calibration_data |> janitor::clean_names() |> left_join(demog)## Joining, by = "subid"Distributions
Demographics
Age
ggplot(demog, aes(x = age_months)) +
geom_histogram(binwidth = 1)
Race and ethnicity.
Note: there is no white, just “Not Provided”. should be recoded?
demog |>
group_by(race, ethnicity) |>
count() |>
pivot_wider(names_from = "ethnicity", values_from = "n") |>
knitr::kable()| race | Not Hispanic Or Latino | Hispanic Or Latino |
|---|---|---|
| American Indian Or Alaskan Native | 1 | NA |
| Asian | 18 | NA |
| Black Or African American | 25 | 1 |
| Not Provided | 29 | 10 |
| Other | 2 | 7 |
Race x Gender
demog |>
group_by(race, gender) |>
count() |>
pivot_wider(names_from = "gender", values_from = "n") |>
knitr::kable()| race | Female | Male |
|---|---|---|
| American Indian Or Alaskan Native | 1 | NA |
| Asian | 6 | 12 |
| Black Or African American | 14 | 12 |
| Not Provided | 13 | 26 |
| Other | 3 | 6 |
Calibrations
Note on calibrations: > I’ve attached a new file with information about calibration. Reminder, there was a 4 point calibration in which a stimuli appeared in each corner sequentially.
The “number of corners detected” column ranges from 0 to 4 depending on where a “look” was calculated for that corner.
The “number of sides” column is only applicable if 3 or 4 corners we detected. Then we could “infer” sides of the iPad, provided the two “left” or two “right” looks were within a reasonable distance from each other. If the corners were too far apart, we might not have been able to “draw” the screen for data visualization.
Only the n=35 who have 4 sides are considered successful calibrations for our tech team’s standards.
hist(calibration_d$number_of_corners_gaze_detected)
Observations by condition.
looking_d |>
group_by(item_number, left_image, right_image, target_word) |>
summarise(n = n())## `summarise()` has grouped output by 'item_number', 'left_image', 'right_image'. You can override using the `.groups` argument.## # A tibble: 10 × 5
## # Groups: item_number, left_image, right_image [10]
## item_number left_image right_image target_word n
## <dbl> <chr> <chr> <chr> <int>
## 1 5 cookie baby cookie 31307
## 2 6 ball cat cat 28522
## 3 7 bird bottle bottle 27965
## 4 8 dog book dog 28239
## 5 9 horse clock horse 27531
## 6 10 table lion lion 27573
## 7 11 monkey spoon monkey 27627
## 8 12 juice frog frog 27261
## 9 13 cup flower cup 27382
## 10 14 chair shoe shoe 26978Looking Timecourses/Visualizations
Automated
Aggregate by item and plot.
ms <- looking_d |>
group_by(target_word, t) |>
filter(t >= 2, t < 8) |>
summarise(correct = sum(gaze_location == correct_side, na.rm=TRUE),
total = sum(gaze_location %in% c("left","right"), na.rm=TRUE),
prop_correct = correct / total,
ci.upper = binom::binom.bayes(x = correct, n = total)$upper,
ci.lower = binom::binom.bayes(x = correct, n = total)$lower)## `summarise()` has grouped output by 'target_word'. You can override using the `.groups` argument.ggplot(ms, aes(x = t, y = prop_correct)) +
geom_pointrange(aes(ymin = ci.lower, ymax = ci.upper), alpha = .1) +
facet_wrap(~target_word) +
geom_hline(yintercept = .5, lty = 2) +
xlab("Time (s)") + ylab("Proportion target looking")
Aggregate by item and plot split by age groups.
ms <- looking_d |>
group_by(age_group, target_word, t) |>
filter(t >= 2, t < 8) |>
summarise(correct = sum(gaze_location == correct_side, na.rm=TRUE),
total = sum(gaze_location %in% c("left","right"), na.rm=TRUE),
prop_correct = correct / total,
ci.upper = binom::binom.bayes(x = correct, n = total)$upper,
ci.lower = binom::binom.bayes(x = correct, n = total)$lower)## `summarise()` has grouped output by 'age_group', 'target_word'. You can override using the `.groups` argument.ggplot(ms, aes(x = t, y = prop_correct, col = age_group)) +
geom_pointrange(aes(ymin = ci.lower, ymax = ci.upper), alpha = .1) +
geom_line() +
facet_wrap(~target_word) +
geom_hline(yintercept = .5, lty = 2) +
xlab("Time (s)") + ylab("Proportion target looking") +
#langcog::theme_mikabr() +
langcog::scale_color_solarized()
Overview plot by age groups.
ms <- looking_d |>
group_by(age_group, t) |>
filter(t >= 2, t < 8) |>
summarise(correct = sum(gaze_location == correct_side, na.rm=TRUE),
total = sum(gaze_location %in% c("left","right"), na.rm=TRUE),
prop_correct = correct / total,
ci.upper = binom::binom.bayes(x = correct, n = total)$upper,
ci.lower = binom::binom.bayes(x = correct, n = total)$lower)## `summarise()` has grouped output by 'age_group'. You can override using the `.groups` argument.ggplot(ms, aes(x = t, y = prop_correct, col = age_group)) +
geom_linerange(aes(ymin = ci.lower, ymax = ci.upper), alpha = .2) +
geom_line() +
geom_hline(yintercept = .5, lty = 2) +
xlab("Time (s)") + ylab("Proportion target looking") +
#langcog::theme_mikabr() +
langcog::scale_color_solarized(name = "Age Group") +
theme(legend.position = "bottom") +
ggtitle("Automated Data")
### Hand Coded Examine handcoding. First, it needs to be cleaned up.
#recode to NA
looking_d$gaze_handcode[!(looking_d$gaze_handcode %in% c("left","right","away"))] <- NA
#interpolate samples across time
looking_d <- looking_d |>
group_by(subid, item_number) |>
fill(gaze_handcode)ms <- looking_d |>
group_by(age_group, t) |>
filter(t >= 2, t < 8) |>
summarise(correct = sum(gaze_handcode == correct_side, na.rm=TRUE),
total = sum(gaze_handcode %in% c("left","right"), na.rm=TRUE),
prop_correct = correct / total,
ci.upper = binom::binom.bayes(x = correct, n = total)$upper,
ci.lower = binom::binom.bayes(x = correct, n = total)$lower)## `summarise()` has grouped output by 'age_group'. You can override using the `.groups` argument.ggplot(ms, aes(x = t, y = prop_correct, col = age_group)) +
geom_linerange(aes(ymin = ci.lower, ymax = ci.upper), alpha = .2) +
geom_line() +
geom_hline(yintercept = .5, lty = 2) +
xlab("Time (s)") + ylab("Proportion target looking") +
#langcog::theme_mikabr() +
langcog::scale_color_solarized(name = "Age Group") +
theme(legend.position = "bottom") +
ggtitle("Hand-coded Data")
ms <- looking_d |>
group_by(age_group, target_word, t) |>
filter(t >= 2, t < 8) |>
summarise(correct = sum(gaze_handcode == correct_side, na.rm=TRUE),
total = sum(gaze_handcode %in% c("left","right"), na.rm=TRUE),
prop_correct = correct / total,
ci.upper = binom::binom.bayes(x = correct, n = total)$upper,
ci.lower = binom::binom.bayes(x = correct, n = total)$lower)## `summarise()` has grouped output by 'age_group', 'target_word'. You can override using the `.groups` argument.ggplot(ms, aes(x = t, y = prop_correct, col = age_group)) +
geom_pointrange(aes(ymin = ci.lower, ymax = ci.upper), alpha = .1) +
geom_line() +
facet_wrap(~target_word) +
geom_hline(yintercept = .5, lty = 2) +
xlab("Time (s)") + ylab("Proportion Target Looking") +
#langcog::theme_mikabr() +
langcog::scale_color_solarized(name = "Age Group") +
ggtitle("Item Effects with Hand-Coded Data") +
theme(legend.position = "bottom")
## Handcoded vs Automated gaze coding
Now we can look at agreement across subjects. How often do the two coding methods agree on the participant’s looking area? Jess Q: why arent we considering two NAs as agrees?
looking_d |>
filter(!is.na(gaze_location) & !is.na(gaze_handcode)) |>
group_by(subid, item_number) |>
mutate(dt = c(diff(t),0)) |>
summarise(prop_correct = sum(dt * as.numeric(gaze_location == gaze_handcode)) / sum(dt)) |>
group_by(subid) |>
summarise(prop_correct = mean(prop_correct)) |>
ggplot(aes(x = prop_correct)) +
geom_histogram(binwidth = .1) +
#langcog::theme_mikabr() +
xlab("Proportion Method Agreement") +
ylab("Number of Participants") +
geom_vline(aes(xintercept = mean(prop_correct)), col = "red", lty =2)## `summarise()` has grouped output by 'subid'. You can override using the `.groups` argument.
Another way to look: average by subject. Here, each point is a trial for a subject. The x is the proportion of looks towards the target image in the handcoding method, and the y is the proportion of correct looks towards the target in the automated coding.
item_comparison <- looking_d |>
group_by(subid, age_months, item_number) |>
mutate(dt = c(diff(t),0)) |>
summarise(handcode_correct = sum(dt * as.numeric(gaze_handcode == correct_side), na.rm=TRUE) /
sum(dt, na.rm=TRUE),
automated_correct = sum(dt * as.numeric(gaze_location == correct_side), na.rm=TRUE) /
sum(dt, na.rm=TRUE))## `summarise()` has grouped output by 'subid', 'age_months'. You can override using the `.groups` argument.#each point is a trial
ggplot(item_comparison,
aes(x = handcode_correct, y = automated_correct, col = age_months)) +
geom_point(alpha = .4) +
xlab("Hand-coded accuracy") +
ylab("Automated accuracy") +
geom_abline(lty = 2) +
#langcog::theme_mikabr() +
viridis::scale_color_viridis(name = "Age (months)") +
# theme(legend.position = "bottom") +
ggtitle("Comparison of data coding")
Calibration quality by demographics
Race
calibration_d %>%
ggplot() +
geom_histogram(aes(x = number_of_corners_gaze_detected, fill = race), binwidth=1, position = "dodge") 
calibration_d %>%
ggplot() +
geom_histogram(aes(x = number_of_corners_gaze_detected, fill = race), binwidth=1) + facet_wrap(~race, scales = "free_y") 
Are we dropping a larger proportion of non-white participants because of calibration failures?
calibration_d |>
mutate(dropped = (number_of_corners_gaze_detected < 4)) |>
group_by(race) |>
summarize(total = n(),
num_dropped = sum(dropped),
proportion_dropped = num_dropped/total)## # A tibble: 5 × 4
## race total num_dropped proportion_dropped
## <chr> <int> <int> <dbl>
## 1 American Indian Or Alaskan Native 1 1 1
## 2 Asian 18 10 0.556
## 3 Black Or African American 26 16 0.615
## 4 Not Provided 39 23 0.590
## 5 Other 9 8 0.889Age
calibration_d %>%
ggplot() +
geom_histogram(aes(x = number_of_corners_gaze_detected, fill = age_group),
binwidth=1,
position = "dodge") 
calibration_d %>%
ggplot() +
geom_histogram(aes(x = number_of_corners_gaze_detected, fill = age_group),
binwidth=1) +
facet_wrap(~age_group, scales = "free_y") 
Are we dropping younger kids more? A: not really?
calibration_d |>
mutate(dropped = (number_of_corners_gaze_detected < 4)) |>
group_by(age_group) |>
summarize(total = n(),
num_dropped = sum(dropped),
proportion_dropped = num_dropped/total)## # A tibble: 3 × 4
## age_group total num_dropped proportion_dropped
## <fct> <int> <int> <dbl>
## 1 (0,12] 31 19 0.613
## 2 (12,24] 39 26 0.667
## 3 (24,36] 23 13 0.565Gaze coding by calibration quality
ms <- looking_d |>
left_join(calibration_d) |>
group_by(number_of_corners_gaze_detected, t) |>
filter(t >= 2, t < 8) |>
summarise(correct = sum(gaze_handcode == correct_side, na.rm=TRUE),
total = sum(gaze_handcode %in% c("left","right"), na.rm=TRUE),
prop_correct = correct / total,
ci.upper = binom::binom.bayes(x = correct, n = total)$upper,
ci.lower = binom::binom.bayes(x = correct, n = total)$lower)## Joining, by = c("subid", "gender", "age_months", "age_group", "race", "ethnicity")## `summarise()` has grouped output by 'number_of_corners_gaze_detected'. You can override using the `.groups` argument.ggplot(ms, aes(x = t, y = prop_correct, col = as.factor(number_of_corners_gaze_detected))) +
geom_linerange(aes(ymin = ci.lower, ymax = ci.upper), alpha = .2) +
geom_line() +
geom_hline(yintercept = .5, lty = 2) +
xlab("Time (s)") + ylab("Proportion target looking") +
#langcog::theme_mikabr() +
langcog::scale_color_solarized(name = "Number of Corners Detected") +
theme(legend.position = "bottom") +
ggtitle("Hand-coded Data")
Predictably, it seems that the automated gaze is worse when it was unable to calibrate
ms <- looking_d |>
left_join(calibration_d) |>
group_by(number_of_corners_gaze_detected, t) |>
filter(t >= 2, t < 8) |>
summarise(correct = sum(gaze_location == correct_side, na.rm=TRUE),
total = sum(gaze_location %in% c("left","right"), na.rm=TRUE),
prop_correct = correct / total,
ci.upper = binom::binom.bayes(x = correct, n = total)$upper,
ci.lower = binom::binom.bayes(x = correct, n = total)$lower)## Joining, by = c("subid", "gender", "age_months", "age_group", "race", "ethnicity")## `summarise()` has grouped output by 'number_of_corners_gaze_detected'. You can override using the `.groups` argument.ggplot(ms, aes(x = t, y = prop_correct, col = as.factor(number_of_corners_gaze_detected))) +
geom_linerange(aes(ymin = ci.lower, ymax = ci.upper), alpha = .2) +
geom_line() +
geom_hline(yintercept = .5, lty = 2) +
xlab("Time (s)") + ylab("Proportion target looking") +
#langcog::theme_mikabr() +
langcog::scale_color_solarized(name = "Number of Corners Detected") +
theme(legend.position = "bottom") +
ggtitle("Automatically-coded Data")
Next steps for 2020:
Can we predict the agreement between the hand coded and the automatic by the number of corners calibrated?
2021
Data reading
files_2021 <- dir(path = "data_2021")
files_2021 |>
map_df(function (fname) {
if (str_sub(fname, -3, -1) == "csv") {
#print(paste("reading",fname,"as XLSX"))
d <- read_csv(paste0("data_2021/",fname))
} else {
print(paste("FAIL ON",fname))
d <- tibble()
}
d |> mutate(subid = fname)
}) -> raw_data_2021Preprocessing These data might be incomplete/less useful? Theres o target or distractor information (no audio file) or left/right distinction in the csvs. Myabe we need information about the trials that’s stored separately? I got us as far as I could
looking_d_2021 <- raw_data_2021 |>
filter(gazeEngineState == "testing") |>
select(subid, elapsedTime, itemID, gazeLocationName)