library(knitr)
library(rmdformats)
library(ROCR)
require(ggplot2)
library(ModelMetrics)
library(rsample)
library(boot)
library(knitr)
require(xlsx)
This file provides some of the code used to generate several results presented in the paper:
Model for predicting perception of facial action unit activation using virtual humans
by R. McDonnell, E. Carrigan, K. Zibrek, and R. Dahyot accepted to Computer and Graphics in 2021.
with Github repo https://github.com/Roznn/facial-blendshapes that is also hosting the code for an earlier version of this work published in ACM MIG 2020.
Results for some models reported in the paper (e.g. AICs, Deviance) have been run in the R Console directly and are not in the Example Rmd code but can easily be inferred from the example code given. Please read the paper for more information on the meaning of the variables and meaning of results shown.
Please cite the paper when using data and/or code.
The data (Experiment 1: Laboratory) is loaded as follows:
mydata =read.xlsx("combined_resultsUpdate.xlsx", sheetName = "combined")
AIC and Deviance (CAG2021 paper: Tab. 3)
Note: some results reported in the paper are sometimes directly read from the output of the function glm
and may differ by a few non significative digit from the ones computed here with the function AIC
for instance. This is illustrated in the first example with Activation as explanatory variable in the model for response variable Difference.
Activation
Activation
mg <- glm(Difference~Activation ,data=mydata,family=gaussian(link="identity"))
mg
Call: glm(formula = Difference ~ Activation, family = gaussian(link = "identity"),
data = mydata)
Coefficients:
(Intercept) Activation
1.438 3.099
Degrees of Freedom: 7199 Total (i.e. Null); 7198 Residual
Null Deviance: 31600
Residual Deviance: 26070 AIC: 29700
# note the output for AIC is 29700 as reported in the paper
mp <- glm(Difference~Activation ,data=mydata,family=poisson(link="identity"))
mp
Call: glm(formula = Difference ~ Activation, family = poisson(link = "identity"),
data = mydata)
Coefficients:
(Intercept) Activation
1.412 3.144
Degrees of Freedom: 7199 Total (i.e. Null); 7198 Residual
Null Deviance: 9388
Residual Deviance: 7650 AIC: 28440
# note the output for AIC is 28440 as reported in the paper
# Now below displaying these AICs with better precision provide slightly different numbers
kable(AIC(mg,mp))
mg |
3 |
29703.40 |
mp |
2 |
28444.39 |
[1] 7650.282
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7396.485
Activation*AU
mg <- glm(Difference~Activation *AU_Name,data=mydata,family=gaussian(link="identity"))
mp <- glm(Difference~Activation *AU_Name,data=mydata,family=poisson(link="identity"))
kable(AIC(mg,mp))
mg |
25 |
24880.39 |
mp |
24 |
24690.88 |
[1] 3852.767
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7374.184
Activation *AU + Race : Sex
mp <- glm(Difference~Activation *AU_Name+Race:Sex,data=mydata,family=poisson(link="identity"))
mg <- glm(Difference~Activation *AU_Name+Race:Sex,data=mydata,family=gaussian(link="identity"))
kable(AIC(mg,mp))
mg |
30 |
24855.14 |
mp |
29 |
24675.45 |
[1] 3827.34
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7368.101
Activation * AU * Race * Sex
mp <- glm(Difference~Activation *AU_Name*Race*Sex,data=mydata,family=poisson(link="identity"))
mg <- glm(Difference~Activation *AU_Name*Race*Sex,data=mydata,family=gaussian(link="identity"))
kable(AIC(mg,mp))
mg |
145 |
24820.55 |
mp |
144 |
24759.12 |
[1] 3681.008
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7252.529
STED
STED
mg <- glm(Difference~STED,data=mydata,family=gaussian(link="identity"))
mp <- glm(Difference~STED,data=mydata,family=poisson(link="identity"))
kable(AIC(mg,mp))
mg |
3 |
28704.83 |
mp |
2 |
27345.97 |
[1] 6551.857
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7396.485
STED*AU
mg <- glm(Difference~STED*AU_Name,data=mydata,family=gaussian(link="sqrt"))
mp <- glm(Difference~STED*AU_Name,data=mydata,family=poisson(link="sqrt"))
kable(AIC(mg,mp))
mg |
24 |
24850.90 |
mp |
23 |
24680.13 |
[1] 3844.015
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7374.184
STED*AU + Race : Sex
mp <- glm(Difference~STED*AU_Name+Race:Sex,data=mydata,family=poisson(link="sqrt"))
mg <- glm(Difference~STED*AU_Name+Race:Sex,data=mydata,family=gaussian(link="sqrt"))
kable(AIC(mg,mp))
mg |
29 |
24832.20 |
mp |
28 |
24669.76 |
[1] 3823.648
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7368.101
STED* AU * Race * Sex
mp <- glm(Difference~STED*AU_Name*Race*Sex,data=mydata,family=poisson(link="sqrt"))
mg <- glm(Difference~STED*AU_Name*Race*Sex,data=mydata,family=gaussian(link="sqrt"))
kable(AIC(mg,mp))
mg |
139 |
24781.44 |
mp |
138 |
24742.48 |
[1] 3676.371
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7252.529
RMS
RMS
mg <- glm(Difference~RMS,data=mydata,family=gaussian(link="identity"))
mp <- glm(Difference~RMS,data=mydata,family=poisson(link="identity"))
kable(AIC(mg,mp))
mg |
3 |
27965.04 |
mp |
2 |
26903.50 |
[1] 6109.388
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7396.485
RMS*AU
mg <- glm(Difference~RMS*AU_Name,data=mydata,family=gaussian(link="identity"))
mp <- glm(Difference~RMS*AU_Name,data=mydata,family=poisson(link="identity"))
kable(AIC(mg,mp))
mg |
24 |
24878.39 |
mp |
23 |
24688.88 |
[1] 3852.773
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7374.184
RMS*AU + Race : Sex
mp <- glm(Difference~RMS*AU_Name+Race:Sex,data=mydata,family=poisson(link="identity"))
mg <- glm(Difference~RMS*AU_Name+Race:Sex,data=mydata,family=gaussian(link="identity"))
kable(AIC(mg,mp))
mg |
29 |
24853.14 |
mp |
28 |
24673.46 |
[1] 3827.344
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7368.101
RMS* AU * Race * Sex
mp <- glm(Difference~RMS*AU_Name*Race*Sex,data=mydata,family=poisson(link="identity"))
mg <- glm(Difference~RMS*AU_Name*Race*Sex,data=mydata,family=gaussian(link="identity"))
kable(AIC(mg,mp))
mg |
139 |
24810.65 |
mp |
138 |
24749.68 |
[1] 3683.565
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7252.529
SSIM
SSIM
mg <- glm(Difference~SSIM,data=mydata,family=gaussian(link="identity"))
mp <- glm(Difference~SSIM,data=mydata,family=poisson(link="identity"))
kable(AIC(mg,mp))
mg |
3 |
29534.91 |
mp |
2 |
28074.83 |
[1] 7280.717
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7396.485
SSIM*AU
mg <- glm(Difference~SSIM*AU_Name,data=mydata,family=gaussian(link="identity"))
mp <- glm(Difference~SSIM*AU_Name,data=mydata,family=poisson(link="identity"))
kable(AIC(mg,mp))
mg |
25 |
26287.12 |
mp |
24 |
25591.53 |
[1] 4753.421
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7374.184
SSIM*AU + Race : Sex
mp <- glm(Difference~SSIM*AU_Name+Race:Sex,data=mydata,family=poisson(link="log"))
mg <- glm(Difference~SSIM*AU_Name+Race:Sex,data=mydata,family=gaussian(link="sqrt"))
kable(AIC(mg,mp))
mg |
30 |
25505.00 |
mp |
29 |
25112.26 |
[1] 4264.153
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7368.101
SSIM* AU * Race * Sex
mp <- glm(Difference~SSIM*AU_Name*Race*Sex,data=mydata,family=poisson(link="log"))
mg <- glm(Difference~SSIM*AU_Name*Race*Sex,data=mydata,family=gaussian(link="sqrt"))
kable(AIC(mg,mp))
mg |
145 |
24798.87 |
mp |
144 |
24758.75 |
[1] 3680.642
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7252.529
MSE
MSE
mg <- glm(Difference~MSE,data=mydata,family=gaussian(link="identity"))
mp <- glm(Difference~MSE,data=mydata,family=poisson(link="identity"))
kable(AIC(mg,mp))
mg |
3 |
29920.07 |
mp |
2 |
28678.49 |
[1] 7884.374
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7396.485
MSE*AU
mg <- glm(Difference~MSE*AU_Name,data=mydata,family=gaussian(link="log"))
mp <- glm(Difference~MSE*AU_Name,data=mydata,family=poisson(link="log"))
kable(AIC(mg,mp))
mg |
25 |
26939.79 |
mp |
24 |
26115.81 |
[1] 5277.696
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7374.184
MSE*AU + Race : Sex
mp <- glm(Difference~MSE*AU_Name+Race:Sex,data=mydata,family=poisson(link="identity"))
mg <- glm(Difference~MSE*AU_Name+Race:Sex,data=mydata,family=gaussian(link="identity"))
kable(AIC(mg,mp))
mg |
30 |
25933.64 |
mp |
29 |
25384.25 |
[1] 4536.134
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7368.101
MSE* AU * Race * Sex
mp <- glm(Difference~MSE*AU_Name*Race*Sex,data=mydata,family=poisson(link="identity"))
mg <- glm(Difference~MSE*AU_Name*Race*Sex,data=mydata,family=gaussian(link="identity"))
kable(AIC(mg,mp))
mg |
145 |
24839.44 |
mp |
144 |
24776.94 |
[1] 3698.828
qchisq(0.95, length(mydata$Difference)-length(mp$coefficient))
[1] 7252.529
ANOVA tables (CAG2021 paper: Tab. 4-7)
Using Geometric metrics
RMS (Tab 4)
kable(anova(lm(Difference~RMS * AU_Name*Race*Sex,data=mydata)))
RMS |
1 |
11125.300638 |
11125.300638 |
6174.5318210 |
0.0000000 |
AU_Name |
11 |
5114.028326 |
464.911666 |
258.0255554 |
0.0000000 |
Race |
2 |
24.913623 |
12.456811 |
6.9135191 |
0.0010010 |
Sex |
1 |
3.555549 |
3.555549 |
1.9733265 |
0.1601392 |
RMS:AU_Name |
10 |
2103.488064 |
210.348806 |
116.7433978 |
0.0000000 |
RMS:Race |
2 |
21.928141 |
10.964071 |
6.0850493 |
0.0022886 |
AU_Name:Race |
22 |
132.014531 |
6.000661 |
3.3303612 |
0.0000002 |
RMS:Sex |
1 |
7.984011 |
7.984011 |
4.4311190 |
0.0353246 |
AU_Name:Sex |
11 |
30.062895 |
2.732991 |
1.5168072 |
0.1178373 |
Race:Sex |
2 |
36.295358 |
18.147679 |
10.0719456 |
0.0000429 |
RMS:AU_Name:Race |
20 |
63.216915 |
3.160846 |
1.7542666 |
0.0198763 |
RMS:AU_Name:Sex |
10 |
10.545040 |
1.054504 |
0.5852488 |
0.8274277 |
RMS:Race:Sex |
2 |
6.866608 |
3.433304 |
1.9054806 |
0.1488276 |
AU_Name:Race:Sex |
22 |
140.943779 |
6.406535 |
3.5556214 |
0.0000000 |
RMS:AU_Name:Race:Sex |
20 |
58.884299 |
2.944215 |
1.6340367 |
0.0368748 |
Residuals |
7062 |
12724.345000 |
1.801805 |
NA |
NA |
STED (Tab. 5)
kable(anova(lm(Difference~STED * AU_Name*Race*Sex,data=mydata)))
STED |
1 |
8.909196e+03 |
8909.1960284 |
4959.5269412 |
0.0000000 |
AU_Name |
11 |
8.879785e+03 |
807.2531671 |
449.3776787 |
0.0000000 |
Race |
2 |
2.751392e+01 |
13.7569583 |
7.6581551 |
0.0004761 |
Sex |
1 |
6.007024e-01 |
0.6007024 |
0.3343960 |
0.5631004 |
STED:AU_Name |
10 |
5.919195e+02 |
59.1919463 |
32.9506783 |
0.0000000 |
STED:Race |
2 |
1.641944e+01 |
8.2097194 |
4.5701457 |
0.0103871 |
AU_Name:Race |
22 |
1.166772e+02 |
5.3035089 |
2.9523310 |
0.0000043 |
STED:Sex |
1 |
1.049386e+01 |
10.4938614 |
5.8416706 |
0.0156761 |
AU_Name:Sex |
11 |
3.423820e+01 |
3.1125638 |
1.7326865 |
0.0602727 |
Race:Sex |
2 |
2.600132e+01 |
13.0006601 |
7.2371428 |
0.0007247 |
STED:AU_Name:Race |
20 |
6.507961e+01 |
3.2539803 |
1.8114095 |
0.0146421 |
STED:AU_Name:Sex |
10 |
9.721461e+00 |
0.9721461 |
0.5411694 |
0.8619625 |
STED:Race:Sex |
2 |
5.764906e+00 |
2.8824531 |
1.6045897 |
0.2010453 |
AU_Name:Race:Sex |
22 |
1.655589e+02 |
7.5254024 |
4.1892036 |
0.0000000 |
STED:AU_Name:Race:Sex |
20 |
5.936597e+01 |
2.9682986 |
1.6523777 |
0.0336347 |
Residuals |
7062 |
1.268604e+04 |
1.7963802 |
NA |
NA |
Using Image metrics
SSIM (Tab. 6)
kable(anova(lm(Difference~SSIM* AU_Name*Race*Sex,data=mydata)))
SSIM |
1 |
6135.88301 |
6135.883010 |
3393.489386 |
0.0000000 |
AU_Name |
11 |
8500.78006 |
772.798188 |
427.400986 |
0.0000000 |
Race |
2 |
539.61982 |
269.809911 |
149.220099 |
0.0000000 |
Sex |
1 |
279.76842 |
279.768416 |
154.727714 |
0.0000000 |
SSIM:AU_Name |
11 |
924.91321 |
84.083019 |
46.502652 |
0.0000000 |
SSIM:Race |
2 |
107.19315 |
53.596574 |
29.641928 |
0.0000000 |
AU_Name:Race |
22 |
419.42216 |
19.064644 |
10.543823 |
0.0000000 |
SSIM:Sex |
1 |
11.40373 |
11.403727 |
6.306904 |
0.0120490 |
AU_Name:Sex |
11 |
489.92097 |
44.538270 |
24.632175 |
0.0000000 |
Race:Sex |
2 |
645.40840 |
322.704198 |
178.473623 |
0.0000000 |
SSIM:AU_Name:Race |
22 |
177.68390 |
8.076541 |
4.466783 |
0.0000000 |
SSIM:AU_Name:Sex |
11 |
68.12323 |
6.193021 |
3.425090 |
0.0000914 |
SSIM:Race:Sex |
2 |
148.00017 |
74.000085 |
40.926221 |
0.0000000 |
AU_Name:Race:Sex |
22 |
297.96831 |
13.544014 |
7.490604 |
0.0000000 |
SSIM:AU_Name:Race:Sex |
22 |
100.09184 |
4.549629 |
2.516202 |
0.0001106 |
Residuals |
7056 |
12758.19241 |
1.808134 |
NA |
NA |
MSE (Tab. 7)
kable(anova(lm(Difference~MSE* AU_Name*Race*Sex,data=mydata)))
MSE |
1 |
4.736388e+03 |
4736.3879475 |
2620.3425082 |
0.0000000 |
AU_Name |
11 |
8.523976e+03 |
774.9068976 |
428.7067500 |
0.0000000 |
Race |
2 |
5.997513e+02 |
299.8756275 |
165.9021310 |
0.0000000 |
Sex |
1 |
3.300257e-01 |
0.3300257 |
0.1825822 |
0.6691765 |
MSE:AU_Name |
11 |
2.162635e+03 |
196.6032101 |
108.7680643 |
0.0000000 |
MSE:Race |
2 |
1.331603e+02 |
66.5801372 |
36.8345595 |
0.0000000 |
AU_Name:Race |
22 |
1.098384e+03 |
49.9265635 |
27.6211953 |
0.0000000 |
MSE:Sex |
1 |
1.379690e+02 |
137.9690345 |
76.3295004 |
0.0000000 |
AU_Name:Sex |
11 |
1.264741e+02 |
11.4976458 |
6.3609169 |
0.0000000 |
Race:Sex |
2 |
2.662114e+02 |
133.1057120 |
73.6389331 |
0.0000000 |
MSE:AU_Name:Race |
22 |
5.476811e+02 |
24.8945964 |
13.7725984 |
0.0000000 |
MSE:AU_Name:Sex |
11 |
1.361104e+02 |
12.3736730 |
6.8455670 |
0.0000000 |
MSE:Race:Sex |
2 |
2.538023e+01 |
12.6901141 |
7.0206338 |
0.0008995 |
AU_Name:Race:Sex |
22 |
1.233556e+02 |
5.6070706 |
3.1020359 |
0.0000014 |
MSE:AU_Name:Race:Sex |
22 |
2.325258e+02 |
10.5693524 |
5.8473511 |
0.0000000 |
Residuals |
7056 |
1.275404e+04 |
1.8075454 |
NA |
NA |