【高级数理统计R语言学习】6 二值变量回归

一、背景
数据集展示了X市高学历外来人口的一些情况。试分析性别、年龄、教育程度和月收入对高学历外来人口的再迁移是否有显著影响以及有怎样的影响。

二、要求和代码

#*****************************变量关系问题*************************************
#1
#利用R读取数据集。注意：不允许改动样本的数据内容。
data6 <- read.csv(file="F:/hxpRlanguage/homework6.csv",header=TRUE,sep=",",stringsAsFactors = F)

#2
#显示数据集的前10条记录。
data6[1:10,]

#3
#对变量重新命名，一律用英文字母命名变量。
cnames <- c("Number","Gender","birthyear","birthmonth","outyear","outmonth","surveyDate","Education","Residence","Income") 
colnames(data6) <- cnames

#4
#显示重命名后数据集中变量的属性情况。
str(data6)

#5
#利用R编写程序对再迁移状况、性别和教育程度变量进行归类，不能用Excel处理数据。
#类别划分标准见Word文件“数据编码要求”。 
#①对迁移状况进行分类
data6$Residence[data6$Residence=="A. 北京"]<-"0"
data6$Residence[data6$Residence=="B. 北京以外的地区"]<-"1"
#②对性别进行分类
data6$Gender[data6$Gender=="A. 男"]<-"1"
data6$Gender[data6$Gender=="B. 女"]<-"0"
#③对教育程度进行分类
data6$Education[data6$Education=="E. 大专" | data6$Education=="F. 大学本科"]<-"0"
data6$Education[data6$Education=="G. 硕士" | data6$Education=="H. 博士"]<-"1"
#转换成因子变量类型
data6$Residence<-as.factor(data6$Residence)
data6$Gender<-as.factor(data6$Gender)
data6$Education<-as.factor(data6$Education)
data0 <- data6

#6
#利用R编写程序计算个体的年龄（以月为单位）。不能用Excel处理数据。
#引入lubridate处理时间日期的包
#install.packages("lubridate")
library(lubridate)
date <- Sys.Date() #获取系统的时间
View(date) #查看现在的日期
nowyear <- year(date) #提取年份
nowmonth <- month(date) #提取月份
Age <- (nowyear*12+nowmonth)-(data6$birthyear*12+data6$birthmonth)
data6 <- cbind(data6,Age)

#7
#删除年龄小于16岁（192个月）的记录。
a=c(which(data6[,"Age"]<192))
if(length(a)==0){
  print("无年龄小于16岁（192个月）的记录")
}else{
  newdata<-data6[-a,]
  print("删除成功")
}

#8
#删除月收入小于500元的记录。
data6 <- data6[data6$Income>=500,]
data6$logIncome<-log(data6$Income)  #转对数收入
data66 <- data6

#9
#分别画图展示数据集中再迁移状况与年龄、收入的关系。
par(mfrow = c(1,2))
boxplot(Age~Residence,xlab="再迁移",ylab="年龄",data=data6)
boxplot(logIncome~Residence,xlab="再迁移",ylab="对数收入",data=data6)
#年龄和对数收入是有显著差异的；基本上可以判断年龄和对数收入的差异对迁移的状况是有显著影响的

#10
#分别检验再迁移状况与性别、教育程度是否显著相关。
#使用person卡方检验
#①迁移状况和性别的显著相关性
table1 <- xtabs(~Residence+Gender,data=data6) #构建一个交叉相乘表，列联表
table1
chisq.test(table1) #从结果显示,p-value不小,可认为是两者独立，不存在某种相关关系
#②迁移状况和教育程度的显著相关性
table2 <- xtabs(~Residence+Education,data=data6) 
table2
chisq.test(table2)

#11
#利用Logistic模型拟合数据集中再迁移状况与性别、年龄、教育程度、收入的关系，记为模型1。
#说明模型参数估计结果的含义。计算出性别和教育程度对再迁移影响的几率（odds）。
#若计算整体模型的显著性水平,p值接近于零，模型显著，说明加入的因素能显著性的解释是否离开
glm1 <- glm(Residence~Gender+Age+Education+logIncome,family = binomial(link=logit),data=data6) #全模型
anova(glm1,test="Chisq")  #对全模型做方差分析
summary(glm1) #展示参数估计的情况，迁移的人群比未迁移的人群的年龄小
#①性别对再迁移影响的几率
#ln[p(y=1)/p(y=0)]= β0+β1*Gender1+β2*Age+β3*Education1+β4*logIncome #对数几率
#β0=1.025,β1=-0.449,β2=0.004,β3=-0.525,β4=-0.192
#在其他条件不变的情况下，女性对再迁移影响的几率是exp(β0+β2*Age+β3*Education1+β4*logIncome)
#在其他条件不变的情况下，男性对再迁移影响的几率是exp(β0+β1*Gender1+β2*Age+β3*Education1+β4*logIncome)
#②教育程度对再迁移影响的几率
#在其他条件不变的情况下，大学本科对再迁移影响的几率是exp(β0+β1*Gender1+β2*Age+β4*logIncome)
#在其他条件不变的情况下，研究生对再迁移影响的几率是exp(β0+β1*Gender1+β2*Age+β3*Education1+β4*logIncome)

#12
#利用Probit模型拟合数据集中再迁移状况与性别、年龄、教育程度、收入的关系，记为模型2。
#说明模型参数估计结果的含义。
glm2 <- glm(Residence~Gender+Age+Education+logIncome,family = binomial(link=probit),data6) 
anova(glm2,test="Chisq")
summary(glm2)
#对比一下logistic和probit的参数估计表中Education1：0.525309/0.323451=1.624076

#*******************************预测问题***************************************
#1
#将习题一步骤8处理后的数据集分为训练集和预测集两部分，随机抽取40条记录作为预测集。
sub1 <- sample(nrow(data66),40,replace=F)  #共225条数据，随机抽取40条记录作为预测集
data66m <- data66[-sub1,]  #训练集
data66p <- data66[sub1,]   #预测集

#2
#利用Logistic模型拟合训练集。
glm3 <- glm(Residence~Gender+Age+Education+logIncome,family = binomial(link = logit),data=data66m)
anova(glm3,test="Chisq") #方差分析
summary(glm3) #展示参数估计情况

#3
#分别以AIC和BIC标准选择最优的Logistic模型。
logistic.aic <- step(glm3,trace=F)
summary(logistic.aic)
logistic.bic <- step(glm3,k=log(nrow(data66m)),trace=F)
summary(logistic.bic)

#4
#以AIC为标准的最优Logistic模型对预测集进行预测。
#以习题一步骤1中已迁移人口数占总样本数的比例为阈值。显示再迁移真实值与预测值的2×2列联表。
a <- sum(data0$Residence==1)/nrow(data0) #阈值=已迁移人口数/人口总数
a
p1 <- predict(logistic.aic,data66p,type="response")  #若type缺省,返回logit函数线性函数预测值,logit函数就是对数几率
#data66p$predict <- ifelse(p1>a,1,0) #大于阈值为1，否则为0
data66p$predict <- 1*(p1>a)
table(data66p$Residence,data66p$predict,deparse.level = 2)

#5
#计算步骤4中模型预测的TPR与FPR值。
#TPR是正例的覆盖率，1-FPR是负例的覆盖率，FPR是真实值为0的样本中预测错的就是预测为1的概率
data666 <- data.frame(prob1=p1,obs=ifelse(data66p$Residence==1,1,0)) #将预测概率p1和实际结果放在一个数据框中
data666 <- data666[order(data666$prob1),] #按预测概率p1从低到高排序
#画出FPR和TPR的关系图
n1 <- nrow(data666) #获取数据框的长度
TPR <- rep(0,n1) #生成长度为n的TPR向量
FPR <- rep(0,n1) #生成长度为n的FPR向量
for(i in 1:n1) #根据不同临界值来计算TPR和FPR，之后绘制成图
{
	threshold <- data666$prob1[i] #获取预测的概率值             #真实    #预测
	tp <- sum(data666$prob1>threshold & data666$obs==1)      #y=1    #y=1(真正类)
	fp <- sum(data666$prob1>threshold & data666$obs == 0)    #y=0    #y=1 (假正类)
 	tn <- sum(data666$prob1<=threshold & data666$obs == 0)   #y=0    #y=0 (真负类)
  	fn <- sum(data666$prob1<=threshold & data666$obs == 1)   #y=1    #y=0 (假负类)
  	TPR[i] <- tp/(tp+fn) #计算出TPR值，真正率，分类器所识别出的正实例占所有正实例的比例
  	FPR[i] <- fp/(fp+tn) #计算出FPR值，假正率，分类器错认为正类的负实例占所有负实例的比例
}
plot(FPR,TPR,type='l',col=2)
points(c(0,1),c(0,1),type='l',lty=2) #画出对照虚线

#6
#画出以AIC为标准的最优Logistic模型进行预测的ROC图，并计算出AUC值。
#install.packages("pROC")
library(pROC)
r1 =roc(ifelse(data66p$Residence==1,1,0),p1)
plot(r1, print.auc=TRUE, auc.polygon=TRUE, grid=c(0.1, 0.2),
     grid.col=c("green", "red"), max.auc.polygon=TRUE,
     auc.polygon.col="blue", print.thres=TRUE)   #AUC是

#7
#利用Probit模型拟合训练集。
glm4 <- glm(Residence~Gender+Age+Education+logIncome,family = binomial(link = probit),data=data66m)
anova(glm4,test="Chisq")
summary(glm4) #展示参数估计情况

#8
#分别以AIC和BIC标准选择最优的Probit模型。
probit.aic <- step(glm4,trace=F)
summary(probit.aic)
probit.bic <- step(glm4,k=log(nrow(data66m)),trace=F)
summary(probit.bic)

#9
#以AIC为标准的最优Probit模型对预测集进行预测。以习题一步骤1中已迁移人口数占总样本数的比例为阈值。显示再迁移真实值与预测值的2×2列联表。
#c <- sum(data6$Residence==1)/nrow(data6) #阈值=已迁移人口数/人口总数
#c
p2 <- predict(probit.aic,data66p,type="response")   #若type缺省，返回logit函数线性函数预测值,概率需要通过
#data66p$predict2 <- ifelse(p2>a,1,0) #大于阈值为1，否则为0
data66p$predict2 <- 1*(p2>a)
table(data66p$Residence,data66p$predict2,deparse.level = 2)

#10
#计算步骤9中模型预测的TPR与FPR值。
data6666 <- data.frame(prob2=p2,obs=ifelse(data66p$Residence==1,1,0)) #将预测概率p1和实际结果放在一个数据框中
data6666 <- data6666[order(data6666$prob2),] #按预测概率从低到高排序
n2 <- nrow(data6666) #获取数据框的长度
TPR <- rep(0,n2) #生成长度为n的TPR向量
FPR <- rep(0,n2) #生成长度为n的FPR向量
for(i in 1:n2) #根据不同临界值来计算TPR和FPR，之后绘制成图
{
	threshold <- data6666$prob2[i] #获取预测的概率值             #真实    #预测
	tp <- sum(data6666$prob2>threshold & data6666$obs==1)     #y=1    #y=1(真正类)
	fp <- sum(data6666$prob2>threshold & data6666$obs == 0)   #y=0    #y=1 (假正类)
 	tn <- sum(data6666$prob2<=threshold & data6666$obs == 0)  #y=0    #y=0 (真负类)
  	fn <- sum(data6666$prob2<=threshold & data6666$obs == 1)  #y=1    #y=0 (假负类)
  	TPR[i] <- tp/(tp+fn) #计算出TPR值，分类器所识别出的正实例占所有正实例的比例
  	FPR[i] <- fp/(fp+tn) #计算出FPR值，分类器错认为正类的负实例占所有负实例的比例
}
plot(FPR,TPR,type='l',col=2)
points(c(0,1),c(0,1),type='l',lty=2) #画出对照虚线

#11
#画出以AIC为标准的最优Probit模型进行预测的ROC图，并计算出AUC值。
r2 =roc(ifelse(data66p$Residence==1,1,0),p2)
plot(r2, print.auc=TRUE, auc.polygon=TRUE, grid=c(0.1, 0.2),
     grid.col=c("green", "red"), max.auc.polygon=TRUE,
     auc.polygon.col="yellow", print.thres=TRUE)   #AUC是

#12
#比较习题二步骤6与步骤11中AUC值的大小，判断预测模型的优劣。
#较大的AUC代表了较好的性能