诺贝尔奖分析
Deng Xiancan
suppressWarnings(library(tidyverse))## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.5.1 ✔ tibble 3.2.1
## ✔ lubridate 1.9.4 ✔ tidyr 1.3.1
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorslibrary(lubridate)
library(dplyr)
library(skimr)## Warning: 程辑包'skimr'是用R版本4.3.3 来建造的df <- read.csv("./nobel_winners.csv")
df <- df %>%
set_names(c('获奖年份','学科','奖项名称','获奖原因','获奖份额',
'获奖人id','获奖类别','姓名','生日','城市','国家','性别',
'组织名称','组织城市','组织国家','死亡日期','死亡城市','死亡国家'))
# 新增一列获奖年龄
df <- df %>% mutate( 获奖年龄=(获奖年份-year(生日)) )head(df,5)1 数据清洗
1.1 重复数据
有没有重复数据
duplicate_rows <- df %>% group_by(获奖年份,学科,奖项名称,获奖原因,获奖份额,获奖人id,获奖类别,姓名, 生日,性别,国家,死亡日期,死亡城市,死亡国家,获奖年龄) %>% filter(n() > 1) %>% ungroup() %>% arrange(获奖年份,学科,奖项名称,获奖原因,获奖份额,获奖人id,获奖类别,姓名, 生日,性别,国家,死亡日期,死亡城市,死亡国家,获奖年龄) head(duplicate_rows,5)有重复数据。因为一个人属于多个组织会产生重复记录
去重,生成df_unique
df_unique <- df %>%
distinct(获奖年份,学科,奖项名称,获奖原因,获奖份额,获奖人id,获奖类别,姓名, 生日,性别,国家,死亡日期,死亡城市,死亡国家,获奖年龄)1.2 缺失值
- 发现是获奖类别有区分组织和个人。性别缺失的都是组织
# 每一列缺失值数量
df_unique %>% map_df(~ sum(is.na(.)))# 找出性别的缺失值
df_na_gender <- df_unique %>%
filter(is.na(性别))2 数据描述性统计
skim_results <- skim(df_unique)
print(skim_results)## ── Data Summary ────────────────────────
## Values
## Name df_unique
## Number of rows 911
## Number of columns 15
## _______________________
## Column type frequency:
## character 12
## numeric 3
## ________________________
## Group variables None
##
## ── Variable type: character ────────────────────────────────────────────────────
## skim_variable n_missing complete_rate min max empty n_unique whitespace
## 1 学科 0 1 5 10 0 6 0
## 2 奖项名称 0 1 26 53 0 579 0
## 3 获奖原因 88 0.903 24 343 0 565 0
## 4 获奖份额 0 1 3 3 0 4 0
## 5 获奖类别 0 1 10 12 0 2 0
## 6 姓名 0 1 6 88 0 904 0
## 7 生日 30 0.967 10 10 0 866 0
## 8 性别 26 0.971 4 6 0 2 0
## 9 国家 26 0.971 4 45 0 121 0
## 10 死亡日期 318 0.651 10 10 0 582 0
## 11 死亡城市 335 0.632 4 30 0 291 0
## 12 死亡国家 329 0.639 5 44 0 50 0
##
## ── Variable type: numeric ──────────────────────────────────────────────────────
## skim_variable n_missing complete_rate mean sd p0 p25 p50 p75 p100
## 1 获奖年份 0 1 1969. 32.8 1901 1946 1975 1997 2016
## 2 获奖人id 0 1 463. 270. 1 228. 457 698. 937
## 3 获奖年龄 30 0.967 59.5 12.4 17 50 60 69 90
## hist
## 1 ▃▃▅▇▇
## 2 ▇▇▇▇▇
## 3 ▁▃▇▇▂3 数据探索
3.1 每个学科获奖过多少次
- 医学奖和物理学奖最多
award_cnt <- df_unique %>% count(学科,name='获奖次数')%>%arrange(desc(获奖次数))%>%mutate(学科 = factor(学科, levels = unique(学科)))
# 画图
award_cnt %>% ggplot(aes(x = 学科, y = 获奖次数, fill = 学科)) +
geom_col() +
geom_text(aes(label = 获奖次数), vjust = -0.25) +
labs(title = "诺贝尔奖各学科获奖次数") +
theme(
legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1), # 旋转 x 轴标签
plot.title = element_text(hjust = 0.5, face = "bold") # 居中并加粗标题
)
3.2 这些人是什么年代出生的
- 1910年~1940年出生最多
df_unique%>%distinct(获奖类别)name_unique <- df_unique %>% filter(获奖类别=="Individual") %>% distinct(姓名,获奖人id,生日)
# 新增列 出生世纪
name_unique <- name_unique %>%
mutate(
出生世纪 = case_when(
substr(生日, 1, 2) == "18" ~ "19世纪",
substr(生日, 1, 2) == "19" ~ "20世纪",
substr(生日, 1, 2) == "20" ~ "21世纪",
TRUE ~ "未知"# 处理其他情况，返回NA
)
)
# 新增列 出生年代_10年区间
name_unique <- name_unique %>%
mutate(
出生年代_10年区间 = substr(生日, 1, 3)%>% paste0("0")
)
# 出生世纪统计
name_cnt_sj <- name_unique %>% count(出生世纪,name=("人数"))%>%arrange(desc(人数))
name_cnt_sj#出生年代_10年区间统计
name_cnt_10y <- name_unique %>% count(出生年代_10年区间,name='人数')%>%arrange(desc(人数)) #%>%mutate(学科 = factor(学科, levels = unique(学科)))
# 画图 出生年代
name_cnt_10y %>% ggplot(aes(x = 出生年代_10年区间, y = 人数, fill = 出生年代_10年区间)) +
geom_col() +
geom_text(aes(label = 人数), vjust = -0.25) +
labs(title = "诺贝尔获奖者出生年代") +
theme(
legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1), # 旋转 x 轴标签
plot.title = element_text(hjust = 0.5, face = "bold") # 居中并加粗标题
)
3.3 获奖年代分布
- 1970~2000是获奖最多的时期
# 新增一列 获奖年代
df_unique <- df_unique %>% mutate( 获奖年代 = substr(获奖年份,1,3) %>% paste0('0') )
# 筛选个人获奖
df_unique_individual = df_unique <- df_unique %>% filter(获奖类别=="Individual")
# 获奖年代分布
award_cnt_10y <- df_unique_individual %>%
count(获奖年代,name='获奖次数')
award_cnt_10y %>% ggplot(aes(x = 获奖年代, y = 获奖次数, fill = 获奖年代)) +
geom_col() +
geom_text(aes(label = 获奖次数), vjust = -0.25) +
labs(title = "诺贝尔奖获奖年代分布_总体") +
theme(
legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1), # 旋转 x 轴标签
plot.title = element_text(hjust = 0.5, face = "bold") # 居中并加粗标题
)
# 各学科获奖年代分布
award_cnt_subject_10y <- df_unique_individual %>%
count(获奖年代,学科,name='获奖次数')
ggplot(award_cnt_subject_10y, aes(x = 获奖年代, y = 获奖次数, color = 学科, group = 学科)) +
geom_line(size = 1, alpha = 0.7) + # 添加半透明折线
geom_point(size = 3, alpha = 0.7) + # 添加半透明数据点
geom_text(aes(label = 获奖次数), vjust = -0.25, check_overlap = TRUE) + # 避免标签重叠
scale_color_brewer(palette = "Set1") + # 使用高对比度的颜色调色板
labs(
title = "诺贝尔奖获奖年代分布_分学科",
x = "获奖年代",
y = "获奖次数"
) +
theme(
legend.position = "right", # 将图例放置在右侧
axis.text.x = element_text(angle = 45, hjust = 1), # 旋转 x 轴标签
plot.title = element_text(hjust = 0.5, face = "bold") # 居中并加粗标题
) +
facet_wrap(~ 学科, scales = "free_y",ncol = 1) # 按学科分面绘制，Y轴尺度自由调整## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
3.4 性别比例情况
总体男性占比94.7% ，女性占比5.3%
所有学科中，女性占比最高的是诺贝尔和平奖14%，男性占比最高的是物理，占比99%
# 各个学科的性别比例
gendr_per <- df_unique_individual %>%count(性别, name = "人数") %>%
pivot_wider(
names_from = 性别,
values_from = 人数,
values_fill = list(人数 = 0)
) %>%
rename(女生人数 = Female, 男生人数 = Male) %>%
mutate(
总人数= 女生人数 + 男生人数,
女生人数占比 = 女生人数 / 总人数,
男生人数占比 = 男生人数 / 总人数
)
gendr_percategory_gendr_per <- df_unique_individual %>%
count(学科, 性别, name = "人数") %>%
pivot_wider(
names_from = 性别,
values_from = 人数,
values_fill = list(人数 = 0)
) %>%
rename(女生人数 = Female, 男生人数 = Male) %>%
mutate(
总人数 = 女生人数 + 男生人数,
女生人数占比 = 女生人数 / 总人数,
男生人数占比 = 男生人数 / 总人数
)%>%
arrange(desc(男生人数占比))
category_gendr_per3.5 获奖平均年龄和获奖数量
#平均年龄和获奖数量 用不同的公式聚合计算
age_award_cnt <- df_unique_individual %>% group_by(学科) %>% summarise(
平均年龄 = mean(获奖年龄,na.rm = TRUE),
获奖数量 = n()
)
# 散点图 两个指标为横纵轴，按照颜色分组
ggplot(age_award_cnt, aes(x = 平均年龄, y = 获奖数量, color = 学科)) +
geom_point(size = 3) + # 设置点的大小
labs(title = "各学科的平均年龄与获奖数量",
x = "平均年龄",
y = "获奖数量") +
theme_minimal() + # 使用简洁的主题
scale_color_brewer(palette = "Set1") # 使用颜色调色板
3.6 最年轻的获奖者
明细如图
最年轻的获奖者是Malala Yousafzai，在17岁获得了诺贝尔和平奖
youngest_awardees <- df_unique_individual %>%
filter(!is.na(获奖年龄)) %>% # 忽略获奖年龄为 NA 的行
group_by(学科) %>%
arrange(学科, 获奖年龄) %>% # 按学科和获奖年龄排序
slice(1) %>% # 取每组的第一条记录
ungroup() %>%
arrange(获奖年龄)
youngest_awardees <- youngest_awardees[, c("姓名", "学科","获奖年龄")]
youngest_awardees3.7 中国的获奖者
- 9个人获得了诺贝尔奖
couttyr_unique <- df_unique_individual %>% distinct(国家)
df_china <- df %>% filter(df$国家=='China')
df_china <- df_china[,c("姓名","获奖年份","学科","奖项名称","获奖类别","国家","城市","性别","组织国家","组织城市","组织名称")]
df_china3.8 得奖的时候多大年龄？男性女性是否存在不同
- 男性平均获奖年龄59岁，男性58岁，没有显著区别
# 各个学科获奖平均年龄
age_award_gender <- df_unique_individual %>% group_by(性别) %>%
summarise(平均年龄=mean(获奖年龄,na.rm=T),获奖次数=n())
age_award_genderage_award_gender_subject <- df_unique_individual %>% group_by(学科,性别) %>%
summarise(平均年龄=mean(获奖年龄,na.rm=T),获奖次数=n(),.groups = 'drop' ) %>%
pivot_wider(
names_from = 性别, # 将学科作为列名
values_from = c(平均年龄, 获奖次数), # 将平均年龄和获奖次数作为值
names_sep = "_" # 使用下划线分隔列名
)
age_award_gender_subject <- age_award_gender_subject %>%
mutate(年龄差=(平均年龄_Male-平均年龄_Female))%>%
arrange(desc(年龄差))
age_award_gender_subject3.9 多次获奖及多学科获奖情况
4个人获奖2次
2个人多学科获奖
# 多次获奖人数 获奖次数>=2 4人
# many_award <- df_unique_individual %>% count(姓名,获奖人id,name='获奖次数')%>% arrange(desc(获奖次数))%>%filter(获奖次数>=2)
# many_award
# # 不同学科获奖
# many_award_diff_subject <- df_unique_individual %>% distinct(姓名,获奖人id,学科) %>% count(姓名,获奖人id,name='获奖学科数')%>% arrange(desc(获奖学科数))%>%filter(获奖学科数>=2)
# many_award_diff_subject
award_summary <- df_unique_individual %>%
group_by(姓名, 获奖人id) %>%
summarise(
获奖次数 = n(),
获奖学科数 = n_distinct(学科),
.groups = 'drop'
) %>%
arrange(desc(获奖次数))%>%
filter(获奖次数>=2)
award_summary3.10 出生地和死亡地分布
- 美国，英国，德国分别排名为1,2,3
df_clean <- df_unique_individual %>%
distinct(姓名,国家,死亡国家)%>%
mutate_at(
vars(
国家, 死亡国家),
~ ifelse(str_detect(., "\\("), str_extract(., "(?<=\\().*?(?=\\))"), .)
) %>%
mutate_at(
vars(国家, 死亡国家),
~ case_when(
. == "scotland" ~ "united kingdom",
. == "northern ireland" ~ "united kingdom",
str_detect(., "czech") ~ "czechia",
str_detect(., "germany") ~ "germany",
TRUE ~ .
)
)
# 死亡地分布
df_clean %>%
count(死亡国家, name = '获奖人数', sort = TRUE) %>%
slice_max(order_by = 获奖人数, n = 10)# 出生地分布
df_clean %>%
count(国家, name = '获奖人数', sort = TRUE) %>%
rename(出生国家 = 国家) %>%
slice_max(order_by = 获奖人数, n = 10)