This document is a final project for the subject “Advanced Visualisation in R” offered by the Faculty of Economic Sciences at the University of Warsaw.
In the project we wanted to explore some characteristics of the super-rich by using interesting plots and graphics.
What we wanted to know? * How old are billionaires? * Are there any differences between males and females? * What is a spatial distribution of billionaires? * What are the main industries their wealth come from? * Are there any relationships between the number of billionaires and other variables? * How unequal are super-rich? * How often billionaires are self-made?
The data we used was collected by Forbes (2023). It was later compiled and shared on Kaggle under the link https://www.kaggle.com/datasets/nelgiriyewithana/billionaires-statistics-dataset. It contains information about 2397 individuals whoose approximate net worth is at least 1 billion US$. The selected information include their age, gender, country of origin, being self-made or not and more.
library(janitor) # for very handy cleaning data
library(dplyr) # for pipeline, widening data and other operations
library(tidyr) # for easier handling data and less messy code
library(stringr) # for operations on strings
library(lubridate) # for dealing with time-data
library(ggplot2) # plotting
library(ggthemes) # for nicer themes
library(hrbrthemes) # for other nice themes
library(sf) # for spatial analysis (maps)
library(rnaturalearth) # for ne_countries data
library(ggrepel) # extra geoms (e.g. for labels)
library(viridis) # colourful charts
library(ggridges) # density plots
library(countrycode) # for accessing countrycode in ISO format
library(gglorenz) # for inequality curve
data = read.csv("Billionaires Statistics Dataset.csv")
summary(data)
## rank finalWorth category personName
## Min. : 1 Min. : 1000 Length:2640 Length:2640
## 1st Qu.: 659 1st Qu.: 1500 Class :character Class :character
## Median :1312 Median : 2300 Mode :character Mode :character
## Mean :1289 Mean : 4624
## 3rd Qu.:1905 3rd Qu.: 4200
## Max. :2540 Max. :211000
##
## age country city source
## Min. : 18.00 Length:2640 Length:2640 Length:2640
## 1st Qu.: 56.00 Class :character Class :character Class :character
## Median : 65.00 Mode :character Mode :character Mode :character
## Mean : 65.14
## 3rd Qu.: 75.00
## Max. :101.00
## NA's :65
## industries countryOfCitizenship organization selfMade
## Length:2640 Length:2640 Length:2640 Mode :logical
## Class :character Class :character Class :character FALSE:828
## Mode :character Mode :character Mode :character TRUE :1812
##
##
##
##
## status gender birthDate lastName
## Length:2640 Length:2640 Length:2640 Length:2640
## Class :character Class :character Class :character Class :character
## Mode :character Mode :character Mode :character Mode :character
##
##
##
##
## firstName title date state
## Length:2640 Length:2640 Length:2640 Length:2640
## Class :character Class :character Class :character Class :character
## Mode :character Mode :character Mode :character Mode :character
##
##
##
##
## residenceStateRegion birthYear birthMonth birthDay
## Length:2640 Min. :1921 Min. : 1.00 Min. : 1.0
## Class :character 1st Qu.:1948 1st Qu.: 2.00 1st Qu.: 1.0
## Mode :character Median :1957 Median : 6.00 Median :11.0
## Mean :1957 Mean : 5.74 Mean :12.1
## 3rd Qu.:1966 3rd Qu.: 9.00 3rd Qu.:21.0
## Max. :2004 Max. :12.00 Max. :31.0
## NA's :76 NA's :76 NA's :76
## cpi_country cpi_change_country gdp_country
## Min. : 99.55 Min. :-1.900 Length:2640
## 1st Qu.:117.24 1st Qu.: 1.700 Class :character
## Median :117.24 Median : 2.900 Mode :character
## Mean :127.76 Mean : 4.364
## 3rd Qu.:125.08 3rd Qu.: 7.500
## Max. :288.57 Max. :53.500
## NA's :184 NA's :184
## gross_tertiary_education_enrollment gross_primary_education_enrollment_country
## Min. : 4.00 Min. : 84.7
## 1st Qu.: 50.60 1st Qu.:100.2
## Median : 65.60 Median :101.8
## Mean : 67.23 Mean :102.9
## 3rd Qu.: 88.20 3rd Qu.:102.6
## Max. :136.60 Max. :142.1
## NA's :182 NA's :181
## life_expectancy_country tax_revenue_country_country total_tax_rate_country
## Min. :54.30 Min. : 0.10 Min. : 9.90
## 1st Qu.:77.00 1st Qu.: 9.60 1st Qu.: 36.60
## Median :78.50 Median : 9.60 Median : 41.20
## Mean :78.12 Mean :12.55 Mean : 43.96
## 3rd Qu.:80.90 3rd Qu.:12.80 3rd Qu.: 59.10
## Max. :84.20 Max. :37.20 Max. :106.30
## NA's :182 NA's :183 NA's :182
## population_country latitude_country longitude_country
## Min. :3.802e+04 Min. :-40.90 Min. :-106.35
## 1st Qu.:6.683e+07 1st Qu.: 35.86 1st Qu.: -95.71
## Median :3.282e+08 Median : 37.09 Median : 10.45
## Mean :5.102e+08 Mean : 34.90 Mean : 12.58
## 3rd Qu.:1.366e+09 3rd Qu.: 40.46 3rd Qu.: 104.20
## Max. :1.398e+09 Max. : 61.92 Max. : 174.89
## NA's :164 NA's :164 NA's :164
We want to unify the names of columns. To do so, we use janitor package
data <- clean_names(data)
#Let's see the new names
names(data)
## [1] "rank"
## [2] "final_worth"
## [3] "category"
## [4] "person_name"
## [5] "age"
## [6] "country"
## [7] "city"
## [8] "source"
## [9] "industries"
## [10] "country_of_citizenship"
## [11] "organization"
## [12] "self_made"
## [13] "status"
## [14] "gender"
## [15] "birth_date"
## [16] "last_name"
## [17] "first_name"
## [18] "title"
## [19] "date"
## [20] "state"
## [21] "residence_state_region"
## [22] "birth_year"
## [23] "birth_month"
## [24] "birth_day"
## [25] "cpi_country"
## [26] "cpi_change_country"
## [27] "gdp_country"
## [28] "gross_tertiary_education_enrollment"
## [29] "gross_primary_education_enrollment_country"
## [30] "life_expectancy_country"
## [31] "tax_revenue_country_country"
## [32] "total_tax_rate_country"
## [33] "population_country"
## [34] "latitude_country"
## [35] "longitude_country"
We remove rows with blank cells or NA’s
data<- subset(data, complete.cases(data))
The birthdate and date column can be converted into date type with lubridate package
data$date <- parse_date_time(data$date, orders = "%m/%d%y %H:%M") %>%
round_date(unit = "day")
data$birth_date <- parse_date_time(data$birth_date, orders = "%m/%d%y %H:%M") %>%
round_date(unit = "day")
Let’s hunt down duplicate colums
colnames(data[duplicated(as.list(data))])
## [1] "industries"
# Well, there is one duplicate. Let's remove it
data <- select(data, -industries)
In gdp_country there is a ‘$’ sign. I will remove it and write numerical values in millions. (To make it comparable with ‘final_worth’ colums)
data$gdp_country <- str_remove(data$gdp_country,pattern="\\$") %>%
str_remove_all(pattern=",") %>%
str_trim() %>% # trim whitespaces
as.numeric() %>%
'/'(1000000) %>%
round(digits = 0)
Based on the existing columns we see the opportunity to extract more information from them. We will check who shares their wealth with the family and who owns the assets on their own.
data$family_wealth <- grepl("& family", data$person_name) # new variable if the wealth is shared with the family
data$person_name <- sub(" & family", "", data$person_name) # removing the suffix from name
iso_codes <- countrycode(data$country, origin = "country.name", destination = "iso3c")
continents <- countrycode(iso_codes, origin = "iso3c", destination = "continent")
data$continent <- continents
Countries from North America and South America are treated as “Americas”. We divide them.
north_american_countries <- c("United States", "Mexico", "Canada", "Guatemala", "Haiti", "Dominican Republic", "Cuba")
data$continent[data$country %in% north_american_countries] <- "North America"
data$continent[data$continent == "Americas"] <- "South America"
Total worth within each category
summary_categories <- data %>%
group_by(category) %>%
summarise(total_final_worth = sum(final_worth))
summary_categories$category=str_wrap(summary_categories$category, width = 10)
ggplot(summary_categories, aes(x = reorder(category, total_final_worth), y = total_final_worth)) +
geom_bar(stat = "identity", fill = "darkblue", width = 0.5) +
geom_text(aes(label = paste0(round((total_final_worth/sum(total_final_worth))*100, 2), "%")),
vjust = 0.2, hjust = -0.2, size = 3) +
labs(title = "Total Final Worth by Category",
x = "Category",
y = "Total Final Worth (bn $)") +
coord_flip() +
theme_gdocs() +
theme(axis.text.y = element_text(size = 7),
plot.title = element_text(size = 20, hjust = 0.5))
categories_wealth <- data %>%
group_by(category) %>%
summarize(categories_count = n(),
males_count = sum(gender == "M"),
females_count = sum(gender == "F")) %>%
arrange(desc(categories_count))
new_dataframe <- categories_wealth %>%
pivot_longer(cols = c(males_count, females_count), names_to = "gender", values_to = "count") %>%
mutate(gender = ifelse(gender == "males_count", "male", "female"))
ggplot(data = new_dataframe, aes(x = reorder(factor(category), -count), y = count, fill = factor(gender))) +
geom_bar(na.rm = TRUE, position = "stack", width = 0.5, stat = "identity") +
ggtitle('Categories by Gender') +
xlab('Category') +
ylab('Count') +
labs(fill = 'Gender') +
theme_gdocs() +
scale_fill_manual(values = c('pink', 'lightblue')) +
geom_text(aes(label = count), position = position_stack(vjust = 0.5), size = 2.5) +
theme(axis.text.x = element_text(angle = 45, hjust = 1),
plot.title = element_text(size = 20, hjust = 0.5))
ggplot(data=data, aes(x = age)) +
geom_histogram(aes(color = gender, fill=gender), alpha=0.5, position="stack")+
geom_vline(aes(xintercept=mean(age, na.rm = T), color="65.14"),
linetype="dashed", size=1)+
scale_color_manual(name = "Mean =", values = c("65.14" = "red"))+
scale_fill_discrete(name = "Gender")+
scale_x_continuous(breaks = c(20,30,40,50,60,70,80,90,100))+
labs(title = 'Number of Billionaires by Age',
x = 'Age' , y = 'Number of Billionaires') +
theme_gdocs()
## 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.
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Find the gender and their respective percentage values
gender_percentages <- data.frame(prop.table(table(data$gender)) * 100) %>% rename(gender = Var1)
Plotting the pie chart
ggplot(gender_percentages, aes(x = "", y = Freq, fill = gender)) +
geom_col(color = "black", alpha=0.5) +
geom_label(aes(label = sprintf("%0.1f%%",Freq)),
color='white',
size=10,
position = position_stack(vjust = 0.5),
show.legend = FALSE) +
guides(fill="none")+
coord_polar(theta = "y") +
theme_void()
Explore the wealth differences across different age groups by dividing them into bins of 10
age_bin_data <- data %>%
mutate(age_bin = cut(age, breaks = c(18,30,40,50,60,70,80,90,101))) %>%
group_by(age_bin) %>%
summarize(avg_wealth = mean(final_worth, na.rm = TRUE),
count_family_share = sum(family_wealth==TRUE)) %>%
na.omit()
Create a histogram
ggplot(age_bin_data, aes(x = age_bin, y = avg_wealth/1000, label = round(avg_wealth/1000,2))) +
geom_bar(stat = "identity", fill = "lightgreen", color = "black") +
geom_text(size=4,vjust=2.5,color= "black") +
labs(title = "Average Wealth by Age Group",x = "Age Group",y = "Average Wealth (Billions)") +
theme(axis.text.x = element_text(hjust = 0.5))+
theme_gdocs()
Create a histogram
ggplot(age_bin_data, aes(x = age_bin, y = count_family_share, label = count_family_share)) +
geom_bar(stat = "identity", fill = "lightgreen", color = "black", alpha = 0.8) +
geom_text(size=4,vjust=-0.4,color= "black") +
labs(title = "Number of Family Share by Age Group",
x = "Age Group",
y = "Number of Family Share") +
theme(axis.text.x = element_text(hjust = 0.5))+
theme_gdocs()
world <- ne_countries(scale = "small", returnclass = "sf")
billionaires_ppl <- data %>%
group_by(country) %>%
summarize(billionaires_count = n())
billionaires_ppl <- billionaires_ppl[-1,]
New column to match with ‘world’ object
billionaires_ppl$name <- billionaires_ppl$country
billionaires_ppl[billionaires_ppl$name=="Czech Republic", 3] = "Czechia"
billionaires_ppl[billionaires_ppl$name=="Eswatini (Swaziland)", 3] = "eSwatini"
billionaires_ppl[billionaires_ppl$name=="United States", 3] = "United States of America"
world <- left_join(world, billionaires_ppl, by= join_by(name))
Creating a world map
ggplot(data = world) +
coord_sf(expand = FALSE) +
geom_sf(aes(fill = billionaires_count)) +
scale_fill_gradient(low = 'azure', #lightgreen
high = 'blue4', #darkorange
breaks = seq(0, 750, by=100),
labels = paste(seq(0, 750, by=100), 'people'),
guide = guide_colorbar(barwidth = 2, barheight = 12,),
name = "Number of Billionaires",
#colours = c("#f7ffe6", "#d9ffb3", "#b1ff80", "#8fe65c", "#64cc39", "#47ab2f", "#2f8f24", "#1f7519"),
space = "Lab",
na.value = "white",
aesthetics = "fill")+
theme(legend.position = 'right')+
theme_gdocs()+
labs(title="Where do Billionaires Come From?")
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.
Preparation
average_age_by_country <- data %>%
group_by(country) %>%
summarise(average_age = mean(age, na.rm = TRUE))
average_age_by_country <- average_age_by_country [-1,]
average_age_by_country$name <- average_age_by_country$country
average_age_by_country[average_age_by_country$name=="Czech Republic", 3] = "Czechia"
average_age_by_country[average_age_by_country$name=="Eswatini (Swaziland)", 3] = "eSwatini"
average_age_by_country[average_age_by_country$name=="United States", 3] = "United States of America"
world_2 <- left_join(world, average_age_by_country, by= join_by(name))
And the map
ggplot(data = world_2) +
coord_sf(expand = FALSE) +
geom_sf(aes(fill = average_age)) +
scale_fill_gradient(low = 'azure',
high = 'blue4',
breaks = seq(0, 90, by=5),
labels = paste(seq(0, 90, by=5), 'years'),
guide = guide_colorbar(barwidth = 2, barheight = 12,),
name = "Age of billionaires",
#colours = c("#f7ffe6", "#d9ffb3", "#b1ff80", "#8fe65c", "#64cc39", "#47ab2f", "#2f8f24", "#1f7519"),
space = "Lab",
na.value = "white",
aesthetics = "fill")+
theme(legend.position = 'right')+
theme_gdocs()+
labs(title="What is the Average Age of Billionaires?")
## Coordinate system already present. Adding new coordinate system, which will
## replace the existing one.
## `summarise()` has grouped output by 'name'. You can override using the
## `.groups` argument.
top_countries <- billionaires_ppl %>%
top_n(10,billionaires_count)
Wrapping the text for better display on a plot
top_countries$name=str_wrap(top_countries$name, width = 10)
And the plot
ggplot(top_countries, aes(x = reorder(name, desc(billionaires_count)), y = billionaires_count, label=billionaires_count)) +
geom_bar(stat = "identity", fill = "lightgreen", alpha=0.8) +
labs(title = "Countries with Most Billionaires",
x = "Country",
y = "Number of Billionaires") +
geom_text(size=4,vjust=0.6,color= "black") +
theme_gdocs()
categories_wealth <- data %>%
group_by(category) %>%
summarize(categories_count = n()) %>%
arrange(desc(categories_count))
head(categories_wealth)
## # A tibble: 6 × 2
## category categories_count
## <chr> <int>
## 1 Finance & Investments 340
## 2 Technology 293
## 3 Manufacturing 287
## 4 Fashion & Retail 244
## 5 Food & Beverage 189
## 6 Healthcare 188
We will sum small categories into one bigger one “Others”
top_categories <- categories_wealth %>%
filter(categories_count>=100) %>%
rbind(c("Others",
sum(categories_wealth[which(categories_wealth$categories_count<100),2])))
Changing to numeric for plotting
top_categories$categories_count <- as.numeric(top_categories$categories_count)
billionaires_ppl$gdp <- 0
billionaires_ppl$population <- 0
billionaires_ppl$total_tax_rate_country <- 0
The loop here takes some time
for (i in 1:nrow(billionaires_ppl)) {
for (j in 1:nrow(data)) {
if (billionaires_ppl[i, "name"] == data[j, "name"]) {
billionaires_ppl[i, "gdp"] = data[j, "gdp_country"]
billionaires_ppl[i, "population"] = data[j, "population_country"]
billionaires_ppl[i, "total_tax_rate_country"] = data[j, "total_tax_rate_country"]
billionaires_ppl[i, "gross_tertiary_education_enrollment"] = data[j, "gross_tertiary_education_enrollment"]
billionaires_ppl[i, "tax_revenue_country_country"] = data[j, "tax_revenue_country_country"]
break
}
}
}
Log transformations
billionaires_ppl$log_pop <- log(billionaires_ppl$population)
billionaires_ppl$log_gdp <- log(billionaires_ppl$gdp)
Let’s see whether there is a relationship between GDP and the number of billionaires
ggplot(billionaires_ppl, aes(x = gdp, y = billionaires_count)) +
geom_point(aes(size = total_tax_rate_country, color = population)) +
labs(title = 'GDP vs. Number of Billionaires', color = 'Population',
x = 'GDP' , y = 'Number of Billionaires', size = 'Total Tax Rate') +
scale_x_continuous(breaks=c(1000000,5000000,10000000,15000000,20000000, 25000000),
labels = c("1 bln $", "5 bln $", "10 bln $", "15 bln $", "20 bln $", "25 bln $"))+
geom_smooth(method='lm', formula= y~x)+
geom_text_repel(aes(label = name))+
theme_gdocs()
## Warning: ggrepel: 59 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps
Maybe tax revenue has an impact too?
ggplot(billionaires_ppl, aes(x = tax_revenue_country_country, y = log(billionaires_count))) +
geom_point(aes(size = total_tax_rate_country, color = population)) +
labs(title = 'Tax Revenue vs. Number of Billionaires', color = 'Population',
x = 'Tax Revenue' , y = 'Number of Billionaires (log)', size = 'Total Tax Rate') +
scale_x_continuous(breaks=c(1,25,50,75,100),
labels = c("1", "25", "50", "75", "100"))+
geom_smooth(method='loess', formula= y~x)+
theme_gdocs()
There are some outliers. We will delete them and rerun the code
billionaires_ppl_new <- billionaires_ppl %>%
filter(tax_revenue_country_country>5) %>%
filter(tax_revenue_country_country<26)
And plot again
ggplot(billionaires_ppl_new, aes(x = tax_revenue_country_country, y = log(billionaires_count))) +
geom_point(color = "darkgreen", size= 3) +
labs(title = 'Tax Revenue vs. Number of Billionaires',
x = 'Tax Revenue' , y = 'Number of Billionaires (log)',
caption = "*Outliers excluded") +
scale_x_continuous(breaks=c(1,5,15,25,35),
labels = c("1", "5", "15", "25", "35"))+
geom_smooth(method='loess', formula= y~x, fill="lightgreen")+
theme_gdocs()
data <- data %>%
mutate(self_made = as.integer(self_made))
data <- data %>%
mutate(family_wealth = as.integer(family_wealth))
data <- data %>%
mutate(self_made = as.integer(self_made))
Hypothesis: the higher the age the lower the probability fo being self-made
ggplot(data = data, aes(x = age, y = self_made)) +
geom_point() +
geom_smooth(method = 'glm', method.args = list(family = binomial(link = 'logit')),
formula = y ~ x) +
theme_gdocs() +
labs(title = "Probability of Being Self-Made vs. Age",
x = "Age", # Label for x-axis
y = "Self-made") + # Label for y-axis
theme(
text = element_text(size = 20),
plot.title = element_text(hjust = 0.5)
)
Maybe tendencies depend on the continent? We will drop Africa and Australia because they may include some unconventional observations
data_filtered <- data %>%
filter(!continent %in% c("Africa", "Oceania"))
ggplot(data = data_filtered, aes(x = age, y = self_made, color = continent)) +
geom_point() +
geom_smooth(
method = 'glm',
method.args = list(family = binomial(link = 'logit')),
formula = y ~ x,
se = TRUE
) +theme_gdocs()+
labs(title = "Probability of Being Self-Made vs. Age",
x = "Age", # Label for x-axis
y = "Self-made") + # Label for y-axis
theme(
text = element_text(size = 20),
plot.title = element_text(hjust = 0.5)
)
We start with removing outliers for better visibility
filtered_data <- data %>%
arrange(final_worth) %>%
slice(1:(0.9 * nrow(.)))
Plotting the distribution of final_worth by gender
ggplot(filtered_data, aes(x = final_worth, y = gender, fill = ..x..)) +
geom_density_ridges_gradient(scale = 3, rel_min_height = 0.01) +
scale_fill_viridis(name = "Final Worth", option = "D") +
theme_minimal() +
theme(plot.title = element_text(size = 20, hjust = 0.5)) +
labs(title = "Density Plots of Billionaires Worth by Gender and Self-Made Status",
x = "Final Worth (mln $)",
y = "Gender") +
facet_grid(self_made ~ ., scales = "free_y", space = "free_y",
labeller = labeller(self_made = c("1" = "Self-Made", "0" = "Non-Self-Made")))+
geom_rect(data = subset(filtered_data, self_made == 0),
aes(xmin = quantile(final_worth[self_made == 0], 0.90),
xmax = max(final_worth[self_made == 0]),
ymin = -Inf,
ymax = 4),
fill = NA, color = "red", size = 1)+
theme_gdocs()
## Warning: The dot-dot notation (`..x..`) was deprecated in ggplot2 3.4.0.
## ℹ Please use `after_stat(x)` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
## Picking joint bandwidth of 520
## Picking joint bandwidth of 424
data %>%
ggplot(aes(final_worth)) +
stat_lorenz(desc = TRUE) +
coord_fixed() +
geom_abline(linetype = 'dashed') +
theme_minimal() +
hrbrthemes::scale_x_percent() +
hrbrthemes::scale_y_percent() +
hrbrthemes::theme_ipsum_rc() +
labs(x = "Cumulative Percentage of the Billionaires",
y = "Cumulative Percentage of Total Net Worth") +
theme_gdocs() +
theme(plot.title = element_text(hjust = 0.5)) +
ggtitle("Inequality Among Billionaires")
Selecting 3 categories with lowest and highest inequality level
data_filtered <- data %>%
filter(category %in% c("Telecom", "Real Estate", "Automotive", "Construction & Engineering", "Service", "Technology"))
data_filtered %>%
ggplot(aes(final_worth, fill = category, color = category)) +
stat_lorenz(desc = TRUE) +
coord_fixed() +
geom_abline(linetype = 'dashed') +
theme_minimal() +
hrbrthemes::scale_x_percent() +
hrbrthemes::scale_y_percent() +
hrbrthemes::theme_ipsum_rc() +
labs(x = "Cumulative Percentage of the Billionaires",
y = "Cumulative Percentage of Total Net Worth") +
theme_gdocs() +
theme(plot.title = element_text(hjust = 0.5)) +
ggtitle("Inequality Among Billionaires by Category")