multi-afc-analysis
Bria Long
2023-04-26
Setup
library(tidyverse)
library(here)
library(lubridate)
library(ggthemes)
library(langcog)
library(mirt)
library(knitr)Load data from multiafc task
pilot_data = read_csv(here::here('data/data_multiafc/multi-afc-april28.csv')) %>%
as_tibble()Load data and impose basic filtering requirements
test_data <- pilot_data %>%
mutate(day_took = lubridate::day(timeStarted)) %>%
filter(day_took>25) %>% # specific testing days
filter(!block %in% c('practice')) %>%
filter(rt>200) %>%
filter(rt<5000) %>%
mutate(item_pair = paste0(targetWord,'_',numAFC)) %>%
mutate(sub_id = pid)We have 201 participants.
sanity <- test_data %>%
group_by(pid, numAFC, itemType) %>%
summarize(num_trials = length(trialId), num_test = sum(task=='test_response'), num_prac = sum(task=='practice_response'), date_took = timeFinished[1], completed_or_not = sum(completed), unique_words = length(unique(targetWord)))low_performers <- test_data %>%
filter(itemType=='catch') %>%
group_by(pid) %>%
summarize(prop_catch = mean(correct)) %>%
filter(prop_catch<1)We filtered out 1 for missing catch trials.
test_data <- test_data %>%
filter(!pid %in% low_performers$pid)Basic descriptives before IRT models
cor_by_afc <- test_data %>%
group_by(pid, numAFC) %>%
summarize(prop_correct = mean(correct))Accuracy by AFC at participant level
ggplot(data=cor_by_afc, aes(x=numAFC, y=prop_correct, color=numAFC)) +
geom_point(alpha=.6) +
geom_line(aes(group=pid), alpha=.2) 
Accuracy by AFC at word level
by_word <- test_data %>%
group_by(targetWord, numAFC, item_pair) %>%
summarize(prop_correct = mean(correct), participants = length(unique(pid)), mean_rt = mean(rt))ggplot(data=by_word, aes(x=numAFC, y=prop_correct, color=numAFC)) +
geom_point(alpha=.6) +
geom_line(aes(group=targetWord), alpha=.2)
RT by AFC at word level
ggplot(data=by_word, aes(x=numAFC, y=mean_rt, color=numAFC)) +
geom_point(alpha=.6) +
geom_line(aes(group=targetWord), alpha=.2)
Construct data for IRT model
Filter out items that are at ceiling – all adult participants got correct.
ceiling = test_data %>%
group_by(item_pair, targetWord, numAFC) %>%
summarize(prop_correct = mean(correct)) %>%
filter(prop_correct == 1)which ones are at ceiling?
ceiling %>%
group_by(numAFC) %>%
summarize(num_item = length(item_pair))## # A tibble: 3 × 2
## numAFC num_item
## <dbl> <int>
## 1 2 31
## 2 3 28
## 3 4 26ceiling %>%
group_by(targetWord) %>%
summarize(num_versions_eliminated = length(numAFC))## # A tibble: 55 × 2
## targetWord num_versions_eliminated
## <chr> <int>
## 1 acorn 1
## 2 ant 3
## 3 antenna 1
## 4 ball 3
## 5 bamboo 2
## 6 barrel 1
## 7 bear 3
## 8 blender 2
## 9 buffet 1
## 10 bulldozer 1
## # … with 45 more rowsd_wide_all<- test_data %>%
filter(!item_pair %in% ceiling$item_pair) %>%
ungroup() %>%
select(sub_id, item_pair, correct) %>%
arrange(item_pair) %>%
ungroup()%>%
pivot_wider(names_from=item_pair, values_from=correct, values_fn = ~mean(.x)) %>%
ungroup()
d_mat_all <- d_wide_all %>%
select(-sub_id) %>%
data.frame %>%
data.matrix
rownames(d_mat_all) <- d_wide_all$sub_idConstruct basic IRT model – 2PL
start.dim <- dim(d_mat_all)[2]-1
mm = (
'F = 1-%d,
PRIOR = (1-%d, a1, norm, .2, 1),
PRIOR = (1-%d, d, norm, 0, 2)'
)
mm = mirt.model(sprintf(mm,start.dim,start.dim,start.dim))Run basic 2PL irt model
m <- mirt(d_mat_all, model = mm,itemtype = '2PL',guess=0.5) ##
Iteration: 1, Log-Lik: -5812.922, Max-Change: 2.69266
Iteration: 2, Log-Lik: -3675.956, Max-Change: 0.88204
Iteration: 3, Log-Lik: -3578.107, Max-Change: 0.43142
Iteration: 4, Log-Lik: -3553.367, Max-Change: 0.30218
Iteration: 5, Log-Lik: -3541.691, Max-Change: 0.21869
Iteration: 6, Log-Lik: -3535.497, Max-Change: 0.15911
Iteration: 7, Log-Lik: -3532.140, Max-Change: 0.11562
Iteration: 8, Log-Lik: -3530.323, Max-Change: 0.08417
Iteration: 9, Log-Lik: -3529.344, Max-Change: 0.06109
Iteration: 10, Log-Lik: -3528.319, Max-Change: 0.01734
Iteration: 11, Log-Lik: -3528.277, Max-Change: 0.01249
Iteration: 12, Log-Lik: -3528.256, Max-Change: 0.00926
Iteration: 13, Log-Lik: -3528.234, Max-Change: 0.00282
Iteration: 14, Log-Lik: -3528.233, Max-Change: 0.00178
Iteration: 15, Log-Lik: -3528.232, Max-Change: 0.00103
Iteration: 16, Log-Lik: -3528.232, Max-Change: 0.00111
Iteration: 17, Log-Lik: -3528.232, Max-Change: 0.00127
Iteration: 18, Log-Lik: -3528.232, Max-Change: 0.00163
Iteration: 19, Log-Lik: -3528.232, Max-Change: 0.00144
Iteration: 20, Log-Lik: -3528.232, Max-Change: 0.00181
Iteration: 21, Log-Lik: -3528.232, Max-Change: 0.00219
Iteration: 22, Log-Lik: -3528.232, Max-Change: 0.00092
Iteration: 23, Log-Lik: -3528.232, Max-Change: 0.00111
Iteration: 24, Log-Lik: -3528.232, Max-Change: 0.00137
Iteration: 25, Log-Lik: -3528.232, Max-Change: 0.00058
Iteration: 26, Log-Lik: -3528.232, Max-Change: 0.00072
Iteration: 27, Log-Lik: -3528.232, Max-Change: 0.00088
Iteration: 28, Log-Lik: -3528.232, Max-Change: 0.00038
Iteration: 29, Log-Lik: -3528.232, Max-Change: 0.00047
Iteration: 30, Log-Lik: -3528.232, Max-Change: 0.00058
Iteration: 31, Log-Lik: -3528.232, Max-Change: 0.00025
Iteration: 32, Log-Lik: -3528.232, Max-Change: 0.00030
Iteration: 33, Log-Lik: -3528.232, Max-Change: 0.00037
Iteration: 34, Log-Lik: -3528.232, Max-Change: 0.00016
Iteration: 35, Log-Lik: -3528.232, Max-Change: 0.00020
Iteration: 36, Log-Lik: -3528.232, Max-Change: 0.00024
Iteration: 37, Log-Lik: -3528.232, Max-Change: 0.00010
Iteration: 38, Log-Lik: -3528.232, Max-Change: 0.00013
Iteration: 39, Log-Lik: -3528.232, Max-Change: 0.00016
Iteration: 40, Log-Lik: -3528.232, Max-Change: 0.00007Data structure for merging back with item info
items_in_model <- test_data %>%
filter(!item_pair %in% ceiling$item_pair) %>%
distinct(item_pair, numAFC, targetWord)Go through all items and compute summed item info for now with thetas (4 to 4
num_items_retained = dim(d_wide_all)[2] -1
items_retained = colnames(d_wide_all %>% select(-sub_id))
Theta <- matrix(seq(-4,4, by = .1))
for (i in seq(1,num_items_retained)){
item_pair = items_retained[i]
item_info = iteminfo(extract.item(m,i), Theta)
summed_item_info = sum(item_info)
if (i==1) {
items = cbind(item_pair, summed_item_info) %>%
as_tibble()
}
else {
this_item = cbind(item_pair, summed_item_info) %>%
as_tibble()
items = items %>%
rbind(this_item)
}
}Join back together with item information
all_item_info <- items_in_model %>%
left_join(items) %>%
mutate(summed_item_info = as.double(summed_item_info))Overall averages and number of items retained by AFC
by_afc <- all_item_info %>%
group_by(numAFC) %>%
summarize(mean_item_info = mean(summed_item_info), num_items = length(item_pair))all_item_info_with_rt <- all_item_info %>%
right_join(by_word %>% select(item_pair, mean_rt)) %>%
mutate(summed_item_info_normalized = summed_item_info / (mean_rt/1000))Plots from IRT models
ggplot(data = all_item_info, aes(x=as.factor(numAFC), y=summed_item_info, col=numAFC)) +
# geom_jitter(height=.1, width=.3, alpha=.8) +
geom_point(alpha=.6) +
geom_line(aes(group=targetWord), alpha=.6, color='grey') +
theme_few() +
ylab('Summed item information') +
xlab('AFC version') +
ggtitle('Item information for each item as a function of 234AFC') +
theme(legend.position = 'none')
ggplot(data = all_item_info_with_rt, aes(x=as.factor(numAFC), y=summed_item_info_normalized, col=numAFC)) +
# geom_jitter(height=.1, width=.3, alpha=.8) +
geom_point(alpha=.6) +
geom_line(aes(group=targetWord), alpha=.6, color='grey') +
theme_few() +
ylab('Summed item information') +
xlab('AFC version') +
ggtitle('RT normalized item information for each item as a function of 234AFC') +
theme(legend.position = 'none')
Run some linear models to check visuals
Non-normalized by AFC?
summary(lm(data = all_item_info_with_rt, summed_item_info ~ numAFC))##
## Call:
## lm(formula = summed_item_info ~ numAFC, data = all_item_info_with_rt)
##
## Residuals:
## Min 1Q Median 3Q Max
## -2.2295 -1.0843 -0.0367 0.9444 3.6992
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 1.7962 0.3377 5.319 2.34e-07 ***
## numAFC 0.1083 0.1079 1.003 0.317
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.386 on 246 degrees of freedom
## (85 observations deleted due to missingness)
## Multiple R-squared: 0.004077, Adjusted R-squared: 2.824e-05
## F-statistic: 1.007 on 1 and 246 DF, p-value: 0.3166Normalized by AFC?
summary(lm(data = all_item_info_with_rt, summed_item_info_normalized ~ numAFC))##
## Call:
## lm(formula = summed_item_info_normalized ~ numAFC, data = all_item_info_with_rt)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.20009 -0.59831 -0.00207 0.54324 1.97967
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 1.30370 0.18482 7.054 1.76e-11 ***
## numAFC -0.04206 0.05908 -0.712 0.477
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.7587 on 246 degrees of freedom
## (85 observations deleted due to missingness)
## Multiple R-squared: 0.002056, Adjusted R-squared: -0.002001
## F-statistic: 0.5068 on 1 and 246 DF, p-value: 0.47722 vs 3 normalized?
summary(lm(data = all_item_info_with_rt %>% filter(numAFC<4), summed_item_info_normalized ~ numAFC))##
## Call:
## lm(formula = summed_item_info_normalized ~ numAFC, data = all_item_info_with_rt %>%
## filter(numAFC < 4))
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.21014 -0.62012 -0.02586 0.54007 1.99905
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 1.37262 0.30839 4.451 1.59e-05 ***
## numAFC -0.07149 0.12053 -0.593 0.554
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.7693 on 161 degrees of freedom
## (59 observations deleted due to missingness)
## Multiple R-squared: 0.002181, Adjusted R-squared: -0.004017
## F-statistic: 0.3518 on 1 and 161 DF, p-value: 0.55393 vs 4 afc normalized?
summary(lm(data = all_item_info_with_rt %>% filter(numAFC>2), summed_item_info_normalized ~ numAFC))##
## Call:
## lm(formula = summed_item_info_normalized ~ numAFC, data = all_item_info_with_rt %>%
## filter(numAFC > 2))
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.15760 -0.56068 -0.00477 0.55386 1.99905
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 1.19778 0.40967 2.924 0.00394 **
## numAFC -0.01321 0.11568 -0.114 0.90919
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.7496 on 166 degrees of freedom
## (54 observations deleted due to missingness)
## Multiple R-squared: 7.86e-05, Adjusted R-squared: -0.005945
## F-statistic: 0.01305 on 1 and 166 DF, p-value: 0.9092