OSCR

Measuring naturalistic speech comprehension in real time.

Code ↔ Paper

16 matches between paragraphs of the paper and lines of its authors' code, computed by the harvester (lexical-v1). Click a colored paragraph or line to see its counterpart.

The 16 matches · 2 of them tie a paragraph to a whole file without given lines: weak matches, whose lines are not tinted
  1. [1] § Experiment 1 › Results › Characterizing the comprehension decline ↔ experiment_1/analysis/linear_vs_categorical.ipynb, lines 128 to 220 · score 0.73 · curve_fit, sigmoid curve, Sigmoidal model, Linear model, speech rate, predicted · Report a mismatch
  2. [2] § Experiment 1 › Results › Characterizing the comprehension decline ↔ experiment_1/analysis/linear_vs_categorical.ipynb, lines 222 to 268 · score 0.71 · Pearson correlation, sigmoidal model, linear model, Wilcoxon, fold, predicted · Report a mismatch
  3. [3] § Experiment 1 › Results ↔ experiment_1/supplamentary/analysis/supplamentary_analysis.Rmd, lines 659 to 733 · score 0.59 · random slopes, digit span score, noise scores, comprehension score, regression, model · Report a mismatch
  4. [4] § Experiment 3 › Results ↔ experiment_1/supplamentary/analysis/supplamentary_analysis.Rmd, lines 659 to 733 · score 0.59 · random slopes, digit span score, noise scores, comprehension score, regression, model · Report a mismatch
  5. [5] § Experiment 1 › Results ↔ experiment_1/analysis/data_analysis.Rmd, lines 1359 to 1429 · score 0.59 · random slopes, digit span score, noise scores, comprehension score, regression, model · Report a mismatch
  6. [6] § Experiment 3 › Results ↔ experiment_1/analysis/data_analysis.Rmd, lines 1359 to 1429 · score 0.59 · random slopes, digit span score, noise scores, comprehension score, regression, model · Report a mismatch
  7. [7] § Experiment 1 › Results › Quantifying summary performance ↔ experiment_1/analysis/semantic_similarity.ipynb, lines 482 to 550 · score 0.58 · GloVe Heard Segment, summary word, dictionary, embedding, cosine, semantic · Report a mismatch
  8. [8] § Experiment 1 › Results › Characterizing the comprehension decline ↔ experiment_1/analysis/linear_vs_categorical.ipynb, lines 128 to 220 · score 0.58 · sigmoidal models predicting, linear model, Folds, fit, speech rate · Report a mismatch
  9. [9] § Experiment 1 › Speech comprehension measures › Real-time speech comprehension measure ↔ experiment_1/experiment_files/lib/psychojs-2023.2.3.iife.js, the whole file · a weak match · score 0.55 · minimizing, compatibility, head, tools, max, segments · Report a mismatch
  10. [10] § Experiment 1 › Speech comprehension measures › Real-time speech comprehension measure ↔ experiment_1/experiment_files/lib/psychojs-2023.2.3.js, the whole file · a weak match · score 0.55 · minimizing, compatibility, head, tools, max, segments · Report a mismatch
  11. [11] § Experiment 1 › Speech comprehension measures › Post-hoc comprehension measures › Summary task ↔ experiment_1/analysis/semantic_similarity.ipynb, lines 368 to 444 · score 0.55 · summary word, GLoVe, Written Summary, embedding, cosine, summed · Report a mismatch
  12. [12] § Experiment 2 › Methods › Participants ↔ experiment_2/analysis/exp2_data_analysis.Rmd, lines 506 to 539 · score 0.55 · standard deviations, slider movements, outliers · Report a mismatch
  13. [13] § Experiment 2 › Methods › Participants ↔ experiment_1/analysis/data_analysis.Rmd, lines 552 to 583 · score 0.54 · standard deviations, slider movements, outliers · Report a mismatch
  14. [14] § Experiment 2 › Results › Slider scores ↔ experiment_2/analysis/exp2_data_analysis.Rmd, lines 555 to 571 · score 0.51 · pairwise comparisons, Tukey, intercepts, slider responses, fit, digit · Report a mismatch
  15. [15] § Experiment 1 › Results › Validating the slider measure ↔ experiment_1/supplamentary/analysis/supplamentary_analysis.Rmd, lines 1892 to 1953 · score 0.50 · confidence intervals, Regression coefficient, speech rate, slider · Report a mismatch
  16. [16] § Experiment 1 › Results › Validating the slider measure ↔ experiment_1/analysis/data_analysis.Rmd, lines 1556 to 1614 · score 0.50 · confidence intervals, Regression coefficient, speech rate · Report a mismatch

Paper

Loaded from Europe PMC by your browser; OSCR does not store it: doi.org · Europe PMC

The paper is loaded when this pane is shown.

The authors' code

R Markdown · 1,686 lines · 59 KB · no license · 4 matches

  1. ---
  2. title: "Measuring Naturalistic Speech Comprehension in Real Time"
  3. output: html_document
  5. ---
  6. # DATA WRANGLING
  8. ```{r setup, echo=FALSE, message=FALSE, warning=FALSE}
  9. # Load libraries
  10. library(stringi)
  11. library(lme4)
  12. library(MuMIn)
  13. library(stringr)
  14. library(fs)
  15. library(readxl)
  16. library(readr)
  17. library(simr)
  18. library(lmerTest)
  19. library(patchwork)
  20. library(RColorBrewer)
  21. library(cowplot)
  22. library(scales)
  23. library(gridExtra)
  24. library(PerformanceAnalytics)
  25. library(corrplot)
  26. library(Hmisc)
  27. library(GGally)
  28. library(visreg)
  29. library(broom.mixed)
  30. library(sjPlot)
  31. library(gridExtra)
  32. library(grid)
  33. library(rempsyc)
  34. library(flextable)
  35. library(officer)
  36. library(ggsignif)
  37. library(MuMIn)
  38. library(rstatix)
  39. library(caret)
  40. library(modelr)
  41. library(tidyr)
  42. library(purrr)
  43. library(broom)
  44. library(dplyr)
  45. library(ggplot2)
  46. library(rsample)
  47. library(corrplot)
  49. # set the default ggplot theme
  50. theme_set(theme_classic())
  51. ```
  53. ```{r}
  54. # Set path and participant ids
  56. # Change the folder path to data folder relative to the wd
  57. folder_path <- '/Users/irmakergin/Desktop/measuring_naturalistic_speech_comprehension_2024/data/raw_data'
  59. # Define the list of participant IDs
  60. participant_ids <- c("p_1","p_2","p_3","p_4","p_5", "p_6", "p_7", "p_8", "p_9","p_10",
  61. "p_11", "p_12", "p_13", "p_14","p_15","p_16","p_17","p_18","p_19","p_20",
  62. "p_21", "p_22", "p_23", "p_24","p_25","p_26","p_27","p_28","p_29","p_30")
  63. ```
  65. ```{r, echo=FALSE, message=FALSE, warning=FALSE}
  66. # Organize the data csv files
  68. # Get a list of all files in the folder
  69. files <- dir(folder_path, full.names = TRUE)
  71. # Set a path to save the organized files
  72. organized_data_path<-"/Users/irmakergin/Desktop/measuring_naturalistic_speech_comprehension_2024/data/organized_data"
  74. # Find files by participant ID
  75. for(part_id in participant_ids) {
  77. # Match the slider files that involve the participant ID
  78. slider_pattern <- paste0("slider_", part_id, ".*\\.csv$")
  80. # Match data (csv) files that start with the participant ID
  81. additional_csv_pattern <- paste0("^", part_id, "_.*\\.csv$")
  83. # Find slider files that match the pattern
  84. slider_matched_files <- files[str_detect(basename(files), slider_pattern)]
  86. # Find data CSV files that match the pattern
  87. additional_csv_matched_files <- files[str_detect(basename(files),
  88. additional_csv_pattern)]
  90. # Create a directory for the current participant on the organized data path
  91. participant_folder <- file.path(organized_data_path, part_id)
  92. if(!dir.exists(participant_folder)) {
  93. dir.create(participant_folder, recursive = TRUE, showWarnings = TRUE)
  94. }
  96. # Create a subdirectory for slider files within the participant folder
  97. slider_folder <- file.path(participant_folder, paste0("slider_", part_id))
  98. if(!dir.exists(slider_folder)) {
  99. dir.create(slider_folder, recursive = TRUE, showWarnings = TRUE)
  100. }
  102. # Move slider matched files to the slider subfolder
  103. if(length(slider_matched_files) > 0) {
  104. for(file in slider_matched_files) {
  105. file_copy(file, file.path(slider_folder, basename(file)), overwrite = TRUE)
  106. }
  107. }
  109. # Move additional CSV matched files (experiment data) to the main participant folder
  110. # and rename the participant folders
  111. if(length(additional_csv_matched_files) > 0) {
  112. # Loop to rename the file during the copy process
  113. for(file in additional_csv_matched_files) {
  114. # New filename with '_raw_data'
  115. new_name <- paste0(part_id, "_raw_data.csv")
  116. # Copy and rename the file to the new name in the participant folder
  117. file_copy(file, file.path(participant_folder, new_name), overwrite = TRUE)
  118. }
  119. }
  120. # check
  121. if(length(slider_matched_files) > 0 || length(additional_csv_matched_files) > 0) {
  122. cat("Files for participant ID '", part_id,
  123. "' have been organized successfully. Slider files in: ", slider_folder,
  124. ", other CSVs in: ", participant_folder, "\n")
  125. } else {
  126. cat("No files found for participant ID '", part_id, "'.\n")
  127. }
  128. }
  130. # Commented out because they are already there
  131. # # Put excel files (of digit in noise and digit span) in the organized data folder
  132. #
  133. #source_folder<-"/Users/irmakergin/Desktop/measuring_naturalistic_speech_comprehension_2024/data"
  134. # destination_folder<-"/Users/irmakergin/Desktop/measuring_naturalistic_speech_comprehension_2024/data/organized_data"
  135. #
  136. # List all Excel files in the source folder
  137. #excel_files <- dir_ls(path = source_folder, glob = "*.xlsx")
  139. # Copy each Excel file to the destination folder- commented out to re-run
  140. #for (file_path in excel_files) {
  141. #dest_file_path <- file.path(destination_folder)
  142. #file_copy(file_path, dest_file_path)
  143. # # Check
  144. # cat("Copied:", file_path, "to", dest_file_path, "\n")
  145. #}
  147. # Loop through each participant ID
  148. for (part_id in participant_ids) {
  149. # Define the path to the participant's raw data CSV
  150. raw_data_path <- file.path(organized_data_path,
  151. part_id,
  152. paste0(part_id, "_raw_data.csv"))
  154. # Read the CSV for each participant
  155. if (file.exists(raw_data_path)) {
  156. df.raw <- read_csv(raw_data_path) %>%
  157. filter(!wav_file %in% c("Someday_trial_condition.wav",
  158. "Someday_trial_condition-5x.wav")) %>%
  159. mutate(index = row_number()) %>%
  160. select(index, participant, wav_file, old_name, segment_text, question,
  161. C1, C2, C3, C4, C_correct, duration,
  162. A.numClicks, B.numClicks, C.numClicks, D.numClicks, slider.response,
  163. summary, `textbox.text`) %>%
  164. group_by(wav_file) %>%
  165. summarise(
  166. index = first(index),
  167. participant = first(participant),
  168. old_name = first(old_name),
  169. segment_text = first(segment_text),
  170. question = first(question),
  171. C1 = first(C1),
  172. C2 = first(C2),
  173. C3 = first(C3),
  174. C4 = first(C4),
  175. C_correct = first(C_correct),
  176. duration = first(duration),
  177. summary = first(summary),
  178. textbox.text = first(textbox.text),
  179. A.numClicks = max(A.numClicks, na.rm = TRUE),
  180. B.numClicks = max(B.numClicks, na.rm = TRUE),
  181. C.numClicks = max(C.numClicks, na.rm = TRUE),
  182. D.numClicks = max(D.numClicks, na.rm = TRUE),
  183. likert_response = max(slider.response, na.rm = TRUE),
  184. .groups = 'drop'
  185. ) %>%
  186. arrange(index) %>%
  187. mutate(index = row_number())
  189. # Fill NA values in participant_id column with part_id for participant p_3
  190. if (part_id == "p_3") {
  191. df.raw <- df.raw %>%
  192. mutate(participant = replace_na(participant, part_id))
  193. }
  194. if (part_id == "p_1") {
  195. df.raw <- df.raw %>%
  196. mutate(participant = replace_na(participant, part_id))
  197. }
  198. if (part_id == "p_2") {
  199. df.raw <- df.raw %>%
  200. mutate(participant = replace_na(participant, part_id))
  201. }
  202. if (part_id == "p_14") {
  203. df.raw <- df.raw %>%
  204. mutate(participant = replace_na(participant, part_id))
  205. }
  206. if (part_id == "p_13") {
  207. df.raw <- df.raw %>%
  208. mutate(participant = replace_na(participant, part_id))
  209. }
  210. if (part_id == "p_26") {
  211. df.raw <- df.raw %>%
  212. mutate(participant = replace_na(participant, part_id))
  213. }
  214. # Remove the extra last row from df.raw
  215. df.raw <- head(df.raw, n = -1)
  217. #Assign processed data of each participant to a new df
  218. assign(paste0("df.raw.merged_", part_id), df.raw, envir = .GlobalEnv)
  219. }
  220. }
  221. ```
  223. ```{r}
  224. # Merge all participant dfs into one df
  226. # Create an empty data frame to store merged data
  227. df.raw <- data.frame()
  229. # Loop through each participant ID and merge their df
  230. for (part_id in participant_ids) {
  231. # Construct the name of the data frame variable
  232. df_name <- paste0("df.raw.merged_", part_id)
  234. # Check if the data frame exists in the global environment
  235. if (exists(df_name, envir = .GlobalEnv)) {
  236. # Get the data frame from its name
  237. df_participant <- get(df_name, envir = .GlobalEnv)
  239. # Merge the data frame with the main merged data frame
  240. df.raw <- rbind(df.raw, df_participant)
  241. }
  242. }
  243. ```
  245. ```{r}
  246. # Add accuracy columns for multiple choice questions
  248. # Calculate the multiple choice accuracy
  250. df.raw<- df.raw %>%
  251. mutate(
  252. multiple_choice_accuracy = apply(., 1, function(row) {
  253. # Extract the first character from C_correct - it is the correct letter to click on
  254. correct_answer <- substr(row[["C_correct"]], 1, 1)
  256. # Determine which of the click columns matches the correct answer
  257. clicked_column <- ifelse(row[["A.numClicks"]] == 1, "A",
  258. ifelse(row[["B.numClicks"]] == 1, "B",
  259. ifelse(row[["C.numClicks"]] == 1, "C",
  260. ifelse(row[["D.numClicks"]] == 1, "D", NA))))
  262. # Return 1 if the clicked column matches the correct answer, 0 otherwise
  263. if (!is.na(clicked_column) && clicked_column == correct_answer) {
  264. return(1)
  265. } else {
  266. return(0)
  267. }
  268. })
  269. )
  271. # Change the column the order
  272. df.raw<- df.raw[c("index", "participant", "wav_file", "old_name",
  273. "duration","segment_text",
  274. "question", "C1", "C2", "C3", "C4", "C_correct",
  275. "A.numClicks", "B.numClicks", "C.numClicks",
  276. "D.numClicks", "multiple_choice_accuracy",
  277. "likert_response", "summary","textbox.text")]
  278. ```
  280. ```{r}
  281. # Extract the speech rate information from the trial name and create a speech_rate column
  282. df.raw<- df.raw %>%
  283. mutate(speech_rate = case_when(
  284. str_detect(wav_file, "2x") ~ 2,
  285. str_detect(wav_file, "3x") ~ 3,
  286. str_detect(wav_file, "4x") ~ 4,
  287. str_detect(wav_file, "5x") ~ 5,
  288. TRUE ~ 1 # not sped up if there are no numbers + x in the name
  289. ))
  290. ```
  292. ```{r}
  293. # Add the Digit Span (working memory) scores of each participant
  295. # Create an empty digit_span_score column
  296. df.raw$digit_span_score <- NA
  298. for (part_id in unique(df.raw$participant)) {
  299. # Construct the filename based on the participant ID
  300. filename <- paste0(organized_data_path, "/digit_span_", part_id, ".xlsx")
  302. # Check if the file exists
  303. if (file.exists(filename)) {
  304. # Correctly read the file using read_excel
  305. digit_span_data <- read_excel(filename)
  307. # The score is located in the first row of the 'score' column
  308. score <- digit_span_data$score[1]
  310. df.raw<- df.raw%>%
  311. mutate(digit_span_score = ifelse(participant == part_id, score, digit_span_score))
  312. } else {
  313. cat("File not found for participant", part_id, "\n")
  314. }
  315. }
  316. ```
  318. ```{r}
  319. # Add the hearWHO (digit-in-noise task for hearing in noise) scores of each participants
  321. hearwho_pilot_data <- read_excel(paste0(organized_data_path,
  322. "/hearwho_experiment.xlsx"))
  324. # Excel file has columns named 'participant' and 'score'
  325. # Merge the scores into df.raw based on participant ID
  326. df.raw <- merge(df.raw, hearwho_pilot_data[, c("participant", "score")],
  327. by.x = "participant", by.y = "participant", all.x = TRUE)
  329. # Rename the 'score' column to 'digit_in_noise_score'
  330. names(df.raw)[names(df.raw) == "score"] <- "digit_in_noise_score"
  331. ```
  333. ```{r}
  334. # Add slider values and time points
  336. # Check if the 'slider_values' column exists, if not, create it
  337. if (!"slider_values" %in% names(df.raw)) {
  338. df.raw$slider_values <- NA
  339. }
  341. # Check if the 'slider_time' column exists, if not, create it
  342. if (!"slider_time" %in% names(df.raw)) {
  343. df.raw$slider_time <- NA
  344. }
  346. # Define a function to extract and return slider values and time as strings
  347. get_slider_values_and_time <- function(wav_file_name, part_id) {
  348. # Extract the trial number from wav_file name
  349. matches <- regmatches(wav_file_name, regexec("Someday_([0-9]+)", wav_file_name))
  350. if (length(matches[[1]]) < 2) { # If no match or match does not have a capture group
  351. return(list(values = NA, time = NA))
  352. }
  353. trial_number <- matches[[1]][2]
  355. # Construct the path to the slider file
  356. slider_file_path <- sprintf("%s/%s/slider_%s/slider_%s_001_Someday_%s_condition*.csv",
  357. organized_data_path,
  358. part_id, part_id, part_id,
  359. trial_number)
  361. # Find slider files matching the pattern
  362. slider_files <- Sys.glob(slider_file_path)
  364. if (length(slider_files) == 0) {
  365. return(list(values = NA, time = NA)) # if no matching file found
  366. }
  368. slider_data <- read.csv(slider_files[1], skip = 1)
  370. # Prepare output for values
  371. slider_values_str <- if ("value" %in% colnames(slider_data)) {
  372. paste(slider_data$value, collapse = ",")
  373. } else {
  374. NA
  375. }
  377. # Prepare output for time
  378. slider_time_str <- if ("time" %in% colnames(slider_data)) {
  379. rounded_times <- round(slider_data$time, 2)
  380. paste(rounded_times, collapse = ",")
  381. } else {
  382. NA
  383. }
  385. return(list(values = slider_values_str, time = slider_time_str))
  386. }
  388. # Apply the function to each row of df.raw and extract results into separate columns
  389. slider_info <- mapply(get_slider_values_and_time,
  390. df.raw$wav_file,
  391. df.raw$participant,
  392. SIMPLIFY = FALSE) # Ensure output is a list
  394. # Assign values and time from the list output to respective columns
  395. df.raw$slider_values <- sapply(slider_info, '[[', "values")
  396. df.raw$slider_time <- sapply(slider_info, '[[', "time")
  397. ```
  399. ```{r}
  400. # Re-scale slider values to be between 0-1
  402. # Convert slider_values from string to numeric lists
  403. df.raw$slider_values <- strsplit(as.character(df.raw$slider_values),
  404. ",\\s*")
  405. df.raw$slider_values <- lapply(df.raw$slider_values,
  406. function(x) as.numeric(x))
  408. rescale_values <- function(values) {
  409. sapply(values, function(x) x / 255)
  410. }
  412. # Apply the rescaling function to each row's slider_values
  413. df.raw$slider_values_rescaled <- lapply(df.raw$slider_values,
  414. rescale_values)
  415. ```
  417. ```{r}
  418. # Create a column showing number of slider values
  419. df.raw <- df.raw %>%
  420. mutate(slider_values_number = lengths(slider_values_rescaled))
  421. ```
  423. ```{r}
  424. # Rescale the 10-point-scale values to be between 0-1
  425. df.raw <- df.raw %>%
  426. mutate(likert_rescaled = likert_response / 10)
  427. ```
  429. ## Calculations for the data exclusion criteria
  430. For the post-hoc comprehension measures, to ensure that we are validating the novel measure against actual comprehension, following exclusion criteria will be applied:
  432. ### 1. Absolute threshold for comprehension
  433. 75% correctness on the multiple choice questions for the slowest (easiest to comprehend) speech rate.
  435. ```{r}
  436. # Find trials that do not have a number right before .wav in the wav_file column
  437. # (slowest condition)
  438. attention_check_trials <- df.raw %>%
  439. filter(!grepl("x\\.wav$", wav_file))
  441. # Calculate the accuracy
  442. accuracy_results <- attention_check_trials %>%
  443. group_by(participant) %>%
  444. summarise(
  445. accuracy = mean(multiple_choice_accuracy == 1, na.rm = TRUE),
  446. n = n()
  447. ) %>%
  448. mutate(passed = if_else(accuracy >= 0.75, TRUE, FALSE))
  450. # Print out participants who passed or failed
  451. passed_participants <- accuracy_results %>%
  452. filter(passed) %>%
  453. pull(participant)
  455. failed_participants <- accuracy_results %>%
  456. filter(!passed) %>%
  457. select(participant, accuracy)
  459. if(length(passed_participants) > 0) {
  460. cat(paste(passed_participants, collapse = ", "),
  461. "passed the question accuracy criterion\n")
  462. }
  464. if(nrow(failed_participants) > 0) {
  465. cat(paste(failed_participants$participant, "with accuracy:", failed_participants$accuracy, collapse = ", "),
  466. "failed the question accuracy criterion\n")
  467. }
  468. ```
  469. #### Figure: failed vs accepted participants
  471. ```{r figure-size, fig.width=6, fig.height=4}
  472. # Histogram with all participants accuracies for speech rate 1
  473. p_mult <- ggplot(accuracy_results, aes(x = accuracy)) +
  474. geom_histogram(binwidth = 0.04, fill = "violetred", alpha = 0.7, color = "black") +
  475. labs(title = "All Participants' Multiple Choice Question Accuracy for Speech Rate x1",
  476. x = "Accuracy",
  477. y = "Number of Participants")
  479. # Failed vs passed
  480. p_mult +
  481. geom_histogram(data = failed_participants, aes(x = accuracy),
  482. binwidth = 0.04, fill = "pink", alpha = 0.7, color = "black") +
  483. labs(title = "",
  484. x = "Accuracy",
  485. y = "Number of Participants") +
  486. scale_x_continuous(breaks = c(0.6, 0.8, 1), labels= c('0.6', '0.8', '1')) +
  487. theme(axis.title.x = element_text(size = 14),
  488. axis.title.y = element_text(size = 14),
  489. plot.title = element_text(hjust = 0.5, size = 15, margin = margin(b = 40)), =
  490. axis.text = element_text(size = 12))
  492. ```
  494. ### 2. Ratings on the 10-point scale
  495. They should be significantly different for the slowest and fastest speech rates.
  497. ```{r}
  498. # t-test
  499. participants <- unique(df.raw$participant)
  501. # Create a vector to store results
  502. rating_criteria_results <- character(length(participants))
  504. # Loop through each participant
  505. for (i in seq_along(participants)) {
  506. part_id <- participants[i]
  508. # Subset data for the current participant for slowest and fastest speech rates
  509. subset_data <- df.raw %>%
  510. filter(participant == part_id & (speech_rate == 1 | speech_rate == 4)) %>%
  511. select(likert_response, speech_rate)
  513. # Perform a t-test comparing likert_response for speech_rate 1 vs 4
  514. test_result <- t.test(likert_response ~ speech_rate, data = subset_data)
  516. # Check if the difference is significant (p-value < 0.05)
  517. if (test_result$p.value < 0.05) {
  518. rating_criteria_results[i] <- paste(part_id, "passed the rating criterion")
  519. } else {
  520. rating_criteria_results[i] <- paste(part_id, "failed the rating criterion")
  521. }
  522. }
  524. # Print the results
  525. cat(rating_criteria_results, sep = "\n")
  526. ```
  527. ### 3. Summaries
  528. Participants shouldn't leave all summaries empty
  530. ```{r}
  531. # If all rows under textbox.tex are empty
  533. # Check if all 'textbox.text' entries are empty or NA for each participant
  534. summary_criterion <- df.raw %>%
  535. group_by(participant) %>%
  536. summarise(all_empty = all(textbox.text == "" | is.na(textbox.text))) %>%
  537. ungroup()
  539. # Print the results for participants where all textbox.text are empty
  540. summary_criterion %>%
  541. filter(all_empty) %>%
  542. pull(participant) %>%
  543. walk(~ cat(.x, "failed summary criterion\n"))
  545. # Print the results for participants where not all textbox.text are empty
  546. summary_criterion %>%
  547. filter(!all_empty) %>%
  548. pull(participant) %>%
  549. walk(~ cat(.x, "passed summary criterion\n"))
  550. ```
  552. ### 4. Slider movements
  553. For the physical slider to ensure that participants actually used it actively: Distribution of the amount of slider movements across trials and participants- If a participant's slider movements exceeds ±3.5 standard deviations from the mean, we will remove those participants' data.
  555. ```{r}
  556. # Calculate movement score with magnitude for each trial
  557. df.raw <- df.raw %>%
  558. rowwise() %>%
  559. mutate(trial_movement_score_magnitude =
  560. ifelse(slider_values[[1]][1] == 0, sum(abs(diff(unlist(slider_values)))), NA))
  562. # Aggregate these scores for each participant
  563. participant_movement_scores <- df.raw %>%
  564. group_by(participant) %>%
  565. summarise(movement_score_all = sum(trial_movement_score_magnitude, na.rm = TRUE))
  567. # Add the movement scores back to the df
  568. df.raw <- left_join(df.raw, participant_movement_scores, by = "participant")
  570. # Calculate mean and standard deviation for movement scores, identify outliers
  571. mean_movement_score <- mean(participant_movement_scores$movement_score_all, na.rm = TRUE)
  572. sd_movement_score <- sd(participant_movement_scores$movement_score_all, na.rm = TRUE)
  574. cutoff_upper <- mean_movement_score + 3.5 * sd_movement_score
  575. cutoff_lower <- mean_movement_score - 3.5 * sd_movement_score
  577. outliers <- participant_movement_scores %>%
  578. filter(movement_score_all < cutoff_lower | movement_score_all > cutoff_upper) %>%
  579. pull(participant)
  581. # Print participant IDs for those outside the ±3.5 SD range
  582. cat("Participants outside the ±3.5 SD range:", paste(outliers, collapse = ", "), "\n")
  583. ```
  585. ### Remove the participants that failed the criteria.
  586. p_12, p_16, p_2, p_20, p_23, p_26, p_27, p_6 failed the question accuracy criterion.
  587. ```{r}
  588. # Remove failed participants
  589. df.raw_success <- df.raw %>%
  590. filter(participant != "p_12")
  591. df.raw_success <- df.raw_success %>%
  592. filter(participant != "p_16")
  593. df.raw_success <- df.raw_success %>%
  594. filter(participant != "p_2")
  595. df.raw_success <- df.raw_success %>%
  596. filter(participant != "p_20")
  597. df.raw_success <- df.raw_success %>%
  598. filter(participant != "p_23")
  599. df.raw_success <- df.raw_success %>%
  600. filter(participant != "p_26")
  601. df.raw_success <- df.raw_success %>%
  602. filter(participant != "p_27")
  603. df.raw_success <- df.raw_success %>%
  604. filter(participant != "p_6")
  605. # check
  606. count(df.raw_success, participant)
  607. ```
  609. ## Save the df
  610. ```{r}
  611. # Convert list to string for slider values
  612. df.raw_success$slider_values <- sapply(df.raw_success$slider_values,
  613. function(x) paste(x, collapse = ","))
  615. output_file_path <- file.path(organized_data_path, "organized_data.csv")
  616. write.csv(df.raw_success, output_file_path, row.names = FALSE)
  618. ```
  620. # ANALYSIS
  622. Typos in the summaries participants wrote are corrected first using this code and then manually: *analysis/correct_typos.ipynb*
  624. Semantic similarity between the summaries participants wrote and segments they heard in each trial are calculated using the code in: *analysis/semantic_similarity.ipynb*
  625. data file with semantic similarity scores are in: *data/organized_data/df_semantic.csv*
  627. ```{r}
  628. # upload data after semantic similarity calculations
  629. df.data <- read.csv(file.path(organized_data_path, "df_semantic.csv"))
  630. ```
  632. ```{r}
  633. # Calculate median trial movements for each trial
  635. df.data <- df.data %>%
  636. mutate(
  637. slider_values_numeric = str_split(slider_values_rescaled, ",") %>%
  638. map(~ as.numeric(.x))
  639. )
  641. # Mean and median slider values for each trial
  642. df.data <- df.data %>%
  643. rowwise() %>%
  644. mutate(trial_mean_rescaled = mean(unlist(slider_values_numeric), na.rm = TRUE),
  645. trial_median_rescaled = median(unlist(slider_values_numeric), na.rm = TRUE)) %>%
  646. ungroup()
  647. ```
  649. ## I. Semantic Similarity
  650. ### Average word cound per second for each speech rate
  651. ```{r}
  652. # per-trial word counts and words/min
  653. df_wpm <- df.data %>%
  654. mutate(
  655. text_chr = as.character(segment_text),
  656. word_count = if_else(
  657. is.na(text_chr) | stri_trim_both(text_chr) == "",
  658. 0L,
  659. lengths(stri_extract_all_words(text_chr))
  660. ),
  661. wpm = if_else(duration > 0, 60 * word_count / duration, NA_real_) # words per minute
  662. )
  664. # summaries by speech_rate (both unweighted and duration-weighted)
  665. wpm_by_rate <- df_wpm %>%
  666. group_by(speech_rate) %>%
  667. summarise(
  668. mean_wpm_unweighted = mean(wpm, na.rm = TRUE),
  669. sd_wpm_unweighted = sd(wpm, na.rm = TRUE),
  670. mean_wpm_weighted = 60 * sum(word_count, na.rm = TRUE) / sum(duration, na.rm = TRUE),
  671. n_trials = sum(!is.na(wpm)),
  672. .groups = "drop"
  673. ) %>%
  674. mutate(across(c(mean_wpm_unweighted, sd_wpm_unweighted, mean_wpm_weighted), ~ round(., 2)))
  676. wpm_by_rate
  677. ```
  679. Which semantic similarity analysis explains comprehension better?
  681. ### Visualization
  682. First, let's visualize all 3 to see if they show the same pattern:
  684. ```{r figure-size, fig.width=9, fig.height=5}
  686. # GloVe - Written Summary
  687. average_similarity_summary <- df.data %>%
  688. group_by(speech_rate) %>%
  689. summarise(
  690. average_similarity = mean(glove_sum_max_similarity_rescaled, na.rm = TRUE),
  691. sd = sd(glove_sum_max_similarity_rescaled, na.rm = TRUE),
  692. n = n(),
  693. se = sd / sqrt(n) # standard error
  694. )
  697. # GloVe - Heard Segment
  698. average_similarity_text <- df.data %>%
  699. group_by(speech_rate) %>%
  700. summarise(
  701. average_similarity = mean(glove_text_average_max_similarity, na.rm = TRUE),
  702. sd = sd(glove_text_average_max_similarity, na.rm = TRUE),
  703. n = n(),
  704. se = sd / sqrt(n) # standard error
  705. )
  707. # BERT
  708. average_similarity_bert <- df.data %>%
  709. group_by(speech_rate) %>%
  710. summarise(
  711. average_similarity = mean(bert_cosine_similarity, na.rm = TRUE),
  712. sd = sd(bert_cosine_similarity, na.rm = TRUE),
  713. n = n(),
  714. se = sd / sqrt(n) # standard error
  715. )
  718. # Create the plots without x and y labels
  719. plot_glove_summary <- ggplot(average_similarity_summary, aes(x = factor(speech_rate),
  720. y = average_similarity,
  721. fill = as.factor(speech_rate))) +
  722. geom_bar(stat = "identity", position = "dodge", width = 0.7, fill = "green3") +
  723. scale_x_discrete(labels = function(x) paste0("x ", x)) +
  724. labs(x = NULL, y= NULL,
  725. title = "GloVe- Written Summary") +
  726. geom_text(aes(label = round(average_similarity, 2)),
  727. vjust = -1, position = position_dodge(width = 0.7), size = 3) +
  728. geom_errorbar(aes(ymin = average_similarity - se, ymax = average_similarity + se),
  729. width = 0, position = position_dodge(width = 0.7)) +
  730. theme(axis.title.x = element_text(size = 14),
  731. axis.title.y = element_text(size = 14),
  732. plot.title = element_text(size = 13, hjust = 0.5))
  734. plot_glove_text <- ggplot(average_similarity_text, aes(x = factor(speech_rate),
  735. y = average_similarity,
  736. fill = as.factor(speech_rate))) +
  737. geom_bar(stat = "identity", position = "dodge", width = 0.7, fill = "darkseagreen2") +
  738. scale_x_discrete(labels = function(x) paste0("x ", x)) +
  739. labs(x = NULL, y = NULL,
  740. title = "GloVe - Heard Segment") +
  741. geom_text(aes(label = round(average_similarity, 2)),
  742. vjust = -1, position = position_dodge(width = 0.7), size = 3) +
  743. geom_errorbar(aes(ymin = average_similarity - se, ymax = average_similarity + se),
  744. width = 0,position = position_dodge(width = 0.7)) +
  745. theme(plot.title = element_text(size = 13, hjust = 0.5))
  747. # Adjust the plot for BERT without individual axis labels
  748. plot_bert <- ggplot(average_similarity_bert, aes(x = factor(speech_rate),
  749. y = average_similarity,
  750. fill = as.factor(speech_rate))) +
  751. geom_bar(stat = "identity", position = "dodge", width = 0.7, fill = "darkseagreen3") +
  752. scale_x_discrete(labels = function(x) paste0("x ", x)) +
  753. labs(x = NULL, y = NULL,
  754. title = "BERT") +
  755. geom_text(aes(label = round(average_similarity, 2)),
  756. vjust = -1.2, position = position_dodge(width = 0.7), size = 3) +
  757. geom_errorbar(aes(ymin = average_similarity - se, ymax = average_similarity + se),
  758. width = 0, position = position_dodge(width = 0.7)) +
  759. theme(plot.title = element_text(size = 13, hjust = 0.5))
  761. #put them in a grid
  762. grid.arrange(
  763. arrangeGrob(
  764. plot_glove_summary,plot_glove_text, plot_bert,
  765. ncol = 3,
  766. left = textGrob("Average Normalized Cosine Similarity Value",
  767. rot = 90, vjust = 0.5),
  768. bottom = textGrob("Speech Rate",
  769. rot = 0, vjust = 0.5)
  770. )
  771. )
  772. ```
  773. ### Correlation
  775. Do 3 different semantic similarity measures correlate with each other?
  776. ```{r}
  777. # Subset the relevant columns
  778. semantic_columns <- df.data[, c("bert_cosine_similarity",
  779. "glove_text_average_max_similarity",
  780. "glove_sum_max_similarity_rescaled")]
  782. # Calculate the correlation matrix
  783. correlation_matrix <- cor(semantic_columns, use = "complete.obs")
  785. # Print
  786. print(correlation_matrix)
  788. ```
  789. Test if any of these correlations are statistically significant:
  790. ```{r}
  791. # Correlation test between BERT and GloVe- Heard Segment
  792. test1 <- cor.test(df.data$bert_cosine_similarity,
  793. df.data$glove_text_average_max_similarity)
  795. # Correlation test between BERT and GloVe- Written Summary
  796. test2 <- cor.test(df.data$bert_cosine_similarity,
  797. df.data$glove_sum_max_similarity_rescaled)
  799. # Correlation test between GloVe- Heard Segment & GloVe- Written Summary
  800. test3 <- cor.test(df.data$glove_text_average_max_similarity,
  801. df.data$glove_sum_max_similarity_rescaled)
  803. print(test1)
  804. print(test2)
  805. print(test3)
  807. ```
  809. ### Comparison
  810. Which semantic similarity analysis method explains the most varience in comprehension?
  812. To see which if semantic similarity scores explains variance in comprehension better than the others,we conducted a linear mixed model was conducted to predict the 10-Point Scale responses based on BERT, GloVe- Written Summary, and GloVe- Heard Segment. Random effects for digit span score and digit in noise score were included in the model.
  815. ```{r}
  816. model_all<- lmer(likert_rescaled ~
  817. bert_cosine_similarity + glove_text_average_max_similarity +
  818. glove_sum_max_similarity_rescaled +
  819. (1 | digit_span_score) +
  820. (1 | digit_in_noise_score), data = df.data)
  821. #model_compare <- anova(model_g1, model_all)
  822. summary(model_all)
  823. ```
  824. All fixed effects (different sem similarity scores) are significant, they are finding independent variance, interestingly. Glove- Written Summary has the highest t value and estimate. Therefore, I will use/ report the GLoVe- written summary Segment for the rest of the analyses.
  826. ### Speech Rate
  827. Are semantic similarity scores btw speech rates sig different from each other?
  829. #### Glove- Written Summary
  830. ```{r}
  831. semantic.anova <- aov(glove_sum_max_similarity_rescaled ~ speech_rate, data = df.data)
  832. summary(semantic.anova)
  834. pairwise_results <- df.data %>% pairwise_t_test(
  835. glove_sum_max_similarity_rescaled ~ speech_rate, pool.sd = FALSE,
  836. p.adjust.method = "bonferroni"
  837. )
  838. pairwise_results
  839. ```
  840. All significant except x1-x2
  842. #### Glove- Heard Segment
  843. ```{r}
  844. semantic.anova2 <- aov(glove_text_average_max_similarity ~ speech_rate, data = df.data)
  845. summary(semantic.anova2)
  847. pairwise_results2 <- df.data %>% pairwise_t_test(
  848. glove_text_average_max_similarity ~ speech_rate, pool.sd = FALSE,
  849. p.adjust.method = "bonferroni"
  850. )
  851. pairwise_results2
  852. ```
  853. All significant except x1-x2 & x2-x3
  855. #### BERT
  856. ```{r}
  857. semantic.anova3 <- aov(bert_cosine_similarity ~ speech_rate, data = df.data)
  858. summary(semantic.anova3)
  860. pairwise_results3 <- df.data %>% pairwise_t_test(
  861. bert_cosine_similarity ~ speech_rate, pool.sd = FALSE,
  862. p.adjust.method = "bonferroni"
  863. )
  864. pairwise_results3
  865. ```
  866. All significant except except x2-x3
  868. ### Recency Effect
  869. Is there a recency effect in summaries that participants wrote?
  871. #### Glove- Written Summary
  872. ```{r}
  873. # First, make sure that the right ones are NA, right now NAs are also 0
  874. df.data <- df.data %>%
  875. mutate(
  876. rescaled_glove_bin1 = ifelse(textbox.text_corrected_manual == "",
  877. NA, rescaled_glove_bin1),
  878. rescaled_glove_bin2 = ifelse(textbox.text_corrected_manual == "",
  879. NA, rescaled_glove_bin2),
  880. rescaled_glove_bin3 = ifelse(textbox.text_corrected_manual == "",
  881. NA, rescaled_glove_bin3),
  882. rescaled_glove_bin4 = ifelse(textbox.text_corrected_manual == "",
  883. NA, rescaled_glove_bin4),
  884. rescaled_glove_bin5 = ifelse(textbox.text_corrected_manual == "",
  885. NA, rescaled_glove_bin5)
  886. )
  888. # Create a long dataset for bins and scores
  889. df.bin <- df.data %>%
  890. select(participant, index, speech_rate, segment_text, textbox.text_corrected_manual,
  891. glove_bin1, glove_bin2, glove_bin3, glove_bin4, glove_bin5) %>%
  892. pivot_longer(cols = starts_with("glove_bin"),
  893. names_to = "bin",
  894. names_prefix = "glove_bin",
  895. values_to = "semantic_score") %>%
  896. mutate(bin = as.integer(bin)) %>%
  897. arrange(participant, index, bin)
  899. # If a recency effect -> latter bins should be recalled better than earlier ones
  900. binned.anova <- aov(semantic_score ~ speech_rate * bin, data = df.bin)
  901. summary(binned.anova)
  903. df.bin_factor = df.bin %>%
  904. mutate(speech_bin = factor(paste(speech_rate, bin, sep="_")))
  906. # pairwise comparison
  907. df.bin_factor %>% pairwise_t_test(
  908. semantic_score ~ speech_bin, pool.sd = FALSE,
  909. p.adjust.method = "bonferroni"
  910. )
  911. ```
  913. #### Glove- Heard Segment
  914. ```{r}
  915. # First, make sure that the right ones are NA, right now NAs are also 0
  917. df.data <- df.data %>%
  918. mutate(
  919. glove2_bin1 = ifelse(textbox.text_corrected_manual == "", NA, glove2_bin1),
  920. glove2_bin2 = ifelse(textbox.text_corrected_manual == "", NA, glove2_bin2),
  921. glove2_bin3 = ifelse(textbox.text_corrected_manual == "", NA, glove2_bin3),
  922. glove2_bin4 = ifelse(textbox.text_corrected_manual == "", NA, glove2_bin4),
  923. glove2_bin5 = ifelse(textbox.text_corrected_manual == "", NA, glove2_bin5)
  924. )
  926. # Create a long dataset for bins and scores
  927. df.bin_glove2 <- df.data %>%
  928. select(participant, index, speech_rate, segment_text, textbox.text_corrected_manual,
  929. glove2_bin1, glove2_bin2, glove2_bin3, glove2_bin4, glove2_bin5) %>%
  930. pivot_longer(cols = starts_with("glove2_bin"),
  931. names_to = "bin",
  932. names_prefix = "glove2_bin",
  933. values_to = "glove2_score") %>%
  934. mutate(bin = as.integer(bin)) %>%
  935. arrange(participant, index, bin)
  937. # If a recency effect -> latter bins should be recalled better than earlier ones
  939. binned.anova2 <- aov(glove2_score ~ speech_rate * bin, data = df.bin_glove2)
  940. summary(binned.anova2)
  942. df.bin_factor = df.bin_glove2 %>%
  943. mutate(speech_bin = factor(paste(speech_rate, bin, sep="_")))
  945. # pairwise comparison
  946. df.bin_factor %>% pairwise_t_test(
  947. glove2_score ~ speech_bin, pool.sd = FALSE,
  948. p.adjust.method = "bonferroni"
  949. )
  950. ```
  952. #### BERT
  953. ```{r}
  954. # Create a long dataset for bins and scores for BERT
  955. df.bin_bert <- df.data %>%
  956. select(participant, index, speech_rate, segment_text, textbox.text_corrected_manual,
  957. cosine_similarity_bin1,
  958. cosine_similarity_bin2,
  959. cosine_similarity_bin3,
  960. cosine_similarity_bin4,
  961. cosine_similarity_bin5) %>%
  962. pivot_longer(cols = starts_with("cosine_similarity_bin"),
  963. names_to = "bin",
  964. names_prefix = "cosine_similarity_bin",
  965. values_to = "bert_score") %>%
  966. mutate(bin = as.integer(bin)) %>%
  967. arrange(participant, index, bin)
  969. binned.anova_bert <- aov(bert_score ~ speech_rate * bin, data = df.bin_bert)
  970. summary(binned.anova_bert)
  972. df.bin_bert_factor = df.bin_bert %>%
  973. mutate(speech_bin = factor(paste(speech_rate, bin, sep="_")))
  975. # pairwise comparison
  976. df.bin_bert_factor %>% pairwise_t_test(
  977. bert_score ~ speech_bin, pool.sd = FALSE,
  978. p.adjust.method = "bonferroni"
  979. )
  980. ```
  982. There is a main effect of Speech Rate for all 3, main effect of binning (recency) only for GloVe- Heard Summary & BERT.
  984. ## II. Validation
  985. Can we predict the scores of our novel comprehension measure from the existing post-hoc comprehension measures?
  987. ### Correlation between comprehension measures
  989. ```{r}
  990. vars <- c("trial_median_rescaled",
  991. "glove_sum_max_similarity_rescaled",
  992. "likert_rescaled",
  993. "multiple_choice_accuracy")
  995. # <-- rename map to match your visreg wording
  996. labs <- c(
  997. trial_median_rescaled = "Real-Time Comprehension",
  998. glove_sum_max_similarity_rescaled = "Semantic Similarity",
  999. likert_rescaled = "10-Point Scale",
  1000. multiple_choice_accuracy = "Multiple Choice"
  1001. )
  1003. X <- df.data[, vars]
  1004. rc_p <- rcorr(as.matrix(X), type = "pearson")
  1006. # apply pretty labels to matrices
  1007. R <- rc_p$r; P <- rc_p$P
  1008. dimnames(R) <- lapply(dimnames(R), function(nm) unname(labs[nm]))
  1009. dimnames(P) <- lapply(dimnames(P), function(nm) unname(labs[nm]))
  1011. # tidy pairwise table with pretty names
  1012. pairs_tbl <- (\(R, P) {
  1013. nm <- colnames(R)
  1014. out <- do.call(rbind, lapply(1:(ncol(R)-1), function(i)
  1015. do.call(rbind, lapply((i+1):ncol(R), function(j)
  1016. data.frame(var1 = nm[i], var2 = nm[j], r = R[i,j], p = P[i,j])
  1017. ))
  1018. ))
  1019. out[order(abs(out$r), decreasing = TRUE), ]
  1020. })(R, P) %>%
  1021. mutate(r = round(r, 2),
  1022. p = signif(p,4))
  1023. pairs_tbl
  1024. ```
  1026. ```{r}
  1028. # palette: purple (-1) → white (0) → green (+1)
  1029. pal_pg <- colorRampPalette(c("#6A00A8", "#F7F7F7", "#10B981"))(200)
  1031. corrplot(R,
  1032. method = "circle",
  1033. type = "upper",
  1034. col = pal_pg,
  1035. tl.col = "black",
  1036. tl.srt = 45,
  1037. cl.lim = c(-1, 1),
  1038. p.mat = P,
  1039. sig.level = c(0.001, 0.01, 0.05),
  1040. insig = "label_sig", # prints ***, **, *
  1041. pch.cex = 1.2,
  1042. pch.col = "black")
  1043. ```
  1046. ### Each measure as a fixed effect in seperate models
  1048. #### 10-Point Scale Ratings
  1050. ```{r}
  1051. model_likert<- lmer(trial_median_rescaled ~
  1052. likert_rescaled +
  1053. (1 | digit_span_score) +
  1054. (1 | digit_in_noise_score), data = df.data)
  1056. summary(model_likert)
  1057. ```
  1059. ##### Visualize 10-Point Scale Ratings per Sepeech Speed
  1060. ```{r figure-size, fig.width=6, fig.height=6 }
  1062. # Calculate the average 10-point scale scores per speech_rate category
  1063. average_score_likert <- df.data %>%
  1064. group_by(speech_rate) %>%
  1065. summarise(average_likert = mean(likert_rescaled, na.rm = TRUE),
  1066. sd = sd(likert_rescaled, na.rm = TRUE),
  1067. n = n(),
  1068. se = sd / sqrt(n) # standard error
  1069. )
  1071. # Plot
  1072. likert_plot <- ggplot(average_score_likert, aes(x = factor(speech_rate),
  1073. y = average_likert)) +
  1074. geom_bar(stat = "identity", width = 0.7, fill = "royalblue") +
  1075. labs(x = "Speech Rate", y = "10-Point Scale Response") +
  1076. geom_text(aes(label = round(average_likert, 2)), vjust = -0.2, size = 6) +
  1077. scale_x_discrete(labels = function(x) paste0("x ", x)) +
  1078. geom_errorbar(aes(ymin = average_likert - se, ymax = average_likert + se),
  1079. width = 0, position = position_dodge(width = 0.5)) +
  1080. scale_y_continuous(breaks = c(0, 0.25, 0.50)) +
  1081. theme(axis.title.x = element_text(size = 24),
  1082. axis.title.y = element_text(size = 24),
  1083. axis.text.x = element_text(size = 20),
  1084. axis.text.y = element_text(size = 20))
  1086. print(likert_plot)
  1089. ```
  1090. ##### variance explained by the fixed effect (partial r2)
  1091. The proportion of variance explain uniquely by the predictor relative to total
  1092. variance
  1093. ```{r}
  1094. res_likert <- partR2(model_likert,
  1095. partvars = "likert_rescaled",
  1096. data = df.data,
  1097. R2_type = "marginal")
  1098. res_likert
  1100. res_likert_round <- as.data.frame(res_likert$R2) %>%
  1101. mutate(across(where(is.numeric), ~ round(., 2)))
  1102. res_likert_round
  1104. ```
  1105. Cohen's f2
  1106. ```{r}
  1107. r2 <- r.squaredGLMM(model_likert)
  1108. R2_m <- as.numeric(r2[1])
  1110. # Cohen's f^2 for a single fixed effect
  1111. f2 <- if (is.finite(R2_m) && R2_m < 1) R2_m / (1 - R2_m) else NA_real_
  1113. # Partial R^2 equals Marginal R^2 when there's only one fixed effect
  1114. PR2_likert <- R2_m
  1116. # Pretty print (2 decimals)
  1117. cat(sprintf("Marginal R^2 (fixed effects): %.2f\n", R2_m))
  1118. cat(sprintf("Cohen's f^2: %.2f\n", f2))
  1119. cat(sprintf("Partial R^2 for likert_rescaled: %.2f\n", PR2_likert))
  1120. ```
  1123. #### Multiple Choice Quesitons
  1124. ```{r}
  1125. model_multiple_choice<- lmer(trial_median_rescaled ~
  1126. multiple_choice_accuracy +
  1127. (1 | digit_span_score) +
  1128. (1 | digit_in_noise_score), data = df.data)
  1130. summary(model_multiple_choice)
  1131. ```
  1133. ##### Visualize Multiple Choice Quesitons per Speech Rate
  1134. ```{r figure-size, fig.width=6, fig.height=6 }
  1135. # Calculate the average multiple_choice_accuracy scores per speech_rate category
  1136. average_scores <- df.data %>%
  1137. group_by(speech_rate) %>%
  1138. summarise(average_accuracy = mean(multiple_choice_accuracy, na.rm = TRUE),
  1139. sd = sd(multiple_choice_accuracy, na.rm = TRUE),
  1140. n = n(),
  1141. se = sd / sqrt(n) # standard error
  1142. )
  1144. question_plot <- ggplot(average_scores, aes(x = factor(speech_rate), y = average_accuracy)) +
  1145. geom_bar(stat = "identity", width = 0.7, fill = "violetred") +
  1146. labs(x = "Speech Rate", y = "Multiple Choice Accuracy") +
  1147. geom_text(aes(label = round(average_accuracy, 2)), vjust = -0.5, size = 6) +
  1148. scale_x_discrete(labels = function(x) paste0("x ", x)) +
  1149. geom_errorbar(aes(ymin = average_accuracy - se, ymax = average_accuracy + se),
  1150. width = 0, position = position_dodge(width = 0.5)) +
  1151. # Add dashed line at chance level:
  1152. geom_hline(yintercept = 0.25, linetype = "dashed", color = "black", size=1.5) +
  1153. scale_y_continuous(breaks = c(0, 0.25, 0.5)) +
  1154. theme(axis.title.x = element_text(size = 24),
  1155. axis.title.y = element_text(size = 24),
  1156. axis.text.x = element_text(size = 20),
  1157. axis.text.y = element_text(size = 20))
  1159. print(question_plot)
  1160. ```
  1162. ##### variance explained by the fixed effect (partial r2)
  1163. The proportion of variance explain uniquely by the predictor relative to total
  1164. variance
  1165. ```{r}
  1166. res_mcq <- partR2(model_multiple_choice,
  1167. partvars = "multiple_choice_accuracy",
  1168. data = df.data,
  1169. R2_type = "marginal")
  1170. res_mcq
  1171. res_mcq_round <- as.data.frame(res_mcq$R2) %>%
  1172. mutate(across(where(is.numeric), ~ round(., 2)))
  1173. res_mcq_round
  1174. ```
  1175. Cohen's f2
  1176. ```{r}
  1177. ## 1) Marginal R^2 (fixed effects) + Cohen's f^2
  1178. r2 <- r.squaredGLMM(model_multiple_choice)
  1179. R2_m <- as.numeric(r2[1]) # marginal R^2
  1180. f2 <- R2_m / (1 - R2_m) # Cohen's f^2
  1182. ## 2) Partial R^2 for the single fixed effect (equals marginal R^2)
  1183. PR2_mcq <- R2_m
  1185. ## 3) Standardized beta (ΔSD_y per 1 SD_x)
  1186. df.data$y_z <- scale(df.data$trial_median_rescaled)
  1187. df.data$x_z <- scale(df.data$multiple_choice_accuracy)
  1188. mod_std <- lmer(y_z ~ x_z +
  1189. (1 | digit_span_score) +
  1190. (1 | digit_in_noise_score),
  1191. data = df.data)
  1192. beta_std <- fixef(mod_std)["x_z"]
  1194. ## 4) (Optional) Semi-standardized beta: SD(y) per 1 raw-unit of x
  1195. mod_semistd <- lmer(y_z ~ multiple_choice_accuracy +
  1196. (1 | digit_span_score) +
  1197. (1 | digit_in_noise_score),
  1198. data = df.data)
  1199. beta_semistd <- fixef(mod_semistd)["multiple_choice_accuracy"]
  1201. ## Pretty print
  1202. cat(sprintf(
  1203. "Marginal R^2: %.2f\nCohen's f^2: %.2f\nPartial R^2: %.2f",
  1204. R2_m, f2, PR2_mcq
  1205. ))
  1206. ```
  1208. #### Summary
  1209. ```{r}
  1210. # Summary- GloVe- Written Summary
  1211. model_glove1<- lmer(trial_median_rescaled ~
  1212. glove_sum_max_similarity_rescaled +
  1213. (1 | digit_span_score) +
  1214. (1 | digit_in_noise_score), data = df.data)
  1216. summary(model_glove1)
  1217. ```
  1219. ##### Visualize Semantic Simlarity Scores of Summaries per Speech Rate
  1220. ```{r figure-size, fig.width=6, fig.height=6}
  1221. plot_glove_summary <- ggplot(average_similarity_summary, aes(x = factor(speech_rate),
  1222. y = average_similarity,
  1223. fill = as.factor(speech_rate))) +
  1224. geom_bar(stat = "identity", position = "dodge", width = 0.7, fill = "green3") +
  1225. scale_x_discrete(labels = function(x) paste0("x ", x)) +
  1226. labs(x = "Speech Rate", y= "Semantic Similarity\nScore") +
  1227. geom_text(aes(label = round(average_similarity, 2)),
  1228. vjust = -0.5, position = position_dodge(width = 0.7), size = 6) +
  1229. geom_errorbar(aes(ymin = average_similarity - se, ymax = average_similarity + se),
  1230. width = 0, position = position_dodge(width = 0.7)) +
  1231. scale_y_continuous(breaks = c(0, 0.25, 0.5), limits = c(0, 0.5)) +
  1232. theme(axis.title.x = element_text(size = 24),
  1233. axis.title.y = element_text(size = 24),
  1234. axis.text.x = element_text(size = 20),
  1235. axis.text.y = element_text(size = 20),
  1236. plot.title = element_text(size = 20, hjust = 0.5))
  1238. plot_glove_summary
  1239. ```
  1241. ##### variance explained by the fixed effect (partial r2)
  1242. The proportion of variance explain uniquely by the predictor relative to total
  1243. variance
  1244. ```{r}
  1245. res_sem <- partR2(model_glove1,
  1246. partvars = "glove_sum_max_similarity_rescaled",
  1247. data = df.data,
  1248. R2_type = "marginal")
  1249. res_sem
  1250. res_sem_round <- as.data.frame(res_sem$R2) %>%
  1251. mutate(across(where(is.numeric), ~ round(., 2)))
  1252. res_sem_round
  1253. ```
  1254. Cohen's f2
  1255. ```{r}
  1256. ## 1) Marginal R^2 (fixed effects) + Cohen's f^2
  1257. r2 <- r.squaredGLMM(model_glove1)
  1258. R2_m <- as.numeric(r2[1]) # marginal R^2
  1259. f2 <- R2_m / (1 - R2_m) # Cohen's f^2
  1261. ## 2) Partial R^2 (same as marginal R^2 with one fixed effect)
  1262. PR2_glove <- R2_m
  1264. ## 3) Standardized beta (ΔSD_y per 1 SD_x)
  1265. df.data$y_glove_z <- scale(df.data$trial_median_rescaled)
  1266. df.data$x_glove_z <- scale(df.data$glove_sum_max_similarity_rescaled)
  1267. mod_std_glove <- lmer(y_glove_z ~ x_glove_z +
  1268. (1 | digit_span_score) +
  1269. (1 | digit_in_noise_score),
  1270. data = df.data)
  1272. ## print
  1273. cat(sprintf(
  1274. "Marginal R^2: %.3f\nCohen's f^2: %.3f\nPartial R^2: %.3f",
  1275. R2_m, f2, PR2_glove
  1276. ))
  1278. ```
  1280. ### Visualize single fixed effect regression models
  1281. ```{r figure-size, fig.width=6, fig.height=6 }
  1282. visreg_summary <- visreg(model_glove1, "glove_sum_max_similarity_rescaled", gg=TRUE,
  1283. line=list(col="green3", size=1.7), points=list(alpha=0.5),
  1284. xlab= "Semantic Similarity Score",
  1285. ylab= "Predicted Real-Time\nComprehension Score") +
  1286. theme(axis.title.x = element_text(size = 24),
  1287. axis.title.y = element_text(size = 24),
  1288. axis.text.x = element_text(size = 20), # Adjust X-axis tick label size
  1289. axis.text.y = element_text(size = 20)) + # Adjust Y-axis tick label size
  1290. scale_x_continuous(breaks = c(0, 0.5, 1)) + # Set x-axis ticks at 0, 0.5, 1
  1291. scale_y_continuous(breaks = c(0, 0.5, 1))
  1294. visreg_likert <- visreg(model_likert, "likert_rescaled", gg=TRUE,
  1295. line=list(col="royalblue",size=1.7), points=list(alpha=0.5),
  1296. xlab= "10-point Scale Response",
  1297. ylab= "") +
  1298. theme(axis.title.x = element_text(size = 24),
  1299. axis.title.y = element_text(size = 24),
  1300. axis.text.x = element_text(size = 20), # Adjust X-axis tick label size
  1301. axis.text.y = element_text(size = 20)) + # Adjust Y-axis tick label size
  1302. scale_x_continuous(breaks = c(0, 0.5, 1)) + # Force x-axis to include 0, 0.5, 1
  1303. scale_y_continuous(breaks = c(0, 0.5, 1))
  1306. visreg_multiple <- visreg(model_multiple_choice, "multiple_choice_accuracy", gg=TRUE,
  1307. line=list(col="violetred", size=1.7), points=list(alpha=0.5),
  1308. xlab= "Multiple Choice Accuracy",
  1309. ylab= "") +
  1310. theme(axis.title.x = element_text(size = 24),
  1311. axis.title.y = element_text(size = 24),
  1312. axis.text.x = element_text(size = 20), # Adjust X-axis tick label size
  1313. axis.text.y = element_text(size = 20)) + # Adjust Y-axis tick label size
  1314. scale_x_continuous(breaks = c(0, 0.5, 1)) + # Set x-axis ticks at 0, 0.5, 1
  1315. scale_y_continuous(breaks = c(0, 0.5, 1))
  1318. visreg_summary
  1319. visreg_likert
  1320. visreg_multiple
  1321. ```
  1323. ### Visualize regression models + Bar plots
  1324. ```{r figure-size, fig.width=18, fig.height=14}
  1325. # Create a multi-panel plot for
  1327. # Create title groups
  1328. title1 <- textGrob("Summary", gp=gpar(fontsize=28, color='green3',fontface="bold"))
  1329. title2 <- textGrob("10-Point Scale", gp=gpar(fontsize=28, color='royalblue', fontface="bold"))
  1330. title3 <- textGrob("Multiple Choice Question", gp=gpar(fontsize=28,color='violetred', fontface="bold"))
  1332. combined_plot_effects <- grid.arrange(
  1333. title1, title2, title3,
  1334. visreg_summary, visreg_likert, visreg_multiple,
  1335. plot_glove_summary, likert_plot, question_plot,
  1336. ncol = 3,
  1337. nrow = 4,
  1338. heights = unit.c(unit(4, "null"), unit(8, "null"), unit(2, "null"), unit(8, "null")), # Adjust heights
  1339. layout_matrix = rbind(c(1, 2, 3), c(4, 5, 6), c(NA, NA, NA), c(7, 8, 9))
  1340. )
  1342. print(combined_plot_effects)
  1343. ```
  1345. ## All post-hoc measures as fixed effects in one regression model
  1346. Now predict the novel measure's scores from all post-hoc comprehension measures to see if they can explain independent variance.
  1348. ```{r}
  1349. model_all_glove1 <- lmer(trial_median_rescaled ~
  1350. glove_sum_max_similarity_rescaled +
  1351. likert_rescaled +
  1352. multiple_choice_accuracy +
  1353. (1 | digit_span_score) +
  1354. (1 | digit_in_noise_score), data = df.data)
  1356. summary(model_all_glove1)
  1357. ```
  1359. ### Visualize the multiple fixed effects regression
  1360. ```{r figure-size, fig.width=15, fig.height=5 }
  1362. visreg_summary_all <- visreg(model_all_glove1, "glove_sum_max_similarity_rescaled",
  1363. gg=TRUE,
  1364. line=list(col="green3", size = 1.7), points=list(alpha=0.5),
  1365. xlab= "Semantic Similarity Score",
  1366. ylab= "Predicted Real-Time\nComprehension Score") +
  1367. theme(axis.title.x = element_text(size = 24),
  1368. axis.title.y = element_text(size = 24),
  1369. axis.text.x = element_text(size = 20),
  1370. axis.text.y = element_text(size = 20)) +
  1371. scale_x_continuous(breaks = c(0, 0.5, 1)) +
  1372. scale_y_continuous(breaks = c(0, 0.5, 1))
  1374. # Update for visreg_likert
  1375. visreg_likert_all <- visreg(model_all_glove1, "likert_rescaled", gg=TRUE,
  1376. line=list(col="royalblue",size=1.7), points=list(alpha=0.5),
  1377. xlab= "10-point Scale Response",
  1378. ylab= NULL)+
  1379. theme(axis.title.x = element_text(size = 24),
  1380. axis.title.y = element_text(size = 24),
  1381. axis.text.x = element_text(size = 20),
  1382. axis.text.y = element_text(size = 20)) +
  1383. scale_x_continuous(breaks = c(0, 0.5, 1)) +
  1384. scale_y_continuous(breaks = c(0, 0.5, 1))
  1386. # Update for visreg_multiple
  1387. visreg_multiple_all <- visreg(model_all_glove1, "multiple_choice_accuracy", gg=TRUE,
  1388. line=list(col="violetred", size=1.7), points=list(alpha=0.5),
  1389. xlab= "Multiple Choice Accuracy",
  1390. ylab= NULL) +
  1391. theme(axis.title.x = element_text(size = 24),
  1392. axis.title.y = element_text(size = 24),
  1393. axis.text.x = element_text(size = 20),
  1394. axis.text.y = element_text(size = 20)) +
  1395. scale_x_continuous(breaks = c(0, 0.5, 1)) +
  1396. scale_y_continuous(breaks = c(0, 0.5, 1))
  1398. # Arrange plots in a grid
  1399. grid.arrange(
  1400. arrangeGrob(
  1401. visreg_summary_all, visreg_likert_all, visreg_multiple_all,
  1402. ncol = 3
  1403. )
  1404. )
  1407. # For random slopes
  1408. visreg_wm <- visreg(model_all_glove1, "digit_span_score", gg=TRUE,
  1409. xlab= "Working Memory Scores",
  1410. ylab= NULL)
  1411. #scale_y_continuous(breaks = c(1, 2, 3, 4, 5), limits = c(1, 5))
  1413. visreg_hearing <- visreg(model_all_glove1, "digit_in_noise_score", gg=TRUE,
  1414. xlab= "Hearing In Noise",
  1415. ylab= NULL)
  1416. #scale_y_continuous(breaks = c(1, 2, 3, 4, 5), limits = c(1, 5))
  1419. # put them in a grid
  1420. grid.arrange(
  1421. arrangeGrob(
  1422. visreg_wm, visreg_hearing,
  1423. ncol = 2,
  1424. left = textGrob(" Predicted real-time comprehension scores
  1425. given the post-hoc measures",
  1426. rot = 90, vjust = 1.5)
  1427. )
  1428. )
  1429. ```
  1432. 0.00##### variance explained
  1433. ```{r}
  1434. cohens_f2_lmer <- function(mod, digits = 3) {
  1435. stopifnot(inherits(mod, "lmerMod"))
  1437. # Use the exact rows the model used (avoid NA mismatches)
  1438. mf <- model.frame(mod, na.action = na.omit)
  1439. mod_clean <- lmer(formula(mod), data = mf, REML = lme4::isREML(mod))
  1441. # Pieces
  1442. resp <- as.character(formula(mod_clean))[2]
  1443. fixed_terms <- attr(terms(mod_clean), "term.labels") # fixed-only labels
  1444. rand_terms <- lme4::findbars(formula(mod_clean)) # random terms
  1446. # Keep random effects in all reduced models
  1447. rand_str <- if (length(rand_terms)) {
  1448. vapply(rand_terms, function(x) paste0("(", deparse(x), ")"), character(1))
  1449. } else character(0)
  1451. # Model-level R^2 (marginal for fixed effects)
  1452. r2_full_vec <- r.squaredGLMM(mod_clean)
  1453. r2_full_m <- as.numeric(r2_full_vec[1]) # Marginal R^2 (fixed effects)
  1454. r2_full_c <- as.numeric(r2_full_vec[2]) # Conditional R^2 (fixed + random), FYI
  1456. # Build reduced models dropping ONE fixed term at a time
  1457. rows <- lapply(fixed_terms, function(trm) {
  1458. keep_fixed <- setdiff(fixed_terms, trm)
  1459. fixed_rhs <- if (length(keep_fixed)) paste(keep_fixed, collapse = " + ") else "1"
  1460. rhs <- paste(c(fixed_rhs, rand_str), collapse = " + ")
  1461. f_reduced <- as.formula(paste(resp, "~", rhs))
  1463. m_red <- lmer(f_reduced, data = mf, REML = lme4::isREML(mod_clean))
  1464. r2_red <- as.numeric(r.squaredGLMM(m_red)[1]) # marginal R^2 of reduced
  1465. dR2 <- r2_full_m - r2_red # unique/semi-partial R^2
  1466. f2 <- if (is.finite(r2_full_m) && r2_full_m < 1) dR2 / (1 - r2_full_m) else NA_real_
  1468. data.frame(
  1469. Predictor = trm,
  1470. Marginal_R2 = r2_full_m, # same for all rows (model-level)
  1471. Partial_R2 = dR2, # unique/semi-partial R^2 for this predictor
  1472. R2_reduced = r2_red, # for transparency
  1473. Cohen_f2 = f2,
  1474. stringsAsFactors = FALSE
  1475. )
  1476. })
  1478. out <- bind_rows(rows) |>
  1479. arrange(desc(Partial_R2)) |>
  1480. mutate(across(c(Marginal_R2, Partial_R2, R2_reduced, Cohen_f2),
  1481. ~ round(., digits)))
  1483. # (optional) attach conditional R^2 as an attribute for reference
  1484. attr(out, "R2_conditional_model") <- round(r2_full_c, digits)
  1485. out
  1486. }
  1488. # ----- Use it -----
  1489. f2_tbl <- cohens_f2_lmer(model_all_glove1, digits = 3)
  1490. f2_tbl
  1491. # View the model Conditional R^2 (optional):
  1492. attr(f2_tbl, "R2_conditional_model")
  1494. # Cohen (1988) benchmarks: small ~0.02, medium ~0.15, large ~0.35
  1495. ```
  1497. ## Figure: Single fixed-effect regressions + bar plots + multiple fixed-effect regression
  1498. ```{r figure-size, fig.width=18, fig.height=22}
  1499. # all 3 plots in the same grid
  1500. # Create title groups
  1501. title1 <- textGrob("Summary", gp=gpar(fontsize=28,
  1502. color='green3',
  1503. fontface="bold"))
  1504. title2 <- textGrob("10-Point Scale", gp=gpar(fontsize=28,
  1505. color='royalblue',
  1506. fontface="bold"))
  1507. title3 <- textGrob("Multiple Choice Question", gp=gpar(fontsize=28,
  1508. color='violetred',
  1509. fontface="bold"))
  1511. combined_plot_effects <- grid.arrange(
  1512. title1, title2, title3,
  1513. visreg_summary, visreg_likert, visreg_multiple,
  1514. plot_glove_summary, likert_plot, question_plot,
  1515. visreg_summary_all, visreg_likert_all, visreg_multiple_all,
  1516. ncol = 3,
  1517. nrow = 6,
  1518. heights = unit.c(
  1519. unit(4, "null"), # Title row
  1520. unit(8, "null"), # First row of plots
  1521. unit(2, "null"), # Spacer row
  1522. unit(8, "null"), # Second row of plots
  1523. unit(2, "null"), # Spacer row (optional)
  1524. unit(8, "null") # Third row of plots
  1525. ),
  1526. layout_matrix = rbind(
  1527. c(1, 2, 3),
  1528. c(4, 5, 6),
  1529. c(NA, NA, NA),
  1530. c(7, 8, 9),
  1531. c(NA, NA, NA),
  1532. c(10, 11, 12)
  1533. )
  1534. )
  1537. print(combined_plot_effects)
  1538. ```
  1541. ## Predicting speech rate from comprehension
  1542. Does comprehension change with Speech Rate?
  1544. ```{r}
  1545. model_rate <- lmer(speech_rate ~
  1546. trial_median_rescaled +
  1547. glove_sum_max_similarity_rescaled +
  1548. likert_rescaled +
  1549. multiple_choice_accuracy +
  1550. (1 | digit_span_score) +
  1551. (1 | digit_in_noise_score), data = df.data)
  1553. summary(model_rate)
  1554. ```
  1556. ### Figure: Estimates of fixed effects (comprehension measures) on Speech Rate
  1557. ```{r}
  1558. # Extract the fixed effects from the model (including confidence intervals)
  1559. fixed_effects <- tidy(model_rate, effects = "fixed", conf.int = TRUE)
  1561. # Filter out the intercept term
  1562. fixed_effects <- fixed_effects %>%
  1563. filter(term != "(Intercept)")
  1565. # Map the actual terms to custom axis labels
  1566. term_mapping <- c(
  1567. "multiple_choice_accuracy" = "Multiple Choice Question Accuracy",
  1568. "glove_sum_max_similarity_rescaled" = "Summary Semantic Similarity",
  1569. "likert_rescaled" = "10-Point Scale",
  1570. "trial_median_rescaled" = "Median Real-Time Comprehension"
  1571. )
  1573. # Replace the term names with custom labels
  1574. fixed_effects <- fixed_effects %>%
  1575. mutate(term = recode(term, !!!term_mapping))
  1577. # Reorder the terms based on the estimate values in descending order
  1578. fixed_effects <- fixed_effects %>%
  1579. mutate(term = reorder(term, -estimate))
  1581. # Add a column for significance stars based on p-values
  1582. fixed_effects <- fixed_effects %>%
  1583. mutate(sig_stars = case_when(
  1584. p.value < 0.001 ~ "***",
  1585. p.value < 0.01 ~ "**",
  1586. p.value < 0.05 ~ "*",
  1587. TRUE ~ ""
  1588. ))
  1590. # Plot with ggplot2 - swapped x and y axes
  1591. ggplot(fixed_effects, aes(y = term, x = estimate)) + # Swapped axes
  1592. geom_point(aes(color = term), size = 3) + # Add color to the points
  1593. geom_errorbarh(aes(xmin = conf.low, xmax = conf.high, color = term),
  1594. height = 0,
  1595. width = 0) +
  1596. geom_text(aes(label = paste0(round(estimate, 2), sig_stars)), vjust = -1, size = 4) +
  1597. scale_color_manual(values = c(
  1598. "Multiple Choice Question Accuracy" = "violetred",
  1599. "10-Point Scale" = "royalblue",
  1600. "Summary Semantic Similarity" = "green3",
  1601. "Median Real-Time Comprehension" = "purple"
  1602. )) +
  1603. labs(title = " ",
  1604. x = "Regression Coefficient Estimates",
  1605. y = NULL) +
  1606. theme(
  1607. plot.title = element_text(hjust = 0.5, size = 18),
  1608. axis.title.x = element_text(size = 13),
  1609. axis.text.y = element_text(size = 13, color = "black"),
  1610. axis.text.x = element_text(size = 12)
  1611. ) +
  1612. guides(color = "none")
  1614. ```
  1617. ## III. Multiple Choice Questions Diagnosis
  1618. Are questions comparable in difficulty?
  1620. Take all stories presented at 1x. (divide by questions and average across participants for that item)
  1621. ```{r figure-size, fig.width=6, fig.height=6}
  1623. pid <- "participant"
  1625. # 1) per-participant accuracy for each QUESTION at 1×
  1626. by_pp_1x <- df.data %>%
  1627. filter(speech_rate == 1,
  1628. !is.na(question), !is.na(.data[[pid]]),
  1629. !is.na(multiple_choice_accuracy)) %>%
  1630. group_by(.data[[pid]], question) %>%
  1631. summarise(acc = mean(multiple_choice_accuracy, na.rm = TRUE), .groups = "drop")
  1633. # 2) per-question mean accuracy + n participants
  1634. q_summary_1x <- by_pp_1x %>%
  1635. group_by(question) %>%
  1636. summarise(
  1637. mean_acc = mean(acc, na.rm = TRUE),
  1638. n_participants = n(),
  1639. .groups = "drop"
  1640. )
  1642. # quick stats (optional)
  1643. summary_1x <- q_summary_1x %>%
  1644. summarise(
  1645. n_questions = n(),
  1646. mean = mean(mean_acc), median = median(mean_acc),
  1647. sd = sd(mean_acc), iqr = IQR(mean_acc)
  1648. )
  1649. print(round(summary_1x, 3))
  1651. # histogram
  1652. # counts of per-question means rounded to 2 decimals
  1653. counts_2dp <- q_summary_1x %>%
  1654. mutate(mean_acc_2dp = round(mean_acc, 1)) %>%
  1655. count(mean_acc_2dp) %>%
  1656. arrange(mean_acc_2dp)
  1658. ggplot(counts_2dp,
  1659. aes(x = factor(mean_acc_2dp, levels = sort(unique(mean_acc_2dp))), y = n)) +
  1660. scale_x_discrete(expand = c(0,0)) +
  1661. scale_y_continuous(expand = c(0,0), limits = c(0, NA))+
  1662. geom_col(width = 0.75, color = "white") +
  1663. labs(x = "Accuracy", y = "Number of questions", title = "") +
  1664. theme_classic(base_size = 20)
  1666. tbl_1x <- df.data %>%
  1667. filter(speech_rate == 1,
  1668. !is.na(question), !is.na(.data[[pid]]),
  1669. !is.na(multiple_choice_accuracy)) %>%
  1670. # per-participant accuracy per question (in case of multiple trials)
  1671. group_by(.data[[pid]], question) %>%
  1672. summarise(acc = mean(multiple_choice_accuracy, na.rm = TRUE), .groups = "drop") %>%
  1673. # average across participants
  1674. group_by(question) %>%
  1675. summarise(
  1676. n_participants = n(),
  1677. mean_accuracy = mean(acc, na.rm = TRUE),
  1678. .groups = "drop"
  1679. ) %>%
  1680. mutate(mean_accuracy = round(mean_accuracy, 2)) %>% # 2 decimals
  1681. arrange(desc(mean_accuracy))
  1683. tbl_1x
  1684. ```
  1685. Distribution of per-question accuracy averaged across participants for speech rate x1

data_analysis.Rmd at commit b741b80, no license · at the source

Overview

Authors: Irmak Ergin1,2,3, Jill Kries1,2, Shiven Gupta2, Maria Papworth Burrel1,2, Laura Gwilliams1,2,3
ORCID iDs: Irmak Ergin, Jill Kries, Maria Papworth Burrel, Laura Gwilliams
  1. Department of Psychology, Stanford University,Stanford, CA USA
  2. Wu Tsai Neurosciences Institute, Stanford University,Stanford, CA USA
  3. Stanford Data Science, Stanford University,Stanford, CA USA
Institutions: Stanford University (United States)
Journal: Behavior research methods, volume 58, issue 4, article 93
Dates: received 3 May 2025; accepted 19 December 2025; published online 27 March 2026; in print 2026
Type: Research article · Language: English
License: CC BY
Identifiers: DOI 10.3758/s13428-026-02941-1 · PMID 41896392 · PMCID PMC13031255 · OpenAlex W7141543328
Open access: hybrid, a free copy (OpenAlex)
Status: code verified (how the code is found and verified)
Categories: human (organism), cognitive (subfield)
Keywords: Speech comprehension, Naturalistic, Real-time measurement, Language
MeSH: Comprehension*, Speech*, Speech Perception*, Adult, Female, Humans, Male, Young Adult (* major topic)
Journal subjects: Original Manuscript
Topic: Neuroscience and Music Perception (Cognitive Neuroscience, Neuroscience), according to OpenAlex
Funding: LG: BRAIN Foundation (A-0741551370); Whitehall Foundation (2024-08-04); Esther A. and Joseph Klingenstein Fund (Esther A. & Joseph Klingenstein Fund, Inc.)
Citations: not cited yet (Europe PMC); 81 references in the paper

Abstract

Speech comprehension has been described as an effortless and robust process; yet, in real-world contexts, it is common for a listener to misunderstand what was said or fail to derive meaning entirely. Typically, methods of measuring speech comprehension are applied ‘post hoc’ - that is, after the comprehension has happened. This approach fails to capture comprehension as it occurs, limiting the field’s understanding of the cognitive processes involved in real-time comprehension. To overcome these challenges, we designed and tested a novel method of measuring real-time speech comprehension during naturalistic listening. We built a slider device that synchronizes with experimental software and provides millisecond read-out. In three experiments, participants listened to audiobook segments while providing continuous comprehension ratings using the slider. To vary comprehension success, we presented speech segments at speed factors of 1–5 times faster than normal. We validated the time-resolved slider data against established speech comprehension assessment methods. Overall, our findings validate our novel time-resolved comprehension measure and demonstrate that it is possible to derive an online behavioral measure of real-time speech comprehension. We also confirmed numerous limitations of static post hoc assessments, including challenges with multiple-choice question design and the confounding of potential effects due to recency bias and comprehension for summarization. The measure proposed here overcomes the constraints of static post hoc assessments and can be effectively integrated with neuroimaging techniques, offering a valuable tool for future research on dynamic processes during naturalistic listening.

Supplementary Information: The online version contains supplementary material available at 10.3758/s13428-026-02941-1.

Reproduced under the paper's license (CC BY), from the paper cited above.

Repository

Its files are read in the Code ↔ Paper reader above, with 16 matches between paragraphs and lines of code.

irmak-ergin/measuring_naturalistic_speech_comprehension_2024

License: none: the authors keep all their rights
State: the link answers, verified on 30 September 2026
Evidence: files inventoried
Commit: b741b80d2cf99b80484da4fdb781af702bb04092, 3 May 2026
Languages: Jupyter (7), R (4), Python (4), JavaScript (2)
Size: 529 files, 17 scripts
Software Heritage: not archived
Found in: “Data and Code Availability”
Holds: README, 11 notebooks
Not found: license file, CITATION.cff, environment file, tests, continuous integration, documentation
Tools: NumPy (7 files), Matplotlib (6 files), pandas (6 files), scikit-learn (5 files), seaborn (5 files), SciPy (4 files), broom (3 files), caret (3 files), cowplot (3 files), ggplot2 (3 files), lmerTest (3 files), patchwork (3 files), rstatix (3 files), statsmodels (3 files), tidyverse (3 files), emmeans (2 files), lme4 (2 files), multcomp (1 file), PsychoPy (1 file)
Availability: 1 check, the latest on 30 September 2026: the link answers
  • 30 September 2026: the link answers
14 files
At the source: github.com/irmak-ergin/measuring_naturalistic_speech_comprehension_2024

The paper's code and data availability statement is in the Data section.

Tracing map

Proposed by the machine: these links were found in the paper and verified at the source, without human review. The map will receive a Zenodo DOI once one of the paper's authors has validated it with their ORCID.

What the map holds:

  • 1 repository of the authors' code, each at its verified commit, with its license and how the link was found in the paper;
  • 13 scripts, each with its path and the digest of its content;
  • 16 matches between paragraphs of the paper and lines of the code (method lexical-v1);
  • neither the text of the paper nor the code itself.

Its JSON (tracing-map.json) is deposited on Zenodo with its DOI once the map is validated.

Data

Datasets cited

Data and Code Availability

Data is available at https://osf.io/zk3c5/files/osfstorage, and code and experiment files are publicly available at https://github.com/irmak-ergin/measuring_naturalistic_speech_comprehension_2024. You can find the preregistration and link to the GitHub repository on doi.org/10.17605/OSF.IO/F5UZ8 as well. The design, analyses, and participant-exclusion criteria for Experiment 1 were preregistered. The only exploratory analyses not preregistered were the recency analysis and the investigation of the nature of decline in comprehension (linear vs categorical decline). Experiments 2 and 3 were conducted after preregistration, during the review process.

Reproduced under the paper's license (CC BY), from the paper cited above.

Versions

The history of this record: each version stored by the harvester or made by a correction of its authors or of the maintainers of its code, and what changed in its facts. The texts of the paper (its abstract, its availability statements) are not part of it; versions that changed only those are not listed.

Version 1, 30 September 2026: the first record

Recorded: type, language, journal, volume, issue, pages, dates, 5 authors, 4 keywords, 8 MeSH terms, 3 funders, 56 references.

Cite

This paper

Ergin, I., Kries, J., Gupta, S., Papworth Burrel, M., & Gwilliams, L. (2026). Measuring naturalistic speech comprehension in real time. Behavior research methods, 58(4), 93. https://doi.org/10.3758/s13428-026-02941-1

BibTeX

@article{ergin2026measuring,
author = {Ergin, Irmak and Kries, Jill and Gupta, Shiven and Papworth Burrel, Maria and Gwilliams, Laura},
title = {{Measuring naturalistic speech comprehension in real time}},
journal = {Behavior research methods},
year = {2026},
month = mar,
volume = {58},
number = {4},
pages = {93},
publisher = {Springer Science+Business Media},
issn = {1554-351X},
doi = {10.3758/s13428-026-02941-1},
url = {https://doi.org/10.3758/s13428-026-02941-1},
pmid = {41896392},
pmcid = {PMC13031255}
}

RIS

TY - JOUR
AU - Ergin, Irmak
AU - Kries, Jill
AU - Gupta, Shiven
AU - Papworth Burrel, Maria
AU - Gwilliams, Laura
TI - Measuring naturalistic speech comprehension in real time
T2 - Behavior research methods
J2 - Behav Res Methods
PY - 2026
DA - 2026/03/27
VL - 58
IS - 4
SP - 93
SN - 1554-351X
PB - Springer Science+Business Media
DO - 10.3758/s13428-026-02941-1
UR - https://doi.org/10.3758/s13428-026-02941-1
LA - en
ER -

CSL-JSON

{
"id": "10.3758/s13428-026-02941-1",
"type": "article-journal",
"title": "Measuring naturalistic speech comprehension in real time",
"container-title": "Behavior research methods",
"author": [
{
"family": "Ergin",
"given": "Irmak"
},
{
"family": "Kries",
"given": "Jill"
},
{
"family": "Gupta",
"given": "Shiven"
},
{
"family": "Papworth Burrel",
"given": "Maria"
},
{
"family": "Gwilliams",
"given": "Laura"
}
],
"container-title-short": "Behav Res Methods",
"volume": "58",
"issue": "4",
"page": "93",
"DOI": "10.3758/s13428-026-02941-1",
"PMID": "41896392",
"PMCID": "PMC13031255",
"ISSN": "1554-351X",
"publisher": "Springer Science+Business Media",
"URL": "https://doi.org/10.3758/s13428-026-02941-1",
"language": "en",
"issued": {
"date-parts": [
[
2026,
3,
27
]
]
}
}

The tracing map gets a citation of its own once an author has validated it and it has a DOI.

Similar papers

The papers with a page that share the most with this one: the tools found in their code, their categories, datasets, cited references and authors, the rarest counting most.

[1] doi:10.1523/jneurosci.1001-25.2025 [code]
The Spatio-Temporal Dynamics of Phoneme Encoding in Aging and Aphasia.
Journal: The Journal of neuroscience : the official journal of the Society for Neuroscience
In common: seaborn, scikit-learn, pandas, 3 other tools, cognitive, 5 references, 2 authors
[2] doi:10.1371/journal.pbio.3003588 [code]
Sensory sharpening and semantic prediction errors unify competing models of predictive processing in human speech comprehension.
Journal: PLoS biology
In common: PsychoPy, emmeans, lmerTest, 8 other tools, cognitive, 8 references
[3] doi:10.1126/sciadv.ado8915 [code]
The human auditory cortex concurrently tracks syllabic and phonemic timescales via acoustic spectral flux.
Journal: Science advances
In common: multcomp, emmeans, lmerTest, 8 other tools, 6 references
[4] doi:10.1523/jneurosci.0657-25.2025 [code]
Attentional Engagement with Target and Distractor Streams Predicts Speech Comprehension in Multitalker Environments.
Journal: The Journal of neuroscience : the official journal of the Society for Neuroscience
In common: rstatix, emmeans, lmerTest, 9 other tools, cognitive, 5 references
[5] doi:10.1162/nol_a_00081 [code]
Causal Contributions of the Domain-General (Multiple Demand) and the Language-Selective Brain Networks to Perceptual and Semantic Challenges in Speech Comprehension.
Journal: Neurobiology of language (Cambridge, Mass.)
In common: rstatix, emmeans, lmerTest, 4 other tools, cognitive, 6 references
[6] doi:10.1002/hbm.26305 [code]
Cortical haemodynamic responses predict individual ability to recognise vocal emotions with uninformative pitch cues but do not distinguish different emotions.
Journal: Human brain mapping
In common: multcomp, caret, broom, 9 other tools, cognitive, 2 references
[7] doi:10.1523/eneuro.0069-26.2026 [code]
Electrophysiological Indices of Hierarchical Speech Processing Differentially Reflect the Comprehension of Speech in Noise.
Journal: eNeuro
In common: emmeans, lmerTest, cognitive, 10 references
[8] doi:10.1038/s41598-024-69602-1 [code]
Neural encoding of linguistic speech cues is unaffected by cognitive decline, but decreases with increasing hearing impairment.
Journal: Scientific reports
In common: emmeans, lmerTest, lme4, 8 other tools, cognitive, 5 references
[9] doi:10.1093/bioinformatics/btag592 [code]
Network-based stratification of allele-specific expression reveals patient subgroups in Huntington's disease.
Journal: Bioinformatics (Oxford, England)
In common: multcomp, broom, rstatix, 12 other tools
[10] doi:10.1016/j.dcn.2023.101251 [code]
Age and vocabulary knowledge differentially influence the N400 and theta responses during semantic retrieval.
Journal: Developmental cognitive neuroscience
In common: multcomp, broom, rstatix, 9 other tools, 2 references

Contribute

The authors of this paper can claim it, correct its record and validate its tracing map, and the maintainers of its code (its owner, or a public member of its organization) correct what it says of their repository; anyone signed in can ask for its removal. Every request goes to OSCR's own machine, which answers it; your account page follows them.

Sign in with ORCID to claim this paper as one of its authors, correct its record or validate its tracing map: when the paper's metadata lists your ORCID iD, you are recognized at once. Maintainers of its code: sign in with GitHub, then claim the repository on your account page.

Add the badge to the code's README

OSCR: the badge of this paper

If you are an author or a maintainer of this paper's code, you can add this badge. It says what OSCR knows of the paper (its code, its validated tracing map) and links the code to this page. Paste one of these snippets under the README's title. Keep the two marks around it, so that the badge can be replaced in place and is never added twice. OSCR changes nothing in your repository.

Markdown
<!-- oscr-badge:start -->
[![OSCR](https://openscicode.org/badge/doi/10.3758/s13428-026-02941-1.svg)](https://openscicode.org/badge/doi/10.3758/s13428-026-02941-1)
<!-- oscr-badge:end -->
reStructuredText
.. oscr-badge:start

.. image:: https://openscicode.org/badge/doi/10.3758/s13428-026-02941-1.svg
   :target: https://openscicode.org/badge/doi/10.3758/s13428-026-02941-1
   :alt: OSCR

.. oscr-badge:end
HTML
<!-- oscr-badge:start -->
<a href="https://openscicode.org/badge/doi/10.3758/s13428-026-02941-1"><img src="https://openscicode.org/badge/doi/10.3758/s13428-026-02941-1.svg" alt="OSCR"></a>
<!-- oscr-badge:end -->

On GitHub, open the README, choose Edit (the pencil), paste the snippet under the title, then "Commit changes".

If you choose to, you can have the badge kept up to date for you, with oscr badge --write from the command line or with the GitHub Action in your repository's workflows. Every other form and option (a card, AsciiDoc, LaTeX, shields.io) is on the badge page.

Request its removal

To ask OSCR to remove this record, the copies of its authors' scripts or its tracing map, use the removal request page: signed in, you say who you are, what to remove and why, then review and confirm the request. Published rules decide every request (how).

Discussion, reproductions, activity

Discussion: code errors and mismatches between the code and the paper about this paper and its code, from readers and its authors, beside the paper and its tracing map.

Report a mismatch between the code and the paper · Report a code error (signed in)

Reproductions: reports from readers who ran the authors' code and did not get the paper's result, what they ran, with which environment, commit and data.

Report a reproduction failure (signed in)

Versions of its code: the releases of its code tied to a version of this paper (the preprint, the accepted manuscript, the version of record…), each with the tracing map versioned with it.

Activity: what happens around this paper: new versions of its record, its map's validation, discussions and reproductions. It opens with sign-in.