2019年（1）
分类： 大数据
2019-08-09 10:32:39
漫画PCA分析
要分析的数据来源于一张excel表。经观察分析，这张表有以下特点：
1、最后一行是个多余行；
2、“人气”列是数字加“万”字构成；
3、“话题数”、“累计打赏”、“今日打赏数”等列有非数字值或空值；
4、“漫画名称”列有重复，有些是名称和作者都相同，有些是不同作者的相同名称的作品；
因此，需要对原始数据进行处理，我选择的包是readxl。
R code:
install.packages("readxl")
首先，导入excel数据（我的excel表放路径为D:\R\漫画.xlsx）：
R code:
library(readxl)
origin <- read_excel("D:\\R\\漫画.xlsx", trim_ws=T, n_max=1713, col_types = c("text","text","text","text","numeric","numeric","text","numeric","numeric","numeric","text","guess","numeric","numeric","numeric","numeric","numeric","numeric","numeric","numeric"))
其次，处理“人气”列：
R code:
origin$人气 <- as.numeric(gsub("万", "0000", origin$人气))
然后，选取有效数据，并去除漫画名称+作者都相同的行：
R code:
fr <- data.frame(origin[1], origin[3], origin[5:10], origin[13:14], origin[19:20], origin[4])
fr <- fr[!duplicated(fr[1:2]),]
之后，给作者不同但漫画名称相同的数据赋予不同的漫画名称：
R code:
fr[duplicated(fr[1]),1] <- paste(fr[duplicated(fr[1]),1],"2")
最后，设置行名称并去掉NA值：
R code:
row.names(fr)=fr[,1]
fr[is.na(fr)] <- 0
二、PCA计算及特征值分析
首先，在PCA分析之前需要将数据标准化，即xi?mean(x)/sd(x)。R语言的PCA函数一般都自带数据标准化功能，所以不需要自己手工处理。
这里我调用的是PCA函数：
R code:
fr.active <- fr[3:12]
library("FactoMineR")
res.pca <- PCA(fr.active, scale.unit = TRUE, graph = F)
下面，检查特征值以确定要考虑的主成分数量。
R code:
library("factoextra")
eig.val <- get_eigenvalue(res.pca)
eig.val是这样一张表：
eigenvalue variance.percent cumulative.variance.percent
Dim.1 5.28225236 52.8225236 52.82252
Dim.2 1.36873525 13.6873525 66.50988
Dim.3 1.04034679 10.4034679 76.91334
Dim.4 0.76420624 7.6420624 84.55541
Dim.5 0.57861584 5.7861584 90.34156
Dim.6 0.32639774 3.2639774 93.60554
Dim.7 0.27760653 2.7760653 96.38161
Dim.8 0.19712376 1.9712376 98.35285
Dim.9 0.09733676 0.9733676 99.32621
Dim.10 0.06737872 0.6737872 100.00000
每个特征值解释的变化比例在上表第二列中给出。解释的累积百分比，即第三列是通过将所解释的变化的连续比例相加以获得运行总计来获得的。可见，前三项的特征值大于1，而且累计解释比例已达到76.9%，是个可接受的大比例了。在本分析中，我们认为前三个主成分是足够的。
确定主成分数量的另一种方法是查看Scree Plot，它是从最大到最小排序的特征值图。
R code:
fviz_eig(res.pca, addlabels = TRUE)
从图中可见明显的拐点。
三、变量分析
提取变量：
R code:
var <- get_pca_var(res.pca)
通过var$coord可以得出变量的坐标：
Dim.1 Dim.2 Dim.3 Dim.4 Dim.5
评分 0.14504324 -0.65942446 -0.3425518 0.64909673 0.05983225
评分人数 0.90490818 0.24085647 -0.2270857 0.06384066 0.03587817
人气 0.87250774 -0.02218187 0.0434355 0.04202673 -0.25411353
收藏数 0.85272910 -0.27026410 0.2323292 -0.04391026 -0.17712932
好票 0.74881709 0.41131323 -0.3975698 0.04973863 0.12347331
黑票 0.73507799 0.40811946 -0.2567772 0.03413473 0.18441070
话题数 0.86898726 -0.21466541 0.2539299 -0.06126312 -0.14311966
累计打赏 0.86238216 -0.06427954 0.1441258 -0.04509377 -0.15636620
单次得到打赏最高数额 0.59173004 -0.34567500 0.3375211 -0.14698821 0.61779233
作者作品数 -0.06234063 0.54488871 0.6264218 0.55143307 0.04411640
通过var$contrib可得出变量的贡献：
Dim.1 Dim.2 Dim.3 Dim.4 Dim.5
评分 0.39826841 31.76952028 11.2790982 55.1325727 0.6187004
评分人数 15.50207675 4.23835344 4.9568018 0.5333155 0.2224694
人气 14.41184006 0.03594816 0.1813475 0.2311217 11.1600271
收藏数 13.76584950 5.33650909 5.1883524 0.2523024 5.4223878
好票 10.61530188 12.36021156 15.1931801 0.3237257 2.6348500
黑票 10.22934173 12.16900734 6.3377446 0.1524693 5.8773547
话题数 14.29577400 3.36670195 6.1979694 0.4911201 3.5400409
累计打赏 14.07927802 0.30187429 1.9966666 0.2660863 4.2256689
单次得到打赏最高数额 6.62869584 8.73004509 10.9502415 2.8271861 65.9621365
作者作品数 0.07357381 21.69182880 37.7185979 39.7901002 0.3363643
可以画一个关系圈图形：
R code:
fviz_pca_var(res.pca)
在关系圈上加上贡献度的颜色：
R code:
fviz_pca_var(res.pca, col.var = "contrib", gradient.cols = c("green", "blue", "red"))
可见，评分人数、收藏数、话题数更趋近圆圈且颜色趋于红色，具备良好的表示。评分和作者作品数是相对的，呈现负相关关系。
下面，进一步观察变量对主成分的贡献：
第一主成分：
R code:
fviz_contrib(res.pca, choice = "var", axes = 1, top = 10)
第二主成分：
R code:
fviz_contrib(res.pca, choice = "var", axes = 2, top = 10)
第三主成分：
R code:
fviz_contrib(res.pca, choice = "var", axes = 3, top = 10)
由此可见，第一主成分与评分人数、人气、话题数、累计打赏、收藏数有很大的正相关关系，因此该部分主要衡量的是漫画的火热程度。第二主成分与评分有很大的相关关系，因此该部分主要衡量的是漫画的评价。第三主成分与作者作品数有很大的相关关系，因此该部分主要衡量的是作者的产出程度。
四、个体分析
提取个体信息：
R code:
ind <- get_pca_ind(res.pca)
类似于变量分析，也可以查看坐标：
R code:
head(ind$coord, 20)
Dim.1 Dim.2 Dim.3 Dim.4 Dim.5
火影忍者 15.703775 -0.15260505 0.9157721 1.80424066 -5.45376319
尸兄（我叫白小飞） 49.505306 20.26742784 -18.5185968 3.72477443 5.28046421
海贼王/航海王 13.800529 1.03628295 -0.9545084 2.14283526 -4.00187878
妖怪名单 27.994483 -3.34223413 4.6512021 -0.86789120 -6.82876018
中国惊奇先生 26.209129 2.47086254 -1.4026582 0.05612973 -0.91231199
狐妖小红娘 23.997306 -2.43800991 3.8512758 -0.61664679 -4.06631681
王牌御史 21.454015 -3.97112032 4.6135486 -1.03327587 -4.06077511
死神/境·界 6.355510 -0.64211629 0.3791436 1.69280734 -3.19429618
斗破苍穹 22.763770 1.80172024 1.1098332 -0.40859805 0.58935065
一人之下 13.265945 -4.34797747 4.7288114 -1.01613293 -1.90666809
银之守墓人 11.122643 -4.21761061 4.0564674 -0.86729807 -1.00280565
从前有座灵剑山 11.423870 -2.72407594 2.8150461 -0.63548099 -0.17421731
妖精种植手册 11.386147 -4.54579442 4.4551326 -1.04549114 -1.12695647
通职者 7.979733 -1.97815843 1.6741200 -0.09576681 -3.48720435
偷星九月天 5.203160 0.05577831 0.4154013 0.45784300 -1.55823012
罗刹大人请留步 6.703990 -2.56950107 1.9134348 -0.14788972 -2.30044848
灵契 17.363979 -5.07121423 6.6000628 -2.03119632 -3.95767328
妖神记 11.290169 -3.71206130 3.7141885 -0.70693574 -2.95717362
通灵妃 4.169304 -1.85097903 1.3497245 -0.13685945 -2.74473521
我的双修道侣（我的天劫女友） 11.590207 -3.39868423 3.9348743 -1.36517399 -0.06083572
查看贡献：
R code:
head(ind$contrib, 20)
Dim.1 Dim.2 Dim.3 Dim.4 Dim.5
火影忍者 2.7365915 9.973310e-04 0.047251727 0.2496889511 3.0131670587
尸兄（我叫白小飞） 27.1960182 1.759133e+01 19.322307716 1.0641683687 2.8247164854
海贼王/航海王 2.1134564 4.598945e-02 0.051333677 0.3521988712 1.6224021628
妖怪名单 8.6965446 4.783825e-01 1.218914529 0.0577751344 4.7240488469
中国惊奇先生 7.6226680 2.614560e-01 0.110852766 0.0002416552 0.0843174412
狐妖小红娘 6.3903818 2.545496e-01 0.835703222 0.0291664342 1.6750704618
王牌御史 5.1076248 6.753480e-01 1.199259137 0.0818922810 1.6705079022
死神/境·界 0.4482318 1.765749e-02 0.008099351 0.2197988715 1.0336678828
斗破苍穹 5.7502958 1.390197e-01 0.069399808 0.0128056897 0.0351866718
一人之下 1.9528919 8.096104e-01 1.259931169 0.0791974950 0.3682823047
银之守墓人 1.3728334 7.617886e-01 0.927126110 0.0576961922 0.1018741982
从前有座灵剑山 1.4481994 3.177898e-01 0.446492197 0.0309752995 0.0030747746
妖精种植手册 1.4386509 8.849548e-01 1.118314901 0.0838399683 0.1286604128
通职者 0.7066080 1.675806e-01 0.157912322 0.0007034616 1.2319283605
偷星九月天 0.3004251 1.332393e-04 0.009722512 0.0160784267 0.2459766298
罗刹大人请留步 0.4987335 2.827477e-01 0.206286203 0.0016775920 0.5361121891
灵契 3.3458028 1.101350e+00 2.454363994 0.3164566274 1.5867574065
妖神记 1.4144991 5.901084e-01 0.777267877 0.0383327758 0.8858991872
通灵妃 0.1928985 1.467251e-01 0.102643885 0.0014366797 0.7631880543
我的双修道侣（我的天劫女友） 1.4906792 4.946786e-01 0.872377715 0.1429507390 0.0003749281
下面画出个体的贡献度图：
R code:
fviz_pca_ind(res.pca, col.ind = "cos2", gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"))
个体数量太多，这个图不是很明显，下面我们把名称去掉再看一下：
R code:
fviz_pca_ind(res.pca, col.ind = "cos2", gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"), label="none")
这样就明显多了。
下面我们更进一步的来看个体对主成分的贡献：
我们来选取对第一主成分的贡献个体，因为数量太多，所以我们选择前十个来展示：
R code:
fviz_contrib(res.pca, choice = "ind", axes = 1, top=10)
我们再来看对前三维主成分的贡献排名前十名的个体有哪些：
R code:
fviz_contrib(res.pca, choice = "ind", axes = 1:3, top=10)
他们是：尸兄（我叫白小飞）、妖怪名单、中国惊奇先生、狐妖小红娘、斗破苍穹、王牌御史、灵契、火影忍者、一人之下、斗罗大陆。相应的，可以把他们放在本站显著位置进行宣传。也可根据这种分析方法，相应的得出比如前50的个体，进行不同等级的宣传。
五、组群分析
在源数据表中，“合约关系”列可以当作分组依据，我们来据此看看分组情况。
R code:
fviz_pca_ind(res.pca, label="none", habillage=as.factor(fr$合约关系), addEllipses=TRUE)
从图中可见，签约作者、合作伙伴、普通作者并没有形成特别明显的群落。但是普通作者和合作伙伴的数量多且特性更趋于集中，而签约作者数量少且趋于分散。这样，对于本站来说，就需要进一步分析签约作者的分散性，通过解约签约或者上架下架的方式来使本站的收益最大化。
附件——本文用到的代码：
excel表《漫画.xlsx》地址：https://github.com/beforeicer/blog/blob/master/%E4%BD%BF%E7%94%A8R%E5%AF%B9%E6%BC%AB%E7%94%BB%E8%BF%9B%E8%A1%8CPCA%E5%88%86%E6%9E%90/%E6%BC%AB%E7%94%BB.xlsx
# install required packages first:
# Here, I commented the install instructions:
# install.packages("readxl")
# install.packages("factoextra")
# --preprocess data from excel begin--
library(readxl)
origin <- read_excel("D:\\R\\漫画.xlsx", trim_ws=T, n_max=1713, col_types = c("text","text","text","text","numeric","numeric","text","numeric","numeric","numeric","text","guess","numeric","numeric","numeric","numeric","numeric","numeric","numeric","numeric"))
origin$人气 <- as.numeric(gsub("万", "0000", origin$人气))
fr <- data.frame(origin[1], origin[3], origin[5:10], origin[13:14], origin[19:20], origin[4])
fr <- fr[!duplicated(fr[1:2]),]
fr[duplicated(fr[1]),1] <- paste(fr[duplicated(fr[1]),1],"2")
row.names(fr)=fr[,1]
fr[is.na(fr)] <- 0
# --preprocess data from excel end--
# --PCA begin--
# --eig--
fr.active <- fr[3:12]
library("FactoMineR")
res.pca <- PCA(fr.active, scale.unit = TRUE, graph = F)
library("factoextra")
eig.val <- get_eigenvalue(res.pca)
fviz_eig(res.pca, addlabels = TRUE)
# --variable--
var <- get_pca_var(res.pca)
fviz_pca_var(res.pca)
fviz_pca_var(res.pca, col.var = "contrib", gradient.cols = c("green", "blue", "red"))
fviz_contrib(res.pca, choice = "var", axes = 1, top = 10)
fviz_contrib(res.pca, choice = "var", axes = 2, top = 10)
fviz_contrib(res.pca, choice = "var", axes = 3, top = 10)
# --individual--
ind <- get_pca_ind(res.pca)
fviz_pca_ind(res.pca, col.ind = "cos2", gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"))
fviz_pca_ind(res.pca, col.ind = "cos2", gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"), label="none")
fviz_contrib(res.pca, choice = "ind", axes = 1, top=10)
fviz_contrib(res.pca, choice = "ind", axes = 1:3, top=10)
# --groups--
fviz_pca_ind(res.pca, label="none", habillage=as.factor(fr$合约关系), addEllipses=TRUE)
