This file provides some of the code used to generate several results presented in the paper:

Investigating perceptually-based models to predict importance of facial blendshapes

by E. Carrigan, K. Zibrek, R. Dahyot and R. McDonnell published in ACM MIG 2020.

with Github repo https://github.com/Roznn/facial-blendshapes

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.

1 Data Exploration

library(knitr)
require(xlsx)

mydata =read.xlsx("combined_resultsUpdate.xlsx", sheetName = "combined")

str(mydata)
## 'data.frame':    7200 obs. of  14 variables:
##  $ ID          : num  2.02e+13 2.02e+13 2.02e+13 2.02e+13 2.02e+13 ...
##  $ Sex         : chr  "female" "female" "female" "female" ...
##  $ Race        : chr  "white" "white" "white" "white" ...
##  $ AU_Name     : chr  "Eyes_Closed" "Eyes_Closed" "Eyes_Closed" "Eyes_Closed" ...
##  $ AU          : chr  "43" "43" "43" "43" ...
##  $ Activation  : num  0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 0.2 ...
##  $ Difference  : num  4 3 3 2 2 2 3 3 7 3 ...
##  $ ResponseTime: num  3.25 5.06 3.76 3.51 2.03 ...
##  $ Hausdorff   : num  0.228 0.228 0.228 0.228 0.228 ...
##  $ RMS         : num  51.6 51.6 51.6 51.6 51.6 ...
##  $ Tri.Diffs   : num  202 202 202 202 202 ...
##  $ MSE         : num  74.9 74.9 74.9 74.9 74.9 ...
##  $ SSIM        : num  0.984 0.984 0.984 0.984 0.984 ...
##  $ STED        : num  0.117 0.117 0.117 0.117 0.117 ...

Six virtual characters are used (3 females Asian-Black-White, 3 males Asian-Black-White) in this study (see variables Sex and Race in the data).

2 ANOVA tables (MIG2020 paper: Tab. 4-7)

2.1 Using Geometric metrics

2.1.1 RMS

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

2.1.2 STED

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

2.2 Using Image metrics

2.2.1 SSIM

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

2.2.2 MSE

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

3 AIC and Deviance (MIG2020 paper: Tab. 3)

3.1 STED

3.1.1 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

3.1.2 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

3.1.3 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

3.1.4 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

3.2 RMS

3.2.1 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

3.2.2 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

3.2.3 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

3.2.4 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

3.3 SSIM

3.3.1 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

3.3.2 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

3.3.3 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

3.3.4 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

3.4 MSE

3.4.1 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

3.4.2 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

3.4.3 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

3.4.4 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

4 Figures (MIG2020 paper: Fig. 3)

4.1 RMS*AU+Race:Sex

require(ggplot2)


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")

4.2 RMS*AU

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")

4.3 STED*AU+Race:Sex

require(ggplot2)


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")

4.4 STED*AU

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")

4.5 MSE* AU* Sex* Race

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")

4.6 MSE*AU

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")

4.7 SSIM* AU * Sex* Race

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")

4.8 SSIM*AU

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")