机器学习简介

Dongbei University of Finance & Economics

Abstract

机器学习已经成为建模环节中必备的实践方法。本章主要介绍用R语言实现机器学习的一些典型算法。其中，本章将以相亲市场数据为例，讲解相关模型的建立与解读。

1 😄加载经常用的R包😄

library(pacman)
# 读数据
p_load(readxl,writexl,data.table,openxlsx,haven,rvest)

# 数据探索
p_load(tidyverse,DT,skimr,DataExplorer,explore,vtable,stringr,kableExtra,lubridate)

# 模型
p_load(grf,glmnet,caret,tidytext,fpp2,forecast,car,tseries,hdm,tidymodels,broom)

# 可视化
p_load(patchwork,ggrepel,ggcorrplot,gghighlight,ggthemes,shiny)

# 其它常用包
p_load(magrittr,listviewer,devtools,here,janitor,reticulate,jsonlite)

2 😄机器学习简介😄

机器学习的整个过程就像是烹饪。首先是准备食材，也就是准备并读入数据；其次是对食材进行加工，比如洗菜、切菜，也就是数据预处理；再次是对这些食材进行烹调，也就是模型训练；最后是将不同厨师做出来的菜给评委品尝，评委满意度越高越好，也即模型预测及评价。

3 😄读入数据😄

分析之前，要先把数据和分析所需要的R包准备好。这里分析用到的数据为相亲数据.csv，直接使用read.csv操作即可。分析的整个过程借用了caret包来完成。这里的caret包是为了解决预测问题的综合机器学习工具包。这个包的特点就是能够快速把所有的材料准备好，包括数据预处理、模型训练、模型预测的整个过程。

data <- read.csv(here::here("Machine_Learning_and_Causal_Inference/data/相亲数据重新编码.csv"))

data %>% as_tibble() -> data

data %>% str()

## tibble [8,378 x 29] (S3: tbl_df/tbl/data.frame)
##  $ 决定            : int [1:8378] 1 1 1 1 1 0 1 0 1 1 ...
##  $ 性别            : int [1:8378] 0 0 0 0 0 0 0 0 0 0 ...
##  $ 吸引力          : num [1:8378] 6 7 5 7 5 4 7 4 7 5 ...
##  $ 共同爱好        : num [1:8378] 5 6 7 8 6 4 7 6 8 8 ...
##  $ 幽默            : num [1:8378] 7 8 8 7 7 4 4 6 9 8 ...
##  $ 真诚            : num [1:8378] 9 8 8 6 6 9 6 9 6 6 ...
##  $ 雄心            : num [1:8378] 6 5 5 6 6 6 6 5 8 10 ...
##  $ 智力            : num [1:8378] 7 7 9 8 7 7 7 7 8 6 ...
##  $ 好感            : num [1:8378] 7 7 7 7 6 6 6 6 7 6 ...
##  $ 成功率自估      : num [1:8378] 6 5 NA 6 6 5 5 7 7 6 ...
##  $ 日常出门频率    : int [1:8378] 1 1 1 1 1 1 1 1 1 1 ...
##  $ 对宗教的看重程度: int [1:8378] 4 4 4 4 4 4 4 4 4 4 ...
##  $ 对种族的看重程度: int [1:8378] 2 2 2 2 2 2 2 2 2 2 ...
##  $ 年龄            : int [1:8378] 21 21 21 21 21 21 21 21 21 21 ...
##  $ 种族            : int [1:8378] 4 4 4 4 4 4 4 4 4 4 ...
##  $ 从事领域        : int [1:8378] 1 1 1 1 1 1 1 1 1 1 ...
##  $ 对方决定        : int [1:8378] 0 0 1 1 1 1 0 0 1 0 ...
##  $ 好感得分        : num [1:8378] 7 8 10 7 8 7 2 7 6.5 6 ...
##  $ 对方评估成功率  : num [1:8378] 4 4 10 7 6 6 1 5 8 6 ...
##  $ 吸引力得分      : num [1:8378] 6 7 10 7 8 7 3 6 7 6 ...
##  $ 共同爱好得分    : num [1:8378] 6 5 10 8 7 7 7 6 9 6 ...
##  $ 幽默得分        : num [1:8378] 8 7 10 8 6 8 5 6 8 6 ...
##  $ 真诚得分        : num [1:8378] 8 8 10 8 7 7 6 7 7 6 ...
##  $ 雄心得分        : num [1:8378] 8 7 10 9 9 7 8 8 8 6 ...
##  $ 智力得分        : num [1:8378] 8 10 10 9 9 8 7 5 8 6 ...
##  $ 对方年龄        : int [1:8378] 27 22 22 23 24 25 30 27 28 24 ...
##  $ 对方种族        : int [1:8378] 2 2 4 2 3 2 2 2 2 2 ...
##  $ 是否同一种族    : int [1:8378] 0 0 1 0 0 0 0 0 0 0 ...
##  $ 日常约会频率    : int [1:8378] 7 7 7 7 7 7 7 7 7 7 ...

data %>% glimpse()

## Rows: 8,378
## Columns: 29
## $ 决定             <int> 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 0, 1, 0, 0, 1, 0...
## $ 性别             <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0...
## $ 吸引力           <dbl> 6, 7, 5, 7, 5, 4, 7, 4, 7, 5, 5, 8, 5, 7, 6, 8, 7, 5,...
## $ 共同爱好         <dbl> 5, 6, 7, 8, 6, 4, 7, 6, 8, 8, 3, 6, 4, 7, 8, 2, 9, 5, ...
## $ 幽默             <dbl> 7, 8, 8, 7, 7, 4, 4, 6, 9, 8, 4, 6, 6, 6, 9, 3, 6, 5...
## $ 真诚             <dbl> 9, 8, 8, 6, 6, 9, 6, 9, 6, 6, 7, 5, 8, 9, 8, 7, 5, 8...
## $ 雄心             <dbl> 6, 5, 5, 6, 6, 6, 6, 5, 8, 10, 6, 9, 3, 5, 7, 6, 7, ...
## $ 智力             <dbl> 7, 7, 9, 8, 7, 7, 7, 7, 8, 6, 8, 6, 9, 7, 7, 8, 9, 7...
## $ 好感             <dbl> 7, 7, 7, 7, 6, 6, 6, 6, 7, 6, 6, 7, 6, 7, 8, 6, 8, 5...
## $ 成功率自估       <dbl> 6, 5, NA, 6, 6, 5, 5, 7, 7, 6, 4, 3, 7, 8, 6, 5, 7, 6, ...
## $ 日常出门频率     <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ 对宗教的看重程度 <int> 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5...
## $ 对种族的看重程度 <int> 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2...
## $ 年龄             <int> 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 24, 24, 24, ...
## $ 种族             <int> 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 2, 2, 2, 2, 2, 2, 2, 2...
## $ 从事领域         <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ...
## $ 对方决定         <int> 0, 0, 1, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 1, ...
## $ 好感得分         <dbl> 7.0, 8.0, 10.0, 7.0, 8.0, 7.0, 2.0, 7.0, 6.5, 6.0, 7.0...
## $ 对方评估成功率   <dbl> 4, 4, 10, 7, 6, 6, 1, 5, 8, 6, 2, 4, 10, 7, 1, 5, 3, 6, 8...
## $ 吸引力得分       <dbl> 6, 7, 10, 7, 8, 7, 3, 6, 7, 6, 8, 7, 10, 9, 10, 7, 5, 7...
## $ 共同爱好得分     <dbl> 6, 5, 10, 8, 7, 7, 7, 6, 9, 6, 4, 5, 10, 9, 8, 7, 3, 5, ...
## $ 幽默得分         <dbl> 8, 7, 10, 8, 6, 8, 5, 6, 8, 6, 9, 6, 10, 9, 10, 5, 3, ...
## $ 真诚得分         <dbl> 8, 8, 10, 8, 7, 7, 6, 7, 7, 6, 7, 6, 10, 9, 10, 8, 3, ...
## $ 雄心得分         <dbl> 8, 7, 10, 9, 9, 7, 8, 8, 8, 6, 7, 6, 10, 9, 7, 7, 5, 7...
## $ 智力得分         <dbl> 8, 10, 10, 9, 9, 8, 7, 5, 8, 6, 6, 10, 10, 9, 10, 7, 4...
## $ 对方年龄         <int> 27, 22, 22, 23, 24, 25, 30, 27, 28, 24, 27, 22, 22, 23...
## $ 对方种族         <int> 2, 2, 4, 2, 3, 2, 2, 2, 2, 2, 2, 2, 4, 2, 3, 2, 2, 2, ...
## $ 是否同一种族     <int> 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1,...
## $ 日常约会频率     <int> 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 5, 5, 5, 5, 5, 5, 5, 5,...

data %>% skimr::skim()

Table 3.1: Data summary

Name	Piped data
Number of rows	8378
Number of columns	29
_______________________
Column type frequency:
numeric	29
________________________
Group variables	None

Variable type: numeric

skim_variable	n_missing	complete_rate	mean	sd	p0	p25	p50	p75	p100	hist
决定	0	1.00	0.42	0.49	0	0	0	1	1.0	▇▁▁▁▆
性别	0	1.00	0.50	0.50	0	0	1	1	1.0	▇▁▁▁▇
吸引力	202	0.98	6.19	1.95	0	5	6	8	10.0	▁▃▇▇▂
共同爱好	1067	0.87	5.47	2.16	0	4	6	7	10.0	▂▅▇▆▂
幽默	350	0.96	6.40	1.95	0	5	7	8	10.0	▁▂▇▇▂
真诚	277	0.97	7.18	1.74	0	6	7	8	10.0	▁▁▃▇▃
雄心	712	0.92	6.78	1.79	0	6	7	8	10.0	▁▂▆▇▃
智力	296	0.96	7.37	1.55	0	6	7	8	10.0	▁▁▃▇▃
好感	240	0.97	6.13	1.84	0	5	6	7	10.0	▁▃▇▇▂
成功率自估	309	0.96	5.21	2.13	0	4	5	7	10.0	▂▅▇▅▁
日常出门频率	79	0.99	2.16	1.11	1	1	2	3	7.0	▇▃▁▁▁
对宗教的看重程度	79	0.99	3.65	2.81	1	1	3	6	10.0	▇▃▃▂▁
对种族的看重程度	79	0.99	3.78	2.85	0	1	3	6	10.0	▇▃▂▂▂
年龄	95	0.99	26.36	3.57	18	24	26	28	55.0	▇▇▁▁▁
种族	63	0.99	2.76	1.23	1	2	2	4	6.0	▇▁▃▁▁
从事领域	82	0.99	7.66	3.76	1	5	8	10	18.0	▃▃▇▂▁
对方决定	0	1.00	0.42	0.49	0	0	0	1	1.0	▇▁▁▁▆
好感得分	250	0.97	6.13	1.84	0	5	6	7	10.0	▁▃▇▇▂
对方评估成功率	318	0.96	5.21	2.13	0	4	5	7	10.0	▂▅▇▅▁
吸引力得分	212	0.97	6.19	1.95	0	5	6	8	10.5	▁▃▇▇▂
共同爱好得分	1076	0.87	5.47	2.16	0	4	6	7	10.0	▂▅▇▆▂
幽默得分	360	0.96	6.40	1.95	0	5	7	8	11.0	▁▂▇▇▂
真诚得分	287	0.97	7.18	1.74	0	6	7	8	10.0	▁▁▃▇▃
雄心得分	722	0.91	6.78	1.79	0	6	7	8	10.0	▁▂▆▇▃
智力得分	306	0.96	7.37	1.55	0	6	7	8	10.0	▁▁▃▇▃
对方年龄	104	0.99	26.36	3.56	18	24	26	28	55.0	▇▇▁▁▁
对方种族	73	0.99	2.76	1.23	1	2	2	4	6.0	▇▁▃▁▁
是否同一种族	0	1.00	0.40	0.49	0	0	0	1	1.0	▇▁▁▁▅
日常约会频率	97	0.99	5.01	1.44	1	4	5	6	7.0	▁▂▅▃▇

4 😄数据预处理和数据分割😄

4.1 💐处理缺失值💐

现实生活中，在数据分析时，经常会碰到缺失值，比如相亲数据中，有些女性不愿意暴露自己的年龄，年龄就会有缺失值。那么对于缺失值，怎么处理呢？处理方式很多，甚至有时候数据缺失本身也暗含一些信息（比如年龄缺失的女性可能是因为年龄比较大），由此引申了许多插补方法。不过这里缺失值处理并不是重点，因此对于缺失值直接删除即可。

data %>% is.na() %>% sum()  # 7735个缺失值

## [1] 7735

data %>% janitor::get_dupes()  # 重复的行

## No variable names specified - using all columns.

data %>% dim()

## [1] 8378   29

data %>% janitor::remove_empty(which = "rows")

data %<>% drop_na()
data %>% dim()  # 删除的缺失值不少

## [1] 5723   29

4.2 💐转换数据类型💐

对于完整的观测，首先需要定义变量的类型：属于定性变量还是连续变量。对于定性变量而言，需要给定性变量的各个水平取名，比如性别有两个水平1和0，分别命名为男、女。

data %>% str()  # 全是数值型，需要改变

## tibble [5,723 x 29] (S3: tbl_df/tbl/data.frame)
##  $ 决定            : int [1:5723] 1 1 1 1 0 1 0 1 1 0 ...
##  $ 性别            : int [1:5723] 0 0 0 0 0 0 0 0 0 0 ...
##  $ 吸引力          : num [1:5723] 6 7 7 5 4 7 4 7 5 5 ...
##  $ 共同爱好        : num [1:5723] 5 6 8 6 4 7 6 8 8 3 ...
##  $ 幽默            : num [1:5723] 7 8 7 7 4 4 6 9 8 4 ...
##  $ 真诚            : num [1:5723] 9 8 6 6 9 6 9 6 6 7 ...
##  $ 雄心            : num [1:5723] 6 5 6 6 6 6 5 8 10 6 ...
##  $ 智力            : num [1:5723] 7 7 8 7 7 7 7 8 6 8 ...
##  $ 好感            : num [1:5723] 7 7 7 6 6 6 6 7 6 6 ...
##  $ 成功率自估      : num [1:5723] 6 5 6 6 5 5 7 7 6 4 ...
##  $ 日常出门频率    : int [1:5723] 1 1 1 1 1 1 1 1 1 1 ...
##  $ 对宗教的看重程度: int [1:5723] 4 4 4 4 4 4 4 4 4 5 ...
##  $ 对种族的看重程度: int [1:5723] 2 2 2 2 2 2 2 2 2 2 ...
##  $ 年龄            : int [1:5723] 21 21 21 21 21 21 21 21 21 24 ...
##  $ 种族            : int [1:5723] 4 4 4 4 4 4 4 4 4 2 ...
##  $ 从事领域        : int [1:5723] 1 1 1 1 1 1 1 1 1 1 ...
##  $ 对方决定        : int [1:5723] 0 0 1 1 1 0 0 1 0 0 ...
##  $ 好感得分        : num [1:5723] 7 8 7 8 7 2 7 6.5 6 7 ...
##  $ 对方评估成功率  : num [1:5723] 4 4 7 6 6 1 5 8 6 2 ...
##  $ 吸引力得分      : num [1:5723] 6 7 7 8 7 3 6 7 6 8 ...
##  $ 共同爱好得分    : num [1:5723] 6 5 8 7 7 7 6 9 6 4 ...
##  $ 幽默得分        : num [1:5723] 8 7 8 6 8 5 6 8 6 9 ...
##  $ 真诚得分        : num [1:5723] 8 8 8 7 7 6 7 7 6 7 ...
##  $ 雄心得分        : num [1:5723] 8 7 9 9 7 8 8 8 6 7 ...
##  $ 智力得分        : num [1:5723] 8 10 9 9 8 7 5 8 6 6 ...
##  $ 对方年龄        : int [1:5723] 27 22 23 24 25 30 27 28 24 27 ...
##  $ 对方种族        : int [1:5723] 2 2 2 3 2 2 2 2 2 2 ...
##  $ 是否同一种族    : int [1:5723] 0 0 0 0 0 0 0 0 0 1 ...
##  $ 日常约会频率    : int [1:5723] 7 7 7 7 7 7 7 7 7 5 ...

data %>% map(unique)

## $决定
## [1] 1 0
## 
## $性别
## [1] 0 1
## 
## $吸引力
##  [1]  6.0  7.0  5.0  4.0  8.0  9.0  3.0 10.0  2.0  1.0  0.0  6.5  7.5  9.5  8.5
## [16]  9.9  3.5
## 
## $共同爱好
##  [1]  5.0  6.0  8.0  4.0  7.0  3.0  2.0  9.0 10.0  1.0  0.0  7.5  6.5  8.5  5.5
## 
## $幽默
##  [1]  7.0  8.0  4.0  6.0  9.0  3.0  5.0 10.0  2.0  1.0  0.0  5.5  6.5  9.5  7.5
## [16]  8.5
## 
## $真诚
##  [1]  9.0  8.0  6.0  7.0  5.0 10.0  4.0  3.0  2.0  1.0  0.0  8.5  7.5
## 
## $雄心
##  [1]  6.0  5.0  8.0 10.0  9.0  3.0  7.0  4.0  2.0  1.0  0.0  9.5  7.5  8.5
## 
## $智力
##  [1]  7.0  8.0  6.0  9.0 10.0  5.0  4.0  3.0  2.0  1.0  0.0  6.5  8.5  7.5  5.5
## 
## $好感
##  [1]  7.0  6.0  8.0  5.0  9.0  4.0 10.0  2.0  3.0  6.5  1.0  8.5  9.5  0.0  7.5
## [16]  5.5  4.5  9.7
## 
## $成功率自估
##  [1]  6.0  5.0  7.0  4.0  3.0  8.0  1.0 10.0  2.0  9.0  0.0  6.5  7.5  8.5  9.5
## [16]  5.5  3.5  4.5
## 
## $日常出门频率
## [1] 1 4 2 3 5 7 6
## 
## $对宗教的看重程度
##  [1]  4  5  1  3  2  8 10  6  7  9
## 
## $对种族的看重程度
##  [1]  2  8  1  4  7  3  9 10  5  6  0
## 
## $年龄
##  [1] 21 24 25 23 22 26 27 30 28 29 34 35 32 20 19 18 33 36 31 42 38 55
## 
## $种族
## [1] 4 2 6 3 1
## 
## $从事领域
##  [1]  1  2 13  8  5  9  3 11 12  4  7  6 10 14 16 15 17 18
## 
## $对方决定
## [1] 0 1
## 
## $好感得分
##  [1]  7.0  8.0  2.0  6.5  6.0 10.0  9.0  4.0  5.0  3.0  1.0  9.5  7.5  4.5  8.5
## [16]  5.5  0.0  9.7
## 
## $对方评估成功率
##  [1]  4.0  7.0  6.0  1.0  5.0  8.0  2.0 10.0  3.0  9.0  4.5  6.5  5.5  0.0  7.5
## [16]  8.5  9.5  3.5
## 
## $吸引力得分
##  [1]  6.0  7.0  8.0  3.0 10.0  9.0  5.0  4.0  2.0  1.0  0.0  6.5  7.5  8.5  9.5
## [16]  9.9  3.5
## 
## $共同爱好得分
##  [1]  6.0  5.0  8.0  7.0  9.0  4.0 10.0  3.0  2.0  1.0  7.5  6.5  8.5  0.0  5.5
## 
## $幽默得分
##  [1]  8.0  7.0  6.0  5.0  9.0 10.0  3.0  4.0  2.0  1.0  5.5  6.5  9.5  0.0  7.5
## [16]  8.5 11.0
## 
## $真诚得分
##  [1]  8.0  7.0  6.0 10.0  9.0  3.0  5.0  4.0  2.0  1.0  4.5  8.5  0.0  7.5
## 
## $雄心得分
##  [1]  8.0  7.0  9.0  6.0 10.0  5.0  4.0  2.0  3.0  1.0  5.5  9.5  0.0  7.5  8.5
## 
## $智力得分
##  [1]  8.0 10.0  9.0  7.0  5.0  6.0  4.0  3.0  1.0  2.0  6.5  8.5  0.0  7.5  5.5
## 
## $对方年龄
##  [1] 27 22 23 24 25 30 28 21 26 29 32 35 34 18 20 19 33 31 36 42 38 55
## 
## $对方种族
## [1] 2 3 4 6 1
## 
## $是否同一种族
## [1] 0 1
## 
## $日常约会频率
## [1] 7 5 3 4 6 1 2

data %>%
  mutate(决定   = factor(决定,
                         levels = c(0, 1),
                         labels = c("拒绝", "接受"))) %>%
  mutate(性别   = factor(性别,
                         levels = c(0, 1),
                         labels = c("女", "男"))) %>%
  mutate(种族   = factor(
    种族,
    levels = c(1, 2, 3, 4, 5, 6),
    labels = c("非洲裔", "欧洲裔", "拉丁裔", "亚裔", "印第安土著", "其他")
  )) %>%
  mutate(从事领域 = factor(
    从事领域,
    levels = 1:18,
    labels = c(
      "法律",
      "数学",
      "社会科学或心理学",
      "医学或药物学或生物技术",
      "工程学",
      "写作或新闻",
      "历史或宗教或哲学",
      "商业或经济或金融",
      "教育或学术",
      "生物科学或化学或物理",
      "社会工作",
      "大学在读或未择方向",
      "政治学或国际事务",
      "电影",
      "艺术管理",
      "语言",
      "建筑学",
      "其他"
    )
  )) %>%
  mutate(对方决定  = factor(对方决定,
                            levels = 0:1,
                            labels = c("拒绝", "接收"))) %>%
  mutate(对方种族  = factor(
    对方种族,
    levels = c(1, 2, 3, 4, 5, 6),
    labels = c("非洲裔", "欧洲裔", "拉丁裔", "亚裔", "印第安土著", "其他")
  )) %>%
  mutate(是否同一种族  = factor(
    是否同一种族,
    levels = c(0, 1),
    labels = c("非同一种族", "同一种族") 
  )) -> data

重新看看数据，有的变量已经成为因子变量

data %>% str()

## tibble [5,723 x 29] (S3: tbl_df/tbl/data.frame)
##  $ 决定            : Factor w/ 2 levels "拒绝","接受": 2 2 2 2 1 2 1 2 2 1 ...
##  $ 性别            : Factor w/ 2 levels "女","男": 1 1 1 1 1 1 1 1 1 1 ...
##  $ 吸引力          : num [1:5723] 6 7 7 5 4 7 4 7 5 5 ...
##  $ 共同爱好        : num [1:5723] 5 6 8 6 4 7 6 8 8 3 ...
##  $ 幽默            : num [1:5723] 7 8 7 7 4 4 6 9 8 4 ...
##  $ 真诚            : num [1:5723] 9 8 6 6 9 6 9 6 6 7 ...
##  $ 雄心            : num [1:5723] 6 5 6 6 6 6 5 8 10 6 ...
##  $ 智力            : num [1:5723] 7 7 8 7 7 7 7 8 6 8 ...
##  $ 好感            : num [1:5723] 7 7 7 6 6 6 6 7 6 6 ...
##  $ 成功率自估      : num [1:5723] 6 5 6 6 5 5 7 7 6 4 ...
##  $ 日常出门频率    : int [1:5723] 1 1 1 1 1 1 1 1 1 1 ...
##  $ 对宗教的看重程度: int [1:5723] 4 4 4 4 4 4 4 4 4 5 ...
##  $ 对种族的看重程度: int [1:5723] 2 2 2 2 2 2 2 2 2 2 ...
##  $ 年龄            : int [1:5723] 21 21 21 21 21 21 21 21 21 24 ...
##  $ 种族            : Factor w/ 6 levels "非洲裔","欧洲裔",..: 4 4 4 4 4 4 4 4 4 2 ...
##  $ 从事领域        : Factor w/ 18 levels "法律","数学",..: 1 1 1 1 1 1 1 1 1 1 ...
##  $ 对方决定        : Factor w/ 2 levels "拒绝","接收": 1 1 2 2 2 1 1 2 1 1 ...
##  $ 好感得分        : num [1:5723] 7 8 7 8 7 2 7 6.5 6 7 ...
##  $ 对方评估成功率  : num [1:5723] 4 4 7 6 6 1 5 8 6 2 ...
##  $ 吸引力得分      : num [1:5723] 6 7 7 8 7 3 6 7 6 8 ...
##  $ 共同爱好得分    : num [1:5723] 6 5 8 7 7 7 6 9 6 4 ...
##  $ 幽默得分        : num [1:5723] 8 7 8 6 8 5 6 8 6 9 ...
##  $ 真诚得分        : num [1:5723] 8 8 8 7 7 6 7 7 6 7 ...
##  $ 雄心得分        : num [1:5723] 8 7 9 9 7 8 8 8 6 7 ...
##  $ 智力得分        : num [1:5723] 8 10 9 9 8 7 5 8 6 6 ...
##  $ 对方年龄        : int [1:5723] 27 22 23 24 25 30 27 28 24 27 ...
##  $ 对方种族        : Factor w/ 6 levels "非洲裔","欧洲裔",..: 2 2 2 3 2 2 2 2 2 2 ...
##  $ 是否同一种族    : Factor w/ 2 levels "非同一种族","同一种族": 1 1 1 1 1 1 1 1 1 2 ...
##  $ 日常约会频率    : int [1:5723] 7 7 7 7 7 7 7 7 7 5 ...

data %>% glimpse()

## Rows: 5,723
## Columns: 29
## $ 决定             <fct> 接受, 接受, 接受, 接受, 拒绝, 接受, 拒绝, 接受, 接受, 拒绝, 拒绝, 拒绝, 接受, ...
## $ 性别             <fct> 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女, 女...
## $ 吸引力           <dbl> 6, 7, 7, 5, 4, 7, 4, 7, 5, 5, 8, 5, 7, 6, 8, 7, 5, 7,...
## $ 共同爱好         <dbl> 5, 6, 8, 6, 4, 7, 6, 8, 8, 3, 6, 4, 7, 8, 2, 9, 5, 5, ...
## $ 幽默             <dbl> 7, 8, 7, 7, 4, 4, 6, 9, 8, 4, 6, 6, 6, 9, 3, 6, 5, 9...
## $ 真诚             <dbl> 9, 8, 6, 6, 9, 6, 9, 6, 6, 7, 5, 8, 9, 8, 7, 5, 8, 6...
## $ 雄心             <dbl> 6, 5, 6, 6, 6, 6, 5, 8, 10, 6, 9, 3, 5, 7, 6, 7, 9, ...
## $ 智力             <dbl> 7, 7, 8, 7, 7, 7, 7, 8, 6, 8, 6, 9, 7, 7, 8, 9, 7, 8...
## $ 好感             <dbl> 7, 7, 7, 6, 6, 6, 6, 7, 6, 6, 7, 6, 7, 8, 6, 8, 5, 5...
## $ 成功率自估       <dbl> 6, 5, 6, 6, 5, 5, 7, 7, 6, 4, 3, 7, 8, 6, 5, 7, 6, 6, 7...
## $ 日常出门频率     <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ 对宗教的看重程度 <int> 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 4...
## $ 对种族的看重程度 <int> 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 8...
## $ 年龄             <int> 21, 21, 21, 21, 21, 21, 21, 21, 21, 24, 24, 24, 24, ...
## $ 种族             <fct> 亚裔, 亚裔, 亚裔, 亚裔, 亚裔, 亚裔, 亚裔, 亚裔, 亚裔, 欧洲裔, 欧洲裔, 欧洲裔, 欧...
## $ 从事领域         <fct> 法律, 法律, 法律, 法律, 法律, 法律, 法律, 法律, 法律, 法律, 法律, 法律, 法律, 法律...
## $ 对方决定         <fct> 拒绝, 拒绝, 接收, 接收, 接收, 拒绝, 拒绝, 接收, 拒绝, 拒绝, 拒绝, 接收, 接收, 接收...
## $ 好感得分         <dbl> 7.0, 8.0, 7.0, 8.0, 7.0, 2.0, 7.0, 6.5, 6.0, 7.0, 8.0,...
## $ 对方评估成功率   <dbl> 4, 4, 7, 6, 6, 1, 5, 8, 6, 2, 4, 10, 7, 1, 5, 3, 6, 8, 9,...
## $ 吸引力得分       <dbl> 6, 7, 7, 8, 7, 3, 6, 7, 6, 8, 7, 10, 9, 10, 7, 5, 7, 8,...
## $ 共同爱好得分     <dbl> 6, 5, 8, 7, 7, 7, 6, 9, 6, 4, 5, 10, 9, 8, 7, 3, 5, 7, 7...
## $ 幽默得分         <dbl> 8, 7, 8, 6, 8, 5, 6, 8, 6, 9, 6, 10, 9, 10, 5, 3, 7, 9...
## $ 真诚得分         <dbl> 8, 8, 8, 7, 7, 6, 7, 7, 6, 7, 6, 10, 9, 10, 8, 3, 7, 6...
## $ 雄心得分         <dbl> 8, 7, 9, 9, 7, 8, 8, 8, 6, 7, 6, 10, 9, 7, 7, 5, 7, 8,...
## $ 智力得分         <dbl> 8, 10, 9, 9, 8, 7, 5, 8, 6, 6, 10, 10, 9, 10, 7, 4, 7,...
## $ 对方年龄         <int> 27, 22, 23, 24, 25, 30, 27, 28, 24, 27, 22, 22, 23, 24...
## $ 对方种族         <fct> 欧洲裔, 欧洲裔, 欧洲裔, 拉丁裔, 欧洲裔, 欧洲裔, 欧洲裔, 欧洲裔, 欧洲裔, 欧洲裔, 欧洲裔,...
## $ 是否同一种族     <fct> 非同一种族, 非同一种族, 非同一种族, 非同一种族, 非同一种族, 非同一种族, 非同一种族, 非同一种族, ...
## $ 日常约会频率     <int> 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,...

data %>% map(unique)

## $决定
## [1] 接受 拒绝
## Levels: 拒绝 接受
## 
## $性别
## [1] 女 男
## Levels: 女 男
## 
## $吸引力
##  [1]  6.0  7.0  5.0  4.0  8.0  9.0  3.0 10.0  2.0  1.0  0.0  6.5  7.5  9.5  8.5
## [16]  9.9  3.5
## 
## $共同爱好
##  [1]  5.0  6.0  8.0  4.0  7.0  3.0  2.0  9.0 10.0  1.0  0.0  7.5  6.5  8.5  5.5
## 
## $幽默
##  [1]  7.0  8.0  4.0  6.0  9.0  3.0  5.0 10.0  2.0  1.0  0.0  5.5  6.5  9.5  7.5
## [16]  8.5
## 
## $真诚
##  [1]  9.0  8.0  6.0  7.0  5.0 10.0  4.0  3.0  2.0  1.0  0.0  8.5  7.5
## 
## $雄心
##  [1]  6.0  5.0  8.0 10.0  9.0  3.0  7.0  4.0  2.0  1.0  0.0  9.5  7.5  8.5
## 
## $智力
##  [1]  7.0  8.0  6.0  9.0 10.0  5.0  4.0  3.0  2.0  1.0  0.0  6.5  8.5  7.5  5.5
## 
## $好感
##  [1]  7.0  6.0  8.0  5.0  9.0  4.0 10.0  2.0  3.0  6.5  1.0  8.5  9.5  0.0  7.5
## [16]  5.5  4.5  9.7
## 
## $成功率自估
##  [1]  6.0  5.0  7.0  4.0  3.0  8.0  1.0 10.0  2.0  9.0  0.0  6.5  7.5  8.5  9.5
## [16]  5.5  3.5  4.5
## 
## $日常出门频率
## [1] 1 4 2 3 5 7 6
## 
## $对宗教的看重程度
##  [1]  4  5  1  3  2  8 10  6  7  9
## 
## $对种族的看重程度
##  [1]  2  8  1  4  7  3  9 10  5  6  0
## 
## $年龄
##  [1] 21 24 25 23 22 26 27 30 28 29 34 35 32 20 19 18 33 36 31 42 38 55
## 
## $种族
## [1] 亚裔   欧洲裔 其他   拉丁裔 非洲裔
## Levels: 非洲裔 欧洲裔 拉丁裔 亚裔 印第安土著 其他
## 
## $从事领域
##  [1] 法律                   数学                   政治学或国际事务      
##  [4] 商业或经济或金融       工程学                 教育或学术            
##  [7] 社会科学或心理学       社会工作               大学在读或未择方向    
## [10] 医学或药物学或生物技术 历史或宗教或哲学       写作或新闻            
## [13] 生物科学或化学或物理   电影                   语言                  
## [16] 艺术管理               建筑学                 其他                  
## 18 Levels: 法律 数学 社会科学或心理学 医学或药物学或生物技术 ... 其他
## 
## $对方决定
## [1] 拒绝 接收
## Levels: 拒绝 接收
## 
## $好感得分
##  [1]  7.0  8.0  2.0  6.5  6.0 10.0  9.0  4.0  5.0  3.0  1.0  9.5  7.5  4.5  8.5
## [16]  5.5  0.0  9.7
## 
## $对方评估成功率
##  [1]  4.0  7.0  6.0  1.0  5.0  8.0  2.0 10.0  3.0  9.0  4.5  6.5  5.5  0.0  7.5
## [16]  8.5  9.5  3.5
## 
## $吸引力得分
##  [1]  6.0  7.0  8.0  3.0 10.0  9.0  5.0  4.0  2.0  1.0  0.0  6.5  7.5  8.5  9.5
## [16]  9.9  3.5
## 
## $共同爱好得分
##  [1]  6.0  5.0  8.0  7.0  9.0  4.0 10.0  3.0  2.0  1.0  7.5  6.5  8.5  0.0  5.5
## 
## $幽默得分
##  [1]  8.0  7.0  6.0  5.0  9.0 10.0  3.0  4.0  2.0  1.0  5.5  6.5  9.5  0.0  7.5
## [16]  8.5 11.0
## 
## $真诚得分
##  [1]  8.0  7.0  6.0 10.0  9.0  3.0  5.0  4.0  2.0  1.0  4.5  8.5  0.0  7.5
## 
## $雄心得分
##  [1]  8.0  7.0  9.0  6.0 10.0  5.0  4.0  2.0  3.0  1.0  5.5  9.5  0.0  7.5  8.5
## 
## $智力得分
##  [1]  8.0 10.0  9.0  7.0  5.0  6.0  4.0  3.0  1.0  2.0  6.5  8.5  0.0  7.5  5.5
## 
## $对方年龄
##  [1] 27 22 23 24 25 30 28 21 26 29 32 35 34 18 20 19 33 31 36 42 38 55
## 
## $对方种族
## [1] 欧洲裔 拉丁裔 亚裔   其他   非洲裔
## Levels: 非洲裔 欧洲裔 拉丁裔 亚裔 印第安土著 其他
## 
## $是否同一种族
## [1] 非同一种族 同一种族  
## Levels: 非同一种族 同一种族
## 
## $日常约会频率
## [1] 7 5 3 4 6 1 2

4.3 💐数据划分💐

这一步，需要将数据分割为训练集和测试集。常用的方式是5折划分，也就是将数据的80%划分为训练集，20%划分为测试集。训练集用于训练模型，测试集用于测试模型的效果。需要注意的是，测试集的信息就是黑盒子，是“雷区”，是绝对不能用到的信息。

当因变量Y的各个水平比例分布不均时，需要保证训练集和测试集中有相同比例，这时就会用到caret包。

caret包中createDataPartition()函数可以用于创建训练集，该函数的抽样方法类似分层抽样，从因变量Y的各个水平中随机抽取80%的数据作为训练集，剩下的数据作为测试集。

set.seed(1234)
data_id <- createDataPartition(data$决定,
                               p = 0.8,
                               list = FALSE,
                               times = 1)
data_training <- data[data_id,]

## Warning: The `i` argument of ``[`()` can't be a matrix as of tibble 3.0.0.
## Convert to a vector.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.

data_testing <- data[-data_id,]

table(data_training$决定) %>% prop.table()

## 
##      拒绝      接受 
## 0.5599476 0.4400524

table(data_testing$决定) %>% prop.table()

## 
##      拒绝      接受 
## 0.5603147 0.4396853

data %$% table(决定) %>% prop.table()

## 决定
##     拒绝     接受 
## 0.560021 0.439979

4.4 💐标准化处理💐

标准化处理是指将数据处理为均值为0、标准差为1的数据。那么为什么要进行标准化处理呢？因为在进行实证分析时，有些变量取值很大，有些变量取值很小，这里需要营造一个公平公正的环境，权重的大小不能被自身变量取值的大小所束缚。比如在判断一个女生是否是美女时，会考虑腿长、脸长、脸宽、腰围等因素，这些因素的学名为特征。显然腿长的取值比脸长的取值大得多，这时为了防止腿长的权重过高，就需要将这些特征进行标准化才能学习各个变量真实的权重。

标准化处理时，只能利用训练集的均值与标准差对训练集和测试集进行标准化。

pre_process_value <- preProcess(data_training,
                                method = c("center","scale"))

data_training_std <- predict(pre_process_value,data_training)

# 利用训练集的均值和标准差对测试集进行标准化(重要)
data_testing_std <- predict(pre_process_value,data_testing)

data_training_std

data_testing_std

5 😄特征选择😄

特征选择是指选择出那些对研究问题至关重要的特征，剔除掉那些不重要的变量。依然拿判断一个女生是否是美女为例，我们会考虑腿长、脸长、脸宽、腰围、年龄、肤色、脸型、上下身比例、牙齿是否洁白……影响一个人是否是美女的因素很多，但并不是所有因素都是特别重要的。所以需要选择出那些对判断是否为美女至关重要的变量。

特征选择在R中如何实现呢？caret包中rfe()函数可以用于特征选择，该函数属于特征选择中的封装法。该函数还内嵌一个特殊的函数——rfecontrol()，用于输入目标函数和抽样方法。在判断一个女生是否为美女的例子中，我们以随机森林为目标函数，即functions为rfFuncs，抽样方法为交叉验证，即将参数method设置为cv。该方法的核心思想为用随机森林法进行预测，挑出来的特征使交叉验证的平均预测精度越高越好。

封装法 rfe: Recursive feature selection

subsets = c(2, 5, 10, 15, 20)
# 要选择的变量个数
ctrl = rfeControl(functions = rfFuncs, method = "cv")

首先定义控制参数，functions是确定用什么样的模型进行自变量排序，本例选择的模型是随机森林。根据目标函数（通常是预测效果评分），每次选择若干特征。method是确定用什么样的抽样方法，本例使用cv，即交叉检验。

data_training_std_x <- data_training_std %>% 
  select(-决定)

data_training_std_y <- data_training_std %>% 
  select(决定) %>% 
  pull()

# data_training_std_select <- rfe(data_training_std_x,
#                                 data_training_std_y,
#                                 rfeControl = ctrl)
# 
# save(data_training_std_select,file = here::here("Machine_Learning_and_Causal_Inference/code/data_training_std_select.RData"))

load(file = here::here("Machine_Learning_and_Causal_Inference/code/data_training_std_select.RData"))
data_training_std_select

## 
## Recursive feature selection
## 
## Outer resampling method: Cross-Validated (10 fold) 
## 
## Resampling performance over subset size:
## 
##  Variables Accuracy  Kappa AccuracySD KappaSD Selected
##          4   0.7449 0.4824    0.01377 0.02866         
##          8   0.7713 0.5379    0.01523 0.03126         
##         16   0.8058 0.6063    0.01309 0.02741        *
##         28   0.7921 0.5782    0.01497 0.03102         
## 
## The top 5 variables (out of 16):
##    好感, 吸引力, 共同爱好, 幽默, 成功率自估

data_training_std_select$optVariables

##  [1] "好感"             "吸引力"           "共同爱好"         "幽默"            
##  [5] "成功率自估"       "从事领域"         "性别"             "对种族的看重程度"
##  [9] "种族"             "对宗教的看重程度" "日常出门频率"     "年龄"            
## [13] "真诚"             "吸引力得分"       "日常约会频率"     "智力"

6 😄模型训练😄

随机森林算法选择了16个让其预测精度最高的特征，接下来就要把这16个特征作为自变量来训练模型，此时用到的数据为训练集，建模依然用随机森林法。

data_training_std_select_fin <- data_training_std %>% 
  select(data_training_std_select$optVariables,决定)

data_testing_std_select_fin <- data_testing_std %>% 
  select(data_training_std_select$optVariables,决定)

set.seed(1234)
# model_rf <- caret::train(决定~.,data = data_training_std_select_fin,
#                            method = "rf")

# save(model_rf,file = here::here("Machine_Learning_and_Causal_Inference/result/data_training_std_select.RData"))

load(file = here::here("Machine_Learning_and_Causal_Inference/result/data_training_std_select.RData"))
model_rf

## Random Forest 
## 
## 4579 samples
##   16 predictor
##    2 classes: '拒绝', '接受' 
## 
## No pre-processing
## Resampling: Bootstrapped (25 reps) 
## Summary of sample sizes: 4579, 4579, 4579, 4579, 4579, 4579, ... 
## Resampling results across tuning parameters:
## 
##   mtry  Accuracy   Kappa    
##    2    0.7854677  0.5608539
##   19    0.7964451  0.5855091
##   36    0.7896081  0.5721527
## 
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 19.

变量重要性

model_rf %>% varImp(scale = FALSE) -> variable_imp
variable_imp %>% ggplot() + mytheme

模型训练出来后，就可以顺便把变量的重要性给提取出来了。从下图可以看出，好感、吸引力与共同爱好这三个特征最为重要。

7 😄模型测试集评估😄

最后来测试一下模型的预测精度。数据分析的结局不能是开放式任凭想象的，需要给出一个具体的数值。使用caret包的predict()函数，预测精度就呈现出来了

data_predict <- predict(model_rf,newdata = data_testing_std_select_fin)
confusionMatrix(data_predict,data_testing_std_select_fin$决定)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction 拒绝 接受
##       拒绝  558  110
##       接受   83  393
##                                           
##                Accuracy : 0.8313          
##                  95% CI : (0.8083, 0.8526)
##     No Information Rate : 0.5603          
##     P-Value [Acc > NIR] : < 2e-16         
##                                           
##                   Kappa : 0.6556          
##                                           
##  Mcnemar's Test P-Value : 0.06127         
##                                           
##             Sensitivity : 0.8705          
##             Specificity : 0.7813          
##          Pos Pred Value : 0.8353          
##          Neg Pred Value : 0.8256          
##              Prevalence : 0.5603          
##          Detection Rate : 0.4878          
##    Detection Prevalence : 0.5839          
##       Balanced Accuracy : 0.8259          
##                                           
##        'Positive' Class : 拒绝            
##