In wjhopper/FAM: Forgetting and Memory, an Investigation of the Testing Effect

library(whoppeR)
library(Hmisc)
library(reshape2)
library(ggplot2)
library(dplyr)
library(FAM)
library(grid)
library(gridExtra)
library(pander)
knitr::opts_chunk$set(echo = FALSE,fig.width=11,fig.height=7,cache=FALSE, 
               warning=F, message=FALSE, fig.align='center')

Start by removing any subjects with less than 5% accuracy across all conditions. They are not helpful.

subject_means <- badSubs(LB4L_allSs)
LB4L_allSs <- filter(LB4L_allSs, !(subject %in% subject_means$removed))
LB4L_allSs$subject <- factor(LB4L_allSs$subject)
print(paste0("Removed Subjects: ", subject_means$removed))

Tailoring Phase

  tailoring <- LB4L_allSs %>% filter(list==1) %>% 
    performanceBins("subject",cutpoints = c(0,.25,.75,1),
                    acc=mean(final_score))
  ggplot(tailoring, aes(x=acc,y=percentage)) +
    geom_bar(stat='identity')  + 
    geom_text(aes(label =c("6 Secs","5 secs","4 Secs"),
                  y= percentage+.025)) +
    scale_y_continuous("Proportion of Subjects", limits = c(0,max(tailoring$percentage)+.025)) +
    scale_x_discrete("Practice List Performance",
                     labels=c("[0,0.25]" = "< 25%",
                              "(0.25,0.75]" = "25-75%",
                              "(0.75,1]" = "75% <")) +
    theme_larger() +
    ggtitle('Tailoring List')

Grand Average Performance

group_means <-  LB4L_allSs %>%
  filter(list != 1) %>%
  group_by(group) %>%
  summarise(final_acc=mean(final_score, na.rm=T),
            prac_acc = mean(prac_score, na.rm=T))

sub_means_plot <- ggplot(subject_means$means,aes(prac_acc,final_acc)) +
  geom_point(aes(color= group),size=4) +
  geom_point(aes(prac_acc,final_acc,fill=group),
             data = group_means,shape=25,size=4,color='black') +
  scale_x_continuous("Practice Test Accuracy",limits=c(0,1)) +
  ylab("Final Test Accuracy") +
  theme_larger() +
  ggtitle("Grand Average Performace by Subject within Group")

print(sub_means_plot)

Subject Performance

IVsummary <- heirarchicalSummary(collapse = c("subject","group"),
                            hold =c("practice","other_type"),
                            rawData = mutate(filter(LB4L_allSs,list !=1) ,n=1),
                            w_prac_score = weighted.mean(prac_score,w=n),                            
                            prac_score = mean(prac_score,na.rm=TRUE),
                            w_final_sd = sqrt(wtd.var(final_score)),
                            final_sd = sd(final_score),                            
                            w_final_score = weighted.mean(final_score,w=n),                         
                            final_score = mean(final_score),
                            n=sum(n))

IVss <- melt(IVsummary$subject,
             id.vars = c("subject","group","practice","other_type"),
             measure.vars = c("prac_score","final_score"),
             variable.name = "timepoint", value.name="acc")
condSummary <- LB4L_conditional(LB4L_allSs)

subs <- unique(LB4L_allSs$subject)
for (i in subs) {

  IVplot <- ggplot(data= filter(IVss, subject==i, is.finite(acc)),
                   aes(x=timepoint,y=acc,
                       color=strSort(interaction(practice,other_type)),
                       group=strSort(interaction(practice,other_type)))) +
    geom_point(size=3) +    
    geom_line(size=.75) + 
    scale_x_discrete("Test",expand=c(0,.25),labels=c("Practice","Final")) + 
    scale_color_discrete("Condition",
                         breaks = c("C.T","C.NA","NA.S","NA.T"),
                         labels = c(C.T = "2 Cues\n[Unpracticed, Tested]",
                                    C.NA = "1 Cue, No Practice",
                                    NA.S  = "1 Cue, Restudied",
                                    NA.T = "1 Cue, Tested")) + 
    scale_y_continuous("Final Test Accuracy",limit=0:1) + 
    theme(legend.key.height=unit(2,"line")) + 
    ggtitle('Test Accuracy')

  conPlot <- ggplot(filter(condSummary$subject,subject == i, 
                           merged_prac_score %in% 0:1),
                    aes(x=other_type, y= final_acc,
                        fill=merged_prac_score,ymax=1)) +
    geom_bar(position='dodge',stat="identity") +
    # label n observations in each cell
    geom_text(aes(y=-.05,label = count, group=merged_prac_score),
              position = position_dodge(width=0.9),
              size=4) +
    scale_fill_brewer("Practice\nAccuracy",
                      breaks=c(0,1),
                      labels=c("Incorrect", "Correct"),
                      palette="Set1") +
    scale_x_discrete("Final Test Cue", 
                     limits=c(NA,'T'),labels=c("Practiced","Unpracticed")) +
    scale_y_continuous("Final Test Accuracy",expand=c(0,.04)) +
    ggtitle('Conditional Final Test Accuracy')

    cat('<h4 class="subid"> Subject', i, '</h4>')
    grid.arrange(IVplot, conPlot, ncol=2, nrow=1)
}

missings <- condSummary$subject %>% filter(count == 0) %>%
  select(subject) %>% unique()
p_missing <- nrow(missings)/length(unique(condSummary$subject$subject)) 

IVgrouped <- melt(IVsummary$group,
                  id.vars = c("group","practice","other_type"),
                  measure.vars = c("prac_score","final_score"),
                  variable.name = "timepoint", value.name="acc")
IVgrouped_sd <- melt(IVsummary$group,
                  id.vars = c("group","practice","other_type"),
                  measure.vars = c("final_sd"),
                  variable.name = "timepoint", value.name="sd")
IVgrouped$timepoint <- factor(IVgrouped$timepoint,labels=c(1,2))
#step two: add an unused level to this new factor
IVgrouped$timepoint <- factor(IVgrouped$timepoint,levels =c(1,2,3))
#Step three: values where group is delay and timepoint is 2
# (aka final test) become a 3 now
IVgrouped$timepoint[IVgrouped$timepoint %in% 2
                    & IVgrouped$group == 'delay'] <- as.factor(3)
# levels(IVgrouped$other_type) <- list(T='T',C='C',none=NA)

Averaged Results

IVaveragedPlot <- ggplot(filter(IVgrouped, is.finite(acc)) %>%
                           mutate(del_to_imm = replace(group,
                                           which(group=='delay' & timepoint ==3),
                                           'immediate')),
                         aes(x=timepoint, y=acc,ymax=.85,ymin=.15,
                             color = strSort(interaction(practice,other_type)))) +
    geom_point(size=3) +
    geom_line(aes(group = paste(del_to_imm,
                                strSort(interaction(practice,other_type)),
                                sep='.')),
              size=.75) +
        scale_color_discrete("Condition",
                         breaks = c("C.T","C.NA","NA.S","NA.T"),
                         labels = c(C.T = "2 Cues\n[Unpracticed, Tested]",
                                    C.NA = "1 Cue, No Practice",
                                    NA.S  = "1 Cue, Restudied",
                                    NA.T = "1 Cue, Tested")) + 
    scale_x_discrete("Group",expand=c(0,.25),
                     labels=c("Practice","Immediate","Delay")) + 
    ylab("Final Test Accuracy") + 
    theme(legend.key.height=unit(2,"line")) + 
    ggtitle('Cued Recall Accuracy')

condAvergedPlot <- ggplot(filter(condSummary$groups,merged_prac_score %in% 0:1),
                          aes(x=other_type, y= final_acc,
                              fill=merged_prac_score,ymax=1)) +
  geom_bar(position='dodge',stat="identity") +
  facet_grid(. ~ group, labeller=as_labeller(c(`1`="Immediate", `2`="Delayed"))) +
  geom_errorbar(aes(ymax =upper, ymin=lower),
                position=position_dodge(width=.9), width=0.2) +
  # label n observations in each cell
  geom_text(aes(y=-.05,label = n_obs,group=merged_prac_score),
            position = position_dodge(width=0.9)) +
  # label percent missing in each cell!
  geom_text(aes(y=-.02,label = paste(round(missing,3)*100,'%',sep=''),
                group=merged_prac_score),
            position = position_dodge(width=.9)) +
  scale_fill_brewer("Practice\nAccuracy",
                    breaks=c(0,1),
                    labels=c("Incorrect", "Correct"),
                    palette="Set1") +
  scale_x_discrete("Final Test Cue", limits=c(NA,'T'),
                   labels=c("Practiced","Unpracticed")) +
  scale_y_continuous("Final Test Accuracy",expand=c(0,.02)) +
  ggtitle('Conditional Final Test Accuracy For Tested Items')

print(IVaveragedPlot)
print(condAvergedPlot)

Final Test IV ANOVA

IVanova_data <- IVsummary$subject %>% 
  filter(is.finite(final_score)) %>%
  select(subject, group, practice, other_type, final_score) %>%
  mutate(target_class = interaction(practice,other_type)) %>%
  select(-practice,-other_type)

IVanova <- aov(final_score ~ group * target_class + Error(subject/target_class),
               data = IVanova_data)
pander(summary(IVanova),style="rmarkdown",split.tables=Inf,
       justify = c("lccccc"))

simplerIVPlot <- ggplot(data = filter(IVsummary$group, is.finite(final_score)),
                        aes(x = group, y = final_score, ymax=.85, ymin=.15,
                            color = strSort(interaction(practice,other_type)),
                            group = strSort(interaction(practice,other_type)))) +
    geom_point(size=5) + 
    geom_line(size=1) +
    geom_errorbar(aes(ymax = final_score + final_sd/sqrt(groupsize),
                      ymin = final_score - final_sd/sqrt(groupsize)),
                  width = .075) + 
    scale_color_discrete("Practice\nCondition",
                         breaks = c("C.T","C.NA","NA.S","NA.T"),
                         labels = c(C.T = "Other Cue", C.NA = "Baseline",
                                    NA.S  = "Restudy", NA.T = "Same Cue")) + 
    scale_x_discrete("Group",expand=c(0,.25),
                     labels=c("Immediate","Delay")) + 
    ylab("Final Test Accuracy") + 
    theme(legend.key.height = unit(2,"line")) + 
    ggtitle('Cued Recall Accuracy')   + 
    theme_larger(3.25)

simplerCondPlot <- condAvergedPlot + 
  scale_x_discrete("Cue Used During Practice", limits=c(NA,'T'),
                   labels=c("Same Cue","Other Cue")) +
  theme_larger(3.25)

## Log odds of conditional data ####
## @knitr logodds_plots

# Calculate the log odds with the aggregate data
log_of_means  <- filter(conAcc_grouped,merged_prac_score %in% 0:1) %>%
  group_by(group,practice,other_type) %>%
  summarize(logodds = log(final_acc[merged_prac_score%in%1]/final_acc[merged_prac_score%in%0]),
            upp_bound = log(upper[merged_prac_score%in%1]/lower[merged_prac_score%in%0]),
            low_bound = log(lower[merged_prac_score%in%1]/upper[merged_prac_score%in%0])) %>%
  droplevels()

log_of_means_plot <- ggplot(data=log_of_means, aes(x=group, y = logodds, fill=practice)) +
  geom_bar(position='dodge',stat="identity") +
  geom_errorbar(aes(ymax =upp_bound, ymin=low_bound),
                position=position_dodge(width=0.9), width=0.2) +
  scale_fill_brewer("Cue Used", labels=c("Practiced Cue","Unpracticed Cue"),
                    limits=c('T','C'),
                    drop=TRUE, palette="Set1") +
  scale_x_discrete("Group",labels = c("Immediate","Delayed")) +
  ylab("Log Odds Ratio") +
  mytheme +
  ggtitle('Diagnosticity of Practice Accuracy')


# calculate log odds subject wise
conAcc_grouped_log <- conAcc %>% filter((practice=='T'| other_type=='T'), !(practice=='T' & other_type =='C')) %>%
  group_by(subject,group,practice,other_type) %>%
  summarize(logodds = calc_odds(final_acc,merged_prac_score)) %>%
  mutate(logodds = replace(logodds, which(!is.finite(logodds)),NA_real_)) %>%
#  filter(!(subject %in% subject[!is.finite(logodds)])) %>%  # maybe want to use this if we want subs with observations in both conditions
  group_by(group,practice,other_type) %>%
  summarise(odds = mean(logodds,na.rm = TRUE),
            missing=length(logodds[!is.na(logodds)])/length(odds))

mean_of_logs_plot <- ggplot(conAcc_grouped_log, aes(x = group, y= odds,fill=practice,ymax= max(odds+.025))) +
  geom_bar(position='dodge',stat="identity") +
  geom_text(aes(y=.05, label = as.character(missing)),
            position = position_dodge(width=.9)) +
  scale_fill_brewer("Number of Cues", labels=c("Practiced Cue","Unpracticed "),
                    limits=c('T','C'),
                    palette="Set1",drop=F) +
  scale_x_discrete("Group",labels = c("Immediate","Delayed")) +
  ylab("Log Odds Ratio") +
  ggtitle('Diagnosticity of Practice Accuracy')