(该题来自《多元统计分析-基于R》第七章课后习题最后一题)我国2017年各地区城镇居民人均全年消费数据如下表1所示（表中数据放在文末），这些指标分别从食品烟酒（），衣着(
)，居住(
)，生活用品及服务(
)，交通通信(
)，教育文化娱乐(
)，医疗保健和其他用品(
)及服务(
)八个方面来描述消费情况，试对这些数据进行因子分析。
表1
先读取数据，求消费数据指标间的相关系数矩阵，R程序如下
d6.7<-read.csv("ex6.7.csv",header=T) #将ex6.7.csv中的数据读到R中
data<-d6.7[,-1] #将数据第一列名称去掉
name<-d6.7[,1] #将样本名称提取出来
da<-scale(data) #标准化数据矩阵
da
dat<-cor(da) #计算样本数据的相关系数矩阵
dat
消费数据指标间的相关系数矩阵如表2所示
表2
由上面的相关系数矩阵可知，消费指标之间存在较强的线性相关关系，适合用因子分析模型进行分析。下面分别用主成分法，主因子法，极大似然估计法进行因子分析。
R程序如下
#采用主成分法做因子分析
source("mvstats.R")
fac=factpc(da,3) #进行主成分分析，取三个因子
fac #显示因子分析结果
fac1=factpc(da,3,rotation="varimax") #用主成分法采用方差最大化作因子正交旋转
fac1
write.table(fac1, file = 'D:/学习资料/dat1.csv', sep = ',', quote = TRUE) #将因子旋转后的分析结果导出到Excel中以供做表
#采用主因子法做因子分析
f<-solve(dat) #求逆矩阵
psiini<-diag(1/f[row(f)==col(f)]) #对角阵
psi<-psiini #特殊方差的初始估计
for (i in 1:100){
ee<-eigen(dat-psi)
eigval<-ee$values[1:3]
eigvec<-ee$vectors[,1:3]
EE<-matrix(eigval,nrow(dat),ncol=3,byrow=T)
QQ<-sqrt(EE)*eigvec
psiold=psi
psi=diag(as.vector(1-t(colSums(t(QQ*QQ)))))
i=i+1
z=psi-psiold
convergence<-z[row(z)==col(z)]
} #迭代求解
QQ #迭代求解得到的因子载荷矩阵
pfm<-varimax(QQ) #对因子载荷矩阵作最大方差正交旋转
load<-pfm$loadings #正交旋转后的因子载荷矩阵
ld<-cbind(load[,1],load[,2],load[,3]) #取正交旋转后的因子载荷矩阵前三列数据
ld
K<-as.vector(colSums(ld*ld)) #将结果向量化
K1<-K/nrow(dat) #各因子解释的总方差的比例
K1 #显示因子解释比例
write.table(k1, file = 'D:/学习资料/dat2.csv', sep = ',', quote = TRUE) #将因子旋转后的分析结果导出到Excel中以供做表
#采用极大似然法作因子分析
mlm<-factanal(da,3,rotation="none",covmat=dat) #极大似然法作因子分析，不进行正交旋转
mlm #显示结果
mlm1<-factanal(da,3,rotation="varimax",covmat=dat) #极大似然法作因子分析，进行正交旋转
mlm1 #显示结果
write.table(mlm1/Loadings, file = 'D:/学习资料/dat3.csv', sep = ',', quote = TRUE) #将因子旋转后的分析结果导出到Excel中以供做表
表3
由表3可知，主成分法提取的因子方差贡献最大，因此本案例选用主成分法做因子分析 主成分法计算共性方差和特殊因子方差程序如下：
fac1=factpc(da,3,rotation="varimax") #用主成分法采用方差最大化作因子正交旋转
fac1 #显示因子旋转后分析结果
plot(fac1$loadings,type="n",xlab="Factor1",ylab="Factor2") #输出因子载荷图
text(fac1$loadings,paste("x",1:12,sep=""),cex=1.5) #添加标签
fac1_plotdata<-fac1$scores #提取因子分析中得分以便绘图
rownames(fac1_plotdata)<-unlist(name) #将证券名称与因子得分进行对应，便于在图形上绘制标签
plot.text(fac1_plotdata) #绘制第一个因子和第二个因子的因子得分图
biplot(fac1_plotdata,fac1$loadings) #因子得分图和原坐标在因子方向上的图
A<-fac1$loadings #正交旋转后的因子载荷矩阵
K<-as.vector(colSums(A*A)) #将列和结果转为向量
K1<-K/nrow(dat) #各因子解释的总方差的比例
K1 #显示因子解释比例
com<-diag(A%*%t(A)) #计算共性方差
psi<-diag(dat)-diag(A%*%t(A)) #计算特殊方差
tbl<-cbind(A,com,psi) #将结果进行合并，方便查看
tbl #显示结果结果如表4所示：
表4
由表4可知，生活用品及服务、教育文化娱乐、医疗保健在因子f1上的载荷分别是0.57184，083887，0.85417，这三个消费指标都是增加身心健康的，因为我们将f1命名为文化娱乐提高因子；食品烟酒、居住、交通通信、其他用品及服务在因子f2上的载荷分别是0.95837，0.6912，0.60774，0.63258，这四个消费指标都是生活必须品，因此将f2命名为生活保障因子；衣着在因子f3上的载荷是0.96368，只有在实现温饱还有富余下才会考虑增添更多衣服，因此我们称之为富余因子。
由主成分旋转得到的因子分析模型解为：
绘制前两个因子载荷、得分及信息重叠图，R程序如下：
plot(fac1$loadings,type="n",xlab="Factor1",ylab="Factor2") #输出因子载荷图
text(fac1$loadings,paste("x",1:8,sep=""),cex=1.5) #添加标签因子载荷图如图1：
图1
绘制因子得分图程序如下：
fac1_plotdata<-fac1$scores #提取因子分析中得分以便绘图
rownames(fac1_plotdata)<-unlist(name) #将证券名称与因子得分进行对应，便于在图形上绘制标签
plot.text(fac1_plotdata) #绘制第一个因子和第二个因子的因子得分图第一个因子和第二个因子得分图：
图2
由因子得分图可知，上海、浙江、北京、天津、江苏在表示文化教育以及居住因子上的得分比较高，这与实际吻合，而广东、福建在因子1上得分不高，但是在表示居住和食品的因子2上得分较高，这也与这两省人民的消费习惯吻合。
绘制信息重叠图的程序如下：
biplot(fac1_plotdata,fac1$loadings) #信息重叠图信息重叠图如图3所示：
图3 各省消费情况的因子得分图和原坐标在因子方向上的图
因此，我们可以得到下面各种排序，包括单因子排序和综合因子排序如表4-表7所示：
表4 按照f1因子得分的排序（加权最小二乘法）
表5 按照f2因子得分的排序（加权最小二乘法）
表6 按照f3因子得分的排序（加权最小二乘法）
表6 按照综合因子得分的排序（加权最小二乘法）
全部R程序
d6.7<-read.csv("ex6.7.csv",header=T) #将ex6.7.csv中的数据读到R中
data<-d6.7[,-1] #将数据第一列名称去掉
name<-d6.7[,1] #将样本名称提取出来
da<-scale(data) #标准化数据矩阵
da
dat<-cor(da) #计算样本数据的相关系数矩阵
dat
write.table(dat, file = 'D:/学习资料/dat.csv', sep = ',', quote = TRUE)
#采用主成分法作因子分析
library(mvstats) #加载mvstats包
fac=factpc(da,3) #进行主成分因子分析，取3个因子
fac #显示因子分析结果
fac1=factpc(da,3,rotation="varimax") #用主成分法采用方差最大化作因子正交旋转
fac1 #显示因子旋转后分析结果
plot(fac1$loadings,type="n",xlab="Factor1",ylab="Factor2") #输出因子载荷图
text(fac1$loadings,paste("x",1:12,sep=""),cex=1.5) #添加标签
fac1_plotdata<-fac1$scores #提取因子分析中得分以便绘图
rownames(fac1_plotdata)<-unlist(name) #将证券名称与因子得分进行对应，便于在图形上绘制标签
plot.text(fac1_plotdata) #绘制第一个因子和第二个因子的因子得分图
biplot(fac1_plotdata,fac1$loadings) #因子得分图和原坐标在因子方向上的图
A<-fac1$loadings #正交旋转后的因子载荷矩阵
K<-as.vector(colSums(A*A)) #将列和结果转为向量
K1<-K/nrow(dat) #各因子解释的总方差的比例
K1 #显示因子解释比例
com<-diag(A%*%t(A)) #计算共性方差
psi<-diag(dat)-diag(A%*%t(A)) #计算特殊方差
tbl<-cbind(A,com,psi) #将结果进行合并，方便查看
tbl #显示结果
D<-matrix(0,nrow=nrow(dat),ncol=ncol(dat)) #构建为0的矩阵
for(i in 1:nrow(dat)){
D[i,i]<-psi[i]
i=i+1
}
D #特殊因子的协方差矩阵
#加权最小二乘法的因子得分排序
B<-solve(t(A)%*%solve(D)%*%A)%*%t(A)%*%solve(D) #加权最小二乘法的因子得分矩阵
score<-t(B%*%t(da)) #加权最小二乘法的因子得分
score #显示因子得分结果
newscore<-matrix(nrow=nrow(score),ncol=4) #构建空矩阵
newscore[,1]<-score[,1] #将第一因子得分填入空矩阵的第一列
newscore[,2]<-score[,2] #将第二因子得分填入空矩阵的第二列
newscore[,3]<-score[,3] #将第三因子得分填入空矩阵的第三列
newscore[,4]<-K1[1]*score[,1]+K1[2]*score[,2]+K1[3]*score[,3] #计算综合得分
colnames(newscore)<-c("第一因子得分","第二因子得分","第三因子得分","综合得分") #进行命名
newscore<-data.frame(name,newscore) #构建数据框，将得分与证券名称进行对应
newscore #各证券的因子得分和因子综合得分
newscore1<-newscore[order(newscore[,2],decreasing=T),] #按第一因子得分排序
newscore1 #显示以第一因子得分排序结果
newscore2<-newscore[order(newscore[,3],decreasing=T),] #按第二因子得分排序
newscore2 #显示以第二因子得分排序结果
newscore3<-newscore[order(newscore[,4],decreasing=T),] #按第三因子得分排序
newscore3 #显示以第三因子得分排序结果
newscore4<-newscore[order(newscore[,5],decreasing=T),] #按因子综合得分排序
newscore4 #显示以因子综合得分排序结果
#回归法的因子得分排序
B1<-t(A)%*%solve(dat) #回归法得到的因子得分矩阵
score1<-t(B1%*%t(da)) #回归法的因子得分
score1 #显示因子得分
new1score<-matrix(nrow=nrow(score1),ncol=4) #构建空矩阵
new1score[,1]<-score1[,1] #将第一因子得分填入空矩阵的第一列
new1score[,2]<-score1[,2] #将第二因子得分填入空矩阵的第二列
new1score[,3]<-score1[,3] #将第三因子得分填入空矩阵的第三列
new1score[,4]<-K1[1]*score1[,1]+K1[2]*score1[,2]+K1[3]*score1[,3] #计算综合得分
colnames(new1score)<-c("第一因子得分","第二因子得分","第三因子得分","综合得分") #进行命名
new1score<-data.frame(name,new1score) #构建数据框，将得分与证券名称进行对应
new1score #各证券的因子得分和因子综合得分
new1score1<-new1score[order(new1score[,2],decreasing=T),] #按第一因子得分排序
new1score1 #显示以第一因子得分排序结果
new1score2<-new1score[order(new1score[,3],decreasing=T),] #按第二因子得分排序
new1score2 #显示以第二因子得分排序结果
new1score3<-new1score[order(new1score[,4],decreasing=T),] #按第三因子得分排序
new1score3 #显示以第三因子得分排序结果
new1score4<-new1score[order(new1score[,5],decreasing=T),] #按因子综合得分排序
new1score4 #显示以综合因子得分排序结果
#采用主因子法作因子分析
f<-solve(dat) #求逆矩阵
psiini<-diag(1/f[row(f)==col(f)]) #对角阵
psi<-psiini #特殊方差的初始估计
for (i in 1:100){
ee<-eigen(dat-psi)
eigval<-ee$values[1:3]
eigvec<-ee$vectors[,1:3]
EE<-matrix(eigval,nrow(dat),ncol=3,byrow=T)
QQ<-sqrt(EE)*eigvec
psiold=psi
psi=diag(as.vector(1-t(colSums(t(QQ*QQ)))))
i=i+1
z=psi-psiold
convergence<-z[row(z)==col(z)]
} #迭代求解
QQ #迭代求解得到的因子载荷矩阵
pfm<-varimax(QQ) #对因子载荷矩阵作最大方差正交旋转
load<-pfm$loadings #正交旋转后的因子载荷矩阵
ld<-cbind(load[,1],load[,2],load[,3]) #取正交旋转后的因子载荷矩阵前三列数据
K<-as.vector(colSums(ld*ld)) #将结果向量化
K1<-K/nrow(dat) #各因子解释的总方差的比例
K1 #显示因子解释比例
com<-diag(ld%*%t(ld)) #计算共性方差
psi<-diag(dat)-diag(ld%*%t(ld)) #计算特殊方差
tbl<-cbind(load[,1],load[,2],load[,3],com,psi) #将结果合并
tbl #显示结果
#采用极大似然法作因子分析
mlm<-factanal(da,3,rotation="none",covmat=dat) #极大似然法作因子分析，不进行正交旋转
mlm #显示结果
mlm1<-factanal(da,3,rotation="varimax",covmat=dat) #极大似然法作因子分析，进行正交旋转
mlm1 #显示结果
ex6.7.csv
地区 x1 x2 x3 x4 x5 x6 x7 x8
北京 8003.3 2428.7 13347.4 2633 5395.5 4325.2 3088 1125.1
天津 9456.2 2118.9 6469.9 1773.8 3924.2 2979 2599.5 962.2
河北 5067.1 1688.8 5047.6 1485.1 2923.3 2172.7 1737.3 478.4
山西 4244.2 1774.4 3866.6 1093.8 2658.2 2559.4 1741.4 465.9
内蒙古 6468.8 2576.7 4108 1670.2 3511.3 2636.7 1907.3 758.8
辽宁 6988.3 2167.9 4510.6 1536.8 3770.7 3164.3 2380.1 860.6
吉林 5168.7 1954.1 3800 1114.9 2785.2 2445.4 2164 619
黑龙江 5247 1920.8 3644.1 1030.8 2563.9 2289.5 1966.7 606.9
上海 10456.5 1827 14749 1927.9 4253.5 5087.2 2734.7 1268.5
江苏 7616.2 1838.5 6773.5 1708.6 3971.6 3450.5 1573.7 793.6
浙江 8906.1 1925.7 8413.5 1617.4 4955.8 3521.1 1871.8 713
安徽 6665.3 1544.1 4234.6 1215 2914.3 2372.2 1274.5 520.1
福建 8551.6 1438 6829.1 1478.1 3353 2483.5 1235.1 612.1
江西 5994 1531.2 4588.8 1196.2 2156.9 2235.4 1044.3 497.7
山东 6179.6 2033.6 4894.8 1736.5 3284.4 2622.5 1780.6 540.2
河南 5187.8 1779.3 4226.6 1572.1 2269.6 2226.9 1611.5 548.5
湖北 6542.5 1544.8 4669.4 1287.2 2131.7 2420.9 2165.5 513.6
湖南 6585 1682.4 4353.2 1492.6 2904.6 3972.9 1693 478.9
广东 9711.7 1587.1 7127.8 1782.8 4285.5 3284.3 1503.6 915.1
广西 6098.5 908.1 3884.6 1093.3 2607.3 2151.5 1254.2 351
海南 7575.3 895.7 3855.9 1102.8 2811.5 2236.1 1505.1 389.5
重庆 7305.3 1950.9 3960.4 1592.1 2992 2528.5 1882.5 547.5
四川 7329.3 1723.3 3906.2 1403.8 3198.3 2221.9 1595.6 612.1
贵州 6242.6 1570 3819.8 1359.2 2889 2731.3 1244 491.9
云南 5665.1 1144.2 3904.8 1162.7 3113.6 2363.1 1786.6 419.5
西藏 9253.6 1973.3 4183.6 1161.8 2312.5 1044 639.7 519
陕西 5798.6 1627 3796.5 1486.6 2394.7 2617.9 2140.8 526.1
甘肃 6032.6 1905.8 3828.3 1358 2952.6 2341.9 1741.2 499.1
青海 6060.8 1901.1 3836.8 1398.8 3241.3 2528.3 1948.6 557.2
宁夏 4952.2 1768.1 3680.3 1257.1 3470.9 2629.7 1936.6 524.5
新疆 6359.6 2025.3 3954.7 1590 3545.2 2629.5 2065.6 627.1