CHI 2025 - Facial Inputs Study 1
Mark McGill
2025-02-07
Analysis for Study 1 - participants performed 3 trials * 53 target facial action units sensed by a Meta Quest Pro, each trial lasting around 3 seconds in the “do/hold this as comfortably and accurately as possible” or some such. In each trial, we logged not just the FAU they were asked to perform, but all the other 52 FAU “scores” (a magic activation number between 0..1 reported by the Meta SDK).
##
## Attaching package: 'dplyr'## The following objects are masked from 'package:plyr':
##
## arrange, count, desc, failwith, id, mutate, rename, summarise,
## summarize## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union##
## Attaching package: 'purrr'## The following object is masked from 'package:scales':
##
## discard## The following object is masked from 'package:plyr':
##
## compact## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ lubridate 1.9.3 ✔ tibble 3.2.1
## ✔ readr 2.1.5 ✔ tidyr 1.3.1
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::arrange() masks plyr::arrange()
## ✖ readr::col_factor() masks scales::col_factor()
## ✖ purrr::compact() masks plyr::compact()
## ✖ dplyr::count() masks plyr::count()
## ✖ dplyr::desc() masks plyr::desc()
## ✖ purrr::discard() masks scales::discard()
## ✖ dplyr::failwith() masks plyr::failwith()
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::id() masks plyr::id()
## ✖ dplyr::lag() masks stats::lag()
## ✖ dplyr::mutate() masks plyr::mutate()
## ✖ dplyr::rename() masks plyr::rename()
## ✖ dplyr::summarise() masks plyr::summarise()
## ✖ dplyr::summarize() masks plyr::summarize()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorsParsing the FAU data from Study 1
Lots of csv files split in folders by participant. Common headers we’ll use are PID for participant ID; and AUofFocus for the AU they were performing during the trial/task.
Grab the released data as “resting face” data for the model, written to “data.recording_released.csv”.
data.recording_released <- data.recording_raw %>% filter(TimeInTrial > 3500 & TrialPhase == "released") # %>% select (-c(TrialNo, TrialPhase, TimeInTrial, EndOfTrialFrame, TrialFrameNo))
# get the various IDs we need for later
FAUs <- levels(factor(data.recording_released$AUofFocus))
PIDs <- levels(factor(data.recording_released$PID))
for( i in rownames(data.recording_released) ){
data.recording_released[i, "AUofFocusValue"] = data.recording_released[i, data.recording_released[i, "AUofFocus", drop=TRUE], drop=TRUE]
}
write.csv(data.recording_released, "r_outputs/data.recording_released.csv", row.names=FALSE)
data.recording_released## # A tibble: 38,693 × 61
## PID AUofFocus TrialNo TrialPhase TimeInTrial EndOfTrialFrame TrialFrameNo
## <dbl> <chr> <dbl> <chr> <dbl> <lgl> <dbl>
## 1 1 BrowLowere… 1 released 3506 FALSE 89
## 2 1 BrowLowere… 1 released 3534 FALSE 90
## 3 1 BrowLowere… 1 released 3575 FALSE 91
## 4 1 BrowLowere… 1 released 3617 FALSE 92
## 5 1 BrowLowere… 1 released 3659 FALSE 93
## 6 1 BrowLowere… 1 released 3701 FALSE 94
## 7 1 BrowLowere… 1 released 3728 FALSE 95
## 8 1 BrowLowere… 1 released 3770 FALSE 96
## 9 1 BrowLowere… 1 released 3811 FALSE 97
## 10 1 BrowLowere… 1 released 3839 FALSE 98
## # ℹ 38,683 more rows
## # ℹ 54 more variables: BrowLowererL <dbl>, BrowLowererR <dbl>,
## # CheekPuffL <dbl>, CheekPuffR <dbl>, CheekRaiserL <dbl>, CheekRaiserR <dbl>,
## # CheekSuckL <dbl>, CheekSuckR <dbl>, ChinRaiserB <dbl>, ChinRaiserT <dbl>,
## # DimplerL <dbl>, DimplerR <dbl>, InnerBrowRaiserL <dbl>,
## # InnerBrowRaiserR <dbl>, JawDrop <dbl>, JawSidewaysLeft <dbl>,
## # JawSidewaysRight <dbl>, JawThrust <dbl>, LidTightenerL <dbl>, …Filter FAU Data by Trial Time
Filter the recording data based on a sensible window within the trial, to account for noise at the start/end of the FAU, and extract the values for the AUofFocus from the massive table of FAU values for simplicity
data.recording_filtered <- data.recording_raw %>% filter(TimeInTrial > 500 & TimeInTrial <2500 & TrialPhase == "holding") # %>% select (-c(TrialNo, TrialPhase, TimeInTrial, EndOfTrialFrame, TrialFrameNo))
# get the various IDs we need for later
FAUs <- levels(factor(data.recording_filtered$AUofFocus))
PIDs <- levels(factor(data.recording_filtered$PID))
for( i in rownames(data.recording_filtered) ){
data.recording_filtered[i, "AUofFocusValue"] = data.recording_filtered[i, data.recording_filtered[i, "AUofFocus", drop=TRUE], drop=TRUE]
}
head(data.recording_filtered)## # A tibble: 6 × 61
## PID AUofFocus TrialNo TrialPhase TimeInTrial EndOfTrialFrame TrialFrameNo
## <dbl> <chr> <dbl> <chr> <dbl> <lgl> <dbl>
## 1 1 BrowLowererL 1 holding 541 FALSE 14
## 2 1 BrowLowererL 1 holding 583 FALSE 15
## 3 1 BrowLowererL 1 holding 625 FALSE 16
## 4 1 BrowLowererL 1 holding 653 FALSE 17
## 5 1 BrowLowererL 1 holding 693 FALSE 18
## 6 1 BrowLowererL 1 holding 721 FALSE 19
## # ℹ 54 more variables: BrowLowererL <dbl>, BrowLowererR <dbl>,
## # CheekPuffL <dbl>, CheekPuffR <dbl>, CheekRaiserL <dbl>, CheekRaiserR <dbl>,
## # CheekSuckL <dbl>, CheekSuckR <dbl>, ChinRaiserB <dbl>, ChinRaiserT <dbl>,
## # DimplerL <dbl>, DimplerR <dbl>, InnerBrowRaiserL <dbl>,
## # InnerBrowRaiserR <dbl>, JawDrop <dbl>, JawSidewaysLeft <dbl>,
## # JawSidewaysRight <dbl>, JawThrust <dbl>, LidTightenerL <dbl>,
## # LidTightenerR <dbl>, LipCornerDepressorL <dbl>, …write.csv(data.recording_filtered, "r_outputs/data.recording_filtered.csv", row.names=FALSE)FAU Activation - Resting State
For each AU captured alongside the AUofFocus, we want to calculate the value - resting face value captured at the start of the study
data.recording_filtered_resting_face = NULL
# Overwrite the FAU values to be trial value - resting face value
for(i in PIDs ){
recorded_subset = subset(data.recording_filtered, PID == i)
for (FAU in FAUs){
resting_face_subset <- data.resting_face_raw %>% filter(PID == i & AUofFocus == FAU)
resting_face_default <- resting_face_subset$`Calibration Threshold`
recorded_subset[paste0(FAU)] <- recorded_subset[paste0(FAU)] - resting_face_default
}
data.recording_filtered_resting_face <- rbind(data.recording_filtered_resting_face, recorded_subset)
}
# zero any negative values as this ranges from 0..1
#FAUs_RF <- paste(FAUs, "_Minus_RF", sep="")
data.recording_filtered_resting_face[FAUs] <- lapply(data.recording_filtered_resting_face[FAUs], function(x) ifelse(x < 0.0, 0.0, x))
# then overwrite the AUofFocusValue data with the new values
for( i in rownames(data.recording_filtered_resting_face) ){
data.recording_filtered_resting_face[i, "AUofFocusValue"] = data.recording_filtered_resting_face[i, data.recording_filtered_resting_face[i, "AUofFocus", drop=TRUE], drop=TRUE]
}
# order AUofFocus alphabetically
data.recording_filtered_resting_face$AUofFocus <- factor(data.recording_filtered_resting_face$AUofFocus)
head(data.recording_filtered_resting_face)## # A tibble: 6 × 61
## PID AUofFocus TrialNo TrialPhase TimeInTrial EndOfTrialFrame TrialFrameNo
## <dbl> <fct> <dbl> <chr> <dbl> <lgl> <dbl>
## 1 1 BrowLowererL 1 holding 541 FALSE 14
## 2 1 BrowLowererL 1 holding 583 FALSE 15
## 3 1 BrowLowererL 1 holding 625 FALSE 16
## 4 1 BrowLowererL 1 holding 653 FALSE 17
## 5 1 BrowLowererL 1 holding 693 FALSE 18
## 6 1 BrowLowererL 1 holding 721 FALSE 19
## # ℹ 54 more variables: BrowLowererL <dbl>, BrowLowererR <dbl>,
## # CheekPuffL <dbl>, CheekPuffR <dbl>, CheekRaiserL <dbl>, CheekRaiserR <dbl>,
## # CheekSuckL <dbl>, CheekSuckR <dbl>, ChinRaiserB <dbl>, ChinRaiserT <dbl>,
## # DimplerL <dbl>, DimplerR <dbl>, InnerBrowRaiserL <dbl>,
## # InnerBrowRaiserR <dbl>, JawDrop <dbl>, JawSidewaysLeft <dbl>,
## # JawSidewaysRight <dbl>, JawThrust <dbl>, LidTightenerL <dbl>,
## # LidTightenerR <dbl>, LipCornerDepressorL <dbl>, …write.csv(data.recording_filtered_resting_face, "r_outputs/data.recording_filtered_resting_face.csv", row.names=FALSE)FAU Activation
Calculate a per-participant per-FAU activation threshold based on the participant’s performance data
Reasonable approach is to calculate a confidence interval for the values and pick a threshold based on the lower bound.
# standard error
se <- function(x, na.rm=FALSE) {
if (na.rm) x <- na.omit(x)
sqrt(var(x)/length(x))
}
# confidence interval
conf <- 0.01
quantile <- qnorm(1-conf/2)
data.thresholds <- data.recording_filtered_resting_face %>%
group_by(PID, AUofFocus) %>%
select(c(AUofFocusValue)) %>%
summarise(across(everything(), list(mean=mean, sd=sd, sum=sum, count=~ n(), max=max, se=se)))## Adding missing grouping variables: `PID`, `AUofFocus`
## `summarise()` has grouped output by 'PID'. You can override using the `.groups`
## argument.# what's a reasonable way of calculating everyones activation thresholds based on their performance???
# could take a percentage of peak?
data.thresholds$AUofFocus_CalculatedThreshold_Peak <- 0.8 * data.thresholds$AUofFocusValue_max
# or mean - std dev?
data.thresholds$AUofFocus_CalculatedThreshold_Mean <- data.thresholds$AUofFocusValue_mean - data.thresholds$AUofFocusValue_sd
# or base it on a lower CI?
data.thresholds$AUofFocus_CIUpper <- data.thresholds$AUofFocusValue_mean + (quantile* data.thresholds$AUofFocusValue_se)
data.thresholds$AUofFocus_CILower <- data.thresholds$AUofFocusValue_mean - (quantile* data.thresholds$AUofFocusValue_se)
# whatever it is we pick, stick it into this column
data.thresholds$AUofFocus_Threshold <- data.thresholds$AUofFocus_CILower
#data.thresholds$AUofFocus_Threshold <- data.thresholds$AUofFocus_CalculatedThreshold_Mean
data.thresholds <- data.thresholds %>% select(c(PID, AUofFocus, AUofFocus_Threshold))
# can't have thresholds lower than 0, and if a threshold is 0 then the AU is effectively unactivatable...
data.thresholds$AUofFocus_Threshold <- ifelse(data.thresholds$AUofFocus_Threshold < 0.0, 0.0, data.thresholds$AUofFocus_Threshold)
head(data.thresholds)## # A tibble: 6 × 3
## # Groups: PID [1]
## PID AUofFocus AUofFocus_Threshold
## <dbl> <fct> <dbl>
## 1 1 BrowLowererL 0.0205
## 2 1 BrowLowererR 0.185
## 3 1 CheekPuffL 0.0534
## 4 1 CheekPuffR 0.0181
## 5 1 CheekRaiserL 0.0564
## 6 1 CheekRaiserR 0.0936write.csv(data.thresholds, "r_outputs/data.thresholds.csv", row.names=FALSE)For each AU captured alongside the AUofFocus, calculate whether it met the calibrated activation threshold
data.recording_filtered_with_thresholds = NULL
# hacky, but doing this in a loop as brain is fried
for(i in PIDs ){
recorded_subset = subset(data.recording_filtered_resting_face, PID == i)
for (FAU in FAUs){
threshold_subset <- data.thresholds %>% filter(PID == i & AUofFocus == FAU)
threshold_value <- threshold_subset$`AUofFocus_Threshold`
recorded_subset[paste0(FAU, "_Activation")] <- ifelse(recorded_subset[FAU] > threshold_value , 1, 0)
}
data.recording_filtered_with_thresholds <- rbind(data.recording_filtered_with_thresholds, recorded_subset)
}
head(data.recording_filtered_with_thresholds)## # A tibble: 6 × 114
## PID AUofFocus TrialNo TrialPhase TimeInTrial EndOfTrialFrame TrialFrameNo
## <dbl> <fct> <dbl> <chr> <dbl> <lgl> <dbl>
## 1 1 BrowLowererL 1 holding 541 FALSE 14
## 2 1 BrowLowererL 1 holding 583 FALSE 15
## 3 1 BrowLowererL 1 holding 625 FALSE 16
## 4 1 BrowLowererL 1 holding 653 FALSE 17
## 5 1 BrowLowererL 1 holding 693 FALSE 18
## 6 1 BrowLowererL 1 holding 721 FALSE 19
## # ℹ 107 more variables: BrowLowererL <dbl>, BrowLowererR <dbl>,
## # CheekPuffL <dbl>, CheekPuffR <dbl>, CheekRaiserL <dbl>, CheekRaiserR <dbl>,
## # CheekSuckL <dbl>, CheekSuckR <dbl>, ChinRaiserB <dbl>, ChinRaiserT <dbl>,
## # DimplerL <dbl>, DimplerR <dbl>, InnerBrowRaiserL <dbl>,
## # InnerBrowRaiserR <dbl>, JawDrop <dbl>, JawSidewaysLeft <dbl>,
## # JawSidewaysRight <dbl>, JawThrust <dbl>, LidTightenerL <dbl>,
## # LidTightenerR <dbl>, LipCornerDepressorL <dbl>, …And do the same calculation for the AUofFocus (wrote this first, but no harm doing it this way as well - but this should end up just reproducing same results as if you looked up the AUofFocus’s Activation column from the previous block…). We’ll also join the “AU_categorisation.csv” data at this stage.
categories <- read.csv("Raw Data/AU_categorisation.csv", stringsAsFactors = FALSE)# Join the threshold data with the results
data.recording_filtered_with_thresholds <- data.recording_filtered_with_thresholds %>%
left_join(., data.thresholds, by = join_by(PID, AUofFocus))
# And join the AUofFocus data with our categorisation for plotting based on regions (if we want that? who knows!)
data.recording_filtered_with_thresholds <- data.recording_filtered_with_thresholds %>%
left_join(., categories, by = join_by(AUofFocus))
# Calculate AUofFocus activations based on threshold
data.recording_filtered_with_thresholds$AUofFocus_PositiveActivations = ifelse(data.recording_filtered_with_thresholds$AUofFocusValue > data.recording_filtered_with_thresholds$`AUofFocus_Threshold`, 1, 0)
#recording_data_filtered$PositiveActivationDuration = recording_data_filtered$PositiveActivations * 38 # rough average of milliseconds between each frame
head(data.recording_filtered_with_thresholds)## # A tibble: 6 × 119
## PID AUofFocus TrialNo TrialPhase TimeInTrial EndOfTrialFrame TrialFrameNo
## <dbl> <chr> <dbl> <chr> <dbl> <lgl> <dbl>
## 1 1 BrowLowererL 1 holding 541 FALSE 14
## 2 1 BrowLowererL 1 holding 583 FALSE 15
## 3 1 BrowLowererL 1 holding 625 FALSE 16
## 4 1 BrowLowererL 1 holding 653 FALSE 17
## 5 1 BrowLowererL 1 holding 693 FALSE 18
## 6 1 BrowLowererL 1 holding 721 FALSE 19
## # ℹ 112 more variables: BrowLowererL <dbl>, BrowLowererR <dbl>,
## # CheekPuffL <dbl>, CheekPuffR <dbl>, CheekRaiserL <dbl>, CheekRaiserR <dbl>,
## # CheekSuckL <dbl>, CheekSuckR <dbl>, ChinRaiserB <dbl>, ChinRaiserT <dbl>,
## # DimplerL <dbl>, DimplerR <dbl>, InnerBrowRaiserL <dbl>,
## # InnerBrowRaiserR <dbl>, JawDrop <dbl>, JawSidewaysLeft <dbl>,
## # JawSidewaysRight <dbl>, JawThrust <dbl>, LidTightenerL <dbl>,
## # LidTightenerR <dbl>, LipCornerDepressorL <dbl>, …write.csv(data.recording_filtered_with_thresholds, "r_outputs/data.recording_filtered_with_thresholds.csv", row.names=FALSE)Responsiveness
To examine responsiveness, find the first timepoint for each PID/trial where they hit the threshold for the AUofFocus
library(dplyr)
library(data.table)##
## Attaching package: 'data.table'## The following objects are masked from 'package:lubridate':
##
## hour, isoweek, mday, minute, month, quarter, second, wday, week,
## yday, year## The following object is masked from 'package:purrr':
##
## transpose## The following objects are masked from 'package:dplyr':
##
## between, first, lastdata.responsiveness = data.recording_filtered_with_thresholds %>%
group_by(PID, AUofFocus, TrialNo) %>%
mutate(want = ifelse(row_number()==min(which((AUofFocus_PositiveActivations >= 1) == TRUE)),
"yes", NA_character_)) %>% filter(want=="yes")## Warning: There were 864 warnings in `mutate()`.
## The first warning was:
## ℹ In argument: `want = ifelse(...)`.
## ℹ In group 19: `PID = 1`, `AUofFocus = "CheekSuckL"`, `TrialNo = 1`.
## Caused by warning in `min()`:
## ! no non-missing arguments to min; returning Inf
## ℹ Run `dplyr::last_dplyr_warnings()` to see the 863 remaining warnings.# this data is missing rows at this point because in some cases they never hit the threshold
# so we need to complete the data
head(data.responsiveness)## # A tibble: 6 × 120
## # Groups: PID, AUofFocus, TrialNo [6]
## PID AUofFocus TrialNo TrialPhase TimeInTrial EndOfTrialFrame TrialFrameNo
## <dbl> <chr> <dbl> <chr> <dbl> <lgl> <dbl>
## 1 1 BrowLowererL 1 holding 1418 FALSE 36
## 2 1 BrowLowererL 2 holding 516 FALSE 14
## 3 1 BrowLowererL 3 holding 501 FALSE 12
## 4 1 BrowLowererR 1 holding 1086 FALSE 28
## 5 1 BrowLowererR 2 holding 512 FALSE 13
## 6 1 BrowLowererR 3 holding 514 FALSE 13
## # ℹ 113 more variables: BrowLowererL <dbl>, BrowLowererR <dbl>,
## # CheekPuffL <dbl>, CheekPuffR <dbl>, CheekRaiserL <dbl>, CheekRaiserR <dbl>,
## # CheekSuckL <dbl>, CheekSuckR <dbl>, ChinRaiserB <dbl>, ChinRaiserT <dbl>,
## # DimplerL <dbl>, DimplerR <dbl>, InnerBrowRaiserL <dbl>,
## # InnerBrowRaiserR <dbl>, JawDrop <dbl>, JawSidewaysLeft <dbl>,
## # JawSidewaysRight <dbl>, JawThrust <dbl>, LidTightenerL <dbl>,
## # LidTightenerR <dbl>, LipCornerDepressorL <dbl>, …df1 <- expand.grid(PID = PIDs, AUofFocus = FAUs, TrialNo = c(1,2,3), TimeInTrial = 2000)
df1$PID <- factor(df1$PID)
data.responsiveness$PID <-factor(data.responsiveness$PID)
data.responsiveness = data.responsiveness %>% select(c(PID, AUofFocus, TrialNo, TimeInTrial))
data.responsiveness = data.responsiveness %>% full_join(df1, by=join_by(PID, AUofFocus, TrialNo))
data.responsiveness = data.responsiveness %>%
rowwise() %>%
mutate(TimeToActivation = min(TimeInTrial.x, TimeInTrial.y)) %>%
mutate(across(everything(), ~ ifelse(is.na(.), 2000, .))) %>%
select(-c(TimeInTrial.x, TimeInTrial.y))
head(data.responsiveness)## # A tibble: 6 × 4
## # Rowwise: PID, AUofFocus, TrialNo
## PID AUofFocus TrialNo TimeToActivation
## <fct> <chr> <dbl> <dbl>
## 1 1 BrowLowererL 1 1418
## 2 1 BrowLowererL 2 516
## 3 1 BrowLowererL 3 501
## 4 1 BrowLowererR 1 1086
## 5 1 BrowLowererR 2 512
## 6 1 BrowLowererR 3 514data.recording_filtered_with_thresholds$PID <- factor(data.recording_filtered_with_thresholds$PID)
data.recording_filtered_with_thresholds = data.recording_filtered_with_thresholds %>% left_join(data.responsiveness, by=join_by(PID, AUofFocus, TrialNo))
head(data.recording_filtered_with_thresholds)## # A tibble: 6 × 120
## PID AUofFocus TrialNo TrialPhase TimeInTrial EndOfTrialFrame TrialFrameNo
## <fct> <chr> <dbl> <chr> <dbl> <lgl> <dbl>
## 1 1 BrowLowererL 1 holding 541 FALSE 14
## 2 1 BrowLowererL 1 holding 583 FALSE 15
## 3 1 BrowLowererL 1 holding 625 FALSE 16
## 4 1 BrowLowererL 1 holding 653 FALSE 17
## 5 1 BrowLowererL 1 holding 693 FALSE 18
## 6 1 BrowLowererL 1 holding 721 FALSE 19
## # ℹ 113 more variables: BrowLowererL <dbl>, BrowLowererR <dbl>,
## # CheekPuffL <dbl>, CheekPuffR <dbl>, CheekRaiserL <dbl>, CheekRaiserR <dbl>,
## # CheekSuckL <dbl>, CheekSuckR <dbl>, ChinRaiserB <dbl>, ChinRaiserT <dbl>,
## # DimplerL <dbl>, DimplerR <dbl>, InnerBrowRaiserL <dbl>,
## # InnerBrowRaiserR <dbl>, JawDrop <dbl>, JawSidewaysLeft <dbl>,
## # JawSidewaysRight <dbl>, JawThrust <dbl>, LidTightenerL <dbl>,
## # LidTightenerR <dbl>, LipCornerDepressorL <dbl>, …% of Positive Activations Over Trial
Now we want to average by participant and AUOfFocus and calculate some percentages for the amount of activations of each FAU over the trials
# generate summary stats
data.recording_means <- data.recording_filtered_with_thresholds %>%
group_by(PID, AUofFocus) %>%
select(-c(BodyRegion, Side, TrialPhase, "AUofFocusSymmetrical")) %>%
relocate (c(AUofFocusValue, AUofFocus_PositiveActivations), .after = AUofFocus) %>% # move the new calculated columns to the front before all the interference stuff
summarise(across(everything(), list(mean=mean, sd=sd, sum=sum, count=~ n())))## `summarise()` has grouped output by 'PID'. You can override using the `.groups`
## argument.# calculate the percentage of time across the three trials the AUofFocus was active
data.recording_means$PositiveActivationPercentage <- (data.recording_means$AUofFocus_PositiveActivations_sum / data.recording_means$AUofFocus_PositiveActivations_count) * 100
# and do the same calculation for all the other FAUs to see what accidental activations occurred
for (FAU in FAUs){
data.recording_means[paste0(FAU, "_Activation_Percentage")] <- (data.recording_means[paste0(FAU, "_Activation_sum")] / data.recording_means[paste0(FAU, "_Activation_count")]) * 100
}
# figure out the columns needed to sum/count over all FAUs activation summary stats
SumFAUs <- paste(FAUs, "_Activation_sum", sep="")
CountFAUs <- paste(FAUs, "_Activation_count", sep="")
# and then calculate summaries for total accidental activations (excluding the AUofFocus)
data.recording_means <- data.recording_means %>%
mutate(TotalAccidentalActivations_Sum = rowSums(pick(SumFAUs)), na.rm = TRUE) %>%
mutate(TotalAccidentalActivations_Count = rowSums(pick(CountFAUs)), na.rm = TRUE)## Warning: There was 1 warning in `mutate()`.
## ℹ In argument: `TotalAccidentalActivations_Sum = rowSums(pick(SumFAUs))`.
## Caused by warning:
## ! Using an external vector in selections was deprecated in tidyselect 1.1.0.
## ℹ Please use `all_of()` or `any_of()` instead.
## # Was:
## data %>% select(SumFAUs)
##
## # Now:
## data %>% select(all_of(SumFAUs))
##
## See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.## Warning: There was 1 warning in `mutate()`.
## ℹ In argument: `TotalAccidentalActivations_Count = rowSums(pick(CountFAUs))`.
## Caused by warning:
## ! Using an external vector in selections was deprecated in tidyselect 1.1.0.
## ℹ Please use `all_of()` or `any_of()` instead.
## # Was:
## data %>% select(CountFAUs)
##
## # Now:
## data %>% select(all_of(CountFAUs))
##
## See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.data.recording_means$AccidentalActivationsPercentage <- ( (data.recording_means$TotalAccidentalActivations_Sum - data.recording_means$AUofFocus_PositiveActivations_sum) / (data.recording_means$TotalAccidentalActivations_Count-data.recording_means$AUofFocus_PositiveActivations_count) ) * 100
write.csv(data.recording_means, "r_outputs/data.recording_means.csv", row.names=FALSE)
head(data.recording_means)## # A tibble: 6 × 516
## # Groups: PID [1]
## PID AUofFocus AUofFocusValue_mean AUofFocusValue_sd AUofFocusValue_sum
## <fct> <chr> <dbl> <dbl> <dbl>
## 1 1 BrowLowererL 0.0281 0.0363 4.27
## 2 1 BrowLowererR 0.197 0.0540 28.8
## 3 1 CheekPuffL 0.0677 0.0688 10.3
## 4 1 CheekPuffR 0.0221 0.0192 3.34
## 5 1 CheekRaiserL 0.0663 0.0476 10.1
## 6 1 CheekRaiserR 0.0987 0.0242 14.9
## # ℹ 511 more variables: AUofFocusValue_count <int>,
## # AUofFocus_PositiveActivations_mean <dbl>,
## # AUofFocus_PositiveActivations_sd <dbl>,
## # AUofFocus_PositiveActivations_sum <dbl>,
## # AUofFocus_PositiveActivations_count <int>, TrialNo_mean <dbl>,
## # TrialNo_sd <dbl>, TrialNo_sum <dbl>, TrialNo_count <int>,
## # TimeInTrial_mean <dbl>, TimeInTrial_sd <dbl>, TimeInTrial_sum <dbl>, …Combined Dataset and Overall Score
Now we want to create the combined dataset - recorded data (with activation thresholds/responsiveness calculated), questionnaire data (after each set of trials), and calibration data - all grouped by PID and AUofFocus.
Values captured: Average Calibration Value Calibration Value STD %Calibration Value STD Avg Discomfort (lower is better) Avg Discomfort STD Avg Borg RPE (lower is better) Avg Borg RPE STD Avg Performance Avg Performance STD Usability Score (lower is better)
We also calculate our overall score here based on fatigue, performance, discomfort, and responsiveness.
data.all_results <- data.recording_means %>%
# full_join(calibration_data, by = join_by(PID, AUofFocus)) %>%
full_join(data.questionnaire_raw, by = join_by(PID, AUofFocus)) %>%
#relocate (c("Calibration Threshold", "Discomfort", "Borg RPE", "Performance", "PositiveActivationPercentage"), .after = PositiveActivationDuration_count) %>%
rename(BorgRPE = "Borg RPE")
# calculate a score to assess the "best" FAUs based on our measures
data.all_results$Score <- data.all_results$BorgRPE + data.all_results$Performance + data.all_results$Discomfort + ((data.all_results$TimeToActivation_mean/2000))*10 + ((1.0-data.all_results$AUofFocusValue_mean)*10)
data.all_results$TimeToActivation_mean = data.all_results$TimeToActivation_mean/1000
data.all_results <- data.all_results %>%
left_join(., categories, by = join_by(AUofFocus))
write.csv(data.all_results, "r_outputs/data.all_results.csv", row.names=FALSE)
head(data.all_results)## # A tibble: 6 × 523
## # Groups: PID [1]
## PID AUofFocus AUofFocusValue_mean AUofFocusValue_sd AUofFocusValue_sum
## <fct> <chr> <dbl> <dbl> <dbl>
## 1 1 BrowLowererL 0.0281 0.0363 4.27
## 2 1 BrowLowererR 0.197 0.0540 28.8
## 3 1 CheekPuffL 0.0677 0.0688 10.3
## 4 1 CheekPuffR 0.0221 0.0192 3.34
## 5 1 CheekRaiserL 0.0663 0.0476 10.1
## 6 1 CheekRaiserR 0.0987 0.0242 14.9
## # ℹ 518 more variables: AUofFocusValue_count <int>,
## # AUofFocus_PositiveActivations_mean <dbl>,
## # AUofFocus_PositiveActivations_sd <dbl>,
## # AUofFocus_PositiveActivations_sum <dbl>,
## # AUofFocus_PositiveActivations_count <int>, TrialNo_mean <dbl>,
## # TrialNo_sd <dbl>, TrialNo_sum <dbl>, TrialNo_count <int>,
## # TimeInTrial_mean <dbl>, TimeInTrial_sd <dbl>, TimeInTrial_sum <dbl>, …Plots
Plots for Responsiveness, Discomfort, Fatigue, Performance, Score
Generate the boxplots for each measure.
data.plots = data.all_results
data.plots$AUofFocus = factor(data.plots$AUofFocus)
data.plots$AUofFocusSymmetrical = factor(data.plots$AUofFocusSymmetrical)
data.plots = data.plots %>% mutate(AUofFocusSymmetrical = fct_rev(AUofFocusSymmetrical))
plot_AUofFocusVar <- function(plot_data, measure, reorder=FALSE){
#plot_data <- data
#plot_data$AUofFocus = plot_data$AUofFocusSymmetrical
#plot_data$AUofFocus = as.factor(plot_data$AUofFocus)
#plot_data <- plot_data %>% mutate(AUofFocus = factor(plot_data$AUofFocus))
#plot_data$AUofFocus <- factor(plot_data$AUofFocus, levels=rev(levels(plot_data$AUofFocus)))
if (reorder){
p <- ggplot(plot_data, aes(y=reorder(AUofFocusSymmetrical, .data[[measure]], mean), x=.data[[measure]], colour=AUofFocusSymmetrical))
} else {
p <- ggplot(plot_data, aes(y=AUofFocusSymmetrical, x=.data[[measure]], colour=AUofFocusSymmetrical))
}
p<- p + geom_boxplot(outlier.colour=NULL,
outlier.size=1) + theme(legend.position = "none") + ggtitle(measure) + stat_summary(fun = mean, geom = "point", size = 2) + geom_point(pch = ".", size = 3) + theme(plot.margin = margin(10, 10, 10, 10, "pt"))
print(p)
return(p)
}
plot.AUofFocusValue_mean = plot_AUofFocusVar(data.plots, "AUofFocusValue_mean") +xlab("Mean Activation") +ggtitle("Mean Activation") +labs(y="AUs of Focus - Alphabetical Order", colour=" - Alphabetical Order")
#plot.Thresholds = plot_AUofFocusVar(data.thresholds, "AUofFocus_Threshold") + xlab("Threshold")+ ggtitle("Threshold")
plot.TimeToActivation = plot_AUofFocusVar(data.plots, "TimeToActivation_mean") + xlab("Seconds")+ ggtitle("Responsiveness")+labs(y="AUs of Focus - Alphabetical Order", colour=" - Alphabetical Order")
plot.PositiveActivationPercentage = plot_AUofFocusVar(data.plots, "PositiveActivationPercentage") + xlim(0,100) + xlab("%")+ ggtitle("Activation %")+labs(y="AUs of Focus - Alphabetical Order", colour=" - Alphabetical Order")
plot.FalseActivationPercentage = plot_AUofFocusVar(data.plots, "AccidentalActivationsPercentage") + xlim(0,100)+ xlab("%")+ ggtitle("Other FAU\n Activations %")+labs(y="AUs of Focus - Alphabetical Order", colour=" - Alphabetical Order")
plot.Discomfort = plot_AUofFocusVar(data.plots, "Discomfort") + scale_x_continuous(breaks=c(0,2.5,5.0,7.5,10), limits=c(0,10), labels=c("Low", "", "", "", "High")) + ggtitle("Perceived\nDiscomfort")+labs(y="AUs of Focus - Alphabetical Order", colour=" - Alphabetical Order")
plot.BorgRPE = plot_AUofFocusVar(data.plots, "BorgRPE") + ggtitle("Perceived\nEffort") + xlab("Effort") + scale_x_continuous(breaks=c(0,2.5,5.0,7.5,10), limits=c(0,10), labels=c("Low", "", "", "", "High"))+labs(y="AUs of Focus - Alphabetical Order", colour=" - Alphabetical Order")
plot.Performance = plot_AUofFocusVar(data.plots, "Performance") + ggtitle("Perceived\nPerformance") + scale_x_continuous(breaks=c(0,2.5,5.0,7.5,10), limits=c(0,10), labels=c("Best", "", "", "", "Worst "))+labs(y="AUs of Focus - Alphabetical Order", colour=" - Alphabetical Order")
plot.Score = plot_AUofFocusVar(data.plots, "Score", reorder=TRUE) + scale_x_continuous(breaks=c(0,10,20,30,40,50), limits=c(0,50), labels=c("Best", "", "", "", "", "Worst ")) + theme(text = element_text(size = 14)) +labs(y="AUs of Focus - Descending Order", colour="AUs of Focus - Descending Order")
## Combi-plot for Paper - Figure 2 Layout 1.
#combi_plot <- plot.AUofFocusValue_mean + plot.TimeToActivation + plot.PositiveActivationPercentage + plot.FalseActivationPercentage + plot.Discomfort +plot.BorgRPE + #plot.Performance +plot.Score + plot_layout(ncol = 9, guides = "collect", axes= "collect")
#ExportPlot(combi_plot, "r_outputs/combi_plot", 14, 9)
layout <- "
ABCD
AEF#
"
combi_plot <- plot.Score + plot.AUofFocusValue_mean + plot.TimeToActivation + plot.Discomfort +plot.BorgRPE + plot.Performance + plot_layout(ncol = 3, guides = "collect", axes= "collect", design = layout)
ExportPlot(combi_plot, "r_outputs/combi_plot", 11, 11)
print(combi_plot)
Layout 2.
combi_plot = plot.AUofFocusValue_mean + plot.TimeToActivation + plot.Discomfort +plot.BorgRPE + plot.Performance +plot.Score + plot_layout(ncol = 6, guides = "collect", axes= "collect")
ExportPlot(combi_plot, "r_outputs/paper_combi_plot", 13, 7)
print(combi_plot)
Plot - Activation Matrix - Figure 3 Top
Plot by activation percentage.
#cols_to_select <- paste0(FAUs, "_Activation_Percentage", sep="")
cols_to_select = paste0(FAUs, "_mean", sep="")
cols_to_select <- prepend(cols_to_select, "AUofFocus")## Warning: `prepend()` was deprecated in purrr 1.0.0.
## ℹ Please use append(after = 0) instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.cols_to_select <- prepend(cols_to_select, "PID")
# average everything together
data.corr_plot <- data.all_results %>%
select(all_of(c(cols_to_select))) %>%
rename_with(~str_remove(., '_mean')) %>%
group_by(AUofFocus) %>%
summarise(across(FAUs, list(mean=mean))) %>%
rename_with(~str_remove(., '_mean'))# %>%## Warning: There was 1 warning in `summarise()`.
## ℹ In argument: `across(FAUs, list(mean = mean))`.
## Caused by warning:
## ! Using an external vector in selections was deprecated in tidyselect 1.1.0.
## ℹ Please use `all_of()` or `any_of()` instead.
## # Was:
## data %>% select(FAUs)
##
## # Now:
## data %>% select(all_of(FAUs))
##
## See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>. #select(-c(PID))
library(reshape2)##
## Attaching package: 'reshape2'## The following objects are masked from 'package:data.table':
##
## dcast, melt## The following object is masked from 'package:tidyr':
##
## smithsmelted_cormat <- melt(data.corr_plot, id=c("AUofFocus"))
melted_cormat <- rename(melted_cormat, ActivatedAUs = variable)
#head(data.corr_plot)
#head(melted_cormat)
tile_plot_1 <- ggplot(data = melted_cormat, aes(x=AUofFocus, y=ActivatedAUs, fill=value)) +
geom_tile() + theme(axis.text.x = element_text(angle = 90, vjust = 1, hjust=1)) + scale_fill_viridis_c(direction = -1, option = "plasma", limits=c(0,0.5))+ labs(fill="Mean\nActivation") + xlab("FAU of Focus") + ylab("Activated FAUs")
print(tile_plot_1)
ExportPlot(tile_plot_1, "r_outputs/tile_plot_activation", 10, 8)
# x / along the way tells you if the FAU was robust to false activation
# y / up and down tells you the FAUs that were likely falsely activated when trying that FAUPlot - Correlation Matrix - Figure 3 Bottom
Calculate correlations between the AUofFOcus and the other FAUs at the time the FAU gesture was being performed.
subset_FAUs <- FAUs # c("MouthLeft", "MouthRight", "CheekPuffL", "CheekPuffR", "JawDrop", "LidTightenerL", "LidTightenerR")
cols_to_select = paste0(subset_FAUs, "_mean", sep="")
cols_to_select <- prepend(cols_to_select, "AUofFocus")
cols_to_select <- prepend(cols_to_select, "PID")
data.corr_plot = data.all_results %>%
select(all_of(c(cols_to_select))) %>%
rename_with(~str_remove(., '_mean')) %>%
group_by(AUofFocus, PID) %>%
summarise(across(subset_FAUs, list(mean=mean))) %>%
rename_with(~str_remove(., '_mean')) %>% filter(AUofFocus %in% subset_FAUs)## Warning: There was 1 warning in `summarise()`.
## ℹ In argument: `across(subset_FAUs, list(mean = mean))`.
## Caused by warning:
## ! Using an external vector in selections was deprecated in tidyselect 1.1.0.
## ℹ Please use `all_of()` or `any_of()` instead.
## # Was:
## data %>% select(subset_FAUs)
##
## # Now:
## data %>% select(all_of(subset_FAUs))
##
## See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.## `summarise()` has grouped output by 'AUofFocus'. You can override using the
## `.groups` argument.# get the AU of focus value specifically for that row
for( i in rownames(data.corr_plot) ){
data.corr_plot[i, "AUofFocusValue"] = data.corr_plot[i, data.corr_plot[i, "AUofFocus", drop=TRUE], drop=TRUE]
}
#library(smplot2)
#ggplot(data = data.corr_plot, mapping = aes(x = MouthLeft, y = AUofFocusValue)) +
# geom_point(shape = 21, fill = "#0f993d", color = "white", size = 3) +
# sm_statCorr(
# color = "#0f993d", corr_method = "spearman",
# linetype = "dashed"
# ) +facet_wrap(.~AUofFocus)
data.corr_plot## # A tibble: 1,060 × 56
## # Groups: AUofFocus [53]
## AUofFocus PID BrowLowererL BrowLowererR CheekPuffL CheekPuffR CheekRaiserL
## <chr> <fct> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 BrowLower… 1 0.0281 0.0404 0 0 0.00561
## 2 BrowLower… 3 0.679 0.658 0 0 0.121
## 3 BrowLower… 7 0.165 0.118 0 0 0.00509
## 4 BrowLower… 8 0.000568 0.00118 0 0 0
## 5 BrowLower… 9 0.0260 0.00543 0 0 0
## 6 BrowLower… 10 0.0158 0.0128 1.40e-45 1.40e-45 0.0128
## 7 BrowLower… 12 0.108 0.0311 0 7.48e- 5 0.0815
## 8 BrowLower… 13 0.0547 0.0373 1.08e- 4 9.51e- 5 0.0159
## 9 BrowLower… 14 0.651 0.554 2.53e-19 3.14e-33 0.285
## 10 BrowLower… 15 0.560 0.492 0 0 0.277
## # ℹ 1,050 more rows
## # ℹ 49 more variables: CheekRaiserR <dbl>, CheekSuckL <dbl>, CheekSuckR <dbl>,
## # ChinRaiserB <dbl>, ChinRaiserT <dbl>, DimplerL <dbl>, DimplerR <dbl>,
## # InnerBrowRaiserL <dbl>, InnerBrowRaiserR <dbl>, JawDrop <dbl>,
## # JawSidewaysLeft <dbl>, JawSidewaysRight <dbl>, JawThrust <dbl>,
## # LidTightenerL <dbl>, LidTightenerR <dbl>, LipCornerDepressorL <dbl>,
## # LipCornerDepressorR <dbl>, LipCornerPullerL <dbl>, …# convert data to a matrix format for plotting
library(Hmisc)##
## Attaching package: 'Hmisc'## The following objects are masked from 'package:dplyr':
##
## src, summarize## The following objects are masked from 'package:plyr':
##
## is.discrete, summarize## The following objects are masked from 'package:base':
##
## format.pval, unitsmat <- outer(1:53, 1:53)
colnames(mat)<- FAUs
rownames(mat)<- FAUs
for( FAUofFocus in FAUs ){
for (FAUActivated in FAUs){
data.subset <- subset(data.corr_plot, AUofFocus== FAUofFocus)
x <- data.subset$AUofFocusValue
y <- data.subset[FAUActivated]
mycor<-cor(x=x, y=y, method = c("pearson"))
mat[FAUofFocus, FAUActivated] = mycor
}
}
# mat## convert to tibble, add row identifier, and shape "long"
dat2 <-
mat %>%
as_tibble(rownames = "Var1") %>%
pivot_longer(-Var1, names_to = "Var2", values_to = "value")
tile_plot_2 <- ggplot(data = dat2, aes(x=Var1, y=Var2, fill=value)) +
geom_tile() + theme(axis.text.x = element_text(angle = 90, vjust = 1, hjust=1)) + scale_fill_viridis_c(limits=c(-1, 1), direction = -1, option = "H") + xlab("FAU of Focus") + ylab("Activated FAUs") + labs(fill="Pearson\nCorrelation")
tile_plot_2
ExportPlot(tile_plot_2, "r_outputs/tile_plot_correlation", 10, 8)Combi-plot for paper - Figure 3
tile_combi <- tile_plot_1 + tile_plot_2 + plot_layout(ncol = 1, guides = "collect", axes= "collect")
tile_combi
ExportPlot(tile_combi, "r_outputs/tile_combi", 10, 13)Statistical Testing
ART Anovas to show differences here by AUofFocus (discomfort, exertion, performance, score)
data_symmetrical <- data.plots %>%
group_by(PID, AUofFocusSymmetrical) %>%
select(-c(AUofFocus, BodyRegion)) %>%
summarise(across(everything(), list(mean=mean, sd=sd)))## Warning: There were 1120 warnings in `summarise()`.
## The first warning was:
## ℹ In argument: `across(everything(), list(mean = mean, sd = sd))`.
## ℹ In group 1: `PID = 1` and `AUofFocusSymmetrical = UpperLipRaiserLR`.
## Caused by warning in `mean.default()`:
## ! argument is not numeric or logical: returning NA
## ℹ Run `dplyr::last_dplyr_warnings()` to see the 1119 remaining warnings.## `summarise()` has grouped output by 'PID'. You can override using the `.groups`
## argument.fau_art <- function(data, variable){
m <- art(as.formula(paste(variable, "~ AUofFocusSymmetrical + Error(PID)")), data=data)
m.anova <- anova(m)
print(m.anova)
contrasts = art.con(m, "AUofFocusSymmetrical") %>%
summary() %>%
mutate(sig = ifelse(p.value < 0.05, "*", "")) #%>%
#filter(p.value <0.05 & grepl('JawDrop|CheekPuff|MouthLR|LidTightener', contrast) )
# print(contrasts)
return(contrasts)
} discomfort_contrasts = fau_art(data_symmetrical, "Discomfort_mean")## Analysis of Variance of Aligned Rank Transformed Data
##
## Table Type: Repeated Measures Analysis of Variance Table (Type I)
## Model: Repeated Measures (aov)
## Response: art(Discomfort_mean)
##
## Error Df Df.res F value Pr(>F)
## 1 AUofFocusSymmetrical Withn 27 513 6.8568 < 2.22e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1rpe_contrasts = fau_art(data_symmetrical, "BorgRPE_mean")## Analysis of Variance of Aligned Rank Transformed Data
##
## Table Type: Repeated Measures Analysis of Variance Table (Type I)
## Model: Repeated Measures (aov)
## Response: art(BorgRPE_mean)
##
## Error Df Df.res F value Pr(>F)
## 1 AUofFocusSymmetrical Withn 27 513 10.115 < 2.22e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1score_contrasts = fau_art(data_symmetrical, "Score_mean")## Analysis of Variance of Aligned Rank Transformed Data
##
## Table Type: Repeated Measures Analysis of Variance Table (Type I)
## Model: Repeated Measures (aov)
## Response: art(Score_mean)
##
## Error Df Df.res F value Pr(>F)
## 1 AUofFocusSymmetrical Withn 27 513 12.487 < 2.22e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1write.csv(score_contrasts, "r_outputs/score_contrasts", row.names=FALSE)Ranked Optimal FAUs - Table 2
library(rPref)##
## Attaching package: 'rPref'## The following object is masked from 'package:data.table':
##
## between## The following object is masked from 'package:dplyr':
##
## between## The following objects are masked from 'package:plyr':
##
## empty, truepareto_data = data_symmetrical %>% group_by(AUofFocusSymmetrical) %>% select(c(AUofFocusSymmetrical, AUofFocusValue_mean_mean, TimeToActivation_mean_mean, Discomfort_mean, BorgRPE_mean, Performance_mean)) %>% summarise(across(everything(), list(mean=mean)))
result = psel(pareto_data, high(AUofFocusValue_mean_mean_mean) * low(TimeToActivation_mean_mean_mean) * low(Discomfort_mean_mean) * low(BorgRPE_mean_mean) * low(Performance_mean_mean), top=100, show_level=TRUE)
write.csv(result, "r_outputs/rpref_result.csv", row.names=FALSE)
print(result)## # A tibble: 28 × 7
## AUofFocusSymmetrical AUofFocusValue_mean_mean_mean TimeToActivation_mean_me…¹
## <fct> <dbl> <dbl>
## 1 LidTightenerLR 0.463 0.846
## 2 JawDrop 0.499 0.882
## 3 UpperLipRaiserLR 0.242 0.871
## 4 LipSuckLT/RT 0.106 0.976
## 5 JawThrust 0.212 1.08
## 6 MouthLR 0.384 1.14
## 7 LipSuckLB/RB 0.184 0.968
## 8 DimplerLR 0.0753 1.01
## 9 CheekPuffLR 0.148 1.02
## 10 LowerLipDepressorLR 0.174 0.970
## # ℹ 18 more rows
## # ℹ abbreviated name: ¹TimeToActivation_mean_mean_mean
## # ℹ 4 more variables: Discomfort_mean_mean <dbl>, BorgRPE_mean_mean <dbl>,
## # Performance_mean_mean <dbl>, .level <dbl>