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 AICfor 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))
df AIC
mg 3 29703.40
mp 2 28444.39
deviance(mp)
[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))
df AIC
mg 25 24880.39
mp 24 24690.88
deviance(mp)
[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))
df AIC
mg 30 24855.14
mp 29 24675.45
deviance(mp)
[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))
df AIC
mg 145 24820.55
mp 144 24759.12
deviance(mp)
[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))
df AIC
mg 3 28704.83
mp 2 27345.97
deviance(mp)
[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))
df AIC
mg 24 24850.90
mp 23 24680.13
deviance(mp)
[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))
df AIC
mg 29 24832.20
mp 28 24669.76
deviance(mp)
[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))
df AIC
mg 139 24781.44
mp 138 24742.48
deviance(mp)
[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))
df AIC
mg 3 27965.04
mp 2 26903.50
deviance(mp)
[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))
df AIC
mg 24 24878.39
mp 23 24688.88
deviance(mp)
[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))
df AIC
mg 29 24853.14
mp 28 24673.46
deviance(mp)
[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))
df AIC
mg 139 24810.65
mp 138 24749.68
deviance(mp)
[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))
df AIC
mg 3 29534.91
mp 2 28074.83
deviance(mp)
[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))
df AIC
mg 25 26287.12
mp 24 25591.53
deviance(mp)
[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))
df AIC
mg 30 25505.00
mp 29 25112.26
deviance(mp)
[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))
df AIC
mg 145 24798.87
mp 144 24758.75
deviance(mp)
[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))
df AIC
mg 3 29920.07
mp 2 28678.49
deviance(mp)
[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))
df AIC
mg 25 26939.79
mp 24 26115.81
deviance(mp)
[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))
df AIC
mg 30 25933.64
mp 29 25384.25
deviance(mp)
[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))
df AIC
mg 145 24839.44
mp 144 24776.94
deviance(mp)
[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)))
Df Sum Sq Mean Sq F value Pr(>F)
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)))
Df Sum Sq Mean Sq F value Pr(>F)
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)))
Df Sum Sq Mean Sq F value Pr(>F)
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)))
Df Sum Sq Mean Sq F value Pr(>F)
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

Figures (CAG 2021 paper: Fig. 4)

RMS*AU+Race:Sex (Fig.4 (a))

m<-glm(Difference~RMS*relevel(factor(AU_Name),ref='Neutral')+Race:Sex,data=mydata,family=poisson(link="identity"))

ggplot(mydata,aes(RMS, Difference, group=interaction(AU_Name,Race,Sex), col=interaction(AU_Name),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   ylab("Perceptual Difference") + 
   xlab("RMS") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")

RMS*AU (Fig 4 (b))

m<-glm(Difference~RMS*relevel(factor(AU_Name),ref='Neutral'),data=mydata,family=poisson(link="identity"))

ggplot(mydata,aes(RMS, Difference, group=interaction(AU_Name), col=interaction(AU_Name),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   ylab("Perceptual Difference") + 
   xlab("RMS") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")

STED*AU+Race:Sex (Fig.4 (c))

m<-glm(Difference~STED*relevel(factor(AU_Name),ref='Neutral')+Race:Sex,data=mydata,family=poisson(link="sqrt"))

ggplot(mydata,aes(STED, Difference, group=interaction(AU_Name,Race,Sex), col=interaction(AU_Name),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   #  geom_point(alpha = 0.8,show.legend=TRUE) +
   ylab("Perceptual Difference") + 
   xlab("STED") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")

STED*AU (Fig 4 (d))

m<- glm(Difference~STED*AU_Name,data=mydata,family=poisson(link="sqrt"))
ggplot(mydata,aes(STED, Difference, group=interaction(AU_Name), col=interaction(Blendshapes),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   #  geom_point(alpha = 0.8,show.legend=TRUE) +
   ylab("Perceptual Difference") + 
   xlab("STED") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")

MSE* AU* Sex* Race (Fig 4 (e))

m<- glm(Difference~MSE*relevel(factor(AU_Name),ref='Neutral')*Sex*Race,data=mydata,family=poisson(link="log"))
ggplot(mydata,aes(MSE, Difference, group=interaction(AU_Name,Race,Sex), col=interaction(Blendshapes),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   ylab("Perceptual Difference") + 
   xlab("MSE") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")

MSE*AU (Fig 4 (f))

m<- glm(Difference~MSE*relevel(factor(AU_Name),ref='Neutral'),data=mydata,family=poisson(link="identity"))
ggplot(mydata,aes(MSE, Difference, group=interaction(AU_Name), col=interaction(Blendshapes),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   ylab("Perceptual Difference") + 
   xlab("MSE") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")

SSIM* AU * Sex* Race (Fig 4 (g))

m<- glm(Difference~SSIM*relevel(factor(AU_Name),ref='Neutral')*Sex*Race,data=mydata,family=poisson(link="log"))
ggplot(mydata,aes(SSIM, Difference, group=interaction(AU_Name,Race,Sex), col=interaction(Blendshapes),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   ylab("Perceptual Difference") + 
   xlab("SSIM") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")

SSIM*AU (Fig 4 (h))

m<- glm(Difference~SSIM*relevel(factor(AU_Name),ref='Neutral'),data=mydata,family=poisson(link="identity"))
ggplot(mydata,aes(SSIM, Difference, group=interaction(AU_Name), col=interaction(Blendshapes),linetype=interaction(AU_Name)))+
   geom_line(aes(y=m$fitted.values, colour=AU_Name, linetype=AU_Name),size=1) +
   ylab("Perceptual Difference") + 
   xlab("SSIM") +
   theme_bw()+ 
   theme(text = element_text(size = 16))+
   labs(col="Blendshapes",linetype="Blendshapes")