内容字号:默认大号超大号

段落设置:段首缩进取消段首缩进

字体设置:切换到微软雅黑切换到宋体

泰坦尼克号生还率分析

2018-07-08 16:06 出处:清屏网 人气: 评论(0

先把各种包导入进来

library(readr) # 文件读写
library(ggplot2) # Data visualization
library(ggthemes) # Data visualization
library(scales) # 把图形弄的更漂亮的,并提供用于自动地确定用于轴和图例符和标签的方法

library(plyr) #可以进行类似于数据透视表的操作,将数据分割成更小的数据,
#对分割后的数据进行些操作,最后把操作的结果汇总。比如提取首字母,提取姓氏.等等

library(stringr) # String manipulation
library(InformationValue) # 算IV跟WOV用的,即高价值数据
library(MLmetrics) # 衡量回归,分类和排名表现的评估指标的集合,交叉验证的时候用
library(rpart) # 回归树的方法,用来预测缺失的数据
library(randomForest) # <a href="https://hzl-fj.com/tag/%e9%9a%8f%e6%9c%ba%e6%a3%ae%e6%9e%97" data-toggle="tooltip" title="查看更多关于 随机森林 的文章" target="_blank">随机森林</a>
library(dplyr) # Data manipulation

library(e1071) # 在机器学习领域,支持向量机SVM(Support Vector Machine)是一个有监           督的学习模型, 
#通常用来进行模式识别、分类以及回归分析,文中predict就是这个包的

library(Amelia) # 多重插补(MI)是一种基于重复模拟的处理缺失值的方法。在面对复杂的#缺失值问题时,
#MI是最常选用的方法,它将从一个包含缺失值的数据集中生成一组完整的数据集

library(party) # 递归分区的计算工具箱。包的核心是ctree(),这是一个条件推理树的实现,
#它将树结构的回归模型嵌入到一个明确的条件推理过程理论中。
#这种非参数类的回归树适用于各种回归问题,包括名义,序数,数字,检查以及多变量响应变量和协变量的任意测量量表。
#基于条件推理树,cforest()提供了布里曼<a href="https://hzl-fj.com/tag/%e9%9a%8f%e6%9c%ba%e6%a3%ae%e6%9e%97" data-toggle="tooltip" title="查看更多关于 随机森林 的文章" target="_blank">随机森林</a>的实现。

library(gbm) # 广义增强回归模型.Adaboost是提升树(boosting tree),
#所谓“提升树”就是把“弱学习算法”提升(boost)为“强学习算法”.ps:我觉得文中应该没有用到

library(class) # 各种分类功能 包括KNN,学习向量量化和自组织图。

这里用的包就比较多了,但是没关系。通过下面的实例你就会懂的

#读取数据集
train<-read_csv("E:/数据/train.csv")
test<-read_csv("E:/数据/test.csv")

#合并数据集
data<-bind_rows(train,test)
#把从train这个数据集里从1到最后一行的数字存到train.row里
train.row<-1:nrow(train)
#把上式中的最后一行加一,到合并之后的最后一行之间的数字放到test.row里
test.row<-(1+nrow(train)):(nrow(train)+nrow(test))

由于下的是两个数据集,一个训练用,另外一个测试用。但是为了处理方便,所以这里要把这两个数据集合并起来。然后再把同一个数据中分出两个部分来,一个用了训练,一个用来测试

把数据有什么因子都列出来

str(data)

以下是结果

Classes ‘tbl_df’, ‘tbl’ and 'data.frame':	1309 obs. of  17 variables:
 $ PassengerId: int  1 2 3 4 5 6 7 8 9 10 ...
 $ Survived   : Factor w/ 2 levels "0","1": 1 2 2 2 1 1 1 1 2 2 ...
 $ Pclass     : int  3 1 3 1 3 3 1 3 3 2 ...
 $ Name       : chr  "Braund, Mr. Owen Harris" "Cumings, Mrs. John Bradley (Florence Briggs Thayer)" "Heikkinen, Miss. Laina" "Futrelle, Mrs. Jacques Heath (Lily May Peel)" ...
 $ Sex        : Factor w/ 2 levels "female","male": 2 1 1 1 2 2 2 2 1 1 ...
 $ Age        : num  22 38 26 35 35 ...
 $ SibSp      : int  1 1 0 1 0 0 0 3 0 1 ...
 $ Parch      : int  0 0 0 0 0 0 0 1 2 0 ...
 $ Ticket     : chr  "A/5 21171" "PC 17599" "STON/O2. 3101282" "113803" ...
 $ Fare       : num  7.25 71.28 7.92 53.1 8.05 ...
 $ Cabin      : Factor w/ 9 levels "A","B","C","D",..: 9 3 9 3 9 9 5 9 9 9 ...
 $ Embarked   : Factor w/ 3 levels "C","Q","S": 3 1 3 3 3 2 3 3 3 1 ...
 $ Title      : Factor w/ 5 levels "Master","Miss",..: 3 4 2 4 3 3 3 1 4 4 ...
 $ FamilySize : num  2 2 1 2 1 1 1 5 3 2 ...
 $ TicketCount: Factor w/ 2 levels "Share","Unique": 2 1 2 1 2 2 1 1 1 1 ...
 $ Surname    : chr  "Braund" "Cumings" "Heikkinen" "Futrelle" ...
 $ FamilyID   : Factor w/ 61 levels "11Sage","3Abbott",..: 61 61 61 61 61 61 61 52 19 61 ...

从上可见,数据集包含12个变量,1309条数据,其中891条为训练数据,418条为测试数据

  • PassengerId 整型变量,标识乘客的ID,递增变量,对预测无帮助
  • Survived 整型变量,标识该乘客是否幸存。0表示遇难,1表示幸存。将其转换为factor变量比较方便处理
  • Pclass 整型变量,标识乘客的社会-经济状态,1代表Upper,2代表Middle,3代表Lower
  • Name 字符型变量,除包含姓和名以外,还包含Mr. Mrs. Dr.这样的具有西方文化特点的信息
  • Sex 字符型变量,标识乘客性别,适合转换为factor类型变量
  • Age 整型变量,标识乘客年龄,有缺失值
  • SibSp 整型变量,代表兄弟姐妹及配偶的个数。其中Sib代表Sibling也即兄弟姐妹,Sp代表Spouse也即配偶
  • Parch 整型变量,代表父母或子女的个数。其中Par代表Parent也即父母,Ch代表Child也即子女
  • Ticket 字符型变量,代表乘客的船票号
  • Fare 数值型,代表乘客的船票价
  • Cabin 字符型,代表乘客所在的舱位,有缺失值
  • Embarked 字符型,代表乘客登船口岸,适合转换为factor型变量

为什么要转换类型?把字符型(character)的转换成因子型(factor)的。因为数据模型(随机森林)不支持字符型的.......

那下面就一个一个来分析吧(这一步必不可少,是你建立数据思维的根本)

乘客社会阶层越高,幸存率越高

#先分析第一个变量阶级Pclass,将其传换成factor
data$Survived<-factor(data$Survived)

#用ggplot统计出Pclass的幸存和遇难人数
#数据用到的是练习数据,并且fill函数等于把幸存的跟点背的给分开了
ggplot(data = data[1:nrow(train),], mapping = aes(x = Pclass, y = ..count.., fill=Survived)) + 
  #dodge是分开的意思
  geom_bar(stat = "count", position='dodge') + 
  xlab('Pclass') + 
  ylab('Count') + 
  ggtitle('How Pclass impact survivor') + 
  #文本设置
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  #小题目设置
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

能够看出什么呢?第一二阶层(上层和中层阶级)的幸存率(差不多50%)要远远高于第三阶层的幸存率(25%)

很现实也很残酷,但这也是你为什么不去玩游戏跑到我这里看文章的一大原因

#算出WOV和IV。其实这俩是同一个,即互相包含互相影响,这俩指标的目的其实
#就是要算出此段信息是否可以作为高价值信息选入预测模型。
WOETable(X=factor(data$Pclass[1:nrow(train)]),Y=data$Survived[1:nrow(train)])
IV(X=factor(data$Pclass[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.5009497,可以看出这得出的结论是高预言性
[1] 0.5009497
attr(,"howgood")
[1] "Highly Predictive"

为什么要算WOV(Weight of Evidence 权重)跟IV(Information Value 信息价值),看懂了这篇文章,这俩值你也就懂了。 数据挖掘模型中的IV和WOE详解 - 一些杂七杂八的想法 - 博客频道 - CSDN.NET

不同头衔的乘客幸存率不同

我们观察名字这一个变量,发现几乎每一个都有Mr. Mrs. Dr.这种符合西方文化头衔。那么下面我们就对这种头衔进行分析。

#然后再把头衔从名字中提取出来,使用正则表达式
data$Title<-gsub('(.*, )|(\\..*)', '',data$Name)

#查看按照性别划分的头衔数量
table(data$Sex,data$Title)

结果:

Capt Col Don Dona  Dr Jonkheer Lady Major Master Miss Mlle Mme  Mr Mrs  Ms Rev Sir the Countess
  female    0   0   0    1   1        0    1     0      0  260    2   1   0 197   2   0   0            1
  male      1   4   1    0   7        1    0     2     61    0    0   0 757   0   0   8   1            0

发现好多头衔用的其实都很少,很少就会带来一个麻烦,那就是在训练数据集使用完后,就不可能再在测试数据集里发挥预测作用了。

那么就需要合并这些稀有头衔

#发现好多头衔都是很稀有的,对这些头衔进行合并
rareTitle<-c('Dona', 'Lady', 'the Countess','Capt', 'Col', 'Don', 
             'Dr', 'Major', 'Rev', 'Sir', 'Jonkheer')

#将女性以M开头的头衔合并到普通头衔里
data$Title[data$Title=='Mlle']<-'Miss'
data$Title[data$Title=='Ms']<-'Miss'
data$Title[data$Title=='Mme']<-'Mrs'
#把稀有头衔一起放到Rare Title里
data$Title[data$Title %in% rareTitle]<-'Rare Title'

合并完后再看:

#再次按照性别划分头衔的数量
table(data$Sex,data$Title)

然后画图:

#不要忘了转换形势
data$Title<-as.factor(data$Title)
#画图
ggplot(data = data[1:nrow(train),], mapping = aes(x = Title, y = ..count.., fill=Survived)) + 
  geom_bar(stat = "count", position='dodge') + 
  xlab('Title') + 
  ylab('Count') + 
  ggtitle('How Title impact survivor') + 
  scale_fill_discrete(name="Survived", breaks=c(0, 1)) + 
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) +
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

发现不同头衔的幸存率也是不同的。

#算IV和WOV
WOETable(X=factor(data$Title[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=factor(data$Title[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#1.522418,得到的结论Tiele同样是高价值信息

女性幸存率远高于男性

下面分析性别的影响:

#转换类型
data$Sex <- as.factor(data$Sex)
#画图
ggplot(data = data[1:nrow(train),], mapping = aes(x = Sex, y = ..count.., fill=Survived)) + 
  geom_bar(stat = 'count', position='dodge') + 
  xlab('Sex') + 
  ylab('Count') + 
  ggtitle('How Sex impact survivo') + 
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

毫无疑问,电影如实的反应了“让女性和小孩先走”的原则。女性的幸存率要远远高于男性

#算IV和WOV的值
WOETable(X=as.factor(data$Sex[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$Sex[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#1.341681,性别因素也是高价值的

未成年人幸存率高于成年人

让我们用数据证明一下未成年人的幸存率也比较高

#年龄对于生存率的影响
ggplot(data = data[(!is.na(data$Age)) & row(data[, 'Age']) <= 891, ], aes(x = Age, color=Survived)) + 
  geom_line(aes(label=..count..), stat = 'bin', binwidth=5)  + 
  labs(title = "How Age impact survivor", x = "Age", y = "Count", fill = "Survived")

如图:

在7岁之前这个年龄段的幸存率明显比较高。

#IV,WOV
WOETable(X=factor(data$Age[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=factor(data$Age[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.4992192,依然是高价值

虽然电影如实的演示了,“让女性和小孩先走”的这一人道主义原则。可是在践行这条光辉的原则的时候,也同样是有条件的!

什么条件呢?想想第一条数据就给我们展示出的冰冷的现实。阶层越高,幸存率越高。再结合着“让女性和小孩先走”这一光辉原则。会发现电影中没有完全告诉你的真相。

即在救生船有限的情况下,先让上层阶级的家人(老婆孩子)上救生船。等排到最后的时候才轮到平民阶层的家人(老婆孩子)。然而这个时候已经没时间了。

你也许该问了:不对,平民阶层遇难的人多是因为男性比女性多多了,因为都是男人遇难,所以才把人数突然拉高。平民女性的遇难比例应该跟第一二阶层的差不太远!你心理真阴暗!

其实我真的希望是我心理阴暗的问题

ftable(xtabs(~ Pclass+Sex+Survived, data=data))

结果是:

Survived   0   1
Pclass Sex                    
1      female            3  91
       male             77  45
2      female            6  70
       male             91  17
3      female           72  72
       male            300  47

第一阶层女性91/94 存活率是0.9680851

第二阶层女性70/76 存活率是0.9210526

第三阶层女性72/144 存活率是0.5

别的不说,混的好一点起码能救你的家人。

好,言归正传,继续分析

配偶及兄弟姐妹数适中的乘客幸存率高

分析SibSp(配偶及兄弟姐妹数)

ggplot(data = data[1:nrow(train),], mapping = aes(x = SibSp, y = ..count.., fill=Survived)) + 
  geom_bar(stat = 'count', position='dodge') + 
  labs(title = "How SibSp impact survivor", x = "Sibsp", y = "Count", fill = "Survived") + 
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

从图中可以看出配偶及兄弟姐妹数在1的时候幸存率是大于50%的,到了2的时候就成了46.4%(存活率还行)。但是高于或者低于1或者2的幸存率就大大降低了

#IV,WOV
WOETable(X=as.factor(data$SibSp[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$SibSp[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.1448994,同样为高价值

父母与子女数为1到3的乘客幸存率高

分析Parch(父母与子女数)

#分析Parch(父母与子女数)
ggplot(data = data[1:nrow(train),], mapping = aes(x = Parch, y = ..count.., fill=Survived)) + 
  geom_bar(stat = 'count', position='dodge') + 
  labs(title = "How Parch impact survivor", x = "Parch", y = "Count", fill = "Survived") + 
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

结论是,父母与子女数数目大于等于4或者小于1的幸存率都小于50%

#IV,WOV
WOETable(X=as.factor(data$Parch[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$Parch[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.1166611,为高价值

FamilySize为2到4的乘客幸存率更高

通过观察上述两个变量,发现不管是SibSp(配偶及兄弟姐妹数)还是Parch(父母与子女数)其实都是家人的数目,那为什么不能把这俩变量合并到一起呢?

当然可以。

#这里我们把这两个因数相加,形成新的变量,然后再分析这个变量
#那为什么要加1呢,因为即使没有家人在船上,这个人自己其实也代表了他的家庭
data$FamilySize <- data$SibSp + data$Parch + 1
ggplot(data = data[1:nrow(train),], mapping = aes(x = FamilySize, y = ..count.., fill=Survived)) + 
  geom_bar(stat = 'count', position='dodge') + 
  xlab('FamilySize') + 
  ylab('Count') + 
  ggtitle('How FamilySize impact survivor') + 
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

通过观察可以看出家庭成员数在2<=data$FamilySize<=4之间的话,个体存活率都会大于50%,而数目为1或者太多的话对于存活下来不但没有帮助可能还适得其反。

也就是说家庭成员数太多或者没有都不好。

#IV,WOV
WOETable(X=as.factor(data$FamilySize[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$FamilySize[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.3497672,比前两个因素的IV信息价值高

共票号乘客幸存率高

对于Ticket变量,重复度非常低,无法直接利用。先统计出每张票对应的乘客数。

#首先统计出每张票对应的乘客数
ticket.count <- aggregate(data$Ticket, by = list(data$Ticket),
                          function(x) sum(!is.na(x)))

这里有个猜想,票号相同的乘客,是一家人,很可能同时幸存或者同时遇难。现将所有乘客按照Ticket分为两组,一组是使用单独票号,另一组是与他人共享票号,并统计出各组的幸存与遇难人数。

#然后再把数据放到data里
data$TicketCount <- apply(data, 1, function(x) ticket.count[which(ticket.count[, 1] == x['Ticket']), 2])
#把data里区分等于一的和大于一的标注成Unique和share
data$TicketCount <- factor(sapply(data$TicketCount, function(x) ifelse(x > 1, 'Share', 'Unique')))
ggplot(data = data[1:nrow(train),], mapping = aes(x = TicketCount, y = ..count.., fill=Survived)) + 
  geom_bar(stat = 'count', position='dodge') + 
  xlab('TicketCount') + 
  ylab('Count') + 
  ggtitle('How TicketCount impact survivor') + 
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

从上图可以看出共票号的幸存率要明显大于不共票号的。如果再考虑到之前的推论以及上一个变量得出的结论。你就会发现......

这个世界对单身狗充满了恶意!

#IV,WOV
WOETable(X=as.factor(data$TicketCount[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$TicketCount[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.2751882,高价值

票价越贵幸存率越高

#票价越贵幸存率越高
ggplot(data = data[(!is.na(data$Fare)) & row(data[, 'Fare']) <= 891, ], aes(x = Fare, color=Survived)) + 
  geom_line(aes(label=..count..), stat = 'bin', binwidth=10)  + 
  labs(title = "How Fare impact survivor", x = "Fare", y = "Count", fill = "Survived")

如图:

#IV,WOV
WOETable(X=as.factor(data$Fare[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$Fare[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.6123083,高价值

不同船舱的乘客幸存率不同

观测Cabin(船舱)这一变量可以看出第一个数值基本上都是一个字母,然后才是一连串数字,其实可以猜到不同的字母表示的就是不同的船舱。所以可以通过字母表示不同船舱的生存率

ggplot(data[1:nrow(train), ], mapping = aes(x = as.factor(sapply(data$Cabin[1:nrow(train)], function(x) str_sub(x, start = 1, end = 1))), y = ..count.., fill = Survived)) +
  geom_bar(stat = 'count', position='dodge') + 
  xlab('Cabin') +
  ylab('Count') +
  ggtitle('How Cabin impact survivor') +
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

将首字母提出:

data$Cabin <- sapply(data$Cabin, function(x) str_sub(x, start = 1, end = 1))
#IV,WOV
WOETable(X=as.factor(data$Cabin[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$Cabin[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.1866526,虽然高价值但是缺失值太多,不太能做一个合格的预测

Embarked为S的乘客幸存率较低

对登船码头(Embarked)做分析

ggplot(data[1:nrow(train), ], mapping = aes(x = Embarked, y = ..count.., fill = Survived)) +
  geom_bar(stat = 'count', position='dodge') + 
  xlab('Embarked') +
  ylab('Count') +
  ggtitle('How Embarked impact survivor') +
  geom_text(stat = "count", aes(label = ..count..), position=position_dodge(width=1),  vjust=-0.5) + 
  theme(plot.title = element_text(hjust = 0.5), legend.position="bottom")

如图:

可以看出字母为S的幸存率比较低,而字母为C的幸存率大于50%

#IV,WOV
WOETable(X=as.factor(data$Embarked[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
IV(X=as.factor(data$Embarked[1:nrow(train)]), Y=data$Survived[1:nrow(train)])
#0.1227284,高价值

缺失值补完计划:

对缺失值补充完整有助于提高预测的精度。

#列出所有的缺失数据
attach(data)
#由于Pclass没有缺失值,所有可也用它建立一个完整的清单行数
missing <- list(Pclass=nrow(data[is.na(Pclass), ]))
missing$Name <- nrow(data[is.na(Name), ])
missing$Sex <- nrow(data[is.na(Sex), ])
missing$Age <- nrow(data[is.na(Age), ])
missing$SibSp <- nrow(data[is.na(SibSp), ])
missing$Parch <- nrow(data[is.na(Parch), ])
missing$Ticket <- nrow(data[is.na(Ticket), ])
missing$Fare <- nrow(data[is.na(Fare), ])
missing$Cabin <- nrow(data[is.na(Cabin), ])
missing$Embarked <- nrow(data[is.na(Embarked), ])
for (name in names(missing)) {
  if (missing[[name]][1] > 0) {
    print(paste('', name, ' miss ', missing[[name]][1], ' values', sep = ''))
  }
}
detach(data)

结果如下:

[1] "Age miss 263 values"
[1] "Fare miss 1 values"
[1] "Cabin miss 1014 values"
[1] "Embarked miss 2 values"

先补完乘客的年龄

#先补充年龄,由于年龄却的比较多,我们这里用其他变量来预测年龄的值
age.model <- rpart(Age ~ Pclass + Sex + SibSp + Parch + Fare + Embarked +  Title + FamilySize, data=data[!is.na(data$Age), ], method='anova')
data$Age[is.na(data$Age)] <- predict(age.model, data[is.na(data$Age), ])

虽然缺了263条,但是还能通过其他的一千多条进行预测。比船舱(Cabin)好多了

对那一个缺失的Fare值进行补完

#查看票价具体是在哪一行缺失
getFareNullID <- function(total_data){
  count <- 0
  for(i in 1:nrow(total_data))
    if(is.na(total_data$Fare[i])){
      #打印缺失票价的具体行数
      print(i);
      count <- count+1
    }
  
  return(count)
  
}
ab <- getFareNullID(data)
#查看这一行
data[1044,]

如下:

PassengerId Survived Pclass               Name    Sex   Age SibSp Parch Ticket  Fare Cabin Embarked  Title FamilySize TicketCount
        <int>   <fctr>  <int>              <chr> <fctr> <dbl> <int> <int>  <chr> <dbl> <chr>    <chr> <fctr>      <dbl>      <fctr>
1        1044       NA      3 Storey, Mr. Thomas   male  60.5     0     0   3701    NA  <NA>        S     Mr          1      Unique

可以看到,登船码头为S,阶层为3。于是就可以用这两个值大致估计出缺失的票价。

data$Fare[1044] <- median(data[data$Pclass == '3' & data$Embarked == 'S', ]$Fare, na.rm = TRUE)

对登船码头进行补完

首先查看关于登船码头缺失项所对应的其他变量:

data[is.na(data$Embarked), c('PassengerId', 'Pclass', 'Fare', 'Embarked')]

如下:

PassengerId Pclass  Fare Embarked
        <int>  <int> <dbl>    <chr>
1          62      1    80     <NA>
2         830      1    80     <NA>

可以看出Pclass都是1,和Fare都是80

画图:

ggplot(data[!is.na(data$Embarked),], aes(x=Embarked, y=Fare, fill=factor(Pclass))) +
  geom_boxplot() +
  geom_hline(aes(yintercept=80), color='red', linetype='dashed', lwd=2) +
  scale_y_continuous(labels=dollar_format()) + theme_few()

可以看出阶层为1的票价中位数就是80,那么所对应的Embarked就是C

#把Embarked设置为C
data$Embarked[is.na(data$Embarked)] <- 'C'
data$Embarked <- as.factor(data$Embarked)

由于cabin缺失的太多一共就1309条,它能缺失1014条!所以把缺失值填充成X之后,直接放弃吧.....

data$Cabin <- as.factor(sapply(data$Cabin, function(x) ifelse(is.na(x), 'X', str_sub(x, start = 1, end = 1))))

训练模型

set.seed(415)
model <- cforest(Survived ~ Pclass + Title + Sex + Age + SibSp + Parch + FamilySize + TicketCount + Fare + Embarked, data = data[train.row, ], controls=cforest_unbiased(ntree=2000, mtry=3))

下面开始交叉验证。一般情况下,应该将训练数据分为两部分,一部分用于训练,另一部分用于验证。或者使用k-fold交叉验证。

本文将所有训练数据都用于训练,然后随机选取30%数据集用于验证。

它的核心意思就是你自己先看看你做的结果靠普不靠谱,要是差太多就不要上传了,重新建立模型吧!

cv.summarize <- function(data.true, data.predict) {
  #recall:召回值
  print(paste('Recall:', Recall(data.true, data.predict)))
  #precision:精度
  print(paste('Precision:', Precision(data.true, data.predict)))
  #Accuracy:准确性
  print(paste('Accuracy:', Accuracy(data.predict, data.true)))
  #AUC:Area Under Curve(曲线下面积)
  print(paste('AUC:', AUC(data.predict, data.true)))
}
set.seed(415)
cv.test.sample <- sample(1:nrow(train), as.integer(0.3 * nrow(train)), replace = TRUE)
cv.test <- data[cv.test.sample,]
cv.prediction <- predict(model, cv.test, OOB=TRUE, type = "response")
cv.summarize(cv.test$Survived, cv.prediction)
#预测
predict.result <- predict(model, test, OOB=TRUE, type = "response")
output <- data.frame(PassengerId = test$PassengerId, Survived = predict.result)
write.csv(output, file = 'E:/le-go/pre.csv', row.names = FALSE)

结果如下:

[1] "Recall: 0.947976878612717"
[1] "Precision: 0.828282828282828"
[1] "Accuracy: 0.838951310861423"
[1] "AUC: 0.793137375476571"

上传结果

#预测
predict.result <- predict(model, test, OOB=TRUE, type = "response")
output <- data.frame(PassengerId = test$PassengerId, Survived = predict.result)
write.csv(output, file = 'E:/pre.csv', row.names = FALSE)

上传之后发现成绩不是很理想,怎么办呢,继续找原因。

发现只出现一次的姓名(在西方国家里包括日本基本上都是姓多名少)所以可以确定姓氏只出现过一次的变量没有被充分利用

那么,我们就给他们(只出现一次的姓氏)改姓吧!改成Small。

改过姓之后,就等于说在这些姓氏不但在训练数据中可用于建立模型,也能在测试数据中帮助测试,提高精度。

data$Surname<-sapply(data$Name,FUN=function(x){strsplit(x, split='[,.]')[[1]][1]})
data$FamilyID <- paste(as.character(data$FamilySize), data$Surname, sep="")
data$FamilyID[data$FamilySize <= 2] <- 'Small'
#删除稀少姓氏的家庭ID
famIDs <- data.frame(table(data$FamilyID))
famIDs <- famIDs[famIDs$Freq <= 2,]
data$FamilyID[data$FamilyID %in% famIDs$Var1] <- 'Small'
#转换类型
data$FamilyID <- factor(data$FamilyID)

重新预测:

set.seed(415)
model <- cforest(as.factor(Survived) ~ Pclass + Sex + Age + Fare + Embarked + Title + FamilySize + FamilyID + TicketCount, data = data[train.row, ], controls=cforest_unbiased(ntree=2000, mtry=3))
predict.result <- predict(model,  data[test.row, ], OOB=TRUE, type = "response")
output <- data.frame(PassengerId = test$PassengerId, Survived = predict.result)
write.csv(output, file = 'E:/le-go/pre1.csv', row.names = FALSE)

好,至此文章主体算是全部完成了。


分享给小伙伴们:
本文标签: 泰坦尼克号生还率

相关文章

发表评论愿您的每句评论,都能给大家的生活添色彩,带来共鸣,带来思索,带来快乐。

CopyRight © 2015-2016 QingPingShan.com , All Rights Reserved.

清屏网 版权所有 豫ICP备15026204号