In wjhopper/FAM: Forgetting and Memory, an Investigation of the Testing Effect
source("../.Rprofile", chdir = TRUE)
library(FAM)
library(whoppeR)
library(dplyr)
library(tidyr)
library(magrittr)
library(ggplot2)
library(grid)
library(gridExtra)
library(wesanderson)
library(effsize)
library(pander)
library(rococo)
library(broom)
library(afex)
knitr::opts_chunk$set(echo = FALSE, warning=FALSE, message=FALSE, cache=FALSE,
fig.width=10, fig.height=6, fig.align='center')
op <- options(contrasts = c("contr.sum", "contr.poly"))
class_labels <- c(np="Practice Test", sp="Study Practice", tp="Test Practice")
minimal_variables <- c("subject","cond_list","class","resp","score", "RT")
data(CFR, package = "FAM")
tested <- filter(CFR, !is.na(resp))
tested$score <- as.integer(tested$score)
corrects <- filter(tested, score==1) %>%
select_(.dots = c(minimal_variables, "target","resp", "where")) %>%
group_by(subject,class,cond_list) %>%
mutate(output_order = 1:n(),
revOrder = rev(output_order),
logRT = log(RT)) %>%
ungroup() %>%
complete(subject, class, cond_list, output_order, fill=list(score=0))
N_correct <- corrects %>%
group_by(subject, class, cond_list) %>%
summarise(nRecalled = sum(score))
corrects <- left_join(corrects, N_correct,
by = c("subject", "class", "cond_list"))
summaryFun <- function(data) {
grouping_vars <- vapply(groups(data),
as.character,
character(1))
x <- summarise(data,
RT_median = median(RT, na.rm = TRUE),
RT_mean = mean(RT, na.rm = TRUE),
logRT_mean = mean(logRT, na.rm = TRUE),
RT_sd = sd(RT, na.rm = TRUE),
MAD = mad(RT, na.rm = T, constant = 1),
RT_n = sum(!is.na(RT))
)
if (!"nRecalled" %in% grouping_vars) {
y <- summarise(data,
acc_mean = mean(score),
acc_sd = sd(score),
acc_n = n()
)
x <- left_join(y, x, by=grouping_vars)
}
remove <- unique(unlist(lapply(x[grouping_vars],
function(y) which(is.na(y))
)
)
)
if (length(remove) > 0L) {
x <- x[-remove,]
}
ungroup(x)
}
# Ignore subjects here since there are too few observations per subject at each level of
# nRecalled
byCond_order_nRecalled <- corrects %>%
group_by(class, output_order, nRecalled) %>%
summaryFun() %>%
filter(RT_n != 0) %>%
arrange(class, nRecalled)
byCond_revOrder_nRecalled <- corrects %>%
group_by(class, revOrder, nRecalled) %>%
summaryFun() %>%
arrange(class, nRecalled)
## Group by Subject, condition, and order
bySubjects_cond_order <- corrects %>%
group_by(subject, class, output_order) %>%
summaryFun()
## Collapse condition and order over Subjects
byCond_order <- bySubjects_cond_order %>%
WISEsummary(dependentvars = c("acc_mean", "RT_mean", "logRT_mean", "RT_median"),
withinvars = c("class","output_order"),
idvar = "subject",
na.rm = TRUE) %>%
rename_(.dots=setNames(names(.),
gsub("_mean$", "", names(.))
)
) %>%
select(-RT_median_n, -logRT_mean_n) %>%
rename(RT_n = RT_mean_n, acc_n = acc_mean_n)
## Group by subject, condition, and reverse order
bySubjects_cond_revOrder <- corrects %>%
group_by(subject, class, revOrder) %>%
summaryFun()
## Collapse condition and reverse order over Subjects
byCond_revOrder <- bySubjects_cond_revOrder %>%
WISEsummary(dependentvars = c("RT_mean", "logRT_mean", "RT_median"),
withinvars = c("class","revOrder"),
idvar = "subject",
na.rm = TRUE) %>%
rename_(.dots=setNames(names(.),
gsub("_mean$", "", names(.))
)
) %>%
select(-RT_median_n, -logRT_mean_n) %>%
rename(RT_n = RT_mean_n)
## Group by subjects and condition
bySubjects_cond <- corrects %>%
group_by(subject, class) %>%
summaryFun()
## Collapse condition over subjects
byCond <- bySubjects_cond %>%
WISEsummary(dependentvars = c("acc_mean", "RT_mean", "logRT_mean", "RT_median"),
withinvars = "class",
idvar = "subject",
na.rm = TRUE) %>%
rename_(.dots=setNames(names(.),
gsub("_mean$", "", names(.))
)
) %>%
select(-RT_median_n, -logRT_mean_n) %>%
rename(RT_n = RT_mean_n, acc_n = acc_mean_n)
max_complete <- byCond_revOrder %>%
filter(RT_n == 34L) %>%
group_by(class) %>%
summarise(max_position = max(revOrder))
byCond_revOrder_noMissing <- filter(byCond_revOrder,
revOrder <= min(max_complete$max_position))
bySubjects_cond_revOrder_noMissing <- filter(bySubjects_cond_revOrder,
revOrder <= min(max_complete$max_position))
bySubjects_cond_order_noMissing <- filter(bySubjects_cond_order,
output_order <= min(max_complete$max_position))
targets <- filter(.data = CFR,
!is.na(target),
class != "sp") %>%
select(subject, class, cond_list, target, order) %>%
rename(serial_pos = order)
conditional_raw <- left_join(targets,
select(corrects,-target),
by = c("subject", "cond_list", "class", "serial_pos" = "where")
) %>%
mutate(score = replace(score, is.na(score), 0)) %>%
select(subject, class, target, score, RT, logRT) %>%
gather(key = DV, value = value, score, RT, logRT) %>%
unite(col = DV, sep = "_", class, DV) %>%
spread(key = DV, value = value)
conditional_means_bySubject <- conditional_raw %>%
group_by(subject, np_score) %>%
summarise(acc_mean = mean(tp_score),
acc_n = n(),
RT_mean = mean(tp_RT, na.rm=TRUE),
logRT_mean = mean(tp_logRT, na.rm=TRUE),
RT_n = sum(!is.na(tp_RT))
) %>%
ungroup() %>%
tidyr::complete(subject, np_score)
conditional_means <- conditional_means_bySubject %>%
group_by(np_score) %>%
summarise(acc_n = n(),
acc_mean_sem = whoppeR::sem(acc_mean),
acc_CI_width = acc_mean_sem * qt(.975, acc_n - 1),
acc_mean = mean(acc_mean),
RT_n = sum(!is.na(RT_mean)),
RT_mean_sem = whoppeR::sem(RT_mean, na.rm = TRUE),
RT_CI_width = RT_mean_sem * qt(.975, RT_n - 1),
RT_mean = mean(RT_mean, na.rm = TRUE),
logRT_mean_sem = whoppeR::sem(logRT_mean, na.rm = TRUE),
logRT_CI_width = logRT_mean_sem * qt(.975, RT_n - 1),
logRT_mean = mean(logRT_mean, na.rm = TRUE)
) %>%
mutate(acc_mean_CI_upper = acc_mean + acc_CI_width,
acc_mean_CI_lower = acc_mean - acc_CI_width,
RT_mean_CI_upper = RT_mean + RT_CI_width,
RT_mean_CI_lower = RT_mean - RT_CI_width,
logRT_mean_CI_upper = logRT_mean + logRT_CI_width,
logRT_mean_CI_lower = logRT_mean - logRT_CI_width) %>%
select(np_score, acc_mean, acc_n, acc_mean_sem, acc_mean_CI_upper, acc_mean_CI_lower,
RT_mean, RT_n, RT_mean_sem, RT_mean_CI_upper, RT_mean_CI_lower,
logRT_mean, logRT_mean_sem, logRT_mean_CI_upper, logRT_mean_CI_lower
)
Subject Performance
Left figure shows counts of correct recalls, repeats of correct recalls, and extra
list intrusions for each list by each type of list (study practice, test practice, no practice). Perfect performance is 15/15 correct.
Right figure shows latency in seconds to pressing the first key when typing in the word, relative to the last key press of the previous word (or onset of the trial in the case of the first word.) Violin plots are gaussian kernel density estimates of the RT's, bandwidth of 1.
allResponseTypesLong <- tested %>%
select_(.dots = c(minimal_variables,"intrusions", "repeats")) %>%
gather(key = "output_type", value = "count", score,intrusions,repeats) %>%
group_by(subject,class,cond_list,output_type)
accData_bySubjects <- allResponseTypesLong %>%
summarise_at(.cols = "count", .funs = "sum") %>%
arrange(subject,class,cond_list,rev(output_type))
ymax <- max(tested$order)
for (i in unique(tested$subject)){
subAcc <- ggplot(data = filter(accData_bySubjects, subject ==i),
aes(x= cond_list, y=count, fill=output_type)) +
geom_bar(stat="identity") +
facet_grid(class~., labeller = labeller(class=class_labels)) +
scale_y_continuous(limits=c(0,ymax)) +
scale_fill_manual("Response Type",
breaks= c("score","repeats","intrusions"),
labels =c(score = "Correct",
intrusions = "Intrusions",
repeats = "Repeated"),
values = wes_palette("Darjeeling")) +
xlab("List") +
ggtitle("Response Type Frequency")
subTime <- ggplot(data = filter(allResponseTypesLong, subject==i, count == 1),
aes(x = factor(cond_list), y=RT)) +
geom_violin() +
geom_point(aes(color = output_type)) +
stat_summary(fun.y = "median") +
facet_grid(class~., labeller = labeller(class=class_labels)) +
scale_color_manual("Response Type",
breaks= c("score","repeats","intrusions"),
labels =c(score = "Correct",
intrusions = "Intrusion",
repeats = "Repeated"),
values = wes_palette("Darjeeling")) +
xlab("List") +
ggtitle("IRTs Including Intrusions and Repeats")
cat('<h4 class="subid">', paste("Subject", i), '</h4>')
grid.arrange(subAcc,subTime,ncol=2,nrow=1)
}
Performance by Output Position
Output order is computed only for correct responses, but any RT's are measured relative
to the item output immediately prior, even if that item is an intrusion or repeat.
byCond_order_acc_plot <- ggplot(data = byCond_order,
aes(x=factor(output_order), y=acc_mean,
group=class, color=class,
ymin = acc_mean - acc_mean_sem,
ymax = acc_mean + acc_mean_sem)) +
geom_point(size = 2) +
geom_line(size = .75) +
geom_errorbar(width=.3) +
scale_y_continuous("Probability of Recalling at Least x Items") +
scale_x_discrete("Output Position (x)") +
scale_color_manual(name="Practice\nCondition",
labels=c("Baseline","Restudy","Test Practice"),
values = c('black', 'red', '#00cc00')) +
ggtitle("Output Accuracy")
byCond_order_RT_plot <- byCond_order_acc_plot +
aes(y=RT_mean,
ymin = RT_mean - RT_mean_sem,
ymax = RT_mean + RT_mean_sem) +
scale_y_continuous("Mean Inter-Retreival Time of Item x") +
ggtitle("Inter-Retrieval Time")
print(byCond_order_acc_plot)
print(byCond_order_RT_plot)
IRT by Reverse Output Position (All Conditions)
byRevOrder <- corrects %>%
filter(!is.na(RT)) %>%
group_by(revOrder) %>%
summarise(meanRT = mean(RT),
count = n(),
upper = quantile(RT, .975),
lower = quantile(RT, .025))
ggplot(data = byRevOrder,
aes(x= factor(revOrder), y=meanRT)
) +
geom_point(aes(y=RT),
data = filter(corrects, !is.na(RT)),
position = position_jitter(width = .2),
color="black") +
geom_errorbar(mapping = aes(ymax=upper,ymin=lower),
width=.25,color="red",size=.75) +
geom_point(color="red") +
geom_line(aes(x=revOrder), color="red") +
geom_text(aes(label = count, y=-2.5)) +
scale_x_discrete("Reverse Output Position",
labels = c("n", paste("n-",1:14,sep='')))+
scale_y_continuous("IRT") +
ggtitle("Inter-Retrieval Times by Reverse Output Position")
IRT by Total Recalled & Output Position
# Forward Order
forward <- ggplot(filter(byCond_order_nRecalled,
output_order > 1,
nRecalled >= 4 & nRecalled <= 12),
aes(x=output_order, y=RT_mean,
color=factor(nRecalled))) +
geom_point(aes(size=RT_n)) +
geom_line(size = .75) +
facet_grid(class~.,
labeller = labeller(class=class_labels)
) +
scale_x_continuous(breaks = 1:15) +
scale_color_discrete("Items Recalled") +
ylab("Mean IRT") +
xlab("Output Order") +
ggtitle("Forward IRTs by Recall Total")
print(forward)
byCond_revOrder_nRecalled_restricted <- filter(byCond_revOrder_nRecalled,
nRecalled >= 4 & nRecalled <= 12)
backward <- forward %+%
byCond_revOrder_nRecalled_restricted %+%
aes(x=revOrder) +
scale_x_continuous("Reverse Output Order",
breaks = seq(max(byCond_revOrder_nRecalled_restricted$revOrder)),
labels = c("n",
paste("n-",
seq(max(byCond_revOrder_nRecalled_restricted$revOrder)-1)
)
)
) +
ggtitle("Reverse IRTs by Recall Total")
print(backward)
Quantile Plots
quantile_points <- c(0.1, 0.3, 0.5, 0.7, 0.9)
correct_quantiles <- corrects %>%
filter(!is.na(RT)) %>%
group_by(class,output_order) %>%
do(as.data.frame(t(quantile(.$RT, probs =quantile_points)))) %>%
ungroup() %>%
gather_(key_col="quantile",
value_col="RT",
gather_cols=paste0(quantile_points*100, "%")
)
ggplot(correct_quantiles,
aes(x =output_order,
y = RT,
color = quantile)) +
geom_point() +
geom_line() +
facet_grid(.~class, labeller = labeller(class=class_labels)) +
scale_x_continuous("Output Order",
breaks = 1:15
) +
scale_color_discrete(name="Quantile") +
theme(panel.grid.minor.x = element_blank())
Output Order Correlation
The consistency between the output order of items on the practice test and final tests was measured with the Kruskal-Goodman gamma coefficient. Higher values of the gamma statistic indicate more consistent ordering of the recalled words between the two tests.
This statistic was calcuated in two different ways: list-wise, and subject-wise. In the the list-wise calculation, the gamma stastic was calculated for each individual list from each participant. In the subject-wise calculation, the concordances from all four lists were summed together and discordances from list were summed together, before being combined to form the gamma statistic.
ranks <- corrects %>%
select(subject, cond_list, class, resp, target) %>%
filter(class %in% c("np","tp"),
!is.na(resp)) %>%
group_by(subject, cond_list) %>%
filter(c(resp[class=="np"] %in% resp[class=="tp"],
resp[class=="tp"] %in% resp[class=="np"])) %>%
group_by(subject, cond_list, class) %>%
mutate(rank = row_number()) %>%
group_by(subject, cond_list) %>%
mutate(id = replace(rank,
class=="tp",
match(resp[class=="tp"],
resp[class=="np"])
)
) %>%
ungroup()
gamma_cor_bySubject_pooling_lists <- ranks %>%
group_by(subject, cond_list) %>%
do(bind_cols(distinct(.[c("subject","cond_list")]),
as_data_frame(t(rank_agreements(x = .$id[.$class=="np"],
y = .$id[.$class=="tp"])))
)) %>%
group_by(subject) %>%
summarise_at(c("concordances","discordances"), sum) %>%
mutate(gamma = (concordances-discordances)/(concordances+discordances),
gamma_z = atanh(gamma)) # fischer-z transformed the correlation
Ncorrect_diff <- ungroup(N_correct) %>%
filter(class %in% c("np","tp")) %>%
spread(class,nRecalled) %>%
mutate(N_diff = tp-np) %>%
select(-tp, -np)
RT_delta_bySubject_List <- corrects %>%
filter(class %in% c("np","tp")) %>%
group_by(subject, class, cond_list) %>%
summaryFun() %>%
select(subject, class, cond_list, RT_median, RT_mean, logRT_mean) %>%
gather(key = "DV", value="val", RT_median, RT_mean, logRT_mean) %>%
spread(class, val) %>%
mutate(diff = tp - np) %>% # Final Minus Practice. Negative means faster on final test.
select(-tp, -np) %>%
mutate(DV = paste0(DV, "_diff")) %>%
spread(DV, diff)
gamma_cor_bySubject_List <- ranks %>%
group_by(subject, cond_list) %>%
summarise(gamma = rococo(id[class=="np"],
id[class=="tp"]))
gamma_cor_bySubject_List <- Reduce(function(x,y) left_join(x, y, by = c("subject", "cond_list")),
list(gamma_cor_bySubject_List,
Ncorrect_diff,
RT_delta_bySubject_List)
)
hist(gamma_cor_bySubject_pooling_lists$gamma,
xlab=expression(paste("Goodman–Kruskal ", gamma, " Coefficient")),
main = "Practice/Final Test Gamma Correlations\nby Subject"
)
gamma_cor_t.test <- tidy(t.test(gamma_cor_bySubject_pooling_lists$gamma_z)) %>%
rename(`gamma~z~` = estimate, df = parameter, `*t*` = statistic) %>%
select(-method)
pander(gamma_cor_t.test, style="rmarkdown", split.tables = Inf,
caption = "Gamma Correlation t-test")
lm_gamma_by_logRT_mean_diff <- lm(gamma ~ logRT_mean_diff,
data = gamma_cor_bySubject_List)
s_lm_gamma_by_logRT_mean_diff <- summary(lm_gamma_by_logRT_mean_diff)
pander(s_lm_gamma_by_logRT_mean_diff)
plot_gamma_vs_list_diff <- ggplot(gamma_cor_bySubject_List,
aes(x=N_diff, y=gamma)) +
geom_point() +
xlab("Difference in Items Recalled\n(Final - Practice)") +
ylab(expression(paste("Goodman–Kruskal "," ", gamma, " Coefficient")))
x_axis_RT_breaks <- seq(round(min(gamma_cor_bySubject_List$logRT_mean_diff),0),
round(max(gamma_cor_bySubject_List$logRT_mean_diff),0),
by=.5)
plot_gamma_vs_logRT_diff <- plot_gamma_vs_list_diff %+%
aes(x=logRT_mean_diff) +
scale_x_continuous("Log IRT Difference\n(Final - Practice)",
breaks = x_axis_RT_breaks) +
geom_smooth(se=FALSE, method = "lm", color = "black") +
annotate("text", x = 1, y = .75,
label = paste("italic(r) ==",
sub("^(-?)0.", "\\1.", round(sqrt(s_lm_gamma_by_logRT_mean_diff$r.squared),3))
),
parse=TRUE
)
grid.draw(arrangeGrob(plot_gamma_vs_list_diff, plot_gamma_vs_logRT_diff,
nrow=1, ncol=2)
)
State-Trace Plots
state_trace_data <- bind_rows(filter(byCond, class != "tp") %>%
select(-contains("median"), -contains("recentered")),
mutate(conditional_means,
np_score = recode(np_score, `0`="tp_inc", `1`="tp_cor")
) %>%
rename(class = np_score)
)
state_trace_plot <- ggplot(state_trace_data,
aes(x=acc_mean, y=logRT_mean, shape=class)) +
geom_point(size=2) +
geom_errorbar(aes(ymin=logRT_mean_CI_upper,
ymax=logRT_mean_CI_lower),
width=.05) +
geom_errorbarh(aes(xmin=acc_mean_CI_upper,
xmax=acc_mean_CI_lower),
height=.05) +
scale_x_continuous("Accuracy", limits=c(0,1)) +
scale_y_continuous("Recall Latency (log scale seconds)",
breaks = seq(.5, 2, by=.5),
labels = as.character(round(exp(seq(.5, 2, by=.5)), 2))) +
scale_shape_manual("Practice\nCondition",
labels = c("Baseline", "Restudy", "Test (Correct)", "Test (Incorrect"),
values = c(15,16,17,4)
)
print(state_trace_plot)
Grand Averages
pander(as.data.frame(byCond[c("class", "acc_mean", "RT_mean")]),
style="rmarkdown")
Accuracy Analysis
qplot(x=class, y=acc_mean, data=byCond)
Accuracy ANOVA
opts = options(stringsAsFactors = TRUE)
accAnova <- aov_car(acc_mean ~ Error(subject/class),
data = mutate_at(bySubjects_cond, c("subject","class"), factor),
anova_table=list(es = 'pes'))
options(opts)
pander(nice(accAnova), style="rmarkdown")
x <- proj(accAnova$aov)
qqnorm(x[["subject:class"]][,'Residuals'], main = "subject:class",
ylab = "Sample Quantiles subject:class")
qqline(x[["subject:class"]][,'Residuals'])
pander(cbind("strata" = "subject:class",
tidy(shapiro.test(x[["subject:class"]][,'Residuals']))[1:2]
),
caption = "Shapiro-Wilk normality test",
style="rmarkdown"
)
Accuracy Contrasts
acc_t_contrasts <- combn(c("np","sp","tp"), 2, FUN = t_summary, simplify=FALSE,
formula = acc_mean ~ class,
data = bySubjects_cond,
paired=TRUE)
names(acc_t_contrasts) <- vapply(acc_t_contrasts, attr, FUN.VALUE = character(1), "pair")
acc_t_contrasts <- as.data.frame(do.call(rbind, acc_t_contrasts))
acc_t_contrasts$p <- p.adjust(acc_t_contrasts$p, method = "bonferroni")
pander(acc_t_contrasts)
RT Analysis
qplot(x=class, y=RT_mean, data=byCond)
Log-RT ANOVA
opts = options(stringsAsFactors = TRUE)
RTanova <- aov_car(logRT_mean ~ class + Error(subject/class),
data = mutate_at(bySubjects_cond, c("subject","class"), factor),
anova_table = list(es = 'pes'))
options(opts)
pander(nice(RTanova), style="rmarkdown")
x <- proj(RTanova$aov)
qqnorm(x[["subject:class"]][,'Residuals'], main = "subject:class",
ylab = "Sample Quantiles subject:class")
qqline(x[["subject:class"]][,'Residuals'])
pander(cbind("strata" = "subject:class",
tidy(shapiro.test(x[["subject:class"]][,'Residuals']))[1:2]
),
caption = "Shapiro-Wilk normality test",
style="rmarkdown"
)
Log-RT Contrasts
RT_t_contrasts <- combn(c("np","sp","tp"), 2, FUN = t_summary, simplify=FALSE,
formula = logRT_mean ~ class,
data = bySubjects_cond,
paired=TRUE)
names(RT_t_contrasts) <- vapply(RT_t_contrasts, attr, FUN.VALUE = character(1), "pair")
RT_t_contrasts <- as.data.frame(do.call(rbind, RT_t_contrasts))
RT_t_contrasts$p <- p.adjust(RT_t_contrasts$p, method = "bonferroni")
pander(RT_t_contrasts)
RT ~ Reverse-Order x Condition ANOVA
base_formula <- formula(~ class*revOrder + Error(subject/(class*revOrder)))
par(mfcol=c(1,3))
panderOptions('knitr.auto.asis', FALSE)
for (DV in c("RT_mean", "RT_median", "logRT_mean")) {
cat("<h4>", "Using", DV, "</h4>")
model_formula <- update(base_formula, paste(DV, deparse(base_formula)))
RT_revOrder_anova <- aov_car(model_formula,
data = mutate_at(bySubjects_cond_revOrder_noMissing,
.cols = c("subject","class","revOrder"),
.funs = factor
),
anova_table = list(es = 'pes')
)
pander(nice(RT_revOrder_anova), style="rmarkdown",
caption = paste(deparse(model_formula, width.cutoff = 200L), "ANOVA")
)
projections <- proj(RT_revOrder_anova$aov)
strata <- grep("class|revOrder", names(projections), value = TRUE)
SW_tests <- rep(list(data.frame(statistic = numeric(1),
p.value = numeric(1))),
length(strata))
names(SW_tests) <- strata
for (x in strata) {
y <- projections[[x]][,'Residuals']
qqnorm(y, main = x, ylab = paste("Sample Quantiles",
paste(c("(",DV,")"), collapse = "")
)
)
qqline(y)
SW_tests[[x]] <- tidy(shapiro.test(y))[1:2]
}
pander(bind_rows(SW_tests, .id = "strata"), style="rmarkdown")
}
par(mfcol=c(1,1))
panderOptions('knitr.auto.asis', TRUE)
model_formula <- update(base_formula, paste("logRT_mean", deparse(base_formula)))
np_tp_only_anova <- aov_car(model_formula,
data = mutate_at(filter(bySubjects_cond_revOrder_noMissing,
class %in% c("np", "tp")
),
.cols = c("subject", "class", "revOrder"),
.funs = factor),
anova_table = list(es = 'pes'))
pander(nice(np_tp_only_anova), "No Practice vs Test Practice")
np_sp_only_anova <- aov_car(model_formula,
data = mutate_at(filter(bySubjects_cond_revOrder_noMissing,
class %in% c("np", "sp")
),
.cols = c("subject", "class", "revOrder"),
.funs = factor),
anova_table = list(es = 'pes'))
pander(nice(np_sp_only_anova), "No Practice vs Restudy")
RT_order_anova <- aov_car(logRT_mean ~ class*output_order + Error(subject/(class*output_order)),
data = mutate_at(bySubjects_cond_order_noMissing,
.cols = c("subject","class","output_order"),
.funs = factor
),
anova_table = list(es = 'pes'))
pander(nice(RT_order_anova), "Forward-Order ANOVA")
pander(summary(pairs(lsmeans(RT_order_anova, ~ class), adjust = "bonferroni")),
"Forward-Order Contrasts")
Final Figures
diff_bySubjects_cond <- bySubjects_cond %>%
select(subject, class, acc_mean) %>%
spread(class, acc_mean) %>%
mutate_at(c("sp", "tp"),
funs(. - np)) %>%
select(-np) %>%
gather(key="class", value="acc_mean", sp, tp)
diff_byCond <- diff_bySubjects_cond %>%
group_by(class) %>%
summarise(sem = whoppeR::sem(acc_mean, na.rm=TRUE)) %>%
rbind(data.frame(class="np", sem=NA)) %>%
left_join(select(byCond, class, acc_mean),
by="class")
diff_bySubjects_cond_revOrder_noMissing <- bySubjects_cond_revOrder_noMissing %>%
select(subject, class, revOrder, logRT_mean) %>%
spread(class, logRT_mean) %>%
group_by(revOrder) %>%
mutate_at(c("sp", "tp"),
funs(. - np)) %>%
ungroup() %>%
select(-np) %>%
gather(key="class", value="logRT_mean", sp, tp)
diff_byCond_revOrder_noMissing <- diff_bySubjects_cond_revOrder_noMissing %>%
group_by(class, revOrder) %>%
summarise(sem = whoppeR::sem(logRT_mean, na.rm=TRUE)) %>%
bind_rows(data.frame(class="np",
revOrder=unique(byCond_revOrder_noMissing$revOrder),
sem=NA)
) %>%
left_join(select(byCond_revOrder_noMissing, class, revOrder, logRT_mean),
by=c("class","revOrder"))
theme_set(theme_bw(base_size = 16) +
theme(panel.grid = element_blank())
)
byCond_acc_plot <- ggplot(byCond,
aes(x=" ",
y=acc_mean,
ymin = acc_mean - acc_mean_sem,
ymax = acc_mean + acc_mean_sem,
shape = class)) +
geom_point(size=3,
position=position_dodge(.2)) +
geom_errorbar(width=.25,
position=position_dodge(.2),
na.rm=TRUE) +
scale_shape_discrete(guide=FALSE) +
scale_x_discrete(" ") +
scale_y_continuous("Proportion Correct") +
theme(axis.ticks.x = element_blank())
RT_breaks <- seq(round(min(byCond_revOrder_noMissing$logRT_mean),0),
round(max(byCond_revOrder_noMissing$logRT_mean),0),
by=.5)
byCond_revOrder_RTplot <- ggplot(byCond_revOrder_noMissing,
aes(x=revOrder, y=logRT_mean,
ymin = logRT_mean - logRT_mean_sem,
ymax = logRT_mean + logRT_mean_sem,
shape = class,
linetype = class)) +
geom_point(size=3) +
geom_line(size=.75) +
geom_errorbar(width=.15,
na.rm=TRUE,
linetype=1) +
scale_shape_discrete(name="Practice\nCondition",
labels=c("Baseline","Restudy","Test Practice")) +
scale_linetype_manual(name="Practice\nCondition",
labels=c("Baseline","Restudy","Test Practice"),
values= c("solid","dotted","dashed")) +
scale_x_reverse("Output Position",
breaks=1:max(byCond_revOrder_noMissing$revOrder),
labels = c("n",
paste("n-", 1:(max(byCond_revOrder_noMissing$revOrder)-1),
sep=''))
) +
scale_y_continuous("Log Scale IRT (seconds)",
breaks = RT_breaks,
labels = as.character(round(exp(RT_breaks),2))
) +
theme(legend.position = c(.25, .7),
legend.key.width = unit(2.75, "lines"))
g1 <- arrangeGrob(byCond_acc_plot, byCond_revOrder_RTplot,
nrow=1, ncol=2, widths=c(.25, 1))
grid.draw(g1)
plot_gamma_vs_logRT_diff <- plot_gamma_vs_logRT_diff + ylab("")
g2 <- arrangeGrob(plot_gamma_vs_list_diff,
plot_gamma_vs_logRT_diff,
nrow=1, ncol=2, widths=c(.48, .52)
)
grid.draw(g2)
x <- WISEsummary(bySubjects_cond_revOrder_noMissing,
dependentvars = "logRT_mean",
withinvars = "class",
idvar = "subject") %>%
rename_(.dots=setNames(names(.),
gsub("_mean$", "", names(.))
)
) %>%
select(class, logRT_mean, logRT_mean_CI_upper, logRT_mean_CI_lower) %>%
left_join(x = .,
y = byCond[c("class", "acc_mean", "acc_mean_CI_upper", "acc_mean_CI_lower")],
by = "class"
)
x_plot <- ggplot(x, aes(x=acc_mean, y=logRT_mean, shape=class)) +
geom_point(size=2) +
geom_errorbar(aes(ymin=logRT_mean_CI_upper,
ymax=logRT_mean_CI_lower),
width=.05) +
geom_errorbarh(aes(xmin=acc_mean_CI_upper,
xmax=acc_mean_CI_lower),
height=.05) +
scale_x_continuous("Accuracy", limits=c(.5, 1)) +
scale_y_continuous("Recall Latency (log scale seconds)",
limits = c(.15, .8),
breaks = seq(.2, .8, by = .1),
labels = as.character(round(exp(seq(.2, .8, by = .1)), 2))) +
scale_shape_discrete("Practice\nCondition",
labels = c("Baseline", "Restudy", "Test")
)
print(x_plot)
wjhopper/FAM documentation built on May 4, 2019, 7:33 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
source("../.Rprofile", chdir = TRUE) library(FAM) library(whoppeR) library(dplyr) library(tidyr) library(magrittr) library(ggplot2) library(grid) library(gridExtra) library(wesanderson) library(effsize) library(pander) library(rococo) library(broom) library(afex) knitr::opts_chunk$set(echo = FALSE, warning=FALSE, message=FALSE, cache=FALSE, fig.width=10, fig.height=6, fig.align='center') op <- options(contrasts = c("contr.sum", "contr.poly"))
class_labels <- c(np="Practice Test", sp="Study Practice", tp="Test Practice")
minimal_variables <- c("subject","cond_list","class","resp","score", "RT") data(CFR, package = "FAM") tested <- filter(CFR, !is.na(resp)) tested$score <- as.integer(tested$score) corrects <- filter(tested, score==1) %>% select_(.dots = c(minimal_variables, "target","resp", "where")) %>% group_by(subject,class,cond_list) %>% mutate(output_order = 1:n(), revOrder = rev(output_order), logRT = log(RT)) %>% ungroup() %>% complete(subject, class, cond_list, output_order, fill=list(score=0))
N_correct <- corrects %>% group_by(subject, class, cond_list) %>% summarise(nRecalled = sum(score)) corrects <- left_join(corrects, N_correct, by = c("subject", "class", "cond_list"))
summaryFun <- function(data) { grouping_vars <- vapply(groups(data), as.character, character(1)) x <- summarise(data, RT_median = median(RT, na.rm = TRUE), RT_mean = mean(RT, na.rm = TRUE), logRT_mean = mean(logRT, na.rm = TRUE), RT_sd = sd(RT, na.rm = TRUE), MAD = mad(RT, na.rm = T, constant = 1), RT_n = sum(!is.na(RT)) ) if (!"nRecalled" %in% grouping_vars) { y <- summarise(data, acc_mean = mean(score), acc_sd = sd(score), acc_n = n() ) x <- left_join(y, x, by=grouping_vars) } remove <- unique(unlist(lapply(x[grouping_vars], function(y) which(is.na(y)) ) ) ) if (length(remove) > 0L) { x <- x[-remove,] } ungroup(x) }
# Ignore subjects here since there are too few observations per subject at each level of # nRecalled byCond_order_nRecalled <- corrects %>% group_by(class, output_order, nRecalled) %>% summaryFun() %>% filter(RT_n != 0) %>% arrange(class, nRecalled) byCond_revOrder_nRecalled <- corrects %>% group_by(class, revOrder, nRecalled) %>% summaryFun() %>% arrange(class, nRecalled) ## Group by Subject, condition, and order bySubjects_cond_order <- corrects %>% group_by(subject, class, output_order) %>% summaryFun() ## Collapse condition and order over Subjects byCond_order <- bySubjects_cond_order %>% WISEsummary(dependentvars = c("acc_mean", "RT_mean", "logRT_mean", "RT_median"), withinvars = c("class","output_order"), idvar = "subject", na.rm = TRUE) %>% rename_(.dots=setNames(names(.), gsub("_mean$", "", names(.)) ) ) %>% select(-RT_median_n, -logRT_mean_n) %>% rename(RT_n = RT_mean_n, acc_n = acc_mean_n) ## Group by subject, condition, and reverse order bySubjects_cond_revOrder <- corrects %>% group_by(subject, class, revOrder) %>% summaryFun() ## Collapse condition and reverse order over Subjects byCond_revOrder <- bySubjects_cond_revOrder %>% WISEsummary(dependentvars = c("RT_mean", "logRT_mean", "RT_median"), withinvars = c("class","revOrder"), idvar = "subject", na.rm = TRUE) %>% rename_(.dots=setNames(names(.), gsub("_mean$", "", names(.)) ) ) %>% select(-RT_median_n, -logRT_mean_n) %>% rename(RT_n = RT_mean_n) ## Group by subjects and condition bySubjects_cond <- corrects %>% group_by(subject, class) %>% summaryFun() ## Collapse condition over subjects byCond <- bySubjects_cond %>% WISEsummary(dependentvars = c("acc_mean", "RT_mean", "logRT_mean", "RT_median"), withinvars = "class", idvar = "subject", na.rm = TRUE) %>% rename_(.dots=setNames(names(.), gsub("_mean$", "", names(.)) ) ) %>% select(-RT_median_n, -logRT_mean_n) %>% rename(RT_n = RT_mean_n, acc_n = acc_mean_n)
max_complete <- byCond_revOrder %>% filter(RT_n == 34L) %>% group_by(class) %>% summarise(max_position = max(revOrder)) byCond_revOrder_noMissing <- filter(byCond_revOrder, revOrder <= min(max_complete$max_position)) bySubjects_cond_revOrder_noMissing <- filter(bySubjects_cond_revOrder, revOrder <= min(max_complete$max_position)) bySubjects_cond_order_noMissing <- filter(bySubjects_cond_order, output_order <= min(max_complete$max_position))
targets <- filter(.data = CFR, !is.na(target), class != "sp") %>% select(subject, class, cond_list, target, order) %>% rename(serial_pos = order) conditional_raw <- left_join(targets, select(corrects,-target), by = c("subject", "cond_list", "class", "serial_pos" = "where") ) %>% mutate(score = replace(score, is.na(score), 0)) %>% select(subject, class, target, score, RT, logRT) %>% gather(key = DV, value = value, score, RT, logRT) %>% unite(col = DV, sep = "_", class, DV) %>% spread(key = DV, value = value) conditional_means_bySubject <- conditional_raw %>% group_by(subject, np_score) %>% summarise(acc_mean = mean(tp_score), acc_n = n(), RT_mean = mean(tp_RT, na.rm=TRUE), logRT_mean = mean(tp_logRT, na.rm=TRUE), RT_n = sum(!is.na(tp_RT)) ) %>% ungroup() %>% tidyr::complete(subject, np_score) conditional_means <- conditional_means_bySubject %>% group_by(np_score) %>% summarise(acc_n = n(), acc_mean_sem = whoppeR::sem(acc_mean), acc_CI_width = acc_mean_sem * qt(.975, acc_n - 1), acc_mean = mean(acc_mean), RT_n = sum(!is.na(RT_mean)), RT_mean_sem = whoppeR::sem(RT_mean, na.rm = TRUE), RT_CI_width = RT_mean_sem * qt(.975, RT_n - 1), RT_mean = mean(RT_mean, na.rm = TRUE), logRT_mean_sem = whoppeR::sem(logRT_mean, na.rm = TRUE), logRT_CI_width = logRT_mean_sem * qt(.975, RT_n - 1), logRT_mean = mean(logRT_mean, na.rm = TRUE) ) %>% mutate(acc_mean_CI_upper = acc_mean + acc_CI_width, acc_mean_CI_lower = acc_mean - acc_CI_width, RT_mean_CI_upper = RT_mean + RT_CI_width, RT_mean_CI_lower = RT_mean - RT_CI_width, logRT_mean_CI_upper = logRT_mean + logRT_CI_width, logRT_mean_CI_lower = logRT_mean - logRT_CI_width) %>% select(np_score, acc_mean, acc_n, acc_mean_sem, acc_mean_CI_upper, acc_mean_CI_lower, RT_mean, RT_n, RT_mean_sem, RT_mean_CI_upper, RT_mean_CI_lower, logRT_mean, logRT_mean_sem, logRT_mean_CI_upper, logRT_mean_CI_lower )
Subject Performance
Left figure shows counts of correct recalls, repeats of correct recalls, and extra list intrusions for each list by each type of list (study practice, test practice, no practice). Perfect performance is 15/15 correct.
Right figure shows latency in seconds to pressing the first key when typing in the word, relative to the last key press of the previous word (or onset of the trial in the case of the first word.) Violin plots are gaussian kernel density estimates of the RT's, bandwidth of 1.
allResponseTypesLong <- tested %>% select_(.dots = c(minimal_variables,"intrusions", "repeats")) %>% gather(key = "output_type", value = "count", score,intrusions,repeats) %>% group_by(subject,class,cond_list,output_type) accData_bySubjects <- allResponseTypesLong %>% summarise_at(.cols = "count", .funs = "sum") %>% arrange(subject,class,cond_list,rev(output_type)) ymax <- max(tested$order) for (i in unique(tested$subject)){ subAcc <- ggplot(data = filter(accData_bySubjects, subject ==i), aes(x= cond_list, y=count, fill=output_type)) + geom_bar(stat="identity") + facet_grid(class~., labeller = labeller(class=class_labels)) + scale_y_continuous(limits=c(0,ymax)) + scale_fill_manual("Response Type", breaks= c("score","repeats","intrusions"), labels =c(score = "Correct", intrusions = "Intrusions", repeats = "Repeated"), values = wes_palette("Darjeeling")) + xlab("List") + ggtitle("Response Type Frequency") subTime <- ggplot(data = filter(allResponseTypesLong, subject==i, count == 1), aes(x = factor(cond_list), y=RT)) + geom_violin() + geom_point(aes(color = output_type)) + stat_summary(fun.y = "median") + facet_grid(class~., labeller = labeller(class=class_labels)) + scale_color_manual("Response Type", breaks= c("score","repeats","intrusions"), labels =c(score = "Correct", intrusions = "Intrusion", repeats = "Repeated"), values = wes_palette("Darjeeling")) + xlab("List") + ggtitle("IRTs Including Intrusions and Repeats") cat('<h4 class="subid">', paste("Subject", i), '</h4>') grid.arrange(subAcc,subTime,ncol=2,nrow=1) }
Performance by Output Position
Output order is computed only for correct responses, but any RT's are measured relative to the item output immediately prior, even if that item is an intrusion or repeat.
byCond_order_acc_plot <- ggplot(data = byCond_order, aes(x=factor(output_order), y=acc_mean, group=class, color=class, ymin = acc_mean - acc_mean_sem, ymax = acc_mean + acc_mean_sem)) + geom_point(size = 2) + geom_line(size = .75) + geom_errorbar(width=.3) + scale_y_continuous("Probability of Recalling at Least x Items") + scale_x_discrete("Output Position (x)") + scale_color_manual(name="Practice\nCondition", labels=c("Baseline","Restudy","Test Practice"), values = c('black', 'red', '#00cc00')) + ggtitle("Output Accuracy") byCond_order_RT_plot <- byCond_order_acc_plot + aes(y=RT_mean, ymin = RT_mean - RT_mean_sem, ymax = RT_mean + RT_mean_sem) + scale_y_continuous("Mean Inter-Retreival Time of Item x") + ggtitle("Inter-Retrieval Time") print(byCond_order_acc_plot) print(byCond_order_RT_plot)
IRT by Reverse Output Position (All Conditions)
byRevOrder <- corrects %>% filter(!is.na(RT)) %>% group_by(revOrder) %>% summarise(meanRT = mean(RT), count = n(), upper = quantile(RT, .975), lower = quantile(RT, .025)) ggplot(data = byRevOrder, aes(x= factor(revOrder), y=meanRT) ) + geom_point(aes(y=RT), data = filter(corrects, !is.na(RT)), position = position_jitter(width = .2), color="black") + geom_errorbar(mapping = aes(ymax=upper,ymin=lower), width=.25,color="red",size=.75) + geom_point(color="red") + geom_line(aes(x=revOrder), color="red") + geom_text(aes(label = count, y=-2.5)) + scale_x_discrete("Reverse Output Position", labels = c("n", paste("n-",1:14,sep='')))+ scale_y_continuous("IRT") + ggtitle("Inter-Retrieval Times by Reverse Output Position")
IRT by Total Recalled & Output Position
# Forward Order forward <- ggplot(filter(byCond_order_nRecalled, output_order > 1, nRecalled >= 4 & nRecalled <= 12), aes(x=output_order, y=RT_mean, color=factor(nRecalled))) + geom_point(aes(size=RT_n)) + geom_line(size = .75) + facet_grid(class~., labeller = labeller(class=class_labels) ) + scale_x_continuous(breaks = 1:15) + scale_color_discrete("Items Recalled") + ylab("Mean IRT") + xlab("Output Order") + ggtitle("Forward IRTs by Recall Total") print(forward) byCond_revOrder_nRecalled_restricted <- filter(byCond_revOrder_nRecalled, nRecalled >= 4 & nRecalled <= 12) backward <- forward %+% byCond_revOrder_nRecalled_restricted %+% aes(x=revOrder) + scale_x_continuous("Reverse Output Order", breaks = seq(max(byCond_revOrder_nRecalled_restricted$revOrder)), labels = c("n", paste("n-", seq(max(byCond_revOrder_nRecalled_restricted$revOrder)-1) ) ) ) + ggtitle("Reverse IRTs by Recall Total") print(backward)
Quantile Plots
quantile_points <- c(0.1, 0.3, 0.5, 0.7, 0.9) correct_quantiles <- corrects %>% filter(!is.na(RT)) %>% group_by(class,output_order) %>% do(as.data.frame(t(quantile(.$RT, probs =quantile_points)))) %>% ungroup() %>% gather_(key_col="quantile", value_col="RT", gather_cols=paste0(quantile_points*100, "%") ) ggplot(correct_quantiles, aes(x =output_order, y = RT, color = quantile)) + geom_point() + geom_line() + facet_grid(.~class, labeller = labeller(class=class_labels)) + scale_x_continuous("Output Order", breaks = 1:15 ) + scale_color_discrete(name="Quantile") + theme(panel.grid.minor.x = element_blank())
Output Order Correlation
The consistency between the output order of items on the practice test and final tests was measured with the Kruskal-Goodman gamma coefficient. Higher values of the gamma statistic indicate more consistent ordering of the recalled words between the two tests.
This statistic was calcuated in two different ways: list-wise, and subject-wise. In the the list-wise calculation, the gamma stastic was calculated for each individual list from each participant. In the subject-wise calculation, the concordances from all four lists were summed together and discordances from list were summed together, before being combined to form the gamma statistic.
ranks <- corrects %>% select(subject, cond_list, class, resp, target) %>% filter(class %in% c("np","tp"), !is.na(resp)) %>% group_by(subject, cond_list) %>% filter(c(resp[class=="np"] %in% resp[class=="tp"], resp[class=="tp"] %in% resp[class=="np"])) %>% group_by(subject, cond_list, class) %>% mutate(rank = row_number()) %>% group_by(subject, cond_list) %>% mutate(id = replace(rank, class=="tp", match(resp[class=="tp"], resp[class=="np"]) ) ) %>% ungroup() gamma_cor_bySubject_pooling_lists <- ranks %>% group_by(subject, cond_list) %>% do(bind_cols(distinct(.[c("subject","cond_list")]), as_data_frame(t(rank_agreements(x = .$id[.$class=="np"], y = .$id[.$class=="tp"]))) )) %>% group_by(subject) %>% summarise_at(c("concordances","discordances"), sum) %>% mutate(gamma = (concordances-discordances)/(concordances+discordances), gamma_z = atanh(gamma)) # fischer-z transformed the correlation Ncorrect_diff <- ungroup(N_correct) %>% filter(class %in% c("np","tp")) %>% spread(class,nRecalled) %>% mutate(N_diff = tp-np) %>% select(-tp, -np) RT_delta_bySubject_List <- corrects %>% filter(class %in% c("np","tp")) %>% group_by(subject, class, cond_list) %>% summaryFun() %>% select(subject, class, cond_list, RT_median, RT_mean, logRT_mean) %>% gather(key = "DV", value="val", RT_median, RT_mean, logRT_mean) %>% spread(class, val) %>% mutate(diff = tp - np) %>% # Final Minus Practice. Negative means faster on final test. select(-tp, -np) %>% mutate(DV = paste0(DV, "_diff")) %>% spread(DV, diff) gamma_cor_bySubject_List <- ranks %>% group_by(subject, cond_list) %>% summarise(gamma = rococo(id[class=="np"], id[class=="tp"])) gamma_cor_bySubject_List <- Reduce(function(x,y) left_join(x, y, by = c("subject", "cond_list")), list(gamma_cor_bySubject_List, Ncorrect_diff, RT_delta_bySubject_List) )
hist(gamma_cor_bySubject_pooling_lists$gamma, xlab=expression(paste("Goodman–Kruskal ", gamma, " Coefficient")), main = "Practice/Final Test Gamma Correlations\nby Subject" ) gamma_cor_t.test <- tidy(t.test(gamma_cor_bySubject_pooling_lists$gamma_z)) %>% rename(`gamma~z~` = estimate, df = parameter, `*t*` = statistic) %>% select(-method) pander(gamma_cor_t.test, style="rmarkdown", split.tables = Inf, caption = "Gamma Correlation t-test") lm_gamma_by_logRT_mean_diff <- lm(gamma ~ logRT_mean_diff, data = gamma_cor_bySubject_List) s_lm_gamma_by_logRT_mean_diff <- summary(lm_gamma_by_logRT_mean_diff) pander(s_lm_gamma_by_logRT_mean_diff)
plot_gamma_vs_list_diff <- ggplot(gamma_cor_bySubject_List, aes(x=N_diff, y=gamma)) + geom_point() + xlab("Difference in Items Recalled\n(Final - Practice)") + ylab(expression(paste("Goodman–Kruskal "," ", gamma, " Coefficient"))) x_axis_RT_breaks <- seq(round(min(gamma_cor_bySubject_List$logRT_mean_diff),0), round(max(gamma_cor_bySubject_List$logRT_mean_diff),0), by=.5) plot_gamma_vs_logRT_diff <- plot_gamma_vs_list_diff %+% aes(x=logRT_mean_diff) + scale_x_continuous("Log IRT Difference\n(Final - Practice)", breaks = x_axis_RT_breaks) + geom_smooth(se=FALSE, method = "lm", color = "black") + annotate("text", x = 1, y = .75, label = paste("italic(r) ==", sub("^(-?)0.", "\\1.", round(sqrt(s_lm_gamma_by_logRT_mean_diff$r.squared),3)) ), parse=TRUE ) grid.draw(arrangeGrob(plot_gamma_vs_list_diff, plot_gamma_vs_logRT_diff, nrow=1, ncol=2) )
State-Trace Plots
state_trace_data <- bind_rows(filter(byCond, class != "tp") %>% select(-contains("median"), -contains("recentered")), mutate(conditional_means, np_score = recode(np_score, `0`="tp_inc", `1`="tp_cor") ) %>% rename(class = np_score) ) state_trace_plot <- ggplot(state_trace_data, aes(x=acc_mean, y=logRT_mean, shape=class)) + geom_point(size=2) + geom_errorbar(aes(ymin=logRT_mean_CI_upper, ymax=logRT_mean_CI_lower), width=.05) + geom_errorbarh(aes(xmin=acc_mean_CI_upper, xmax=acc_mean_CI_lower), height=.05) + scale_x_continuous("Accuracy", limits=c(0,1)) + scale_y_continuous("Recall Latency (log scale seconds)", breaks = seq(.5, 2, by=.5), labels = as.character(round(exp(seq(.5, 2, by=.5)), 2))) + scale_shape_manual("Practice\nCondition", labels = c("Baseline", "Restudy", "Test (Correct)", "Test (Incorrect"), values = c(15,16,17,4) ) print(state_trace_plot)
Grand Averages
pander(as.data.frame(byCond[c("class", "acc_mean", "RT_mean")]), style="rmarkdown")
Accuracy Analysis
qplot(x=class, y=acc_mean, data=byCond)
Accuracy ANOVA
opts = options(stringsAsFactors = TRUE) accAnova <- aov_car(acc_mean ~ Error(subject/class), data = mutate_at(bySubjects_cond, c("subject","class"), factor), anova_table=list(es = 'pes')) options(opts) pander(nice(accAnova), style="rmarkdown") x <- proj(accAnova$aov) qqnorm(x[["subject:class"]][,'Residuals'], main = "subject:class", ylab = "Sample Quantiles subject:class") qqline(x[["subject:class"]][,'Residuals']) pander(cbind("strata" = "subject:class", tidy(shapiro.test(x[["subject:class"]][,'Residuals']))[1:2] ), caption = "Shapiro-Wilk normality test", style="rmarkdown" )
Accuracy Contrasts
acc_t_contrasts <- combn(c("np","sp","tp"), 2, FUN = t_summary, simplify=FALSE, formula = acc_mean ~ class, data = bySubjects_cond, paired=TRUE) names(acc_t_contrasts) <- vapply(acc_t_contrasts, attr, FUN.VALUE = character(1), "pair") acc_t_contrasts <- as.data.frame(do.call(rbind, acc_t_contrasts)) acc_t_contrasts$p <- p.adjust(acc_t_contrasts$p, method = "bonferroni") pander(acc_t_contrasts)
RT Analysis
qplot(x=class, y=RT_mean, data=byCond)
Log-RT ANOVA
opts = options(stringsAsFactors = TRUE) RTanova <- aov_car(logRT_mean ~ class + Error(subject/class), data = mutate_at(bySubjects_cond, c("subject","class"), factor), anova_table = list(es = 'pes')) options(opts) pander(nice(RTanova), style="rmarkdown") x <- proj(RTanova$aov) qqnorm(x[["subject:class"]][,'Residuals'], main = "subject:class", ylab = "Sample Quantiles subject:class") qqline(x[["subject:class"]][,'Residuals']) pander(cbind("strata" = "subject:class", tidy(shapiro.test(x[["subject:class"]][,'Residuals']))[1:2] ), caption = "Shapiro-Wilk normality test", style="rmarkdown" )
Log-RT Contrasts
RT_t_contrasts <- combn(c("np","sp","tp"), 2, FUN = t_summary, simplify=FALSE, formula = logRT_mean ~ class, data = bySubjects_cond, paired=TRUE) names(RT_t_contrasts) <- vapply(RT_t_contrasts, attr, FUN.VALUE = character(1), "pair") RT_t_contrasts <- as.data.frame(do.call(rbind, RT_t_contrasts)) RT_t_contrasts$p <- p.adjust(RT_t_contrasts$p, method = "bonferroni") pander(RT_t_contrasts)
RT ~ Reverse-Order x Condition ANOVA
base_formula <- formula(~ class*revOrder + Error(subject/(class*revOrder))) par(mfcol=c(1,3)) panderOptions('knitr.auto.asis', FALSE) for (DV in c("RT_mean", "RT_median", "logRT_mean")) { cat("<h4>", "Using", DV, "</h4>") model_formula <- update(base_formula, paste(DV, deparse(base_formula))) RT_revOrder_anova <- aov_car(model_formula, data = mutate_at(bySubjects_cond_revOrder_noMissing, .cols = c("subject","class","revOrder"), .funs = factor ), anova_table = list(es = 'pes') ) pander(nice(RT_revOrder_anova), style="rmarkdown", caption = paste(deparse(model_formula, width.cutoff = 200L), "ANOVA") ) projections <- proj(RT_revOrder_anova$aov) strata <- grep("class|revOrder", names(projections), value = TRUE) SW_tests <- rep(list(data.frame(statistic = numeric(1), p.value = numeric(1))), length(strata)) names(SW_tests) <- strata for (x in strata) { y <- projections[[x]][,'Residuals'] qqnorm(y, main = x, ylab = paste("Sample Quantiles", paste(c("(",DV,")"), collapse = "") ) ) qqline(y) SW_tests[[x]] <- tidy(shapiro.test(y))[1:2] } pander(bind_rows(SW_tests, .id = "strata"), style="rmarkdown") } par(mfcol=c(1,1)) panderOptions('knitr.auto.asis', TRUE)
model_formula <- update(base_formula, paste("logRT_mean", deparse(base_formula))) np_tp_only_anova <- aov_car(model_formula, data = mutate_at(filter(bySubjects_cond_revOrder_noMissing, class %in% c("np", "tp") ), .cols = c("subject", "class", "revOrder"), .funs = factor), anova_table = list(es = 'pes')) pander(nice(np_tp_only_anova), "No Practice vs Test Practice") np_sp_only_anova <- aov_car(model_formula, data = mutate_at(filter(bySubjects_cond_revOrder_noMissing, class %in% c("np", "sp") ), .cols = c("subject", "class", "revOrder"), .funs = factor), anova_table = list(es = 'pes')) pander(nice(np_sp_only_anova), "No Practice vs Restudy")
RT_order_anova <- aov_car(logRT_mean ~ class*output_order + Error(subject/(class*output_order)), data = mutate_at(bySubjects_cond_order_noMissing, .cols = c("subject","class","output_order"), .funs = factor ), anova_table = list(es = 'pes')) pander(nice(RT_order_anova), "Forward-Order ANOVA") pander(summary(pairs(lsmeans(RT_order_anova, ~ class), adjust = "bonferroni")), "Forward-Order Contrasts")
Final Figures
diff_bySubjects_cond <- bySubjects_cond %>% select(subject, class, acc_mean) %>% spread(class, acc_mean) %>% mutate_at(c("sp", "tp"), funs(. - np)) %>% select(-np) %>% gather(key="class", value="acc_mean", sp, tp) diff_byCond <- diff_bySubjects_cond %>% group_by(class) %>% summarise(sem = whoppeR::sem(acc_mean, na.rm=TRUE)) %>% rbind(data.frame(class="np", sem=NA)) %>% left_join(select(byCond, class, acc_mean), by="class") diff_bySubjects_cond_revOrder_noMissing <- bySubjects_cond_revOrder_noMissing %>% select(subject, class, revOrder, logRT_mean) %>% spread(class, logRT_mean) %>% group_by(revOrder) %>% mutate_at(c("sp", "tp"), funs(. - np)) %>% ungroup() %>% select(-np) %>% gather(key="class", value="logRT_mean", sp, tp) diff_byCond_revOrder_noMissing <- diff_bySubjects_cond_revOrder_noMissing %>% group_by(class, revOrder) %>% summarise(sem = whoppeR::sem(logRT_mean, na.rm=TRUE)) %>% bind_rows(data.frame(class="np", revOrder=unique(byCond_revOrder_noMissing$revOrder), sem=NA) ) %>% left_join(select(byCond_revOrder_noMissing, class, revOrder, logRT_mean), by=c("class","revOrder"))
theme_set(theme_bw(base_size = 16) + theme(panel.grid = element_blank()) ) byCond_acc_plot <- ggplot(byCond, aes(x=" ", y=acc_mean, ymin = acc_mean - acc_mean_sem, ymax = acc_mean + acc_mean_sem, shape = class)) + geom_point(size=3, position=position_dodge(.2)) + geom_errorbar(width=.25, position=position_dodge(.2), na.rm=TRUE) + scale_shape_discrete(guide=FALSE) + scale_x_discrete(" ") + scale_y_continuous("Proportion Correct") + theme(axis.ticks.x = element_blank()) RT_breaks <- seq(round(min(byCond_revOrder_noMissing$logRT_mean),0), round(max(byCond_revOrder_noMissing$logRT_mean),0), by=.5) byCond_revOrder_RTplot <- ggplot(byCond_revOrder_noMissing, aes(x=revOrder, y=logRT_mean, ymin = logRT_mean - logRT_mean_sem, ymax = logRT_mean + logRT_mean_sem, shape = class, linetype = class)) + geom_point(size=3) + geom_line(size=.75) + geom_errorbar(width=.15, na.rm=TRUE, linetype=1) + scale_shape_discrete(name="Practice\nCondition", labels=c("Baseline","Restudy","Test Practice")) + scale_linetype_manual(name="Practice\nCondition", labels=c("Baseline","Restudy","Test Practice"), values= c("solid","dotted","dashed")) + scale_x_reverse("Output Position", breaks=1:max(byCond_revOrder_noMissing$revOrder), labels = c("n", paste("n-", 1:(max(byCond_revOrder_noMissing$revOrder)-1), sep='')) ) + scale_y_continuous("Log Scale IRT (seconds)", breaks = RT_breaks, labels = as.character(round(exp(RT_breaks),2)) ) + theme(legend.position = c(.25, .7), legend.key.width = unit(2.75, "lines")) g1 <- arrangeGrob(byCond_acc_plot, byCond_revOrder_RTplot, nrow=1, ncol=2, widths=c(.25, 1)) grid.draw(g1)
plot_gamma_vs_logRT_diff <- plot_gamma_vs_logRT_diff + ylab("") g2 <- arrangeGrob(plot_gamma_vs_list_diff, plot_gamma_vs_logRT_diff, nrow=1, ncol=2, widths=c(.48, .52) ) grid.draw(g2)
x <- WISEsummary(bySubjects_cond_revOrder_noMissing, dependentvars = "logRT_mean", withinvars = "class", idvar = "subject") %>% rename_(.dots=setNames(names(.), gsub("_mean$", "", names(.)) ) ) %>% select(class, logRT_mean, logRT_mean_CI_upper, logRT_mean_CI_lower) %>% left_join(x = ., y = byCond[c("class", "acc_mean", "acc_mean_CI_upper", "acc_mean_CI_lower")], by = "class" ) x_plot <- ggplot(x, aes(x=acc_mean, y=logRT_mean, shape=class)) + geom_point(size=2) + geom_errorbar(aes(ymin=logRT_mean_CI_upper, ymax=logRT_mean_CI_lower), width=.05) + geom_errorbarh(aes(xmin=acc_mean_CI_upper, xmax=acc_mean_CI_lower), height=.05) + scale_x_continuous("Accuracy", limits=c(.5, 1)) + scale_y_continuous("Recall Latency (log scale seconds)", limits = c(.15, .8), breaks = seq(.2, .8, by = .1), labels = as.character(round(exp(seq(.2, .8, by = .1)), 2))) + scale_shape_discrete("Practice\nCondition", labels = c("Baseline", "Restudy", "Test") ) print(x_plot)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.