R语言混合型数据聚类分析案例

本文目的
内容简介
数据简介
数据清洗
距离计算
聚类算法的选择
聚类个数的选择
聚类结果解释
可视化方法

本文目的

利用聚类分析，我们可以很容易地看清数据集中样本的分布情况。以往介绍聚类分析的文章中通常只介绍如何处理连续型变量，这些文字并没有过多地介绍如何处理混合型数据（如同时包含连续型变量、名义型变量和顺序型变量的数据）。本文将利用 Gower 距离、PAM（partitioning around medoids）算法和轮廓系数来介绍如何对混合型数据做聚类分析。

内容简介

本文主要分为三个部分：

距离计算
聚类算法的选择
聚类个数的选择

为了介绍方便，本文直接使用 ISLR 包中的 College 数据集。该数据集包含了自 1995 年以来美国大学的 777 条数据，其中主要有以下几个变量：

连续型变量
- 录取率
- 学费
- 新生数量
分类型变量
- 公立或私立院校
- 是否为高水平院校，即所有新生中毕业于排名前 10% 高中的新生数量占比是否大于 50%

数据简介

set.seed(1680)  # 设置随机种子，使得本文结果具有可重现性

# library(dplyr)
# library(cluster)
# library(ggplot2)
# library(Rtsne)
library(ISLR)

mdata <- College
dim(mdata)

## [1] 777  18

head(mdata)

##                              Private Apps Accept Enroll Top10perc
## Abilene Christian University     Yes 1660   1232    721        23
## Adelphi University               Yes 2186   1924    512        16
## Adrian College                   Yes 1428   1097    336        22
## Agnes Scott College              Yes  417    349    137        60
## Alaska Pacific University        Yes  193    146     55        16
## Albertson College                Yes  587    479    158        38
##                              Top25perc F.Undergrad P.Undergrad Outstate
## Abilene Christian University        52        2885         537     7440
## Adelphi University                  29        2683        1227    12280
## Adrian College                      50        1036          99    11250
## Agnes Scott College                 89         510          63    12960
## Alaska Pacific University           44         249         869     7560
## Albertson College                   62         678          41    13500
##                              Room.Board Books Personal PhD Terminal
## Abilene Christian University       3300   450     2200  70       78
## Adelphi University                 6450   750     1500  29       30
## Adrian College                     3750   400     1165  53       66
## Agnes Scott College                5450   450      875  92       97
## Alaska Pacific University          4120   800     1500  76       72
## Albertson College                  3335   500      675  67       73
##                              S.F.Ratio perc.alumni Expend Grad.Rate
## Abilene Christian University      18.1          12   7041        60
## Adelphi University                12.2          16  10527        56
## Adrian College                    12.9          30   8735        54
## Agnes Scott College                7.7          37  19016        59
## Alaska Pacific University         11.9           2  10922        15
## Albertson College                  9.4          11   9727        55

数据清洗

构建聚类模型之前，我们需要做一些数据清洗工作：

录取率等于录取人数除以总申请人数
判断某个学校是否为高水平院校，需要根据该学校的所有新生中毕业于排名前 10% 高中的新生数量占比是否大于 50% 来决定

set.seed(888)  # 设置随机种子，使得本文结果具有可重现性

library(dplyr)
library(cluster)
library(ggplot2)
library(Rtsne)
library(ISLR)

college_clean <- College %>%
  mutate(name = row.names(.),
         accept_rate = Accept/Apps,
         isElite = cut(Top10perc,
                       breaks = c(0, 50, 100),
                       labels = c("Not Elite", "Elite"),
                       include.lowest = TRUE)) %>%
  mutate(isElite = factor(isElite)) %>%
  select(name, accept_rate, Outstate, Enroll, Grad.Rate, Private, isElite)

glimpse(college_clean)

## Observations: 777
## Variables: 7
## $ name        (chr) "Abilene Christian University", "Adelphi Universit...
## $ accept_rate (dbl) 0.7421687, 0.8801464, 0.7682073, 0.8369305, 0.7564...
## $ Outstate    (dbl) 7440, 12280, 11250, 12960, 7560, 13500, 13290, 138...
## $ Enroll      (dbl) 721, 512, 336, 137, 55, 158, 103, 489, 227, 172, 4...
## $ Grad.Rate   (dbl) 60, 56, 54, 59, 15, 55, 63, 73, 80, 52, 73, 76, 74...
## $ Private     (fctr) Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes,...
## $ isElite     (fctr) Not Elite, Not Elite, Not Elite, Elite, Not Elite...

距离计算

聚类分析的第一步是定义样本之间距离的度量方法，最常用的距离度量方法是欧式距离。然而欧氏距离只适用于连续型变量，所以本文将采用另外一种距离度量方法—— Gower 距离。

Gower 距离（高氏距离）

Gower 距离的定义非常简单。首先每个类型的变量都有特殊的距离度量方法，而且该方法会将变量标准化到[0,1]之间。接下来，利用加权线性组合的方法来计算最终的距离矩阵。不同类型变量的计算方法如下所示：

连续型变量：利用归一化的曼哈顿距离
顺序型变量：首先将变量按顺序排列，然后利用经过特殊调整的曼哈顿距离
名义型变量：首先将包含 k 个类别的变量转换成 k 个 0-1 变量，然后利用 Dice 系数做进一步的计算
- 优点：通俗易懂且计算方便
- 缺点：非常容易受无标准化的连续型变量异常值影响，所以数据转换过程必不可少；该方法需要耗费较大的内存

利用 daisy 函数，我们只需要一行代码就可以计算出 Gower 距离。需要注意的是，由于新生入学人数是右偏变量，我们需要对其做对数转换。daisy 函数内置了对数转换的功能，你可以调用帮助文档来获取更多的参数说明。

library(cluster)

# Remove college name before clustering
gower_dist <- daisy(college_clean[, -1], metric = "gower", type = list(logratio = 3))

# Check attributes to ensure the correct methods are being used
# (I = interval, N = nominal)
# Note that despite logratio being called, 
# the type remains coded as "I"
summary(gower_dist)

## 301476 dissimilarities, summarized :
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
## 0.0018601 0.1034400 0.2358700 0.2314500 0.3271400 0.7773500 
## Metric :  mixed ;  Types = I, I, I, I, N, N 
## Number of objects : 777

此外，我们可以通过观察最相似和最不相似的样本来判断该度量方法的合理性。本案例中，圣托马斯大学和约翰卡罗尔大学最相似，而俄克拉荷马科技和艺术大学和哈佛大学差异最大。

gower_mat <- as.matrix(gower_dist)
# dim(gower_mat)

# Output most similar pair
knitr::kable(college_clean[which(gower_mat == min(gower_mat[gower_mat != min(gower_mat)]), arr.ind = TRUE)[1,], ])

	name	accept_rate	Outstate	Enroll	Grad.Rate	Private	isElite
682	University of St. Thomas MN	0.8784638	11712	828	89	Yes	Not Elite
284	John Carroll University	0.8711276	11700	820	89	Yes	Not Elite

# Output most dissimilar pair
knitr::kable(college_clean[which(gower_mat == max(gower_mat[gower_mat != max(gower_mat)]), arr.ind = TRUE)[1,], ])

	name	accept_rate	Outstate	Enroll	Grad.Rate	Private	isElite
673	University of Sci. and Arts of Oklahoma	0.9824561	3687	208	43	No	Not Elite
251	Harvard University	0.1561486	18485	1606	100	Yes	Elite

聚类算法的选择

现在我们已经计算好样本间的距离矩阵，接下来需要选择一个合适的聚类算法，本文采用 PAM（partioniong around medoids）算法来构建模型：

PAM 算法的主要步骤：

随机选择 k 个数据点，并将其设为簇中心点
遍历所有样本点，并将样本点归入最近的簇中
对每个簇而言，找出与簇内其他点距离之和最小的点，并将其设为新的簇中心点
重复第2步，直到收敛

该算法和 K-means 算法非常相似。事实上，除了中心点的计算方法不同外，其他步骤都完全一致。

优点：简单易懂且不易受异常值所影响
缺点：算法时间复杂度较高

聚类个数的选择

我们将利用轮廓系数来确定最佳的聚类个数，轮廓系数是一个用于衡量聚类离散度的内部指标，该指标的取值范围是[-1,1]，其数值越大越好。通过比较不同聚类个数下轮廓系数的大小，我们可以看出当聚类个数为 3 时，聚类效果最好。

library(cluster)

# Calculate silhouette width for many k using PAM
sil_width <- c(NA)

for(i in 2:10){
  
  pam_fit <- pam(gower_dist, diss=TRUE, k = i)
  sil_width[i] <- pam_fit$silinfo$avg.width
  
}

# Plot sihouette width (higher is better)
plot(1:10, sil_width,xlab = "Number of clusters",ylab = "Silhouette Width")
lines(1:10, sil_width)

聚类结果解释

描述统计量

聚类完毕后，我们可以调用 summary 函数来查看每个簇的汇总信息。从这些汇总信息中我们可以看出：簇1主要是中等学费且学生规模较小的私立非顶尖院校，簇2主要是高收费、低录取率且高毕业率的私立顶尖院校，而簇3则是低学费、低毕业率且学生规模较大的公立非顶尖院校。

library(dplyr)

pam_fit <- pam(gower_dist, diss = TRUE, k = 3)

pam_results <- college_clean %>%
  dplyr::select(-name) %>%
  mutate(cluster = pam_fit$clustering) %>%
  group_by(cluster) %>%
  do(the_summary = summary(.))

print(pam_results$the_summary)

## [[1]]
##   accept_rate        Outstate         Enroll         Grad.Rate     
##  Min.   :0.3283   Min.   : 2340   Min.   :  35.0   Min.   : 15.00  
##  1st Qu.:0.7225   1st Qu.: 8842   1st Qu.: 194.8   1st Qu.: 56.00  
##  Median :0.8004   Median :10905   Median : 308.0   Median : 67.50  
##  Mean   :0.7820   Mean   :11200   Mean   : 418.6   Mean   : 66.97  
##  3rd Qu.:0.8581   3rd Qu.:13240   3rd Qu.: 484.8   3rd Qu.: 78.25  
##  Max.   :1.0000   Max.   :21700   Max.   :4615.0   Max.   :118.00  
##  Private        isElite       cluster 
##  No :  0   Not Elite:500   Min.   :1  
##  Yes:500   Elite    :  0   1st Qu.:1  
##                            Median :1  
##                            Mean   :1  
##                            3rd Qu.:1  
##                            Max.   :1  
## 
## [[2]]
##   accept_rate        Outstate         Enroll         Grad.Rate     
##  Min.   :0.1545   Min.   : 5224   Min.   : 137.0   Min.   : 54.00  
##  1st Qu.:0.4135   1st Qu.:13850   1st Qu.: 391.0   1st Qu.: 77.00  
##  Median :0.5329   Median :17238   Median : 601.0   Median : 89.00  
##  Mean   :0.5392   Mean   :16225   Mean   : 882.5   Mean   : 84.78  
##  3rd Qu.:0.6988   3rd Qu.:18590   3rd Qu.:1191.0   3rd Qu.: 94.00  
##  Max.   :0.9605   Max.   :20100   Max.   :4893.0   Max.   :100.00  
##  Private       isElite      cluster 
##  No : 4   Not Elite: 0   Min.   :2  
##  Yes:65   Elite    :69   1st Qu.:2  
##                          Median :2  
##                          Mean   :2  
##                          3rd Qu.:2  
##                          Max.   :2  
## 
## [[3]]
##   accept_rate        Outstate         Enroll       Grad.Rate     
##  Min.   :0.3746   Min.   : 2580   Min.   : 153   Min.   : 10.00  
##  1st Qu.:0.6423   1st Qu.: 5295   1st Qu.: 694   1st Qu.: 46.00  
##  Median :0.7458   Median : 6598   Median :1302   Median : 54.50  
##  Mean   :0.7315   Mean   : 6698   Mean   :1615   Mean   : 55.42  
##  3rd Qu.:0.8368   3rd Qu.: 7748   3rd Qu.:2184   3rd Qu.: 65.00  
##  Max.   :1.0000   Max.   :15516   Max.   :6392   Max.   :100.00  
##  Private        isElite       cluster 
##  No :208   Not Elite:199   Min.   :3  
##  Yes:  0   Elite    :  9   1st Qu.:3  
##                            Median :3  
##                            Mean   :3  
##                            3rd Qu.:3  
##                            Max.   :3

knitr::kable(college_clean[pam_fit$medoids, ])

	name	accept_rate	Outstate	Enroll	Grad.Rate	Private	isElite
492	Saint Francis College	0.7877629	10880	284	69	Yes	Not Elite
38	Barnard College	0.5616987	17926	531	91	Yes	Elite
234	Grand Valley State University	0.7525653	6108	1561	57	No	Not Elite

PAM 算法的另一个优点是各个簇的中心点是实际的样本点。从聚类结果中我们可以看出，圣弗朗西斯大学是簇1 的中心点，巴朗德学院是簇2 的中心点，而密歇根州州立大学河谷大学是簇3 的中心点。

可视化方法

t-SNE是一种降维方法，它可以在保留聚类结构的前提下，将多维信息压缩到二维或三维空间中。借助t-SNE我们可以将 PAM 算法的聚类结果绘制出来，有趣的是私立顶尖院校和公立非顶尖院校这两个簇中间存在一个小聚类簇。

library(dplyr)
library(ggplot2)
library(Rtsne)

tsne_obj <- Rtsne(gower_dist, is_distance = TRUE)

tsne_data <- tsne_obj$Y %>%
  data.frame() %>%
  setNames(c("X", "Y")) %>%
  mutate(cluster = factor(pam_fit$clustering),
         name = college_clean$name)

ggplot(aes(x = X, y = Y), data = tsne_data) + geom_point(aes(color = cluster))

进一步探究可以发现，这一小簇主要包含一些竞争力较强的公立院校，比如弗吉尼亚大学和加州大学伯克利分校。虽然无法通过轮廓系数指标来证明多分一类是合理的，但是这些院校的确显著不同于其他三个簇的院校。

tsne_data %>%
  filter(X > 15 & X < 25,
         Y > -15 & Y < -10) %>%
  left_join(college_clean, by = "name") %>%
  collect %>%
  .[["name"]]

## character(0)