应用多元统计分析作业

多元统计分析

实验报告

实验课程名称多元统计分析

实验项目名称多元统计理论的计算机实现 年级 2013 专业应用统计学 学生姓名侯杰 成绩

理学院

实验时间：2015 年05月07日

学生所在学院：理学院专业：应用统计学班级：9131137001

姓名 实验时间 实验项目名称 侯杰 16.05.07 学号 指导教师 913113700124 李建军 实验组 多元统计理论的计算机实现 实验目的及要求： 目的：熟悉R（或SPSS）软件，掌握多元统计分析中多元正态分布均值向量和协差阵的检验，判别方法，聚类分析，主成分分析，因子分析，相应分析内容。 要求：程序要有注释，尽量体现多元统计分析多元正态分布均值向量和协差阵的检验，判别方法，聚类分析，主成分分析，因子分析，相应分析内容内容的基本原理。 实验硬件及软件平台： 计算机、R、网络 实验内容（包括实验具体内容、算法分析、源代码等等）： 指导教师意见： 签名：年月日

1

代码及运行结果分析

1、均值检验

问题重述：某医生观察了16名正常人的24小时动态心电图，分析出早晨3小时各小时的低

频心电频谱值（LF）、高频心电频谱值（HF），数据见压缩包，试分析这两个指标的各次重复测定均值向量是否有显著差异。

代码如下：

Tsq.test<-function(data,alpha=0.05){

data<-as.matrix(read.table(\ #读取数据 xdat<-data[,2:4];

xbar<-apply(xdat,2,mean); #计算LF指标的均值 ydat<-data[,5:7];

ybar<-apply(ydat,2,mean); #计算HF指标数据 xcov<-cov(xdat); #计算LF样本协差阵 ycov<-cov(ydat); #计算HF样本协差阵 sinv<-solve(xcov+ycov);#求逆矩阵 Tsq<-(16+16-2)*t(sqrt(16*16/(16+16)*(xbar-ybar)))%*%sinv%*%sqrt(16*16/(16+16)*(xbar-ybar)); #计算T统计量

Fstat<-((16+16-2)-3+1)/((16+16-2)*3)*Tsq; #计算F统计量 pvalue<-as.numeric(1-pf(Fstat,3,16+16-3-1)); cat(\值=\

if(pvalue>0.05) #结果输出 cat('均值向量不存在差异') else

cat('均值向量存在差异'); }

运行结果及分析：

通过运行程序，我们可以得到如下结果： >Tsq.test()

p值= 1.632028e-14 均值向量存在差异

即LF与HF这两个指标的各次重复测定均值向量存在显著差异。

2、判别分析

问题重述：银行的贷款部门需要判别每个客户的信用好坏（是否未履行还贷责任），以决定

2

是否给予贷款。可以根据贷款申请人的年龄（）、受教育程度（）、现在所从事工作的年数（）、未变更住址的年数（）、收入（）、负债收入比例（）、信用卡债务（）、其它债务（）等来判断其信用情况。数据见压缩包。⑴根据样本资料分别用距离判别法、Bayes判别法和Fisher判别法建立判别函数和判别规则。⑵某客户的如上情况资料为（53，1，9，18，50，11.20，2.02，3.58），对其进行信用好坏的判别。

代码如下：

#距离判别法

discrim.dist<-function(x){

data<-read.csv(\ #读取数据 G1<-data[1:5,]; G2<-data[6:10,];

u1<-apply(G1,2,mean); #计算信用好的样本数据均值 u2<-apply(G2,2,mean); #计算信用不好的样本数据均值 s1<-cov(G1); s2<-cov(G2); s<-s1+s2; xbar<-(u1+u2)/2;

alpha<-solve(s)%*%(u1-u2); #计算判别系数alpha w<-t(alpha)%*%(x-xbar); #构造判别函数 if(w>=0) #结果输出

cat(\该客户属于信用好的一类\ else

cat(\该客户属于信用坏的一类\}

#费希尔判别法

fisher.test<-function(x){

data<-read.csv(\ #读取数据 G1<-data[1:5,]; G2<-data[6:10,]; n1<-nrow(G1); n2<-nrow(G2);

u1<-apply(G1,2,mean); #计算信用好的一组的数据均值

u2<-apply(G2,2,mean); #计算信用不好的一组的样本数据均值 s1<-cov(G1); s2<-cov(G2); E<-s1+s2;

B<-n1*n2*(u1-u2)%*%t(u1-u2)/(n1+n1); alpha<-eigen(solve(E)%*%B);

vector<-alpha$vectors[,1]; #提取费希尔判别函数系数

d1<-abs(t(vector)%*%x-t(vector)%*%u1); #计算样本到第一组的费希尔判别函数值

3

d2<-abs(t(vector)%*%x-t(vector)%*%u2); #计算样本到第二组的费希尔判别函数值 if(d1

cat(\该客户属于信用好的一类\ else

cat(\该客户属于信用坏的一类\}

运行结果及分析：

注：由于在本题的情形下，距离判别与贝叶斯判别等价，故在此处仅选取距离判别进行编程。

距离判别的运行结果：

> x<-c(53,1,9,18,50,11.20,2.02,3.58) >discrim.dist(x)

该客户属于信用好的一类

费希尔判别的运行结果：

> x<-c(53,1,9,18,50,11.20,2.02,3.58) >fisher.test(x)

该客户属于信用好的一类

从上面的运行结果可以看出该客户属于信用好的一类，即已履行还贷责任。

3、聚类分析

问题重述：下表（数据见压缩包）是某年我国16个地区农民支出情况的抽样调查数据，每个

地区调查了反映每人平均生活消费支出情况的六个经济指标。试使用系统聚类法和K均值法对这些地区进行聚类分析，并对结果进行分析比较。

代码如下：

#系统聚类法

data<-read.csv(\ #读取数据 Cludata<-data[,2:7];

Dismatrix<-dist(Cludata,method=\ #计算样本间的欧几里得距离 Clu1<-hclust(d=Dismatrix,method=\ #最短距离法 Clu2<-hclust(d=Dismatrix,method=\ #最长距离法 Clu3<-hclust(d=Dismatrix,method=\ #重心法

Clu4<-hclust(d=Dismatrix,method=\ #离差平方和法 ###绘出四种方法情况下的谱系图和聚类情况 opar<-par(mfrow=c(2,2));

plot(Clu1,labels=data[,1]);re1<-rect.hclust(Clu1,k=5,border=\

4

10 46.98910 江苏 3 11 45.69279 浙江 4 13 45.67545 福建 5 2 45.49443 河北 6 19 45.42103 广东 7 14 44.84118 江西 8 9 44.47630 上海 9 1 44.19970 北京 10 31 43.89986 新疆 11 30 43.89648 宁夏 12 6 43.85077 辽宁 13 22 43.84919 重庆 14 12 43.81336 安徽 15 20 43.65408 广西 16 17 43.41939 湖北 17 4 42.94670 山西 18 27 42.73741 陕西 19 18 41.22774 湖南 20 29 40.63502 青海 21 21 40.16107 海南 22 23 40.02236 四川 23 7 39.94659 吉林 24 5 39.33251 内蒙古 25 8 39.01378 黑龙江 26 25 38.63829 云南 27 28 37.48472 甘肃 28 16 36.96833 河南 29 26 36.29778 西藏 30 24 35.74812 贵州 31

上面的结果中，rank列为排名，从上到下按得分从大到小排序。此结果可能会有些许疑问，那就是北京上海等强势地区为何排名却少许靠后。从数据方面来看，我们可以看到例如X3每万人拥有公共交通车辆，X4人均城市道路面积，X5人均公园绿地面积，X6每万人拥有公共厕所的数量等这些涉及到人均或者人口数量的指标对于人口十分密集的地区来说得分应该不会太高，因为北京上海这种人口十分密集的地区虽然强势，但是排名却不是十分靠前。

5、因子分析

问题重述：利用因子分析方法分析下列30个学生成绩的因子构成，并分析各个学生较适合学

文科还是理科。

代码如下：

10

library(psych);

data<-read.csv(\correlations<-cor(data); #计算相关系数矩阵

fa<-fa(correlations,nfactors=2,rotate=\ #设定因子数为2，采用正交旋转进行因子分析 ###画出因子图形

factor.plot(fa,labels=rownames(fa$loadings)); fa.diagram(fa,simple=FALSE); data<-as.matrix(data);

faFs<-data%*ú$weight; #计算因子得分 outcome<-c(); for(i in 1:30){

ifelse((faFs[i,1]>faFs[i,2]),outcome<-c(outcome,\文科\理科\ };

outcome<-as.vector(outcome); #根据得分决定文理科 result<-cbind(data,outcome);

运行结果及分析：

从图上我们看出数学物理化学在第二个因子上载荷较大，语文英语历史在第一个因子载荷上较大，因此我们也就可以将第一个因子和第二个因子理解成日常中的文科和理科

接下来根据每个学生的因子得分比较来分析该学生适合文科还是理科，结果如下：

11

> result

数学物理化学语文历史英语 outcome

[1,] \ \ \文科\ [2,] \ \ \文科\ [3,] \ \ \文科\ [4,] \ \ \文科\ [5,] \ \ \文科\ [6,] \ \ \文科\ [7,] \ \ \文科\ [8,] \ \ \文科\ [9,] \ \理科\ [10,] \ \ \理科\ [11,] \ \ \文科\ [12,] \ \ \文科\ [13,] \ \ \理科\ [14,] \ \ \理科\ [15,] \ \ \文科\ [16,] \ \ \文科\ [17,] \ \ \文科\ [18,] \ \ \文科\ [19,] \ \ \文科\ [20,] \ \ \文科\ [21,] \ \ \理科\ [22,] \ \ \文科\ [23,] \ \ \文科\ [24,] \ \ \文科\ [25,] \ \ \理科\ [26,] \ \ \文科\ [27,] \ \ \理科\ [28,] \ \ \文科\ [29,] \ \ \理科\ [30,] \ \理科\

6 相应分析

问题重述：费希尔研究头发颜色与眼睛颜色的关系，抽查了5387人的资料如下表，试对其进行相

应分析。数据见压缩包。

代码如下：

library(ca);

data<-read.csv(\data1<-as.matrix(data[,2:6]);

12

rownames(data1)<-data[,1]; ca<-ca(data1); plot(ca);

运行结果及分析：

> ca

Principal inertias (eigenvalues):

1 2 3 Value 0.198294 0.030622 0.009021 Percentage 83.34% 12.87% 3.79%

Rows:

蓝色淡蓝浅蓝深蓝

Mass 0.127616 0.295217 0.331465 0.245703 ChiDist 0.500912 0.457501 0.245240 0.710949 Inertia 0.032020 0.061791 0.019935 0.124190 Dim. 1 -0.914587 -0.986518 0.068155 1.568406 Dim. 2 -1.196517 -0.406410 1.378854 -0.750370

Columns:

金黄色红色褐色深红黑色

Mass 0.271861 0.046898 0.399290 0.259903 0.022048 ChiDist 0.580403 0.459708 0.207929 0.592499 1.125736 Inertia 0.091581 0.009911 0.017263 0.091240 0.027941 Dim. 1 -1.234421 -0.323621 -0.107735 1.307839 2.443530 Dim. 2 -1.061472 0.661904 1.137227 -0.620082 -1.605231

13

从结果我们可以看出眼睛颜色与头发颜色这两个变量之间的关系为：淡蓝色和蓝色的眼睛与金黄色的头发有较大关联；浅蓝色的眼睛和红色还有褐色的头发有较大的关联；深蓝色的眼睛与深绿还有黑色的头发有较大的关联。

14

本文来源：https://www.bwwdw.com/article/xoy7.html