Code
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 errors
Code
library(lubridate)
library(dplyr)
library(skimr)
Warning: package 'skimr' was built under R version 4.3.3
Code
df <- read.csv("D:/R_analysis/text/nobel_winners.csv")
df <- df %>%
  set_names(c('获奖年份','学科','奖项名称','获奖原因','获奖份额',
              '获奖人id','获奖类别','姓名','生日','城市','国家','性别',
              '组织名称','组织城市','组织国家','死亡日期','死亡城市','死亡国家'))
# 新增一列获奖年龄
df <- df  %>%  mutate( 获奖年龄=(获奖年份-year(生日)) )
Code
head(df,5)
  获奖年份       学科                                       奖项名称
1     1901  Chemistry              The Nobel Prize in Chemistry 1901
2     1901 Literature             The Nobel Prize in Literature 1901
3     1901   Medicine The Nobel Prize in Physiology or Medicine 1901
4     1901      Peace                     The Nobel Peace Prize 1901
5     1901      Peace                     The Nobel Peace Prize 1901
                                                                                                                                                                                                                                            获奖原因
1                                                                                                 "in recognition of the extraordinary services he has rendered by the discovery of the laws of chemical dynamics and osmotic pressure in solutions"
2                                                                "in special recognition of his poetic composition, which gives evidence of lofty idealism, artistic perfection and a rare combination of the qualities of both heart and intellect"
3 "for his work on serum therapy, especially its application against diphtheria, by which he has opened a new road in the domain of medical science and thereby placed in the hands of the physician a victorious weapon against illness and deaths"
4                                                                                                                                                                                                                                               <NA>
5                                                                                                                                                                                                                                               <NA>
  获奖份额 获奖人id   获奖类别                         姓名       生日
1      1/1      160 Individual Jacobus Henricus van 't Hoff 1852-08-30
2      1/1      569 Individual              Sully Prudhomme 1839-03-16
3      1/1      293 Individual       Emil Adolf von Behring 1854-03-15
4      1/2      462 Individual            Jean Henry Dunant 1828-05-08
5      1/2      463 Individual               Frédéric Passy 1822-05-20
               城市             国家 性别           组织名称 组织城市 组织国家
1         Rotterdam      Netherlands Male  Berlin University   Berlin  Germany
2             Paris           France Male               <NA>     <NA>     <NA>
3 Hansdorf (Lawice) Prussia (Poland) Male Marburg University  Marburg  Germany
4            Geneva      Switzerland Male               <NA>     <NA>     <NA>
5             Paris           France Male               <NA>     <NA>     <NA>
    死亡日期 死亡城市    死亡国家 获奖年龄
1 1911-03-01   Berlin     Germany       49
2 1907-09-07 Châtenay      France       62
3 1917-03-31  Marburg     Germany       47
4 1910-10-30   Heiden Switzerland       73
5 1912-06-12    Paris      France       79

数据清洗

重复数据

  • 有没有重复数据

    Code
    duplicate_rows <- df %>%
      group_by(获奖年份,学科,奖项名称,获奖原因,获奖份额,获奖人id,获奖类别,姓名, 生日,性别,国家,死亡日期,死亡城市,死亡国家,获奖年龄) %>%
      filter(n() > 1) %>%
      ungroup() %>%
      arrange(获奖年份,学科,奖项名称,获奖原因,获奖份额,获奖人id,获奖类别,姓名, 生日,性别,国家,死亡日期,死亡城市,死亡国家,获奖年龄)
    
    head(duplicate_rows,5)
    # A tibble: 5 × 19
      获奖年份 学科   奖项名称 获奖原因 获奖份额 获奖人id 获奖类别 姓名  生日  城市 
         <int> <chr>  <chr>    <chr>    <chr>       <int> <chr>    <chr> <chr> <chr>
    1     1908 Medic… The Nob… "\"in r… 1/2           302 Individ… Paul… 1854… Stre…
    2     1908 Medic… The Nob… "\"in r… 1/2           302 Individ… Paul… 1854… Stre…
    3     1931 Chemi… The Nob… "\"in r… 1/2           189 Individ… Carl… 1874… Colo…
    4     1931 Chemi… The Nob… "\"in r… 1/2           189 Individ… Carl… 1874… Colo…
    5     1931 Chemi… The Nob… "\"in r… 1/2           190 Individ… Frie… 1884… Gold…
    # ℹ 9 more variables: 国家 <chr>, 性别 <chr>, 组织名称 <chr>, 组织城市 <chr>,
    #   组织国家 <chr>, 死亡日期 <chr>, 死亡城市 <chr>, 死亡国家 <chr>,
    #   获奖年龄 <dbl>
  • 有重复数据。因为一个人属于多个组织会产生重复记录

去重,生成df_unique

Code
df_unique <- df %>%
  distinct(获奖年份,学科,奖项名称,获奖原因,获奖份额,获奖人id,获奖类别,姓名, 生日,性别,国家,死亡日期,死亡城市,死亡国家,获奖年龄)

缺失值

  • 发现是获奖类别有区分组织和个人。性别缺失的都是组织
Code
# 每一列缺失值数量
df_unique %>% map_df(~ sum(is.na(.)))
# A tibble: 1 × 15
  获奖年份  学科 奖项名称 获奖原因 获奖份额 获奖人id 获奖类别  姓名  生日  性别
     <int> <int>    <int>    <int>    <int>    <int>    <int> <int> <int> <int>
1        0     0        0       88        0        0        0     0    30    26
# ℹ 5 more variables: 国家 <int>, 死亡日期 <int>, 死亡城市 <int>,
#   死亡国家 <int>, 获奖年龄 <int>
Code
# 找出性别的缺失值
df_na_gender <- df_unique %>%
  filter(is.na(性别))

数据描述性统计

Code
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 ▁▃▇▇▂

数据探索

每个学科获奖过多少次

  • 医学奖和物理学奖最多
Code
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")  # 居中并加粗标题
  )

这些人是什么年代出生的

  • 1910年~1940年出生最多
Code
df_unique%>%distinct(获奖类别)
      获奖类别
1   Individual
2 Organization
Code
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
  出生世纪 人数
1   20世纪  588
2   19世纪  285
3     未知    4
Code
#出生年代_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")  # 居中并加粗标题
)

获奖年代分布

  • 1970~2000是获奖最多的时期
Code
 # 新增一列 获奖年代
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")  # 居中并加粗标题
  )

Code
  # 各学科获奖年代分布
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.

性别比例情况

  • 总体男性占比94.7% ,女性占比5.3%

  • 所有学科中,女性占比最高的是诺贝尔和平奖14%,男性占比最高的是物理,占比99%

Code
  # 各个学科的性别比例
gendr_per <- df_unique_individual %>%count(性别, name = "人数")  %>%
  pivot_wider(
    names_from = 性别,
    values_from = 人数,
    values_fill = list(人数 = 0)
  ) %>% 
  rename(女生人数 = Female, 男生人数 = Male) %>%
  mutate(
    总人数= 女生人数 + 男生人数,
    女生人数占比 = 女生人数 / 总人数,
    男生人数占比 = 男生人数 / 总人数
  )
gendr_per
# A tibble: 1 × 5
  女生人数 男生人数 总人数 女生人数占比 男生人数占比
     <int>    <int>  <int>        <dbl>        <dbl>
1       47      834    881       0.0533        0.947
Code
category_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_per
# A tibble: 6 × 6
  学科       女生人数 男生人数 总人数 女生人数占比 男生人数占比
  <chr>         <int>    <int>  <int>        <dbl>        <dbl>
1 Physics           2      202    204      0.00980        0.990
2 Economics         1       77     78      0.0128         0.987
3 Chemistry         4      171    175      0.0229         0.977
4 Medicine         12      199    211      0.0569         0.943
5 Literature       14       99    113      0.124          0.876
6 Peace            14       86    100      0.14           0.86 

获奖平均年龄和获奖数量

Code
#平均年龄和获奖数量                                 用不同的公式聚合计算
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")  # 使用颜色调色板

最年轻的获奖者

  • 明细如图

  • 最年轻的获奖者是Malala Yousafzai,在17岁获得了诺贝尔和平奖

Code
youngest_awardees <- df_unique_individual %>%
  filter(!is.na(获奖年龄)) %>%  # 忽略获奖年龄为 NA 的行
  group_by(学科) %>%
  arrange(学科, 获奖年龄) %>%    # 按学科和获奖年龄排序
  slice(1) %>%                    # 取每组的第一条记录
  ungroup() %>%  
  arrange(获奖年龄)

youngest_awardees <- youngest_awardees[, c("姓名", "学科","获奖年龄")]
youngest_awardees
# A tibble: 6 × 3
  姓名                    学科       获奖年龄
  <chr>                   <chr>         <dbl>
1 Malala Yousafzai        Peace            17
2 William Lawrence Bragg  Physics          25
3 Frederick Grant Banting Medicine         32
4 Frédéric Joliot         Chemistry        35
5 Rudyard Kipling         Literature       42
6 Kenneth J. Arrow        Economics        51

中国的获奖者

  • 9个人获得了诺贝尔奖
Code
couttyr_unique <- df_unique_individual %>% distinct(国家) 
df_china <- df %>% filter(df$国家=='China') 
df_china <- df_china[,c("姓名","获奖年份","学科","奖项名称","获奖类别","国家","城市","性别","组织国家","组织城市","组织名称")] 
df_china
                     姓名 获奖年份       学科
1  Walter Houser Brattain     1956    Physics
2          Chen Ning Yang     1957    Physics
3    Tsung-Dao (T.D.) Lee     1957    Physics
4       Edmond H. Fischer     1992   Medicine
5          Daniel C. Tsui     1998    Physics
6            Gao Xingjian     2000 Literature
7        Charles Kuen Kao     2009    Physics
8        Charles Kuen Kao     2009    Physics
9         Ei-ichi Negishi     2010  Chemistry
10             Liu Xiaobo     2010      Peace
11                 Mo Yan     2012 Literature
12              Youyou Tu     2015   Medicine
                                         奖项名称   获奖类别  国家
1                 The Nobel Prize in Physics 1956 Individual China
2                 The Nobel Prize in Physics 1957 Individual China
3                 The Nobel Prize in Physics 1957 Individual China
4  The Nobel Prize in Physiology or Medicine 1992 Individual China
5                 The Nobel Prize in Physics 1998 Individual China
6              The Nobel Prize in Literature 2000 Individual China
7                 The Nobel Prize in Physics 2009 Individual China
8                 The Nobel Prize in Physics 2009 Individual China
9               The Nobel Prize in Chemistry 2010 Individual China
10                     The Nobel Peace Prize 2010 Individual China
11             The Nobel Prize in Literature 2012 Individual China
12 The Nobel Prize in Physiology or Medicine 2015 Individual China
              城市   性别                 组织国家           组织城市
1             Amoy   Male United States of America    Murray Hill, NJ
2    Hofei, Anhwei   Male United States of America      Princeton, NJ
3         Shanghai   Male United States of America       New York, NY
4         Shanghai   Male United States of America        Seattle, WA
5            Henan   Male United States of America      Princeton, NJ
6          Ganzhou   Male                     <NA>               <NA>
7         Shanghai   Male           United Kingdom             Harlow
8         Shanghai   Male                    China          Hong Kong
9        Changchun   Male United States of America West Lafayette, IN
10            <NA>   Male                     <NA>               <NA>
11           Gaomi   Male                     <NA>               <NA>
12 Zhejiang Ningbo Female                    China            Beijing
                                        组织名称
1                    Bell Telephone Laboratories
2                   Institute for Advanced Study
3                            Columbia University
4                       University of Washington
5                           Princeton University
6                                           <NA>
7        Standard Telecommunication Laboratories
8                Chinese University of Hong Kong
9                              Purdue University
10                                          <NA>
11                                          <NA>
12 China Academy of Traditional Chinese Medicine

得奖的时候多大年龄?男性女性是否存在不同

  • 男性平均获奖年龄59岁,男性58岁,没有显著区别
Code
  # 各个学科获奖平均年龄
age_award_gender <- df_unique_individual %>% group_by(性别)  %>% 
  summarise(平均年龄=mean(获奖年龄,na.rm=T),获奖次数=n())

age_award_gender
# A tibble: 2 × 3
  性别   平均年龄 获奖次数
  <chr>     <dbl>    <int>
1 Female     58.0       47
2 Male       59.5      834
Code
age_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_subject
# A tibble: 6 × 6
  学科       平均年龄_Female 平均年龄_Male 获奖次数_Female 获奖次数_Male 年龄差
  <chr>                <dbl>         <dbl>           <int>         <int>  <dbl>
1 Peace                 51.3          63.2              14            86  11.9 
2 Physics               46.5          55.5               2           202   8.96
3 Chemistry             51.5          58.2               4           171   6.69
4 Literature            63.1          64.9              14            99   1.83
5 Medicine              62.6          57.7              12           199  -4.89
6 Economics             76            67.1               1            77  -8.92

多次获奖及多学科获奖情况

  • 4个人获奖2次

  • 2个人多学科获奖

Code
  # 多次获奖人数  获奖次数>=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_summary
# A tibble: 4 × 4
  姓名                        获奖人id 获奖次数 获奖学科数
  <chr>                          <int>    <int>      <int>
1 Frederick Sanger                 222        2          1
2 John Bardeen                      66        2          1
3 Linus Carl Pauling               217        2          2
4 Marie Curie, née Sklodowska        6        2          2

出生地和死亡地分布

  • 美国,英国,德国分别排名为1,2,3
Code
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)
                   死亡国家 获奖人数
1                      <NA>      301
2  United States of America      201
3            United Kingdom       72
4                   Germany       55
5                    France       50
6                    Sweden       28
7               Switzerland       26
8                     Italy       14
9                    Russia       11
10                    Spain       10
Code
# 出生地分布
  df_clean %>%
  count(国家, name = '获奖人数', sort = TRUE) %>%
  rename(出生国家 = 国家) %>%
  slice_max(order_by = 获奖人数, n = 10)
                   出生国家 获奖人数
1  United States of America      257
2            United Kingdom       84
3                   Germany       80
4                    France       54
5                    Sweden       29
6                    Russia       26
7                    Poland       25
8                     Japan       24
9                     Italy       19
10                   Canada       18
11              Netherlands       18