pilot_data_analysis

Scan-WM-DG Pilot Analysis

Setup

Load packages

Define helper functions

Load and combine data across versions

Wrangling

Target/foil similarity metrics

LTM image role information from WM task

Are prioritized images better remembered?

WM task: Yes!

summary_valid <- wm_data %>%
  group_by(version, unique_id, cue_valid) %>%
  dplyr::summarise(
    mean_acc = mean(correct, na.rm = TRUE),
    mean_rt = mean(trial_rt, na.rm = TRUE),
    prop_within_cat_err = mean(within_category_error, na.rm = TRUE),
    .groups = "drop"
  )

make_validity_plot <- function(data, y_var, y_lab, title) {
  ggplot(data, aes(x = cue_valid, y = !!sym(y_var), color = cue_valid)) +
    geom_jitter(width = 0.1, alpha = 0.6) +
    facet_wrap(~version) +
    labs(x = "Cue validity", y = y_lab, title = title) +
    stat_summary(fun.data = mean_cl_boot, geom = "errorbar",
                 width = 0.2, color = "black") +
    stat_summary(fun = mean, geom = "point", size = 3, color = "black") +
    guides(color = "none") +
    theme_light()
}

p_acc <- make_validity_plot(summary_valid, "mean_acc",
                            "Mean accuracy", "WM: Acc by cue validity")
p_rt  <- make_validity_plot(summary_valid, "mean_rt",
                            "Mean response time", "WM: RT by cue validity")
p_err <- make_validity_plot(summary_valid, "prop_within_cat_err",
                            "Prop. within-category errors", "WM: Errors by cue validity")

# JW: later, make a plot with the proportion of swap errors (reporting the foil)

p_acc

p_rt

p_err

if (SAVE_PLOTS){
  save_plot(p_acc, "acc_validity_wm.png", plot_dir_all, w = 6)
  save_plot(p_rt, "rt_validity_wm.png",  plot_dir_all, w = 6)
  save_plot(p_err, "err_validity_wm.png", plot_dir_all, w = 6)
}

rm(summary_valid)
rm(p_acc, p_rt, p_err)

LTM task: not really!

ltm_summary_valid <- ltm_data %>%
  dplyr::filter(!wm_response_missing & seen) %>%
  group_by(version, unique_id, cue_valid) %>%
  dplyr::summarise(
    mean_acc = mean(correct, na.rm = TRUE),
    mean_rt = mean(trial_rt, na.rm = TRUE),
    .groups = "keep"
  ) %>%
  ungroup()

p_acc <- make_validity_plot(ltm_summary_valid, "mean_acc",
                            "Mean accuracy", "LTM: Acc by cue validity")
p_rt  <- make_validity_plot(ltm_summary_valid, "mean_rt",
                            "Mean response time", "LTM: RT by cue validity")

p_acc

p_rt

if (SAVE_PLOTS){
  save_plot(p_acc, "acc_validity_ltm.png", plot_dir_all, w = 6)
  save_plot(p_rt, "rt_validity_ltm.png", plot_dir_all, w = 6)
}

rm(ltm_summary_valid)
rm(p_acc, p_rt)

How does the role of the image in WM affect LTM?

role_labels_seen <- c(
  "root" = "Root",
  "target" = "Target",
  "foil" = "Foil"
)

role_labels_unseen <- c(
  "unseen_new_category" = "New Cat.",
  "unseen_old_category" = "Old Cat."
)

# For seen images
ltm_data_role_summary1 <- ltm_data %>%
  dplyr::filter(!is.na(image_role)) %>%
  group_by(version, unique_id, image_role) %>%
  dplyr::summarise(
    mean_acc = mean(correct, na.rm = TRUE),
    .groups = "drop"
  ) %>%
  ungroup()

# For unseen images
ltm_data_role_summary2 <- ltm_data %>%
  dplyr::filter(!seen) %>%
  group_by(version, unique_id, seen_unseen_type) %>%
  dplyr::summarise(
    mean_acc = mean(correct, na.rm = TRUE),
    .groups = "drop"
  ) %>%
  ungroup()

p_seen_role <- ltm_data_role_summary1 %>%
  ggplot(aes(x = fct_reorder(image_role, mean_acc),
             y = mean_acc, color = image_role)) + 
  geom_jitter(width = 0.1, alpha = 0.6) +
  facet_wrap(~version) +
  labs(x = "Role", y = "Mean accuracy") +
  scale_x_discrete(labels=role_labels_seen) +
  scale_color_brewer(palette = "Dark2", guide="none") +
  stat_summary(fun.data = mean_cl_boot, geom = "errorbar", width = 0.2, color = "black") +
  stat_summary(fun = mean, geom = "point", size = 3, color = "black") +
  theme_light()
p_seen_role

p_unseen_role <- ltm_data_role_summary2 %>%
  ggplot(aes(x = fct_reorder(seen_unseen_type, mean_acc),
             y = mean_acc, color = seen_unseen_type)) + 
  geom_jitter(width = 0.1, alpha = 0.6) +
  facet_wrap(~version) +
  scale_x_discrete(labels=role_labels_unseen) +
  scale_color_brewer(palette = "PuRd", guide="none") +
  labs(x = "Role", y = "Mean Correct Rejections") +
  stat_summary(fun.data = mean_cl_boot, geom = "errorbar", width = 0.2, color = "black") +
  stat_summary(fun = mean, geom = "point", size = 3, color = "black") +
  theme_light()
  
p_unseen_role

if (SAVE_PLOTS){
  save_plot(p_seen_role, "acc_ltm_image_role_seen.png", plot_dir_all, w = 6)
  save_plot(p_unseen_role, "acc_ltm_image_role_unseen.png", plot_dir_all, w = 6)
}

Accuracy as a function of target-distractor similarity

Plot

n_bins <- 20

wm_filtered <- wm_data %>%
  filter(!is_neutral & cue_valid) %>%
  mutate(correct = as.numeric(correct))

wm_binned_v2 <- bin_by_version(wm_filtered, "V2_targ_root", "correct", n_bins)
wm_binned_it <- bin_by_version(wm_filtered, "IT_targ_root", "correct", n_bins)

p_v2 <- plot_sim(wm_filtered, wm_binned_v2,
                 "V2_targ_root", "correct",
                 "V2 Target-Root Similarity", "P(Correct)")

p_it <- plot_sim(wm_filtered, wm_binned_it,
                 "IT_targ_root", "correct",
                 "IT Target-Root Similarity", "P(Correct)")

p_v2

p_it

if (SAVE_PLOTS){
  save_plot(p_v2, "v2_targ_dist_sim.png", plot_dir_all)
  save_plot(p_it, "it_targ_dist_sim.png", plot_dir_all)
}

rm(wm_binned_v2, wm_binned_it, p_v2, p_it)

Model comparison

set.seed(42)
curr_version <- "v2"

wm_filtered_curr <- wm_filtered %>% filter(version == curr_version)

v2_comparison <- compare_poly_models(wm_filtered_curr, "V2_targ_root")
it_comparison <- compare_poly_models(wm_filtered_curr, "IT_targ_root")

kable(v2_comparison$aic, caption = "V2 AIC")

V2 AIC

	df	AIC
m1	4	2047.318
m2	5	2049.163
m3	6	2045.208

kable(it_comparison$aic, caption = "IT AIC")

IT AIC

	df	AIC
m1	4	2033.649
m2	5	2035.577
m3	6	2037.566

rm(wm_filtered_curr)

Response time as a function of target-distractor similarity

Plots

wm_filtered_rt <- wm_data %>%
  filter(!is_neutral & cue_valid)

wm_binned_v2_rt <- bin_by_version(wm_filtered_rt, "V2_targ_root", "trial_rt", n_bins)
wm_binned_it_rt <- bin_by_version(wm_filtered_rt, "IT_targ_root", "trial_rt", n_bins)

p_v2_rt <- plot_sim(wm_filtered_rt, wm_binned_v2_rt,
                    "V2_targ_root", "trial_rt",
                    "V2 Target-Root Similarity", "Mean RT",
                    family = gaussian)

p_it_rt <- plot_sim(wm_filtered_rt, wm_binned_it_rt,
                    "IT_targ_root", "trial_rt",
                    "IT Target-Root Similarity", "Mean RT",
                    family = gaussian)

p_v2_rt

p_it_rt

if (SAVE_PLOTS){
  save_plot(p_v2_rt, "v2_rt_targ_dist_sim.png", plot_dir_all)
  save_plot(p_it_rt, "it_rt_targ_dist_sim.png", plot_dir_all)
}

rm(wm_filtered_rt, wm_binned_v2_rt, wm_binned_it_rt, p_v2_rt, p_it_rt)

Accuracy as a function of foil-distractor similarity

Plot

wm_binned_v2_foil <- bin_by_version(wm_filtered, "V2_foil_root", "correct", n_bins)
wm_binned_it_foil <- bin_by_version(wm_filtered, "IT_foil_root", "correct", n_bins)

p_v2 <- plot_sim(wm_filtered, wm_binned_v2_foil,
                 "V2_foil_root", "correct",
                 "V2 Foil-Root Similarity", "P(Correct)")

p_it <- plot_sim(wm_filtered, wm_binned_it_foil,
                 "IT_foil_root", "correct",
                 "IT Foil-Root Similarity", "P(Correct)")

p_v2

p_it

if (SAVE_PLOTS){
  save_plot(p_v2, "v2_foil_dist_sim.png", plot_dir_all)
  save_plot(p_it, "it_foil_dist_sim.png", plot_dir_all)
}

rm(wm_binned_v2_foil, wm_binned_it_foil, p_v2, p_it)

Model comparison

set.seed(42)
curr_version <- "v1"
wm_filtered_curr <- wm_filtered %>% filter(version == curr_version)

v2_foil_comparison <- compare_poly_models(wm_filtered_curr, "V2_foil_root")
it_foil_comparison <- compare_poly_models(wm_filtered_curr, "IT_foil_root")

kable(v2_foil_comparison$aic, caption = "V2 Foil AIC")

V2 Foil AIC

	df	AIC
m1	4	2174.900
m2	5	2176.900
m3	6	2178.899

kable(it_foil_comparison$aic, caption = "IT Foil AIC")

IT Foil AIC

	df	AIC
m1	4	2171.861
m2	5	2173.812
m3	6	2174.170

rm(wm_filtered_curr)

Relative target-foil similarity

Positive values indicate the target is more similar to the root than the foil is.

wm_filtered_relative <- wm_data %>%
  filter(!is_neutral & cue_valid) %>%
  mutate(
    V2_targ_minus_foil = ifelse(target_index == "img1",  signed_V2_diff, -signed_V2_diff),
    IT_targ_minus_foil = ifelse(target_index == "img1",  signed_IT_diff, -signed_IT_diff),
    correct = as.numeric(correct)
  )

wm_binned_v2_rel <- bin_by_version(wm_filtered_relative,
                                   "V2_targ_minus_foil", "correct", n_bins)
wm_binned_it_rel <- bin_by_version(wm_filtered_relative,
                                   "IT_targ_minus_foil", "correct", n_bins)

p_v2_rel <- plot_sim(wm_filtered_relative, wm_binned_v2_rel,
                     "V2_targ_minus_foil", "correct",
                     "V2 Target - Foil Similarity", "P(Correct)")

p_it_rel <- plot_sim(wm_filtered_relative, wm_binned_it_rel,
                     "IT_targ_minus_foil", "correct",
                     "IT Target - Foil Similarity", "P(Correct)")

p_v2_rel

p_it_rel

if (SAVE_PLOTS){
  save_plot(p_v2_rel, "v2_acc_relative_sim.png", plot_dir_all, w = 6)
  save_plot(p_it_rel, "it_acc_relative_sim.png", plot_dir_all, w = 6)
}

rm(wm_binned_v2_rel, wm_binned_it_rel, p_v2_rel, p_it_rel)

WM accuracy vs. LTM accuracy

wm_by_id <- wm_data %>%
  group_by(version, unique_id) %>%
  summarise(mean_wm_acc = mean(correct), .groups = "drop")

ltm_by_id <- ltm_data %>%
  group_by(version, unique_id) %>%
  summarise(mean_ltm_acc = mean(correct), .groups = "drop")

acc_by_id <- full_join(wm_by_id, ltm_by_id, by = c("version", "unique_id"))

p_wm_vs_ltm <- acc_by_id %>%
  ggplot(aes(x = mean_wm_acc, y = mean_ltm_acc, color = version)) +
  geom_point() +
  geom_smooth(method = "gam",
              method.args = list(family = gaussian),
              formula = y ~ s(x)) +
  labs(x = "Mean WM accuracy", y = "Mean LTM accuracy") +
  theme_light()

p_wm_vs_ltm

save_plot(p_wm_vs_ltm, "wm_vs_ltm.png", plot_dir_all)

rm(wm_by_id, ltm_by_id, acc_by_id, p_wm_vs_ltm)

WM competition index and LTM benefit

Fit relative similarity models

mod_linear_relative_v1 <- wm_filtered_relative %>%
  dplyr::filter(version == "v1") %>%
  glmer(correct ~ IT_targ_minus_foil + (1 | unique_id) + (1 | triplet_id),
        data = ., family = binomial)
summary(mod_linear_relative_v1)

Generalized linear mixed model fit by maximum likelihood (Laplace
  Approximation) [glmerMod]
 Family: binomial  ( logit )
Formula: correct ~ IT_targ_minus_foil + (1 | unique_id) + (1 | triplet_id)
   Data: .

      AIC       BIC    logLik -2*log(L)  df.resid 
   2169.7    2193.5   -1080.8    2161.7      2865 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-5.5067  0.2196  0.2958  0.4189  1.0317 

Random effects:
 Groups     Name        Variance Std.Dev.
 triplet_id (Intercept) 0.2020   0.4495  
 unique_id  (Intercept) 0.7051   0.8397  
Number of obs: 2869, groups:  triplet_id, 128; unique_id, 26

Fixed effects:
                   Estimate Std. Error z value Pr(>|z|)    
(Intercept)         2.09174    0.18277   11.45   <2e-16 ***
IT_targ_minus_foil  0.18126    0.07745    2.34   0.0193 *  
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Correlation of Fixed Effects:
            (Intr)
IT_trg_mns_ 0.031 

mod_linear_relative_v2 <- wm_filtered_relative %>%
  dplyr::filter(version == "v2") %>%
  glmer(correct ~ IT_targ_minus_foil + (1 | unique_id) + (1 | triplet_id),
        data = ., family = binomial)
summary(mod_linear_relative_v2)

Generalized linear mixed model fit by maximum likelihood (Laplace
  Approximation) [glmerMod]
 Family: binomial  ( logit )
Formula: correct ~ IT_targ_minus_foil + (1 | unique_id) + (1 | triplet_id)
   Data: .

      AIC       BIC    logLik -2*log(L)  df.resid 
   2033.2    2056.8   -1012.6    2025.2      2701 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-6.7944  0.1770  0.2711  0.3803  1.7896 

Random effects:
 Groups     Name        Variance Std.Dev.
 triplet_id (Intercept) 0.1041   0.3227  
 unique_id  (Intercept) 1.5478   1.2441  
Number of obs: 2705, groups:  triplet_id, 128; unique_id, 24

Fixed effects:
                   Estimate Std. Error z value Pr(>|z|)    
(Intercept)         2.04567    0.26644   7.678 1.62e-14 ***
IT_targ_minus_foil  0.29331    0.07748   3.785 0.000153 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Correlation of Fixed Effects:
            (Intr)
IT_trg_mns_ 0.035 

mod_linear_relative_v3 <- wm_filtered_relative %>%
  dplyr::filter(version == "v3") %>%
  glmer(correct ~ IT_targ_minus_foil + (1 | unique_id) + (1 | triplet_id),
        data = ., family = binomial)

boundary (singular) fit: see help('isSingular')

summary(mod_linear_relative_v3)

Generalized linear mixed model fit by maximum likelihood (Laplace
  Approximation) [glmerMod]
 Family: binomial  ( logit )
Formula: correct ~ IT_targ_minus_foil + (1 | unique_id) + (1 | triplet_id)
   Data: .

      AIC       BIC    logLik -2*log(L)  df.resid 
   1611.0    1634.0    -801.5    1603.0      2320 

Scaled residuals: 
    Min      1Q  Median      3Q     Max 
-6.9616  0.1940  0.2727  0.3685  1.5900 

Random effects:
 Groups     Name        Variance  Std.Dev. 
 triplet_id (Intercept) 3.065e-09 5.536e-05
 unique_id  (Intercept) 1.339e+00 1.157e+00
Number of obs: 2324, groups:  triplet_id, 128; unique_id, 21

Fixed effects:
                   Estimate Std. Error z value Pr(>|z|)    
(Intercept)         2.15084    0.26490   8.119 4.69e-16 ***
IT_targ_minus_foil  0.27800    0.08832   3.148  0.00165 ** 
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Correlation of Fixed Effects:
            (Intr)
IT_trg_mns_ 0.037 
optimizer (Nelder_Mead) convergence code: 0 (OK)
boundary (singular) fit: see help('isSingular')

Get competition index

# take all LTM stimuli that were WM samples AND were answered correctly
ltm_samples_from_wm <- ltm_data %>%
  dplyr::filter(!is.na(image_role)) %>%
  dplyr::filter(image_role != "root") %>%
  dplyr::filter(is_neutral == FALSE) %>%
  dplyr::filter(wm_correct == TRUE) %>%
  dplyr::filter(triplet_id != 214) # 214 had both targs and foils

wm_image_stats <- wm_data %>%
  select(unique_id, triplet_id, V2_targ_minus_foil, IT_targ_minus_foil)

ltm_samples_with_stats <- ltm_samples_from_wm %>%
  left_join(wm_image_stats, by = c("unique_id", "triplet_id")) %>%
  mutate(
    V2_tested_minus_untested = ifelse(image_role == "target",
                                       V2_targ_minus_foil, -V2_targ_minus_foil),
    IT_tested_minus_untested = ifelse(image_role == "target",
                                       IT_targ_minus_foil, -IT_targ_minus_foil)
  )

# so first we'll need to re-combine some image stats...
wm_image_stats <- wm_data %>%
  select(unique_id, triplet_id, 
         V2_targ_minus_foil, IT_targ_minus_foil)

ltm_samples_with_stats <- ltm_samples_from_wm %>%
  left_join(wm_image_stats, by = c("unique_id", "triplet_id"))

# now let's get the image stat we need...
ltm_samples_with_stats <- ltm_samples_with_stats %>%
  mutate(
    V2_tested_minus_untested = ifelse(image_role == "target",
                                      V2_targ_minus_foil,
                                      -V2_targ_minus_foil),
    IT_tested_minus_untested = ifelse(image_role == "target",
                                      IT_targ_minus_foil,
                                      -IT_targ_minus_foil)
  )

# For each version, predict P(WM correct)
# And then do 1 - P(WM correct) to get the competition index
ltm_samples_with_stats_v1 <- ltm_samples_with_stats %>%
  dplyr::filter(version == "v1") %>%
  mutate(
    pred_wm_correct = predict(mod_linear_relative_v1,
                              newdata = data.frame(
                                IT_targ_minus_foil = IT_tested_minus_untested,
                                unique_id = unique_id,
                                triplet_id = triplet_id
                              ),
                              type = "response",
                              allow.new.levels = TRUE),
    comp_index = 1-pred_wm_correct
  )
ltm_samples_with_stats_v2 <- ltm_samples_with_stats %>%
  dplyr::filter(version == "v2") %>%
  mutate(
    pred_wm_correct = predict(mod_linear_relative_v2,
                              newdata = data.frame(
                                IT_targ_minus_foil = IT_tested_minus_untested,
                                unique_id = unique_id,
                                triplet_id = triplet_id
                              ),
                              type = "response",
                              allow.new.levels = TRUE),
    comp_index = 1-pred_wm_correct
  )
ltm_samples_with_stats_v3 <- ltm_samples_with_stats %>%
  dplyr::filter(version == "v3") %>%
  mutate(
    pred_wm_correct = predict(mod_linear_relative_v3,
                              newdata = data.frame(
                                IT_targ_minus_foil = IT_tested_minus_untested,
                                unique_id = unique_id,
                                triplet_id = triplet_id
                              ),
                              type = "response",
                              allow.new.levels = TRUE),
    comp_index = 1-pred_wm_correct
  )

final_ltm_samples_with_stats <- rbind(ltm_samples_with_stats_v1,
                                      ltm_samples_with_stats_v2,
                                      ltm_samples_with_stats_v3)

rm(ltm_samples_with_stats_v1,
   ltm_samples_with_stats_v2,
   ltm_samples_with_stats_v3,
   ltm_samples_with_stats)

Plot competition index vs LTM accuracy (within-subjects)

…not really? sort of? I’m guessing that this was a pretty subtle effect given that it was only significant in one of the cohorts (and the cohorts were pretty large)

n_bins <- 3

binned_comp <- final_ltm_samples_with_stats %>%
  group_by(version, unique_id) %>%
  mutate(comp_bin = ntile(comp_index, n_bins)) %>%
  group_by(version, unique_id, comp_bin) %>%
  summarise(
    mean_ltm  = mean(correct),
    mean_comp = mean(comp_index),
    .groups   = "drop"
  ) %>%
  mutate(comp_bin = as.factor(comp_bin))

p_comp <- binned_comp %>%
  ggplot(aes(x = comp_bin, y = mean_ltm, color = comp_bin)) +
  geom_jitter(width = 0.1, alpha = 0.6) +
  facet_wrap(~version) +
  scale_color_brewer(palette = "Spectral", guide = "none") +
  stat_summary(fun.data = mean_cl_boot, geom = "errorbar",
               width = 0.2, color = "black") +
  stat_summary(fun = mean, geom = "point", size = 3, color = "black") +
  labs(x = "WM Competition Index (tertile)", y = "Mean LTM Accuracy") +
  theme_light()

p_comp

if (SAVE_PLOTS){
  save_plot(p_comp, "comp_index_ltm.png", plot_dir_all)
}

rm(binned_comp, p_comp)

Neutral trials (in prog.)

Note: neutral trials don’t seem to do much behaviorally at first blush — im1-im2 similarity may matter more when there is a meaningful cue vs. not, but I haven’t looked into this.

summary_neutral <- wm_data %>%
  group_by(version, unique_id, is_neutral) %>%
  dplyr::summarize(
    mean_acc = mean(correct, na.rm = TRUE),
    mean_rt = mean(trial_rt, na.rm = TRUE),
    .groups="keep"
  )

summary_neutral %>%
  ggplot(aes(x = is_neutral, y = mean_acc, fill = is_neutral)) +
  geom_bar(stat = "summary", fun = mean) + 
  facet_wrap(~version) +
  stat_summary(fun.data = mean_se, geom = "errorbar", width = 0.2) +
  theme_light()

summary_neutral %>%
  ggplot(aes(x = is_neutral, y = mean_rt, fill = is_neutral)) +
  geom_bar(stat = "summary", fun = mean) + 
  facet_wrap(~version) +
  stat_summary(fun.data = mean_se, geom = "errorbar", width = 0.2) +
  theme_light()