宅男女神网 8320 名模特数据分析报告

library(rvest)
library(progress)
library(io)
library(stringr)
library(lubridate)
library(formattable)
# 提取422个文件中所有模特主页的链接
home <- data.frame(
  title = NA,
  link = NA
)

pb <- progress_bar$new(total = 422)

for(i in 1:422){
  pb$tick(0)
  pb$tick()
  try(
    html <- read_html(paste0('temp', i, '.html'), encoding = 'UTF-8')
    )
    for(j in 1:20){
      try(
        home <- rbind(
          home, 
          data_frame(
            title = html %>% html_node(xpath = paste0('/html/body/ul/li[', j, ']/div/div/a')) %>% html_text(),
            link = html %>% html_node(xpath = paste0('/html/body/ul/li[', j, ']/div/div/a')) %>% html_attr('href')
          ))
      )
    }
}

home <- home[!duplicated(home$title),]
home <- subset(home, !is.na(home$title))  
home$link <- paste0('https://www.nvshens.com', home$link)

# 赶紧把home数据集保存起来
qwrite(home, 'nvshenslink.rds')

# 开始爬取每个模特的数据
rm(list = ls())
home <- qread('nvshenslink.rds')
df <- data.frame(
  name = NA, # 姓名
  age = NA, # 年龄
  birthday = NA, # 生日
  constellation = NA, # 星座
  height = NA, # 身高
  weight = NA, # 体重
  vital = NA, # 三围
  birthplace = NA, # 出生地
  job = NA, # 职业
  interest = NA, # 兴趣
  info = NA, # 详细资料
  link = NA, # 主页链接
  score = NA, # 评分
  scorepeople = NA, # 评分人数
  img = NA # 封面图片链接
)
# 总模特数：8320


# 由于这个循环特别久，中间很容易出错，所以我把循环分成8份运行，每份1000次
# 第一份
pb <- progress_bar$new(total = length(home$link))
for(i in 1:length(home$link)){
  pb$tick(0)
  pb$tick()
  try(html <- read_html(home$link[i]))
  table <- html %>% html_node(css = '#post > div:nth-child(2) > div > div.infodiv > table') %>% html_table()
  table$X1 <- gsub(pattern = '[： ]', replacement = '', table$X1)
  row.names(table) <- table$X1
  try(
  df <- rbind(
    df,
    data.frame(
      name = html %>% html_node(xpath = '//*[@id="post"]/div[2]/div/div[1]/h1') %>% html_text(), # 姓名
      age = table[c('年龄'), c('X2')], # 年龄
      birthday = table[c('生日'), c('X2')], # 生日
      constellation = table[c('星座'), c('X2')], # 星座
      height = table[c('身高'), c('X2')], # 身高
      weight = table[c('体重'), c('X2')], # 体重
      vital = table[c('三围'), c('X2')], # 三围
      birthplace = table[c('出生'), c('X2')], # 出生地
      job = table[c('职业'), c('X2')], # 职业
      interest = table[c('兴趣'), c('X2')], # 兴趣
      info = html %>% html_node(xpath = '//*[@id="post"]/div[5]/div/div[1]/div[2]/p') %>% html_text(), # 详细资料
      link = home$link[i], # 主页链接
      score = html %>% html_node(xpath = '//*[@id="span_score"]') %>% html_text(), # 评分
      scorepeople = html %>% html_node(xpath = '//*[@id="lbl_score"]') %>% html_text(), # 评分人数
      img = html %>% html_node(xpath = '//*[@id="post"]/div[2]/div/div[3]/a/img') %>% html_attr('src') # 封面图片链接
    )
  )
  )
}

df <- subset(df, !is.na(df$name))
df <- df[!duplicated(df$link),]
qwrite(df, 'model.rds')

rm(list = ls())
df <- qread('model.rds')

# 整理数据
df <- df %>% 
  mutate(
    zodiac = gsub(pattern = '[0-9\\(\\) 属]', replacement = '', age),
    age = str_extract(age, pattern = '(.*) \\(') %>% 
      gsub(x = ., pattern = ' \\(', replacement = '') %>% 
      as.numeric(),
    birthday = ymd(birthday),
    height = as.numeric(height),
    weight = gsub(' KG', '', weight) %>% as.numeric(),
    birthcountry = gsub(pattern = ' .*', replacement = '', birthplace),
    birthcity = gsub(pattern = '.* ', replacement = '', birthplace),
    bust = gsub(' W.*', '', vital) %>% 
      gsub(x = ., pattern = '\\(.*\\)', replacement = '') %>% 
      gsub(x = ., pattern = 'B', replacement = '') %>% 
      as.numeric(),
    waist = gsub(x = vital, pattern = ' H.*', replacement = '') %>% 
      gsub(x = ., pattern = '.*W', replacement = '') %>% 
      gsub(x = ., pattern = '\\(.*\\)', replacement = '') %>% 
      gsub(x = ., pattern = 'B*', replacement = '') %>% 
      as.numeric(),
    hipline = gsub('.*H', '', vital) %>% 
      gsub(x = ., pattern = '\\(.*\\)', replacement = '') %>% 
      gsub(x = ., pattern = 'B*', replacement = '') %>% 
      gsub(x = ., pattern = 'W*', replacement = '') %>% 
      gsub(x = ., pattern = '* W*', replacement = '') %>% 
      as.numeric(),
    score = score %>% as.numeric(),
    scorepeople = scorepeople %>% as.numeric()
  ) %>% 
  arrange(desc(scorepeople), desc(score))
``` 

## 分析数据

### 评价人数最多、评分最高的十个模特

首先是评价人数最多、评分最高的十个模特：

```r R
knitr::kable(df %>% 
               slice(1:10) %>% 
               select(name, age, score, link))

df %>% 
  group_by(age) %>% 
  summarise(
    n = length(age)/8320,
    bust = sum(bust, na.rm = T)/length(bust)
  ) %>% 
ggplot() + 
  geom_col(aes(x = age, y = n, fill = bust)) + 
  scale_fill_gradient('胸围', low = '#66c2a5', high = '#fc8d62',
                      breaks = c(0, 20, 40, 60, 80),
                      labels = suffix(c(0, 20, 40, 60, 80), suffix = 'cm')) + 
  labs(x = '年龄', y = '比例',
       title = '宅男女神网上各个年龄的模特的比例',
       subtitle = '一共8320个模特',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com') + 
  scale_y_percent() + 
  scale_x_continuous(
    breaks = c(20, 30, 40, 50),
    labels = suffix(c(20, 30, 40, 50), suffix = '岁'))

knitr::kable(subset(df, df$bust > 50) %>% 
               arrange(desc(bust)) %>% 
               select(name, age, bust, vital, link) %>% 
               slice(1:10))

knitr::kable(subset(df, df$bust > 50) %>% 
               arrange(bust) %>% 
               select(name, age, bust, vital, link) %>% 
               slice(1:10))

subset(df, df$bust > 50) %>% 
  group_by(bust) %>% 
  summarise(
    n = length(bust),
    age = sum(age, na.rm = T)/length(age)
  ) %>% 
ggplot() + 
  geom_col(aes(x = bust, y = n, fill = age)) + 
  labs(x = '胸围', y = '数量', 
       title = '宅男女神网模特胸围分布',
       subtitle = '一共8320个模特',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com') + 
  scale_x_continuous(
    breaks = c(60, 80, 100, 120),
    labels = suffix(c(60, 80, 100, 120), "cm")
  ) + 
  scale_fill_gradient('年龄', low = '#66c2a5', high = '#fc8d62')

subset(df, df$bust > 50) %>% 
  mutate(birthcountry = case_when(
    grepl("zg", birthcountry) ~ "中国",
    grepl("中国", birthcountry) ~ "中国",
    grepl("日本", birthcountry) ~ "日本",
    grepl("韩国", birthcountry) ~ "韩国",
    grepl("美国", birthcountry) ~ "美国",
    is.na(birthcountry) ~ "其它",
    T ~ "其它"
  )) %>% 
  group_by(bust, birthcountry) %>% 
  summarise(
    n = length(bust)
  ) %>% 
  ggplot() + 
  geom_col(aes(x = bust, y = n, fill = birthcountry)) + 
  labs(x = '胸围', y = '数量', 
       title = '宅男女神网模特胸围与国家分布',
       subtitle = '一共8320个模特',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com') + 
  scale_x_continuous(
    breaks = c(60, 80, 100, 120),
    labels = suffix(c(60, 80, 100, 120), "cm")
  ) + 
  scale_fill_brewer(
    "国家", 
    palette = 'Set1',
    breaks = c("中国", "日本", "韩国", "美国", "其它"))

country <- df %>% 
  group_by(birthcountry) %>% 
  summarise(n = length(birthcountry)) %>% 
  arrange(desc(n)) %>% 
  subset(!is.na(birthcountry))

knitr::kable(country %>% slice(1:10))

subset(df, df$bust > 50) %>% 
  mutate(birthcountry = case_when(
    grepl("zg", birthcountry) ~ "中国",
    grepl("中国", birthcountry) ~ "中国",
    grepl("日本", birthcountry) ~ "日本",
    grepl("韩国", birthcountry) ~ "韩国",
    grepl("美国", birthcountry) ~ "美国",
    grepl("越南", birthcountry) ~ "越南",
    grepl("马来西亚", birthcountry) ~ "马来西亚",
    grepl("泰国", birthcountry) ~ "泰国",
    grepl("澳大利亚", birthcountry) ~ "澳大利亚",
    grepl("加拿大", birthcountry) ~ "加拿大",
    grepl("俄罗斯", birthcountry) ~ "俄罗斯",
    is.na(birthcountry) ~ "其它",
    T ~ "其它"
  )) %>% 
  group_by(birthcountry) %>% 
  summarise(
    n = mean(bust, na.rm = T)
  ) %>% 
  ggplot() + 
  geom_col(aes(x = factor(birthcountry, levels = c(country$birthcountry[1:10], "其它")), y = n, fill = factor(birthcountry, levels = c(country$birthcountry[1:10], "其它")))) + 
  geom_text(aes(x = factor(birthcountry, levels = c(country$birthcountry[1:11], "其它")), y = n + 5, label = paste0(round(n), "cm"))) + 
  labs(x = '国家', y = '平均胸围', 
       title = '宅男女神网各个国家模特的平均胸围',
       subtitle = '一共8320个模特',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com') + 
  scale_fill_brewer(palette = 'Set3') + 
  guides(fill = 'none')

library(tidytext)
job <- df %>% 
  unnest_tokens(job, job, token = stringr::str_split, pattern = "、") %>% 
  group_by(job) %>% 
  summarise(n = length(job)) %>% 
  arrange(desc(n))

job %>% 
  slice(1:10)%>% 
  ggplot(aes(x = factor(job), y = n, fill = factor(job))) + 
  geom_col() + 
  scale_fill_brewer(palette = 'Set3') + 
  guides(fill = "none") + 
  labs(x = '职业', y = '数量',
       title = '模特们从事的前十大职业',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com')

library(rWordCloud)
d3Cloud(text = job$job, size = job$n)

df %>% 
  group_by(constellation, age) %>%
  summarise(
    n = length(constellation)
  ) %>% 
  ggplot(aes(x = factor(constellation), y = n, fill = age)) + 
  geom_col() + 
  scale_fill_gradient('年龄', low = '#66c2a5', high = '#fc8d62') + 
  theme(legend.position = 'top') + 
  labs(x = '星座', y = '数量', title = '模特们的星座分布',
       subtitle = '一共8320个模特',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com')

df %>% 
  group_by(zodiac, age) %>%
  summarise(
    n = length(zodiac)
  ) %>% 
  ggplot(aes(x = factor(zodiac), y = n, fill = age)) + 
  geom_col() + 
  scale_fill_gradient('年龄', low = '#66c2a5', high = '#fc8d62') + 
  labs(x = '属相', y = '数量', title = '模特们的属相分布',
       subtitle = '一共8320个模特',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com')

df %>% 
  group_by(score, age) %>%
  summarise(
    n = length(score)
  ) %>% 
  ggplot(aes(x = score, y = n, fill = age)) + 
  geom_col() + 
  scale_fill_gradient('年龄', low = '#66c2a5', high = '#fc8d62') + 
  labs(x = '属相', y = '分数', title = '模特们的得分分布',
       subtitle = '一共8320个模特',
       caption = '数据来源：宅男女神网\nhttps://www.nvshens.com')