统计建模与R软件课后答案

第二章

2.1

> x<-c(1,2,3);y<-c(4,5,6) > e<-c(1,1,1) > z<-2*x+y+e;z [1] 7 10 13

> z1<-crossprod(x,y);z1 [,1] [1,] 32 > z2<-outer(x,y);z2 [,1] [,2] [,3] [1,] 4 5 6 [2,] 8 10 12 [3,] 12 15 18 2.2

(1) > A<-matrix(1:20,nrow=4);B<-matrix(1:20,nrow=4,byrow=T) > C<-A+B;C (2) > D<-A%*%B;D (3) > E<-A*B;E (4) > F<-A[1:3,1:3] (5) > G<-B[,-3]

2.3

> x<-c(rep(1,5),rep(2,3),rep(3,4),rep(4,2));x 2.4

> H<-matrix(nrow=5,ncol=5) > for (i in 1:5) + for(j in 1:5) + H[i,j]<-1/(i+j-1) （1）> det(H) （2）> solve(H) （3）> eigen(H) 2.5

> studentdata<-data.frame(姓名=c('张三','李四','王五','赵六','丁一') + ,性别=c('女','男','女','男','女'),年龄=c('14','15','16','14','15'),

+ 身高=c('156','165','157','162','159'),体重=c('42','49','41.5','52','45.5')) 2.6

> write.table(studentdata,file='student.txt') > write.csv(studentdata,file='student.csv') 2.7

count<-function(n) { if (n<=0)

print('要求输入一个正整数')

else{ repeat{ if (n%%2==0) n<-n/2 else n<-(3*n+1) if(n==1)break }

print('运算成功')} }

第三章

3.1

首先将数据录入为x。利用data_outline函数。如下 > data_outline(x) 3.2

> hist(x,freq=F)

> lines(density(x),col='red') > y<-min(x):max(x)

> lines(y,dnorm(y,73.668,3.9389),col='blue') > plot(ecdf(x),verticals=T,do.p=F) > lines(y,pnorm(y,73.668,3.9389))

> qqnorm(x) > qqline(x) 3.3 > stem(x) > boxplot(x) > fivenum(x) 3.4

> shapiro.test(x)

> ks.test(x,'pnorm',73.668,3.9389)

One-sample Kolmogorov-Smirnov test data: x

D = 0.073, p-value = 0.6611 alternative hypothesis: two-sided

Warning message:

In ks.test(x, \

ties should not be present for the Kolmogorov-Smirnov test

这里出现警告信息是因为ks检验要求样本数据是连续的，不允许出现重复值

3.5

>x1<-c(2,4,3,2,4,7,7,2,2,5,4);x2<-c(5,6,8,5,10,7,12,12,6,6);x3<-c(7,11,6,6,7,9,5,5,10,6,3,10)

> boxplot(x1,x2,x3,names=c('x1','x2','x3'),vcol=c(2,3,4)) >windows()

>plot(factor(c(rep(1,length(x1)),rep(2,length(x2)),rep(3,length(x3)))),c(x1,x2,x3)) 3.6

> rubber<-data.frame(x1=c(65,70,70,69,66,67,68,72,66,68),

+x2=c(45,45,48,46,50,46,47,43,47,48),x3=c(27.6,30.7,31.8,32.6,31.0,31.3,37.0,33.6,33.1,34.2)) > plot(rubber)

具体有相关关系的两个变量的散点图要么是从左下角到右上角（正相关），要么是从左上角到右下角（负相关）。从上图可知所有的图中偶读没有这样的趋势，故均不相关。 3.7

（1）> student<-read.csv('3.7.csv') > attach(student) > plot(体重~身高)

（2）> coplot(体重~身高|性别) （3）> coplot(体重~身高|年龄) （4）> coplot(体重~身高|年龄+性别) 只列出（4）的结果，如下图

3.8

> x<-seq(-2,3,0.5);y<-seq(-1,7,0.5) > f<-function(x,y)

+ x^4-2*x^2*y+x^2-2*x*y+2*y^2+9*x/2-4*y+4 > z<-outer(x,y,f)

>contour(x,y,z,levels=c(0,1,2,3,4,5,10,15,20,30,40,50,60,80,100),col='blue') > windows()

> persp(x,y,z,theta=30,phi=30,expand=0.7,col='red') 3.9

> cor.test(身高,体重)

根据得出的结果看是相关的。具体结果不再列出 3.10

> df<-read.csv('48名求职者得分.csv') > stars(df)

然后按照G的标准来画出星图 > attach(df)

> df$G1<-(SC+LC+SMS+DRV+AMB+GSP+POT)/7 > df$G2<-(FL+EXP+SUIT)/3 > df$G3<-(LA+HON+KJ)/3 > df$G4<-AA > df$G5<-APP

> a<-scale(df[,17:21]) > stars(a)

这里从17开始取，是因为在df中将ID也作为了一列 3.11

使用P159已经编好的函数unison，接着上题，直接有 > unison(a)

第四章

4.1

（1）先求矩估计。 总体的期望为?(a?1)xa?1dx?????a?1a?1?E(x)。可解。因此我们有

a?2a?2得a=(2*E（?? ）-1）/(1-E(?? )).因此我们用样本的均值来估计a即可。在R中实现如下

> x<-c(0.1,0.2,0.9,0.8,0.7,0.7) > (2*mean(x)-1)/(1-mean(x)) [1] 0.3076923

（2）采用极大似然估计 首先求出极大似然函数为

??

??

L a;x = ??+1 ??????=(??+1)?? ??????

??=1

??=1

再取对数为

??

lnL a;x =nln a+1 +aln( ????

??=1

最后求导

??lnL(a;x)??

=+ln ???? ??????+1??=1??

好了下面开始用R编程求解，注意此题中n=6. 方法一、

使用unniroot函数

> f<-function(a) 6/(a+1)+sum(log(x)) > uniroot(f,c(0,1)) 方法二、

使用optimize函数

> g<-function(a) 6*log(a+1)+a*sum(log(x)) > optimize(g,c(0,1),maximum=T) 4.2

用极大似然估计得出λ=n/ ????=1????.现用R求解如下

>x<-c(rep(5,365),rep(15,245),rep(25,150),rep(35,100),rep(45,70),rep(55,45),rep(65,25)) > 1000/sum(x) 4.3

换句话讲，就是用该样本来估计泊松分布中的参数，然后求出该分布的均值。我们知道泊松分布中的参数λ，既是均值又是方差。因此我们只需要用样本均值作矩估计即可

在R中实现如下

> x<-c(rep(0,17),rep(1,20),rep(2,10),rep(3,2),rep(4,1)) > mean(x) [1] 1 4.4

> f<-function(x) {

+obj<-c(-13+x[1]+((5-x[2])*x[2]-2)*x[2],(-29+x[1]+((x[2]+1)*x[2]-14)*x[2]))

+ sum(obj^2)} > nlm(f,c(0.5,-2)) 4.5

在矩估计中，正态分布总体的均值用样本的均值估计。故在R中实现如下

> x<-c(54,67,68,78,70,66,67,70,65,69) > mean(x) [1] 67.4

然后用t.test作区间估计，如下 > t.test(x)

> t.test(x,alternative='less') > t.test(x,alternative='greater')

此时我们只需要区间估计的结果，所以我们只看t.test中的关于置信区间的输出即可。t.test同时也给出均值检验的结果，但是默认mu=0

并不是我们想要的。下面我们来做是否低于72的均值假设检验。如下

> t.test(x,alternative='greater',mu=72) One Sample t-test data: x

t = -2.4534, df = 9, p-value = 0.9817

alternative hypothesis: true mean is greater than 72 95 percent confidence interval: 63.96295 Inf sample estimates: mean of x 67.4

结果说明：我们的备择假设是比72要大，但是p值为0.9817，所以我们不接受备择假设，接受原假设比72小。因此这10名患者的平均脉搏次数比正常人要小。 4.6

我们可以用两种方式来做一做

> x<-c(140,137,136,140,145,148,140,135,144,141) > y<-c(135,118,115,140,128,131,130,115,131,125) > t.test(x,y,var.equal=T) > t.test(x-y)

结果不再列出，但是可以发现用均值差估计和配对数据估计的结果的

数值有一点小小的差别。但得出的结论是不影响的（他们的期望差别很大） 4.7

> A<-c(0.143,0.142,0.143,0.137) > B<-c(0.140,0.142,0.136,0.138,0.140) > t.test(A,B) 4.8

> x<-c(140,137,136,140,145,148,140,135,144,141) > y<-c(135,118,115,140,128,131,130,115,131,125) > var.test(x,y) > t.test(x,y,var.equal=F) 4.9

泊松分布的参数就等于它的均值也等于方差。我们直接用样本均值来估计参数即可，然后作样本均值0.95的置信区间即可。 > x<-c(rep(0,7),rep(1,10),rep(2,12),rep(3,8),rep(4,3),rep(5,2)) > mean(x) [1] 1.904762 > t.test(x) 4.10

正态总体均值用样本均值来估计。故如下

> x<-c(1067,919,1196,785,1126,936,918,1156,920,948)

> t.test(x,alternative='greater')

注意greater才是求区间下限的（都比它大的意思嘛）

第五章

5.1

这是一个假设检验问题，即检验油漆作业工人的血小板的均值是否为225.在R中实现如下 > x<-scan()

1: 220 188 162 230 145 160 238 188 247 113 11: 126 245 164 231 256 183 190 158 224 175 21: Read 20 items > t.test(x,mu=225) 5.2

考察正态密度函数的概率在R中的计算。首先我们要把该正态分布的均值和方差给估计出来，这个就利用样本即可。然后用pnorm函数来计算大于1000的概率。如下

> x<-c(1067,919,1196,785,1126,936,918,1156,920,948) > pnorm(1000,mean(x),sd(x)) [1] 0.5087941 > 1-0.5087941 [1] 0.4912059

5.3

这是检验两个总体是否存在差异的问题。可用符号检验和wilcoxon秩检验。两种方法实现如下

> x<-c(113,120,138,120,100,118,138,123) > y<-c(138,116,125,136,110,132,130,110) > binom.test(sum(x

> wilcox.test(x,y,exact=F) p-value = 0.792

可见无论哪种方法P值都大于0.05，故接受原假设，他们无差异 5.4

（1）采用w检验法

>x<-c(-0.7,-5.6,2,2.8,0.7,3.5,4,5.8,7.1,-0.5,2.5,-1.6,1.7,3,0.4,4.5,4.6,2.5,6,-1.4)

>y<-c(3.7,6.5,5,5.2,0.8,0.2,0.6,3.4,6.6,-1.1,6,3.8,2,1.6,2,2.2,1.2,3.1,1.7,-2) > shapiro.test(x) > shapiro.test(y) 采用ks检验法

> ks.test(x,'pnorm',mean(x),sd(x)) > ks.test(y,'pnorm',mean(y),sd(y)) 采用pearson拟合优度法对x进行检验 > A<-table(cut(x,br=c(-2,0,2,4,6,8)))

> A

(-2,0] (0,2] (2,4] (4,6] (6,8] 4 4 6 4 1

发现A中有频数小于5，故应该重新调整分组 > A<-table(cut(x,br=c(-2,2,4,8))) > A

(-2,2] (2,4] (4,8] 8 6 5 然后再计算理论分布

> p<-pnorm(c(-2,2,4,8),mean(x),sd(x)) > p<-c(p[2],p[3]-p[2],1-p[3]) 最后检验 > chisq.test(A,p=p)

采用pearson拟合优度法对y进行检验 > B<-table(cut(y,br=c(-2.1,1,2,4,7))) > B

(-2.1,1] (1,2] (2,4] (4,7] 5 5 5 5 > p<-pnorm(c(1,2,4),mean(y),sd(y)) > p<-c(p[1],p[2]-p[1],p[3]-p[2],1-p[3]) > chisq.test(B,p=p)

以上的所有结果都不再列出，结论是试验组和对照组都是来自正态分

布。

（2）> t.test(x,y,var.equal=F) > t.test(x,y,var.equal=T) > t.test(x,y,paired=T) 结论是均值无差异 （3）> var.test(x,y) 结论是方差相同

由以上结果可以看出这两种药的效果并无二致 5.5

（1）对新药组应用chisq.test检验（也可用ke.test检验） > x<-c(126,125,136,128,123,138,142,116,110,108,115,140) > y<-c(162,172,177,170,175,152,157,159,160,162) > p<-pnorm(c(105,125,145),mean(x),sd(x)) > p<-c(p[2],1-p[2]) > chisq.test(A,p=p) 对对照组用ks.test检验 > ks.test(y,'pnorm',mean(y),sd(y)) 结论是他们都服从正态分布 （2）> var.test(x,y) 结论是方差相同

（3）> wilcox.test(x,y,exact=F)

结果是有差别 5.6

明显是要检验二项分布的p值是否为0.147.R实现如下 > binom.test(57,400,p=0.147) 结果是支持 5.7

也就是检验二项分布中的p值是否大于0.5 > binom.test(178,328,p=0.5,alternative='greater') 结果是不能认为能增加比例 5.8

就是检验你的样本是否符合那个分布 > chisq.test(c(315,101,108,32),p=c(9,3,3,1)/16) 结果显示符合自由组合规律 5.9

又是检验一个总体是否符合假定分布。 > x<-0:5;y<-c(92,68,28,11,1,0) > z<-rep(x,y)

> A<-table(cut(z,br=c(-1,0,1,2,5))) > q<-ppois(c(0,1,2,5),mean(z)) > p<-c(q[1],q[2]-q[1],q[3]-q[2],1-q[3]) > chisq.test(A,p=p) 结论是符合泊松分布

5.10

> x<-c(2.36,3.14,7.52,3.48,2.76,5.43,6.54,7.41) > y<-c(4.38,4.25,6.53,3.28,7.21,6.55) > ks.test(x,y) 5.11

即列联表的的独立性检验 > x<-c(358,229,2492,2754) > dim(x)<-c(2,2)

> chisq.test(x)或> fisher.test(x) 结论是有影响 5.12

> x<-c(45,12,10,46,20,28,28,23,30,11,12,35) > dim(x)<-c(4,3) > chisq.test(x) 结果是相关 5.13 > x<-c(3,4,6,4) > dim(x)<-c(2,2) > fisher.test(x)

结果显示工艺对产品质量无影响 5.14

即检验两种研究方法是否有差异

> x<-c(58,2,3,1,42,7,8,9,17) > dim(x)<-c(3,3)

> mcnemar.test(x,correct=F) 结果表明两种检测方法有差异 5.15

> x<-c(13.32,13.06,14.02,11.86,13.58,13.77,13.51,14.42,14.44,15.43) > binom.test(sum(x>14.6),length(x),al='l') > wilcox.test(x,mu=14.6,al='l',exact=F) 结果表明是在中位数之下 5.16

（1）（2）（3） > x<-scan()

1: 48.0 33.0 37.5 48.0 42.5 40.0 42.0 36.0 11.3 22.0 11: 36.0 27.3 14.2 32.1 52.0 38.0 17.3 20.0 21.0 46.1 21: Read 20 items > y<-scan()

1: 37.0 41.0 23.4 17.0 31.5 40.0 31.0 36.0 5.7 11.5 11: 21.0 6.1 26.5 21.3 44.5 28.0 22.6 20.0 11.0 22.3 21: Read 20 items

> binom.test(sum(x

> wilcox.test(x,y,paired=T,exact=F) > wilcox.test(x,y,exact=F)

（4）> ks.test(x,'pnorm',mean(x),sd(x)) > ks.test(y,'pnorm',mean(y),sd(y)) > var.test(x,y)

由以上检验可知数据符合正态分布且方差相同，故可做t检验 > t.test(x,y)

可以发现他们的均值是有差别的

（5）综上所述，Wilcoxon符号秩检验的差异检出能力最强，符号检验的差异检出最弱。 5.17

> x<-c(24,17,20,41,52,23,46,18,15,29) > y<-c(8,1,4,7,9,5,10,3,2,6) > cor.test(x,y,method='spearman') > cor.test(x,y,method='kendall') 有关系的 5.18 > x<-1:5

> y<-c(rep(x,c(0,1,9,7,3))) > z<-c(rep(x,c(2,2,11,4,1))) > wilcox.test(y,z,exact=F) 结果显示这两种疗法没什么区别

第六章

6.1

（1）> snow<-data.frame(X=c(5.1,3.5,7.1,6.2,8.8,7.8,4.5,5.6,8.0,6.4), + Y=c(1907,1287,2700,2373,3260,3000,1947,2273,3113,2493)) > plot(snow$X,snow$Y) 结论是有线性关系的。 （2）（3）

> lm.sol<-lm(Y~1+X,data=snow);summary(lm.sol) 结果是方程是显著的

（4）> predict(lm.sol,data.frame(X=7),interval='prediction',level=0.95) fit lwr upr 1 2690.227 2454.971 2925.484 6.2 （1）（2）

> soil<-data.frame(X1=c(0.4,0.4,3.1,0.6,4.7,1.7,9.4,10.1,11.6,12.6, + 10.9,23.1,23.1,21.6,23.1,1.9,26.8,29.9),X2=c(52,23,19,34,24,65,44,31, + 29,58,37,46,50,44,56,36,58,51),X3=c(158,163,37,157,59,123,46,117, + 173,112,111,114,134,73,168,143,202,124),Y=c(64,60,71,61,54,77,81, + 93,93,51,76,96,77,93,95,54,168,99))

> lm.sol<-lm(Y~1+X1+X2+X3,data=soil);summary(lm.sol)

我们发现X2和X3的系数没有通过t检验。但是整个方程通过了检验。

（3）> lm.ste<-step(lm.sol) > summary(lm.ste)

可以发现新模型只含有X1和X3，但是X3的系数还是不显著。接下来考虑用drop1函数处理 > drop1(lm.ste)

发现去掉X3残差升高最小，AIC只是有少量增加。因此应该去掉X3 > lm.new<-lm(Y~X1,data=soil);summary(lm.new) 此时发现新模型lm.new系数显著且方程显著 6.3

（1）> da<-data.frame(X=c(1,1,1,1,2,2,2,3,3,3,4,4,4,5,6,6,6,7,7,7,8,8,8, + 9,11,12,12,12),Y=c(0.6,1.6,0.5,1.2,2.0,1.3,2.5,2.2,2.4,1.2,3.5,4.1, + 5.1,5.7,3.4,9.7,8.6,4.0,5.5,10.5,17.5,13.4,4.5,30.4,12.4,13.4, + 26.2,7.4)) > plot(da$X,da$Y) > lm.sol<-lm(Y~X,data=da) > abline(lm.sol) （2）> summary(lm.sol) 全部通过

（3）> plot(lm.sol,1) > windows() > plot(lm.sol,3)

可以观察到误差符合等方差的。但是有残差异常值点24,27,28.

（4）> lm.up<-update(lm.sol,sqrt(.)~.) > summary(lm.up) 都通过检验 > plot(da$X,da$Y) > abline(lm.up) > windows() > plot(lm.up,1) > windows() > plot(lm.up,3)

可以发现还是有残差离群值24,28 6.4

> lm.sol<-lm(Y~1+X1+X2,data=toothpaste);summary(lm.sol) > influence.measures(lm.sol) > plot(lm.sol,3)

通过influence.measures函数发现5,8,9,24对样本影响较大，可能是异常值点，而通过残差图发现5是残差离群点，但是整个残差还是在[-2,2]之内的。因此可考虑剔除5,8,9,24点再做拟合。 > lm.new<-lm(Y~1+X1+X2,data=toothpaste,subset=c(-5,-8,-9,-24)) > windows() > plot(lm.new,3) > summary(lm.new)

我们发现lm.new模型的残差都控制在[-1.5,1.5]之内，而且方程系数

和方程本身也都通过检验。 6.5

> cement<-data.frame(X1=c(7,1,11,11,7,11,3,1,2,21,1,11,10), + X2=c(26,29,56,31,52,55,71,31,54,47,40,66,68), + X3=c(6,15,8,8,6,9,17,22,18,4,23,9,8), + X4=c(60,52,20,47,33,22,6,44,22,26,34,12,12),

+Y=c(78.5,74.3,104.3,87.6,95.9,109.2,102.7,72.5,93.1,115.9,83.8,113.3,109.4))

> XX<-cor(cement[1:4]) > kappa(XX,exact=T) [1] 1376.881 > eigen(XX)

发现变量的多重共线性很强，且有 0.241X1+0.641X2+0.268X3+0.676X4=0

说明X1,X2，X3，X4多重共线。其实逐步回归可以解决多重共线的问题。我们可以检验一下step函数去掉变量后的共线性。step去掉了X3和X4。我们看看去掉他们的共线性如何。 > XX<-cor(cement[1:2]) > kappa(XX,exact=T) [1] 1.59262

我们发现去掉X3和X4后，条件数降低好多好多。说明step函数是合理的。

6.6

首先得把这个表格看懂。里面的数字应该是有感染和无感染的人数。 而影响变量有三个。我们把这些影响变量进行编码。如下。

发生 抗生素X1 危险因子X2 有无计划X3 是否感染Y 不发生 2 3 4 6 1 5 7 0 对数据的处理，如下

X1 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 X2 4 4 5 5 4 4 5 5 4 4 4 4 5 5 5 5 X3 6 6 6 6 7 7 7 7 6 6 7 7 6 6 7 7 Y 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 频数 1 17 0 2 11 87 0 0 28 30 23 3 8 32 0 9 然后用R处理并求解模型

>hospital<-data.frame(X1=rep(c(2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3),c(1,17,0,2,11,87,

+ 0,0,28,30,23,3,8,32,0,9)),X2=rep(c(4,4,5,5,4,4,5,5,4,4,4,4,5,5,5,5), + c(1,17,0,2,11,87,

+ 0,0,28,30,23,3,8,32,0,9)),X3=rep(c(6,6,6,6,7,7,7,7,6,6,7,7,6,6,7,7),

+ c(1,17,0,2,11,87,0,0,28,30,23,3,8,32,0,9)), +

Y=rep(c(1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0),c(1,17,0,2,11,87,0,0,28,30,23,3,8,32,0,9)) + )

> glm.sol<-glm(Y~X1+X2+X3,family=binomial,data=hospital) > summary(glm.sol)

可以发现如果显著性为0.1，则方程的系数和方程本省全部通过检验。 下面我们来做一个预测，看看（使用抗生素，有危险因子，有计划）的一个孕妇发生感染的概率是多少。

> pre<-predict(glm.sol,data.frame(X1=2,X2=4,X3=6)) > p<-exp(pre)/(1+exp(pre));p 1 0.04240619

即感染的概率为4.2% 6.7

（1）> cofe<-data.frame(X=c(0,0,1,1,2,2,3,3,4,4,5,5,6,6),Y=c(508.1,498.4, +568.2,577.3,651.7,657,713.4,697.5,755.3,758.9,787.6,792.1,841.4,831.8))

> lm.sol<-lm(Y~X,data=cofe) > summary(lm.sol)

（2）> lm.s2<-lm(Y~X+I(X^2),data=cofe)

> summary(lm.s2) （3）> plot(cofe$X,cofe$Y) > abline(lm.sol) > windows() > plot(cofe$X,cofe$Y)

> lines(spline(cofe$X,fitted(lm.s2))) 6.8

（1）> pe<-read.csv('6.8.csv',header=T)

> glm.sol<-glm(Y~X1+X2+X3+X4+X5,family=binomial,data=pe) > summary(glm.sol)

可以发现各变量影响基本都不显著，甚至大部分还没通过显著性检验。 只有X1的系数通过了显著性检验，但是也不是很理想。下面计算每一个病人的生存时间大于200天的概率值。

>pre<-predict(glm.sol,data.frame(X1=pe$X1,X2=pe$X2,X3=pe$X3,X4=pe$X4,X5=pe$X5))

> p<-exp(pre)/(1+exp(pre)) > p

（2）> lm.ste<-step(glm.sol) 结果是只保留了变量X1和X4。

避免了多重共线性。更加合理一些。下面计算各个病人的存活概率。 >pre<-predict(lm.ste,data.frame(X1=pe$X1,X2=pe$X2,X3=pe$X3,X4=pe$X4,X5=pe$X5))

> p.new<-exp(pre)/(1+exp(pre)) > p.new

显然经过逐步回归后的模型更合理。用summary(lm.ste)看，第二个模型通过了显著性检验（a=0.1） 6.9

(1) 首先将公式线性化，对方程两边直接取对数即可。然后将得到的方程用lm回归。

> peo<-data.frame(X=c(2,5,7,10,14,19,26,31,34,38,45,52,53,60,65), + Y=c(54,50,45,37,35,25,20,16,18,13,8,11,8,4,6)) > lm.sol<-lm(log(Y)~1+X,data=peo);summary(lm.sol)

Coefficients:

Estimate Std. Error t value Pr(>|t|) (Intercept) 4.037159 0.084103 48.00 5.08e-16 *** X -0.037974 0.002284 -16.62 3.86e-10 *** > lm.sum<-summary(lm.sol) > exp(lm.sum$coefficients[1,1]) [1] 56.66512

所以theta0=56.66512,theta1=-0.0379

（2）> nls.sol<-nls(Y~b0*exp(b1*X),data=peo,start=list(b0=50,b1=0)) > summary(nls.sol) Parameters:

Estimate Std. Error t value Pr(>|t|) b0 58.606535 1.472160 39.81 5.70e-15 *** b1 -0.039586 0.001711 -23.13 6.01e-12 *** 发现所求的基本上与内在线性相同。 第七章 7.1

（1）>pro<-data.frame(Y=c(115,116,98,83,103,107,118,116,73,89,85,97), + X=factor(rep(1:3,rep(4,3)))) > pro.aov<-aov(Y~X,data=pro) > summary(pro.aov)

可以看到不同工厂对产品的影响是显著的 （2）首先自己编写求均值的小程序如下

> K<-matrix(0,nrow=1,ncol=3,dimnames=list('mean',c('甲','乙','丙'))) > for(i in 1:3)

+ K[1,i]<-mean(pro$Y[pro$X==i]) > K

甲 乙 丙 mean 103 111 86

然后再用t.test来做均值的置信区间估计 > pro.jia<-t.test(pro$Y[pro$X==1]);pro.jia > pro.yi<-t.test(pro$Y[pro$X==2]);pro.yi > pro.bing<-t.test(pro$Y[pro$X==3]);pro.bing

（3）> pairwise.t.test(pro$Y,pro$X) 1 2 2 0.35 - 3 0.13 0.04

可以看到显著性主要有乙工厂和丙工厂造成 7.2

（1）> old<-data.frame(Y=c(20,18,19,17,15,16,13,18,22,17,26,19,26,28, + 23,25,24,25,18,22,27,24,12,14),X=factor(rep(1:4,c(10,6,6,2)))) > old.aov<-aov(Y~X,data=old) > summary(old.aov)

可以发现影响是非常显著的。 （2）> pairwise.t.test(old$Y,old$X)

直接从结果就可以发现国内只有以工厂和丙工厂与国外工厂有显著差异。而国内只有甲乙，甲丙之间存在着显著差异。 7.3

> rat<-data.frame(X=c(30,27,35,35,29,33,32,36,26,41,33,31,43,45,53,44, + 51,53,54,37,47,57,48,42,82,66,66,86,56,52,76,83,72,73,59,53), + A=gl(3,12))

> shapiro.test(rat$X[A==1]) > shapiro.test(rat$X[rat$A==2]) > shapiro.test(rat$X[rat$A==3]) > bartlett.test(X~A,data=rat)

可以看到

数据符合正态性但是不是方差齐性的 7.4

> rat<-data.frame(Y=c(2.79,2.69,3.11,3.47,1.77,2.44,2.83,2.52,3.83, + 3.15,4.7,3.97,2.03,2.87,3.65,5.09,5.41,3.47,4.92,4.07,2.18,3.13,3.77, + 4.26),X=gl(3,8))

> rat.aov<-aov(Y~X,data=rat) > summary(rat.aov) 结果是显著的 7.5

> sleep<-data.frame(Y=c(23.1,57.6,10.5,23.6,11.9,54.6,21.0,20.3,22.7, + 53.2,9.7,19.6,13.8,47.1,13.6,23.6,22.5,53.7,10.8,21.1,13.7,39.2, + 13.7,16.3,22.6,53.1,8.3,21.6,13.3,37.0,14.8,14.8),X=gl(4,8)) > sleep.aov<-aov(Y~X,data=sleep) > summary(sleep.aov) 结果是不显著 7.6

（1）> pro<-data.frame(Y=c(4.6,4.3,6.1,6.5,6.8,6.4,6.3,6.7,3.4,3.8,4.0,3.8, + 4.7,4.3,3.9,3.5,6.5,7.0),A=gl(3,2,18),B=gl(3,6,18)) > pro.aov<-aov(Y~A+B+A:B,data=pro);summary(pro.aov) 结果是A和B及其交互作用都是十分显著的

（2）首先我们要选出最优条件组合，由（1）知影响力为

AB>A>B。下面我们来计算它们各个水平下的均值。首先要交互作用给找出来。如下 > ab<-function(x,y){ + n<-length(x);z<-rep(0,n) + for( i in 1:n)

+ if(x[i]==y[i]){z[i]<-1}else{z[i]<-2} + factor(z)}

> pro$AB<-ab(pro$A,pro$B)

然后我们开始计算各个水平的均值，如下

> K<-matrix(0,nrow=3,ncol=3,dimnames=list(1:3,c('A','B','AB'))) > for( i in 2:4) + for(j in 1:3)

+ K[j,i-1]<-mean(pro$Y[pro[i]==j]) > K

A B AB 1 5.150000 5.783333 4.933333 2 4.533333 4.666667 5.250000 3 5.750000 4.983333 NaN

按照影响力越大（即P值越小），我们首先确定AB应选择水平2，即A和B 不等的是最好的。然后选择A，选择水平3，那么B只能在1和2中选择，需选择1.于是我们的最优组合为A3B1。 下面给出A3B1的点估计和区间估计。

> mean(pro$Y[pro$A==3&pro$B==1]) > t.test(pro$Y[pro$A==3&pro$B==1]) （3）> pairwise.t.test(pro$Y,pro$AB) > pairwise.t.test(pro$Y,pro$B) > pairwise.t.test(pro$Y,pro$A) 7.7

> rice<-data.frame(A=gl(3,3),B=gl(3,1,9),

+ C=factor(c(1,2,3,2,3,1,3,1,2)),Y=c(69.925,57.075,51.6,55.05,58.05, + 56.55,63.225,50.7,54.45))

> rice.aov<-aov(Y~A+B+C,data=rice);summary(rice.aov)

可以看到影响均不显著，那么我们干脆直接按照各因素水平的均值大小来取。下面计算均值

> K<-matrix(0,nrow=3,ncol=3,dimnames=list(1:3,c('品种','密度','施肥量')))

> for(i in 1:3) + for(j in 1:3)

+ K[i,j]<-mean(rice$Y[rice[j]==i]) > K

品种 密度 施肥量 1 59.53333 62.73333 59.05833 2 56.55000 55.27500 55.52500

3 56.12500 54.20000 57.62500

所以应该选品种8号，密度4.5，施肥量0.75 7.8

首先我们绘制出正交试验表格，如下

列号 试验号 A 1 2 3 4 5 6 7 8 1 B 1 1 1 1 2 2 2 2 1 1 2 2 1 1 2 2 2 A*B C*D 1 1 2 2 2 2 1 1 3 C 1 2 1 2 1 2 1 2 4 A*C B*D 1 2 1 2 2 1 2 1 5 B*C A*D 1 2 2 1 1 2 2 1 6 D 1 2 2 1 2 1 1 2 7 产量 86 95 91 94 91 96 83 88 好吧，表示因为多了一个因素D不知道怎么排列交互作用了，我上面排列的也不一定对。此题暂且不做 7.9

首先把正交试验表的结果那一列给计算出来。如下

> pro<-matrix(c(1.5,1.7,1.3,1.5,1,1.2,1,1,2.5,2.2,3.2,2,2.5,2.5,1.5,2.8, + 1.5,1.8,1.7,1.5,1,2.5,1.3,1.5,1.8,1.5,1.8,2.2,1.9,2.6,2.3,2),ncol=4, + byrow=T)

> pro.mean<-apply(pro,1,mean) 现在可以输入正交试验表了，如下

> pro.data<-data.frame(Y=pro.mean,A=gl(2,4),B=gl(2,2,8),C=gl(2,1,8)) 进行分析

>pro.aov<-aov(Y~A+B+C+A:B+A:C+B:C,data=pro.data);summary(pro.aov)

从分析结果可以看出，显著性大小为B>AB>AC，其余均不显著 下面再计算出均值，从而就可以依据显著性来选择最优参数了 > ab<-function(x,y){ + n<-length(x);z<-rep(0,n) + for( i in 1:n)

+ if(x[i]==y[i]){z[i]<-1}else{z[i]<-2} + factor(z)}

> pro.data$AB<-ab(pro.data$A,pro.data$B) > pro.data$AC<-ab(pro.data$A,pro.data$C)

> K<-matrix(0,nrow=2,ncol=5,dimnames=list(1:2,c('A','B','C','AB','AC'))) > for(i in 2:6) + for(j in 1:2)

+ K[j,i-1]<-mean(pro.data$Y[pro.data[i]==j]) > K

A B C AB AC 1 1.83750 1.43750 1.85625 1.64375 1.93750 2 1.80625 2.20625 1.78750 2.00000 1.70625

依据显著性，首先选择B，选择B1。再依据AB,应选择AB1，也就是说A和B应该是同一水平。那么A就被先选定的B决定了它应该选水平1.然后看AC，应该选2.也就是说A和C应该是不同水平。那么A选择1，C必须选择2.

所以最后的最优组合应该是A1B1C2

即通用夹具，特殊铸铁，留研量0.015

第八章

8.1

> x<-matrix(c(-1.9,3.2,-6.9,10.4,5.2,2,5,2.5,7.3,0,6.8,12.7,0.9,-15.4, + -12.5,-2.5,1.5,1.3,3.8,6.8,0.2,0.2,-0.1,7.5,0.4,14.6,2.7,8.3,2.1,0.8, + -4.6,4.3,-1.7,10.9,-2.6,13.1,2.6,12.8,-2.8,10),ncol=2,byrow=T) > g<-gl(2,1,20)

> distinguish.distance(x,g,c(8.1,2)) > distinguish.bayes(x,g,TstX=c(8.1,2))

> distinguish.bayes(x,g,TstX=c(8.1,2),var.equal=T) > discriminiant.fisher(x[1:10,],x[11:20,],c(8.1,2)) 得出的结论都是明天下雨 8.2

> heart<-read.csv('8.2.csv',header=T) > G<-factor(rep(1:3,c(11,7,5)))

> distinguish.distance(heart,G,var.equal=F) > distinguish.distance(heart,G,var.equal=T)

> distinguish.bayes(heart,G,p=c(11/23,7/23,5/23),var.equal=F) > distinguish.bayes(heart,G,p=c(11/23,7/23,5/23),var.equal=T) 无论方差相同还是不同，对于距离判别的正确率都是78.2% 而方差不同的贝叶斯判别正确率仅仅为65.2%

方差相同的贝叶斯判别正确率为87% 8.3

（1）> study<-read.csv('8.3.csv',header=T)

>X<-data.frame(x1=study$x1,x2=study$x2,x3=study$x3,row.names=study$地区) > d<-dist(X)

> hc.1<-hclust(d,method='complete') > hc.2<-hclust(d,method='average') > hc.3<-hclust(d,method='centroid') > hc.4<-hclust(d,method='ward') > opar<-par(mfrow=c(2,2)) > plot(hc.1,hang=-1) > rect1<-rect.hclust(hc.1,k=4) > plot(hc.2,hang=-1) > rect2<-rect.hclust(hc.2,k=4) > plot(hc.3,hang=-1) > rect3<-rect.hclust(hc.3,k=4) > plot(hc.4,hang=-1) > rect4<-rect.hclust(hc.4,k=4) 下面是各种方法分类的结果 > rect1 > rect2

> rect3 > rect4

（2）> km<-kmeans(scale(X),4,nstart=20) > sort(km$clust) 8.4

> coreer<-read.csv('48名求职者得分.csv',header=T)

>X<-data.frame(x1=coreer$FL,x2=coreer$APP,x3=coreer$AA,x4=coreer$LA,+x5=coreer$SC,x6=coreer$LC,x7=coreer$HON,x8=coreer$SMS,x9=coreer$EXP,

+ x10=coreer$DRV,x11=coreer$AMB,x12=coreer$GSP,x13=coreer$POT, + x14=coreer$KJ,x15=coreer$SUIT,row.names=coreer$ID) > d<-as.dist(1-cor(X))

> hc1<-hclust(d,method='complete') > hc2<-hclust(d,method='average') > hc3<-hclust(d,method='centroid') > hc4<-hclust(d,method='ward') > opar<-par(mfrow=c(2,2)) > plot(hc1,hang=-1) > rect1<-rect.hclust(hc1,5) > plot(hc2,hang=-1) > rect2<-rect.hclust(hc2,5) > plot(hc3,hang=-1)

> rect3<-rect.hclust(hc3,5) > plot(hc4,hang=-1) > rect4<-rect.hclust(hc4,5) 下面打印出分类的结果 > rect1 > rect2 > rect3 > rect4

第九章

9.1

（1）> fac<-read.csv('9.1.csv',header=T) > fac.pr<-princomp(fac,cor=T); > summary(fac.pr)

从结果可以知道前四个主成分的累积贡献率达到0.95.至于他们的意义嘛，这牵涉到经济学知识，我不懂。 （2）> apply(pre,2,order)

我们利用以上代码看每个行业在各个主成分的排序，是从小到大排列的。

下面我们只保留前四个主成分，来对这13个行业进行分类，即聚类分析。

首先我们采用动态聚类方法，如下 > prec<-pre[,1:4]

> precc<-data.frame(x1=prec[,1],x2=prec[,2],x3=prec[,3], + x4=prec[,4],row.names=c('冶金','电力','煤炭','化学','机械', + '建材','森工','食品','纺织','缝纫','皮革','造纸','文教用品')) > km<-kmeans(scale(precc),5) > sort(km$cluster)

然后我们也可以使用系统聚类法，如下 > d<-dist(scale(precc)) > hc<-hclust(d) > plot(hc,hang=-1) > rect<-rect.hclust(hc,k=5) > rect<-rect.hclust(hc,k=5)

> rect #打印出类别结果，便于查看。 9.2

> exp<-data.frame(x1=c(82.9,88,99.9,105.3,117.7,131,148.2,161.8,174.2, +

184.7),x2=c(92,93,96,94,100,101,105,112,112,112),x3=c(17.1,21.3,25.1,29, +

34,40,44,49,51,53),x4=c(94,96,97,97,100,101,104,109,111,111),y=c(8.4, + 9.6,10.4,11.4,12.2,14.2,15.8,17.9,19.6,20.8))

> exp.pr<-princomp(~x1+x2+x3+x4,data=exp,cor=T) > summary(exp.pr)

我们会发现第四个特征值近似为0.0036，接近为0.因此存在多重共线性。故可以用主成分回归来处理。前两个主成分的累积贡献率已经达到99%。因此我们用前两个主成分来实现数据降维的目的。 > pr<-predict(exp.pr) > exp$z1<-pr[,1] > exp$z2<-pr[,2]

> lm.sol<-lm(y~z1+z2,data=exp) > summary(lm.sol)

最后的回归方程不再列出。 9.3

> x<-c(1,0.846,0.805,0.859,0.473,0.398,0.301,0.382,0.846,1,0.881, + 0.826,0.376,0.326,0.277,0.277,0.805,0.881,1,0.801,0.380,0.319,0.237, + 0.345,0.859,0.826,0.801,1,0.436,0.329,0.327,0.365,0.473,0.376,0.380, +

0.436,1,0.762,0.730,0.629,0.398,0.326,0.319,0.329,0.726,1,0.583,0.577, +

0.301,0.277,0.237,0.327,0.730,0.583,1,0.539,0.382,0.415,0.345,0.365,0.629,

+ 0.577,0.539,1)

> names<-c('身高','手臂长','上肢长','下肢长','体重','颈围','胸围','胸宽')

> r<-matrix(x,nrow=8,dimnames=list(names,names)) > fac<-factanal(factors=2,covmat=r) > fac

从结果中我们可以看出，第一个因子主要与身高，手臂长，上肢长，下肢长有关，第二个因子主要与体重，颈围，胸围有光。因此第一个因子可以叫做体长因子，第二个可以叫做身宽因子。 9.4

（1）> X<-data.frame(X1=c(99,99,100,93,100,90,75,93,87,95,76,85), + X2=c(94,88,98,88,91,78,73,84,73,82,72,75), + X3=c(93,96,81,88,72,82,88,83,60,90,43,50), + X4=c(100,97,100,96,78,97,89,88,84,39,78,37)) > X$X5<-c(100,99,96,99,96,75,97,68,76,62,67,34) > fa<-factanal(X,factors=2) > fa

我们分析出两个因子，可以看到第一个因子与前面变量关系更大，可称为文科因子，第二个因子与后面的变量相关，可以称之为理科因子。 （2）> fa<-factanal(X,factors=2,scores='Bartlett') > plot(fa$scores[,1:2],type='n') > text(fa$scores[,1],fa$scores[,2])

从图上直观看出，第7位同学文科强而理科弱，第8,10位同学理科强而文科弱。第1,2,3,5同学文理科都很好。

9.5

> kid<-read.csv('9.5.csv',header=T) > kidc<-scale(kid)

> kid.can<-cancor(kidc[,1:3],kidc[,4:6]) > kid.can

> source(\自编函数\\\\corcoef_test.R\> corcoef.test(kid.can$cor,40,p=3,q=3) [1] 2

由此可见，我们应该从前两对典型相关变量里来对数据进行分析。另外，我们还可以看看那每对典型变量的散点图。 > U<-as.matrix(kidc[,1:3])%*%kid.can$xcoef > V<-as.matrix(kidc[,4:6])%*%kid.can$ycoef > opar<-par(mfrow=c(3,1))

> plot(U[,1],V[,1],xlab='U1',ylab='V1') > plot(U[,2],V[,2],xlab='U2',ylab='V2') > plot(U[,3],V[,3],xlab='U3',ylab='V3')

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