Greying of the Nobel laureates
R for Pleasure
Nguyen Chi Dung
(Nguyen Le Xuan Bach edited)
Introduction
In this post I will present R Codes for recreation of the following plot from The Economist:
https://www.economist.com/graphic-detail/2016/10/03/greying-of-the-nobel-laureates
My R Codes
#========================================================
# References:
# https://ggplot2.tidyverse.org/reference/theme.html
# http://rpubs.com/chidungkt/392841
#========================================================
# Load some packages and load data:
rm(list = ls())
library(tidyverse)
library(magrittr)
library(lubridate)
path <- "http://api.nobelprize.org/v1/laureate.csv"
laureate <- read_csv(path)
# Clear data:
mydf2 <- laureate %>%
filter(gender != "org", !is.na(category)) %>%
mutate(age = year - year(born),
category = case_when(category == "chemistry" ~ "Chemistry",
category == "economics" ~ "Economics",
category == "literature" ~ "Literature",
category == "medicine" ~ "Medicine",
category == "peace" ~ "Peace",
TRUE ~ "Physics"))
my_col <- c("#04536e", "#7c2817", "#f15c42", "#3d6a51", "#eca324", "#12a4dc")
# Make a draft:
library(extrafont)
p <- mydf2 %>%
filter(!is.na(category)) %>%
ggplot(aes(year, age, colour = category)) +
geom_point(show.legend = FALSE, size = 2, alpha = 0.4) +
geom_smooth(method = "loess", show.legend = FALSE, se = FALSE, size = 1.8) +
scale_color_manual(values = my_col) +
facet_wrap(~ category, nrow = 1) +
scale_x_continuous(breaks = seq(1900, 2010, 25), labels = c("1900", " ", "50", " ", "2000")) +
theme(panel.grid.minor = element_blank()) +
theme(panel.grid.major.x = element_blank()) +
theme(panel.grid.major.y = element_line(size = 0.8)) +
theme(strip.text.x = element_text(colour = "black", face = "bold", size = 15, family = "OfficinaSansITC")) +
theme(plot.margin = unit(c(0.7, 0.7, 0.7, 1), "cm")) +
scale_y_continuous(sec.axis = sec_axis(~. *1), breaks = seq(0, 100, 25), limits = c(15, 100)) +
theme(axis.text.y.left = element_blank()) +
theme(axis.ticks.y = element_blank()) +
theme(axis.ticks.length = unit(0.15, "cm")) +
theme(axis.ticks = element_line(size = 1)) +
theme(plot.title = element_text(face = "bold", size = 20, family = "OfficinaSansITC", margin = margin(b = 10), hjust = 0, color = "grey10")) +
theme(plot.subtitle = element_text(size = 16, margin = margin(b = 20), hjust = 0, family = "OfficinaSansITC", color = "grey30")) +
theme(plot.caption = element_text(size = 13, color = "grey40", family = "OfficinaSansITC")) +
theme(axis.text.x = element_text(size = 13, color = "grey20", family = "OfficinaSansITC", face = "bold")) +
theme(axis.text.y = element_text(size = 13, color = "grey20", family = "OfficinaSansITC", face = "bold")) +
labs(x = NULL, y = NULL,
title = "Senescience",
subtitle = "Age of Nobel laureates, at the date of award",
caption = "Data Source: Nobelprize.org")
p
Change background color
library(grid)
g <- ggplot_gtable(ggplot_build(p))
strip_t <- which(grepl('strip-t', g$layout$name))
k <- 1
for (i in strip_t) {
g$grobs[[i]]$grobs[[1]]$children[[2]]$children[[1]]$gp$col <- "white"
g$grobs[[i]]$grobs[[1]]$children[[1]]$gp$fill <- my_col[k]
k <- k+1
}
grid.draw(g)
LS0tDQp0aXRsZTogIkdyZXlpbmcgb2YgdGhlIE5vYmVsIGxhdXJlYXRlcyIgDQpzdWJ0aXRsZTogIlIgZm9yIFBsZWFzdXJlIg0KYXV0aG9yOiANCi0gIk5ndXllbiBDaGkgRHVuZyINCi0gIihOZ3V5ZW4gTGUgWHVhbiBCYWNoIGVkaXRlZCkiDQpvdXRwdXQ6DQogIGh0bWxfZG9jdW1lbnQ6IA0KICAgIGNvZGVfZG93bmxvYWQ6IHRydWUNCiAgICBjb2RlX2ZvbGRpbmc6IGhpZGUNCiAgICBoaWdobGlnaHQ6IHB5Z21lbnRzDQogICAgIyBudW1iZXJfc2VjdGlvbnM6IHllcw0KICAgIHRoZW1lOiAiZmxhdGx5Ig0KICAgIHRvYzogVFJVRQ0KICAgIHRvY19mbG9hdDogVFJVRQ0KLS0tDQoNCmBgYHtyIHNldHVwLGluY2x1ZGU9RkFMU0V9DQprbml0cjo6b3B0c19jaHVuayRzZXQoZWNobyA9IFRSVUUsIHdhcm5pbmcgPSBGQUxTRSwgbWVzc2FnZSA9IEZBTFNFKQ0KYGBgDQoNCiMgSW50cm9kdWN0aW9uDQoNCkluIHRoaXMgcG9zdCBJIHdpbGwgcHJlc2VudCBSIENvZGVzIGZvciByZWNyZWF0aW9uIG9mIHRoZSBmb2xsb3dpbmcgcGxvdCBmcm9tIFRoZSBFY29ub21pc3Q6IA0KDQpodHRwczovL3d3dy5lY29ub21pc3QuY29tL2dyYXBoaWMtZGV0YWlsLzIwMTYvMTAvMDMvZ3JleWluZy1vZi10aGUtbm9iZWwtbGF1cmVhdGVzDQoNCiMgTXkgUiBDb2Rlcw0KDQpgYGB7ciwgZmlnLmZ1bGx3aWR0aCA9IFRSVUUsIGZpZy5oZWlnaHQ9NywgZmlnLndpZHRoPTEyfQ0KDQojPT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT0NCiMgICAgICAgICBSZWZlcmVuY2VzOiANCiMgICBodHRwczovL2dncGxvdDIudGlkeXZlcnNlLm9yZy9yZWZlcmVuY2UvdGhlbWUuaHRtbA0KIyAgIGh0dHA6Ly9ycHVicy5jb20vY2hpZHVuZ2t0LzM5Mjg0MSAgICAgICAgDQojPT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT09PT0NCg0KIyBMb2FkIHNvbWUgcGFja2FnZXMgYW5kIGxvYWQgZGF0YTogDQpybShsaXN0ID0gbHMoKSkNCmxpYnJhcnkodGlkeXZlcnNlKQ0KbGlicmFyeShtYWdyaXR0cikNCmxpYnJhcnkobHVicmlkYXRlKQ0KDQpwYXRoIDwtICJodHRwOi8vYXBpLm5vYmVscHJpemUub3JnL3YxL2xhdXJlYXRlLmNzdiINCmxhdXJlYXRlIDwtIHJlYWRfY3N2KHBhdGgpDQoNCg0KIyBDbGVhciBkYXRhOiANCm15ZGYyIDwtIGxhdXJlYXRlICU+JSANCiAgZmlsdGVyKGdlbmRlciAhPSAib3JnIiwgIWlzLm5hKGNhdGVnb3J5KSkgJT4lIA0KICBtdXRhdGUoYWdlID0geWVhciAtIHllYXIoYm9ybiksIA0KICAgICAgICAgY2F0ZWdvcnkgPSBjYXNlX3doZW4oY2F0ZWdvcnkgPT0gImNoZW1pc3RyeSIgfiAiQ2hlbWlzdHJ5IiwgDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBjYXRlZ29yeSA9PSAiZWNvbm9taWNzIiB+ICJFY29ub21pY3MiLCANCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIGNhdGVnb3J5ID09ICJsaXRlcmF0dXJlIiB+ICJMaXRlcmF0dXJlIiwgDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBjYXRlZ29yeSA9PSAibWVkaWNpbmUiIH4gIk1lZGljaW5lIiwgDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBjYXRlZ29yeSA9PSAicGVhY2UiIH4gIlBlYWNlIiwgDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICBUUlVFIH4gIlBoeXNpY3MiKSkNCg0KDQpteV9jb2wgPC0gIGMoIiMwNDUzNmUiLCAiIzdjMjgxNyIsICIjZjE1YzQyIiwgIiMzZDZhNTEiLCAiI2VjYTMyNCIsICIjMTJhNGRjIikNCg0KDQojIE1ha2UgYSBkcmFmdDogDQoNCmxpYnJhcnkoZXh0cmFmb250KQ0KDQpwIDwtIG15ZGYyICU+JSANCiAgZmlsdGVyKCFpcy5uYShjYXRlZ29yeSkpICU+JSANCiAgZ2dwbG90KGFlcyh5ZWFyLCBhZ2UsIGNvbG91ciA9IGNhdGVnb3J5KSkgKyANCiAgZ2VvbV9wb2ludChzaG93LmxlZ2VuZCA9IEZBTFNFLCBzaXplID0gMiwgYWxwaGEgPSAwLjQpICsgDQogIGdlb21fc21vb3RoKG1ldGhvZCA9ICJsb2VzcyIsIHNob3cubGVnZW5kID0gRkFMU0UsIHNlID0gRkFMU0UsIHNpemUgPSAxLjgpICsgDQogIHNjYWxlX2NvbG9yX21hbnVhbCh2YWx1ZXMgPSBteV9jb2wpICsgDQogIGZhY2V0X3dyYXAofiBjYXRlZ29yeSwgbnJvdyA9IDEpICsgDQogIHNjYWxlX3hfY29udGludW91cyhicmVha3MgPSBzZXEoMTkwMCwgMjAxMCwgMjUpLCBsYWJlbHMgPSBjKCIxOTAwIiwgIiAiLCAiNTAiLCAiICIsICIyMDAwIikpICsgDQogIHRoZW1lKHBhbmVsLmdyaWQubWlub3IgPSBlbGVtZW50X2JsYW5rKCkpICsgDQogIHRoZW1lKHBhbmVsLmdyaWQubWFqb3IueCA9IGVsZW1lbnRfYmxhbmsoKSkgKyANCiAgdGhlbWUocGFuZWwuZ3JpZC5tYWpvci55ID0gZWxlbWVudF9saW5lKHNpemUgPSAwLjgpKSArIA0KICB0aGVtZShzdHJpcC50ZXh0LnggPSBlbGVtZW50X3RleHQoY29sb3VyID0gImJsYWNrIiwgZmFjZSA9ICJib2xkIiwgc2l6ZSA9IDE1LCBmYW1pbHkgPSAiT2ZmaWNpbmFTYW5zSVRDIikpICsgDQogIHRoZW1lKHBsb3QubWFyZ2luID0gdW5pdChjKDAuNywgMC43LCAwLjcsIDEpLCAiY20iKSkgKyANCiAgc2NhbGVfeV9jb250aW51b3VzKHNlYy5heGlzID0gc2VjX2F4aXMofi4gKjEpLCBicmVha3MgPSBzZXEoMCwgMTAwLCAyNSksIGxpbWl0cyA9IGMoMTUsIDEwMCkpICsgDQogIHRoZW1lKGF4aXMudGV4dC55LmxlZnQgPSBlbGVtZW50X2JsYW5rKCkpICsgDQogIHRoZW1lKGF4aXMudGlja3MueSA9IGVsZW1lbnRfYmxhbmsoKSkgKyANCiAgDQogIHRoZW1lKGF4aXMudGlja3MubGVuZ3RoID0gdW5pdCgwLjE1LCAiY20iKSkgKyANCiAgdGhlbWUoYXhpcy50aWNrcyA9IGVsZW1lbnRfbGluZShzaXplID0gMSkpICsgDQoNCiAgdGhlbWUocGxvdC50aXRsZSA9IGVsZW1lbnRfdGV4dChmYWNlID0gImJvbGQiLCBzaXplID0gMjAsIGZhbWlseSA9ICJPZmZpY2luYVNhbnNJVEMiLCBtYXJnaW4gPSBtYXJnaW4oYiA9IDEwKSwgaGp1c3QgPSAwLCBjb2xvciA9ICJncmV5MTAiKSkgKyANCiAgdGhlbWUocGxvdC5zdWJ0aXRsZSA9IGVsZW1lbnRfdGV4dChzaXplID0gMTYsIG1hcmdpbiA9IG1hcmdpbihiID0gMjApLCBoanVzdCA9IDAsIGZhbWlseSA9ICJPZmZpY2luYVNhbnNJVEMiLCBjb2xvciA9ICJncmV5MzAiKSkgKyANCiAgdGhlbWUocGxvdC5jYXB0aW9uID0gZWxlbWVudF90ZXh0KHNpemUgPSAxMywgY29sb3IgPSAiZ3JleTQwIiwgZmFtaWx5ID0gIk9mZmljaW5hU2Fuc0lUQyIpKSArIA0KICANCiAgdGhlbWUoYXhpcy50ZXh0LnggPSBlbGVtZW50X3RleHQoc2l6ZSA9IDEzLCBjb2xvciA9ICJncmV5MjAiLCBmYW1pbHkgPSAiT2ZmaWNpbmFTYW5zSVRDIiwgZmFjZSA9ICJib2xkIikpICsgDQogIHRoZW1lKGF4aXMudGV4dC55ID0gZWxlbWVudF90ZXh0KHNpemUgPSAxMywgY29sb3IgPSAiZ3JleTIwIiwgZmFtaWx5ID0gIk9mZmljaW5hU2Fuc0lUQyIsIGZhY2UgPSAiYm9sZCIpKSArIA0KDQogIGxhYnMoeCA9IE5VTEwsIHkgPSBOVUxMLCANCiAgICAgICB0aXRsZSA9ICJTZW5lc2NpZW5jZSIsIA0KICAgICAgIHN1YnRpdGxlID0gIkFnZSBvZiBOb2JlbCBsYXVyZWF0ZXMsIGF0IHRoZSBkYXRlIG9mIGF3YXJkIiwgDQogICAgICAgY2FwdGlvbiA9ICJEYXRhIFNvdXJjZTogTm9iZWxwcml6ZS5vcmciKQ0KDQpwDQoNCmBgYA0KDQojIyBDaGFuZ2UgYmFja2dyb3VuZCBjb2xvcg0KDQpgYGB7ciwgZmlnLmZ1bGx3aWR0aD1UUlVFLCBmaWcuaGVpZ2h0PTcsIGZpZy53aWR0aD0xMn0NCmxpYnJhcnkoZ3JpZCkNCg0KZyA8LSBnZ3Bsb3RfZ3RhYmxlKGdncGxvdF9idWlsZChwKSkNCnN0cmlwX3QgPC0gd2hpY2goZ3JlcGwoJ3N0cmlwLXQnLCBnJGxheW91dCRuYW1lKSkNCmsgPC0gMQ0KZm9yIChpIGluIHN0cmlwX3QpIHsNCiAgZyRncm9ic1tbaV1dJGdyb2JzW1sxXV0kY2hpbGRyZW5bWzJdXSRjaGlsZHJlbltbMV1dJGdwJGNvbCA8LSAid2hpdGUiDQogIGckZ3JvYnNbW2ldXSRncm9ic1tbMV1dJGNoaWxkcmVuW1sxXV0kZ3AkZmlsbCA8LSBteV9jb2xba10NCiAgayA8LSBrKzENCn0NCmdyaWQuZHJhdyhnKQ0KYGBgDQoNCiMjIENoYW5nZSB0ZXh0IGNvbG9yDQoNCmBgYHtyLCBmaWcuZnVsbHdpZHRoPVRSVUUsIGZpZy5oZWlnaHQ9NywgZmlnLndpZHRoPTEyfQ0KZyA8LSBnZ3Bsb3RfZ3RhYmxlKGdncGxvdF9idWlsZChwKSkNCnN0cmlwX3QgPC0gd2hpY2goZ3JlcGwoJ3N0cmlwLXQnLCBnJGxheW91dCRuYW1lKSkNCmsgPC0gMQ0KZm9yIChpIGluIHN0cmlwX3QpIHsNCiAgZyRncm9ic1tbaV1dJGdyb2JzW1sxXV0kY2hpbGRyZW5bWzJdXSRjaGlsZHJlbltbMV1dJGdwJGNvbCA8LSBteV9jb2xba10NCiAgayA8LSBrKzENCn0NCmdyaWQuZHJhdyhnKQ0KYGBg