What is Risk Assessment?

Risk assessment involves identifying, analyzing, and evaluating potential risks that could impact an organization or project. By quantifying these risks, actuaries and decision-makers can develop strategies to mitigate or manage them effectively.

Key Components of Risk Assessment

1. Risk Identification: Recognizing potential risks and their sources.
2. Risk Analysis: Measuring the likelihood and impact of each risk.
3. Risk Evaluation: Prioritizing risks based on their significance.
4. Risk Mitigation: Developing strategies to reduce or eliminate risks.

Tools and Techniques

• Probability Models: Using statistical methods to estimate the likelihood of events.
• Scenario Analysis: Exploring different outcomes based on varying assumptions.
• Stress Testing: Assessing the impact of extreme scenarios on financial stability.

Real-World Applications

• Insurance: Calculating premiums and reserves based on risk profiles.
• Finance: Evaluating investment risks and portfolio performance.
• Healthcare: Assessing risks in patient care and medical treatments.

Conclusion

Risk assessments are essential for navigating uncertainty and making data-driven decisions. By leveraging actuarial science principles, organizations can better prepare for potential challenges and seize opportunities with confidence.

Stay tuned for more insights on risk management and related topics. Feel free to share your thoughts or questions in the comments!

The Strategic Mindset Shift

This roadmap serves as your bridge between these two worlds, transforming you from a generator of data into an architect of corporate survival.

1. Beyond the Spreadsheet: Transitioning from Calculation to Narrative

In the executive suite, communication is not a “soft skill”—it is the primary instrument of leadership. While data provides the foundation, leadership is exercised through the interpretation of that data for stakeholders who lack your technical background. You must move beyond the “black box” to tell the story of the risk.

High-level risk reasoning requires a philosophical grounding that transcends mathematics. Prominent actuarial textbooks often cite the 19th-century philosopher John Ruskin, reminding the profession that the human element is central to the plot of risk management. A leader does not simply report a probability; they provide a narrative that accounts for institutional pressure, human behavior, and ultimate responsibility.

2. The Intuition Safeguard: Developing the “Smell Test” for AI

The greatest strategic risk facing modern firms is “blind trust” in automated systems. While AI is invaluable for exploration—scraping data and identifying heat maps—it is not yet reliable for production. The danger of software hallucinations and model errors makes professional intuition the final line of defense against insolvency.

The UK Post Office Scandal provides a haunting case study: the failure was not just “screwy software,” but the “IT system as gospel” fallacy. Because the system was treated as infallible, the organization ignored human intuition, leading to catastrophic consequences, including jail sentences and suicides. A risk leader’s value lies in their ability to “smell” when a result is wrong, even when the model insists it is correct. This “Smell Test” is the primary justification for an executive salary in an automated age.

3. Architecting the Corporate “Nervous System”

A Chief Risk Officer’s (CRO) value is found in their ability to monitor leading indicators that exist outside official accounting books. To achieve this, you must architect a corporate “Nervous System.”

This system tracks 20 to 100 non-standard metrics—the “canaries in the coal mine.” These indicators are often hidden in unofficial silos, “shoe-box spreadsheets,” or fragmented departmental data that the core accounting system ignores. While AI can scrape numbers, the leader must determine which numbers represent a true signal of disruption and which are merely noise.

4. Strategic Agility: Navigating Disruption as Competitive Advantage

The role of a risk leader is not to prevent disruption, but to position the company to thrive within it. This requires an “Open Mind” philosophy. In periods of massive change—like the 1980s interest rate spike or the 2020 pandemic—a senior executive with 20 years of experience often has “zero more experience” than a junior analyst. In these moments, experience can actually be a disadvantage if it anchors you to an obsolete environment.

5. The Implementation Plan: Your 12-Month Leadership Transition

Transitioning to the boardroom requires unlearning the habit of fifth-decimal precision in favor of strategic authority.

• Phase 1: Narrative Mastery (Months 1-3) Stop presenting spreadsheets; start presenting scripts. Pivot from quantitative isolation to strategic integration by testing how your data interpretations resonate with non-technical stakeholders.
• Phase 2: Network Expansion (Months 4-6) Build the “Nervous System.” Identify the “shoe-box” spreadsheets in marketing, IT, and customer service. Break down departmental silos to find your leading indicators.
• Phase 3: Intuition Calibration (Months 7-9) Study “Disaster Collections”—historical failures like the Equitable Life UK collapse or the CDO square meltdown. Use these to sharpen your “smell test” for model governance.
• Phase 4: Strategic Positioning (Months 10-12) Adopt the “Author Mindset.” Move from being the person who calculates the tables to the authority who writes the script for the organization’s future.

Final Thought: The journey from the basement to the boardroom is the journey from Calculating the Tables to Writing the Script. By mastering narrative, intuition, and systemic thinking, you become the indispensable architect of your organization’s resilience.

Episode Overview

"The Accounting of Human Suffering" refers to the core mission of health metrics to quantify the total human toll of diseases, injuries, and risk factors. This process is centered on the Disability-Adjusted Life Year (DALY), a composite metric that measures one lost year of healthy life.

The discussion involves two primary pillars: morbidity and mortality. Years of Life Lost (YLLs) are calculated by comparing the age at death to a standard life expectancy to measure the impact of premature death. Years Lived with Disability (YLDs) are determined by multiplying the prevalence of a condition by a specific disability weight, which represents the severity of health loss on a scale from 0 to 1.

Key technical "ingredients" for this accounting include standardized life tables, mortality rates, and incidence vs. prevalence data. The sources emphasize that these metrics provide a standardized language to compare the burden of diverse conditions—such as the immediate mortality of a stroke versus the long-term impact of chronic respiratory disease—across different global populations.

Ultimately, this accounting is used to identify health priorities, evaluate the effectiveness of interventions, and guide public health policy to achieve greater global health equity. The discussion also extends to emerging metrics like Well-being-Adjusted Health Expectancy (WAHE), which incorporate happiness, life satisfaction, and social connectedness into the traditional clinical framework.

Key Topics Discussed

• Years of Life Lost (YLLs) are calculated by comparing the age at death to a standard life expectancy to measure the impact of premature death
• prevalence data

Episode Overview

Life expectancies, simulated data and health metrics in a fascinating discussion about how to apply raw data to wel estimated formula.

Key Topics Discussed

• Life expectancies, simulated data and health metrics in a fascinating discussion about how to apply raw data to wel estimated formula

Episode Overview

From death records to predictive algorithms.

This episode traces 400 years of health intelligence—from counting who died to forecasting what comes next.

We move from John Graunt’s 17th-century Bills of Mortality, through modern burden-of-disease metrics like DALYs, to today’s machine-learning models that learn from data to anticipate outbreaks and inform prevention.

Key Topics Discussed

• Data-driven insights
• Health metrics analysis
• Innovative approaches to public health

Episode Overview

17th Century: The Bills of Mortality. John Graunt, the “father of demography,” uses London’s weekly death records to identify the first statistical patterns in human longevity and disease.

Key Topics Discussed

• Data-driven insights
• Health metrics analysis
• Innovative approaches to public health

Overview

So I built {typeR}: a small utility package that prints an R script to the console with a typing effect, character by character, with a configurable delay.

writeLines(
  c(
    "# Demo script",
    "x <- 1:10",
    "y <- x * 2",
    "plot(x, y)"
  ),
  "demo_script.R"
)

library(typeR)

typeR("demo_script.R", delay = 0.03)

# install.packages("devtools")
devtools::install_github("fgazzelloni/typeR")

1. It’s Not Just About How Long We Live, But How Well

For decades, mortality rates were the primary way to track public health crises. But what about the millions who live for years with chronic pain, mobility issues, or mental health disorders? To capture this, experts developed a more holistic metric: the Disability-Adjusted Life Year (DALY). This is now the standard for measuring the total “burden of disease.”

The DALY is a single number composed of two parts:

• Years of Life Lost (YLLs): This is the more traditional part, accounting for the years lost when someone dies prematurely.
• Years Lived with Disability (YLDs): This is the revolutionary component. It measures the years people live in a state of less-than-ideal health due to a disease or injury.

The hidden math that makes this metric so powerful lies in disability weights. Each health condition, from hearing loss to severe depression, is assigned a numerical weight based on its severity. This allows scientists to mathematically quantify the impact of different illnesses, revealing a counter-intuitive truth: a very long life filled with chronic illness can represent a greater public health burden than a shorter one.

By combining mortality (death) and morbidity (illness), this metric shifts the entire goal of public health. It’s no longer just about keeping people alive; it’s about maximizing the healthy, functional years they get to live—and it provides a single, powerful number to measure our success.

2. We Measure Health Risks by Imagining a Perfect World

How do you measure the harm caused by something like air pollution or a poor diet? It’s a surprisingly tricky question. The answer lies in a fascinating concept used by public health scientists: the Theoretical Minimum-Risk Exposure Level (TMREL).

Instead of just tracking the negative effects of a risk factor, scientists first define a hypothetical, ideal scenario. They imagine a perfect world where exposure to that risk is at the absolute lowest, most plausible level. For example, what would our health look like if everyone had the optimal diet, or if air quality was pristine?

The true “burden” of that risk is then calculated as the gap between our current reality and that “perfect world” scenario. This connects directly back to DALYs; the total burden of air pollution, for instance, is the difference in DALYs between our current world and one with theoretically clean air. This is a powerful reframing. It moves public health from a goal of small, incremental improvements to measuring the full potential for health that is lost due to a given risk.

3. Predicting Epidemics: From Hand-Drawn Rules to AI Pattern-Finding

When a new virus emerges, how do scientists predict its spread? Historically, they have relied on “mechanistic models,” but a new approach driven by artificial intelligence is changing the game.

• Mechanistic Models (like SIR): Think of these as a “plumber’s blueprint.” They are “rule-based” and require knowing exactly how all the pipes (rules of transmission and recovery) are connected to predict the water flow (disease spread). The classic SIR model, for example, uses differential equations to simulate how a population moves between being Susceptible, Infected, and Recovered. These models need a deep understanding of a disease’s biology to work.
• Machine Learning Models: These models are “empirically driven”—they are powerful pattern-finders. Imagine a mysterious box that has observed thousands of plumbing systems. It doesn’t need the blueprint; it just learns the patterns of when and where leaks are most likely to occur by analyzing massive datasets (infection rates, demographics, temperature, etc.) to find complex relationships that predict outcomes.

The key distinction is profound and highlights a major shift in epidemiology:

Mechanistic models rely on known relationships and equations, while machine learning models learn patterns from data.

This is a game-changer because machine learning can uncover unexpected drivers of disease that traditional, rule-based models might completely miss, offering a powerful new tool in the fight against pandemics.

4. What We Fear Most Isn’t What Harms Us Most

Modern society is saturated with information about potential threats, from global pandemics and terrorism to environmental disasters. This constant exposure shapes our perception of risk, but our fears don’t always align with the statistical reality of what harms us.

“…fear is the most pervasive emotion of modern society…”

A look at how risks have evolved shows a significant shift. Historical risks were dominated by immediate threats like starvation, infectious diseases, and violent conflicts. Today, while perceived threats like pandemics capture our attention, the greatest “burden of disease” in many parts of the world comes from less dramatic but far more widespread sources.

As the Global Burden of Disease study shows, modern risks are largely driven by four key categories of risk factors: Behavioral, Environmental, Occupational, and Metabolic. These include lifestyle choices like a poor diet, physical inactivity, tobacco use, and excessive alcohol consumption. Conditions like heart disease and obesity contribute massively to the global DALY count. This reveals a critical disconnect: we often fear the sudden and dramatic, but the slow, chronic, and everyday factors are what statistically cause the most harm to our collective health.

5. Geography Can Be Destiny for Disease

Where you live can be just as important as who you are when it comes to health risks. Modern health analysis is increasingly spatial, looking not just at who gets sick, but where outbreaks are most likely to occur.

Using spatial modeling, scientists can feed data like temperature, elevation, and population density into powerful models to create detailed, geographic risk maps. These maps can identify disease “hotspots” with incredible precision.

One of the sophisticated techniques used for this is Kriging. Think of it like creating a weather map: you have temperature readings from a few dozen weather stations (the known points). Kriging is the statistical method that intelligently fills in all the gaps, creating a smooth, continuous heat map of the entire region. Health officials use the same principle to map disease “hotspots” from a limited number of clinic reports. This isn’t just theoretical; the source material dedicates an entire chapter to using these spatial models to map malaria outbreaks. For public health officials, it means they can target interventions—like distributing bed nets—to the precise areas where they will save the most lives and resources, turning a map into a life-saving tool.

Conclusion: The Power of a Clearer Picture

The way we measure, model, and visualize health data is becoming more powerful every year. By moving beyond simple metrics like life expectancy, we are gaining a much clearer, more honest picture of the complex challenges we face—from the quiet burden of chronic disease to the geographic patterns of an epidemic.

For those interested in diving deeper into these concepts, I highly recommend exploring the comprehensive resource: “Health Metrics and the Spread of Infectious Diseases Machine Learning Applications and Spatial Modelling Analysis with R” available at fgazzelloni.github.io/hmsidR/. This book provides an in-depth look at the methodologies and theories that underpin modern health metrics, offering valuable insights for anyone passionate about public health and data science.

Episode Overview

The new science of fighting infectious disease is a multidisciplinary field that integrates health metrics, machine learning, and spatial modeling to predict, track, and mitigate the spread of pathogens. Rather than relying solely on traditional medicine, this approach utilizes advanced data science to understand the "invisible enemies" that threaten global health.

Key pillars of this modern approach include:

• Quantitative Health Metrics: The foundation of this science involves using metrics like Disability-Adjusted Life Years (DALYs) to quantify the total human toll of a disease, combining years lost to premature death (YLLs) with years lived with disability (YLDs).
• Machine Learning and Predictive Modeling: Modern researchers use machine learning algorithms—such as Random Forests, Neural Networks, and Gradient Boosting—to learn patterns from historical data and predict future outbreaks. This allows for parameter auto-calibration, where models automatically adjust to minimize prediction errors based on real-world observations.
• Spatial and Spatiotemporal Analysis: By using Geographic Information Systems (GIS) and techniques like Kriging, scientists can map infection hotspots and visualize how diseases like COVID-19 or Malaria move across a landscape. This helps identify high-risk areas for targeted interventions, such as vaccination or resource allocation.
• The One Health Perspective: This science recognizes that human, animal, and environmental health are interconnected. It focuses on the zoonotic origins of viruses (like those moving from bats or pangolins to humans) to prevent pandemics before they start.
• Transfer Learning: An emerging technique in this field involves model transfer, where insights and models built from one outbreak (like a past cholera epidemic) are adapted to predict and manage new, similar diseases in low-data settings.

Analogy for Understanding the New ScienceThink of this field as a "High-Tech Biological Radar." Traditional medicine is like a lighthouse—it helps you see the danger when it is already close. This new science, however, is a sophisticated radar system that tracks the weather (pathogen spread), predicts where a storm will hit (outbreak forecasting), and calculates the exact amount of damage expected (health metrics), allowing cities to prepare long before the first raindrop falls.

Buy your hardcover here: https://amzn.to/3N7zZjH

Key Topics Discussed

• Data-driven insights
• Health metrics analysis
• Innovative approaches to public health

Load Libraries and Data

library(tidyverse)
library(stringr)
library(readxl)

raw_le2022 <- read_excel("data/IHME_GBD_2021_MORT_LE_FORECASTS_2022_2050_TABLES_0/le.XLSX",skip = 1)
head(raw_le2022)

Reference scenario life expectancy at birth 2022

female_le2022 <- raw_le2022$`Reference scenario life expectancy at birth` %>%
  str_replace_all("·", ".") %>%     
  str_extract_all("\\d+\\.?\\d*", simplify = TRUE)

location_name <- raw_le2022$...1

female_le2022 <- data.frame(location_name,female_le2022) %>%
  select(location_name, le = X1) %>%
  mutate(le = as.numeric(le),
         sex="female") %>%
  drop_na()

female_le2022

male_le2022 <- raw_le2022$...5 %>%
  str_replace_all("·", ".") %>%     
  str_extract_all("\\d+\\.?\\d*", simplify = TRUE)

male_le2022 <- data.frame(location_name,male_le2022) %>%
  select(location_name, le = X1) %>%
  mutate(le = as.numeric(le),
         sex="male") %>%
  drop_na()

male_le2022

Combine female and male le

le2022_data <- bind_rows(female_le2022,male_le2022) %>%
  group_by(location_name) %>%
  reframe(le_avg2022=round(mean(le)))%>%
  distinct()

le2022_data%>%head

raw_le_hale2022 <- read_excel("data/IHME_GBD_2021_MORT_LE_FORECASTS_2022_2050_TABLES_0/le_hale.XLSX")
head(raw_le_hale2022)

location_name <- raw_le_hale2022$`Supplemental Results Table S2. Life expectancy and healthy life expectancy (HALE) in 2022 and 2050 (reference scenario) by location for both sexes. Estimates are listed as means with 95% uncertainty intervals in parentheses. Highlighted rows indicate region and super region results from the GBD location hierarchy.`

hale2022 <- raw_le_hale2022$...5%>%
  str_replace_all("·", ".") %>%      
  str_extract_all("\\d+\\.?\\d*", simplify = TRUE)

hale2022 <- data.frame(location_name,hale2022) %>%
  select(location_name, hale = X1) %>%
  mutate(hale = as.numeric(hale)) %>%
  drop_na()%>%
  distinct()

hale2022

yll_yld2022_raw <- hmsidwR::getunz("https://dl.healthdata.org:443/gbd-api-2023-public/7bae287bc4f06482be6332f797f3ebc2_files/IHME-GBD_2023_DATA-7bae287b-1.zip")

yll_yld2022 <- yll_yld2022_raw[[1]] %>% 
  select(location_name=location,
         measure,val)

yld2022_data <- yll_yld2022%>%
  filter(measure=="YLDs (Years Lived with Disability)")%>%
  rename(yld=val)%>%
  select(-measure) %>%
  distinct()
yll2022_data <- yll_yld2022%>%
  filter(measure=="YLLs (Years of Life Lost)")%>%
  rename(yll=val)%>%
  select(-measure) %>%
  distinct()
  
yll_yld2022_data<- merge(yld2022_data,yll2022_data)

Combine all data

index_data2022 <- le2022_data %>%
  left_join(hale2022, by="location_name") %>%
  left_join(yll_yld2022_data ,by="location_name") %>%
  drop_na()

the dimension index is calculated as:

where scaled yll and scaled yld are the standardized values of yll and yld respectively.

In literature a dimension index is used to measure the quality of life in a location, taking into account not only life expectancy but also the burden of disease and disability.

In particular, the dimension index combines life expectancy at birth (le_avg2022) and healthy life expectancy (hale) in the numerator, reflecting both the quantity and quality of life. The denominator incorporates the scaled values of years of life lost (yll) and years lived with disability (yld), which represent the burden of disease and disability in the population.

Particular attention is put on the values of yll and yld, which are scaled to ensure comparability across different locations. The scaling process standardizes these values, allowing for a more accurate assessment of the overall health status of the population.

for reference see:

• https://www.frontiersin.org/journals/public-health/articles/10.3389/fpubh.2025.1566469/full
• https://pmc.ncbi.nlm.nih.gov/articles/PMC4140376/

scale between 0 and 1

# scale <- function(x){
#   (x - min(x)) / (max(x) - min(x))
# }
# 

index_data2022%>%summary()

index_data2022%>%
  filter(is.na(yll) | is.na(yld))

?scale

index_data2022%>%
  mutate(yll_scaled=scale(yll,center = F),
         yld_scaled=scale(yld,center = F)) %>%
  mutate(dimension_index = round((le_avg2022 + hale)/((1-yll_scaled) + (1-yld_scaled))*100,2),
         .after=location_name) 

index_data2022 %>%
  mutate(across(where(is.numeric), ~ as.numeric(scale(.x, center = F)),
                .names = "{.col}_scaled")) %>%
  mutate(dimension_index = round((le_avg2022 + hale)/((1-yll_scaled) + (1-yld_scaled))*100,2),
         dimension_index2 = round((le_avg2022_scaled + hale_scaled + (1-yll_scaled) + (1-yld_scaled))/4,2),
         dimension_index3 = round(((le_avg2022_scaled + hale_scaled)/ ((1-yll_scaled) + (1-yld_scaled))/2)*100,2),
         dimension_index3_geo=((le_avg2022 + hale)/(((1-yll_scaled)+(1-yld_scaled))/2))^(1/4) *100,
         .after=location_name) %>%
  filter(is.na(dimension_index3_geo))

Setting Up the Project

I started by creating a dedicated RStudio project. Keeping the book isolated in its own project was essential for reproducibility, file organisation, and version control.

Create a new book project structure

usethis::create_project("hmsid-book")

Set up a Git repository to track changes:

# Initialise git
`usethis::use_git()`

Then I added a basic Quarto/bookdown structure:

quarto::quarto_create("hmsidwR", template = "book")

This generated the _quarto.yml file, a structure for chapters, and a place for images and data.

A minimal _quarto.yml looked like this:

project:
  type: book

book:
  title: "Health Metrics and the Spread of Infectious Diseases"
  author: "Federica Gazzelloni"
  chapters:
    - index.qmd
    - 01_introduction.qmd
    - 02_data.qmd
    - 03_methods.qmd
    - 04_modeling.qmd
    - 05_spatial_analysis.qmd
    - 06_results.qmd
    - 07_conclusions.qmd

format:
  html:
    theme: cosmo
  pdf:
    documentclass: scrreprt

Managing Data Inside an R Package

To keep the workflow clean and reproducible, I organised all datasets into a companion R package (hmsidwR). This meant readers could reproduce every example with:

install.packages("hmsidwR")
library(hmsidwR)

Loading a dataset was as simple as:

data("infectious_diseases")
head(infectious_diseases)

Packaging the data required a few lines in the development workflow:

usethis::use_data(tb_data, overwrite = TRUE)

This approach saved hours of manual file handling in later stages of writing.

Writing Chapters with Embedded Code

Most chapters combined narrative text with code chunks. A typical section looked like this:

Life Expectancy Trends

We begin by exploring changes in life expectancy across countries.

library(tidyverse)
library(hmsidwR)
set.seed=04122025
hmsidwR::gho_le_hale %>%
  filter(indicator=="Life expectancy at birth (years)",
         sex=="both sexes") %>%
  group_by(region, year) %>%
  reframe(le=mean(value, na.rm=TRUE)) %>%
  ggplot(aes(year, le, 
             colour = region)) +
  geomtextpath::geom_textline(aes(label = region), 
                              position = "jitter",
                              orientation = "x",
                              hjust=0,size=3,
                              show.legend = F) +
  ggthemes::scale_color_economist()+
  labs(title = "Life Expectancy Over Time",
       x="Time(year)",
       y="Life expectancy at birth (years)")+
  theme_minimal(base_size = 14, 
                base_rect_size = 0.2,
                base_line_size = 1,
                accent = "red",ink = "grey25") +
  theme(text=element_text(face="bold"),
        axis.title = element_text(size=9))

Keeping all figures generated directly from the code ensured:

• No manual image editing
• Fully up-to-date plots on each render
• Transparent modelling steps

Automating Rendering

With dozens of chapters and hundreds of figures, manual rendering was not feasible. I automated it using one command:

quarto::quarto_render()

For more granular control (helpful when writing new sections):

quarto::quarto_render("03_methods.qmd")   # render a single chapter

Before shipping the final manuscript, I used a clean render:

quarto::quarto_clean()
quarto::quarto_render()

This guaranteed that everything knitted from scratch.

usethis::use_github()

  git add 03_methods.qmd
  git commit -m "Expand description of spatial interpolation"
  git push

library(sf)
library(terra)
library(tmap)

world <- vect(hmsidwR::idDALY_map_data)
tb <- hmsidwR::idDALY_map_data

tm_shape(world) +
  tm_borders(fill="grey90",lwd=0.5) +
  tm_shape(tb) +
  tm_dots(col = "DALYs", 
          shape=21,lwd = 0.1,
          palette = "matplotlib.reds") +
  tm_layout(frame = FALSE)

Example of construction of Plain vanilla network architecture

ANN’s (Artificial Neural Networks) is the simplest implementation of deep learning model architectures that mimic the human brain’s neural network. The simplest form of ANN is a single-layer network, also known as a “plain vanilla” network. This network consists of an input layer, a hidden layer, and an output layer. The hidden layer transforms the input data into a new set of features, which are then used to predict the response variable.

In the image above, we have some predictors that are fed into the hidden layer, which then transforms them into a new set of features , which are then used to predict the response variable .

rm(list=ls())
suppressMessages(library(tidyverse))
theme_set(theme_minimal())

set.seed(100)
x <- runif(60, min=-2, max=2)

y <- function(x) {
  Y = (cos(2*x + 1))
  return(Y)
}

data <- tibble(y=y(x),x)
head(data)

# A tibble: 6 × 2
       y       x
   <dbl>   <dbl>
1  0.859 -0.769 
2  0.591 -0.969 
3  0.152  0.209 
4 -0.829 -1.77  
5  0.733 -0.126 
6  0.645 -0.0649

data %>% summary()

       y                  x           
 Min.   :-0.99978   Min.   :-1.77447  
 1st Qu.:-0.59934   1st Qu.:-0.89194  
 Median : 0.15559   Median :-0.04092  
 Mean   : 0.02628   Mean   : 0.01437  
 3rd Qu.: 0.62358   3rd Qu.: 0.88138  
 Max.   : 0.99930   Max.   : 1.95826  

data %>%
  ggplot(aes(x, y)) +
  geom_line() +
  geom_point() +
  geom_hline(yintercept=0, 
             linetype="dashed", color="grey")

hidden_neurons = 5

sigmoid <- function(x) {
  z = (1 / (1 + exp(-x)))
  return(z)
}

relu <- function(x) {
  z = ifelse(x < 0, 0, x)
  return(z)
}

softplus <- function(x) {
  z = log(1 + exp(x))
  return(z)
}

data %>%
  mutate(z=sigmoid(x)) %>%
  ggplot() +
  geom_line(aes(x, z)) +
  ylim(0, 1)
data %>%
  ggplot() +
  geom_line(aes(x, relu(x) * 1/2.4))
data %>%
  ggplot() +
  geom_line(aes(x, softplus(x)))

data %>%
  ggplot() +
  geom_line(aes(x, sigmoid(x))) +
  # relu resized for comparison
  geom_line(aes(x, relu(x) * 1/2.4))+
  labs(y="Sigmoid vs ReLU")

w1 = matrix(rnorm(2*hidden_neurons), 
            nrow=hidden_neurons, 
            ncol=2)
w2 = matrix(rnorm(hidden_neurons + 1), 
            nrow=1, 
            ncol=(hidden_neurons + 1))

data %>%
  ggplot(aes(x, y)) +
  geom_point(shape=21, 
             stroke=0.5, 
             fill="grey", 
             color="grey20") +
  geom_line(linewidth=0.2) +
  geom_smooth(method = "lm", 
              color="steelblue", 
              se=F) +
  geom_line(aes(x, sigmoid(y)), 
            linetype="dashed", 
            color="steelblue")

feedForward <- function(x, w1, w2, activation) {
  output <- rep(0, length(x))

  for (i in 1:length(x)) {
    a1 = w1 %*% matrix(rbind(1, x[i]), ncol=1)
    z1 = activation(a1)
    a2 = w2 %*% matrix(rbind(1, z1), ncol=1)
    output[i] = a2
  }

  return(output)
}

Derivative Activation Function

Now, that we have the feedforward function, we need to compute the derivative of the activation function. The backpropagation algorithm multiplies the derivative of the activation function.

Backpropagation algorithm multiplies the derivative of the activation function.

Here is a recap of the definition of derivative formula, which is applied any time the output released by the activation function is met in the network. And so, a new minimum is found. It will be more clear through the end of the post.

So, it is fundamental to define the derivative of the activation function needed for computing the gradient. For this example, we will use the derivative of the sigmoid function.

derivativeActivation <- function(x) {
  g = (sigmoid(x) * (1 - sigmoid(x)))
  return(g)
}

modelError <- function(x, y, w1, w2, activation) {
  # Predictions
  preds <- feedForward(x, w1, w2, activation)
  # Error calculation
  SSE <- sum((y - preds) ** 2)
  return (SSE)
}

backPropagation <- function(x, y, w1, w2, 
                            activation, derivativeActivation) {
  #predicted values
  preds <- feedForward(x, w1, w2, activation) 
  #Derivative of the cost function (first term)
  derivCost <- -2 * (y - preds) 
  #Gradients for the weights
  dW1 <- matrix(0, ncol=2, nrow=nrow(w1)) 
  dW2 <- matrix(rep(0, length(x) * (dim(w2)[2])), nrow=length(x)) 

  # Computing the Gradient for W2
  for (i in 1:length(x)) {
    a1 = w1 %*% matrix(rbind(1, x[i]), ncol=1)
    da2dW2 = matrix(rbind(1, activation(a1)), nrow=1)
    dW2[i,] = derivCost[i] * da2dW2
  }

  # Computing the gradient for W1
  for (i in 1:length(x)) {
    a1 = w1 %*% matrix(rbind(1, x[i]), ncol=1)
    da2da1 = derivativeActivation(a1) * matrix(w2[,-1], ncol=1)
    da2dW1 = da2da1 %*% matrix(rbind(1, x[i]), nrow=1)
    dW1 = dW1 + derivCost[i] * da2dW1
  }

  # Storing gradients for w1, w2 in a list
  gradient <- list(dW1, colSums(dW2))

  return (gradient)
}

SGD <- function(x, y, w1, w2, activation, derivative, learnRate, epochs) {
  SSEvec <- rep(NA, epochs) # Empty array to store SSE values after each epoch
  SSEvec[1] = modelError(x, y, w1, w2, activation)

  for (j in 1:epochs) {
    for (i in 1:length(x)) {
      gradient <- backPropagation(x[i], y[i], w1, w2, activation, derivative)
      # Adjusting model parameters for a given number of epochs
      w1 <- w1 - learnRate * gradient[[1]]
      w2 <- w2 - learnRate * gradient[[2]]
    }
    SSEvec[j+1] <- modelError(x, y, w1, w2, activation) 
    # Storing SSE values after each iteration
    }
    # Beta vector holding model parameters
    B <- list(w1, w2)
    result <- list(B, SSEvec)
    return(result)
}

model <- SGD(x, y(x), w1, w2, 
             activation = sigmoid, 
             derivative = derivativeActivation,
             learnRate = 0.01, 
             epochs = 200)

SSE <- model[[2]]

model_data <- tibble(x=seq(0, 200, 1), SSE)

ggplot(model_data,aes(x, SSE)) +
  geom_line(linewidth=0.1)+
  geom_point(shape=21, 
             stroke=0.2, 
             fill=alpha("steelblue", 0.3),
             color="brown") +
  labs(title="Model SSE by Number of Epochs",
       x = "Epochs", y = "Error")

new_w1 <- model[[1]][[1]]
new_w2 <- model[[1]][[2]]

par(mfrow=c(1,2))
plot(w1,new_w1)
abline(0,1)

plot(w2,new_w2)
abline(0,1)

y_pred <- feedForward(x, new_w1, new_w2, sigmoid)

data %>%
  mutate(y_pred=y_pred) %>%
  pivot_longer(cols = c(y, y_pred)) %>%
  ggplot(aes(x, value, group=name, color=name)) +
  geom_point(shape=21, stroke=0.5) +
  geom_line() +
  scale_color_discrete(type = c("steelblue", "red")) +
  labs(title= "Target Response vs. Predictions",
       x="Observations", 
       y="Responses")

Resources

1. The code used for this example is customized from tristanoprofetto github repository: https://github.com/tristanoprofetto/neural-networks/blob/main/ANN/Regressor/feedforward.R
2. StatQuest: Neural Networks Pt. 1: Inside the Black Box https://www.youtube.com/watch?v=CqOfi41LfDw
3. Other-Resources: https://towardsdatascience.com/the-mostly-complete-chart-of-neural-networks-explained-3fb6f2367464

R-Ladies Rome Events

urlname <- "rladies-rome"
events <- get_events(urlname)
dplyr::arrange(events, desc(time))%>%
  head()

urlname <- c("rladies-paris","rladies-rome")
events <- purrr::map(urlname,get_events)
dat <- dplyr::bind_rows(events)
dat%>%
  mutate(link=gsub("https://www.meetup.com/","",link),
         chapter=stringr::str_extract(link, "^rladies(.+?)/"),
         chapter=gsub("/","",chapter))%>%
  count(chapter)

All Chapters Events

To do it for all chapters on meetup, we need the list of the chapters from the rladies github archive.

data <- jsonlite::fromJSON('https://raw.githubusercontent.com/rladies/meetup_archive/main/data/events.json')

chapter <- data %>%
  count(group_urlname)%>%
  filter(!str_detect(group_urlname,"@"))
chapters <- chapter$group_urlname

events <- purrr::map(chapters,get_events)
# saveRDS(events,"events.rds")
# another way
# x <- lapply(paths, func)
# res <- dplyr::bind_rows(x)

bind_rows(events[1])%>%head()

dat <- dplyr::bind_rows(events)
# saveRDS(dat,"dat.rds")

dat1 <- dat%>% 
  mutate(link=gsub("https://www.meetup.com/","",link),
         chapter=stringr::str_extract(link, "^rladies(.+?)/"),
         chapter=gsub("/","",chapter))%>%
  relocate(chapter)

# saveRDS(dat1,"dat1.rds")

dat2 <- dat1%>%
  select(time,chapter,title,going,venue_city,
         venue_lon,venue_lat,venue_state,venue_country)%>%
  mutate(time=as.Date(time))%>%
  arrange(desc(going))

dat2%>%
  mutate(year=year(time),.after = time)%>%
  pull(year)%>%
  summary(year)

dat3 <- dat2%>%
  tidytext::unnest_tokens(word, title,drop = F)%>%
  select(chapter,title,going,word)%>% 
  anti_join(get_stopwords())%>%
  filter(!str_length(word)<=3)

dat3%>%
  count(word, sort = TRUE) %>%
  with(wordcloud::wordcloud(word, n, max.words = 100))

Latent Dirichlet Allocation with the topicmodels package

chapters_dtm <- dat3 %>%
  count(title, word, sort = TRUE)%>%
  cast_dtm(title, word, n)

chapters_dtm

chapters_lda <- topicmodels::LDA(chapters_dtm, 
                    k = 4, 
                    control = list(seed = 1234))
chapters_lda_td <- tidy(chapters_lda)
chapters_lda_td
top_terms <- chapters_lda_td %>%
  group_by(topic) %>%
  slice_max(beta, n = 5) %>%
  ungroup() %>%
  arrange(topic, -beta)

top_terms

top_terms %>%
  mutate(term = reorder_within(term, beta, topic)) %>%
  ggplot(aes(term, beta)) +
  geom_col() +
  scale_x_reordered() +
  facet_wrap(vars(topic), scales = "free_x")


assignments <- augment(chapters_lda, data = chapters_dtm)

assignments%>%
  filter(!term=="ladies")

# how words in titles changed overtime
inaug_freq <- dat3 %>%
  inner_join(dat2,by=c("chapter","title","going"))%>%#View
  count(time, word) %>%
  complete(time, word, fill = list(n = 0)) %>%
  group_by(time) %>%
  mutate(time_total = sum(n), 
         percent = n / time_total) %>%
  ungroup()

inaug_freq

# library(broom)
models <- inaug_freq %>%
  group_by(word) %>%
  filter(sum(n) > 50) %>%
  group_modify(
    ~ tidy(glm(cbind(n, time_total - n) ~ time, ., 
               family = "binomial"))
  ) %>%
  ungroup() %>%
  filter(term == "time")

models
models %>%
  filter(term == "time") %>%
  arrange(desc(abs(estimate)))

models %>%
  mutate(adjusted.p.value = p.adjust(p.value)) %>%
  ggplot(aes(estimate, adjusted.p.value)) +
  geom_point(shape=".") +
  #scale_y_log10() +
  geom_text(aes(label = word), 
            #vjust = 1, hjust = 1, 
            check_overlap = TRUE) +
  labs(x = "Estimated change over time", y = "Adjusted p-value")

models %>%
  slice_max(abs(estimate), n = 6) %>%
  inner_join(inaug_freq) %>%
  ggplot(aes(time, percent)) +
  geom_point() +
  geom_smooth() +
  facet_wrap(vars(word)) +
  scale_y_continuous(labels = scales::percent_format()) +
  labs(y = "Frequency of word in speech")

Data ready from the GitHub Repo

Download the georgia-1880-county-shapefile.zip file from: https://github.com/ajstarks/dubois-data-portraits/tree/master/challenge/2024/challenge01

georgia_shp <- sf::read_sf("data/georgia-1880-county-shapefile")

# georgia_shp%>%head

georgia_shp%>%
  ggplot()+
  geom_sf()

dat_sf <- georgia_shp%>%
  janitor::clean_names()%>%
  separate(data1870,into=c("up70","down70"))%>%
  separate(data1880_p,into=c("up80","down80"))%>%
  mutate(# pop 1870
         up70=ifelse(up70=="",0,up70),
         down70=ifelse(is.na(down70),0,down70),
         up70=as.numeric(up70),
         down70=as.numeric(down70),
         # pop 1880
         up80=ifelse(up80=="",0,up80),
         down80=ifelse(is.na(down80),0,down80),
         up80=as.numeric(up80),
         down80=as.numeric(down80))%>%
  rowwise()%>%
  mutate(pop70=mean(up70,down70),
         pop80=mean(up80,down80))%>%
  arrange(pop70,pop80)


data <- dat_sf%>%select(county=icpsrnam,
                pop70,pop80)%>%
  mutate(id=case_when(pop70 == 0 ~ 7,
                      pop70 == 1000 ~ 6,
                      pop70 == 2500 ~ 5,
                      pop70 == 5000 ~ 4,
                      pop70 == 10000 ~ 3,
                      pop70 == 15000 ~ 2,
                      pop70 == 20000 ~ 1),
         pop70=case_when(pop70 == 0 ~ "UNDER 1,000",
                         pop70 == 1000 ~ "1000 TO 2,500",
                         pop70 == 2500 ~ "2,500 TO 5,000",
                         pop70 == 5000 ~ "5,000 TO 10,000",
                         pop70 == 10000 ~ "10,000 TO 15,000",
                         pop70 == 15000 ~ "15,000 TO 20,000",
                         pop70 == 20000 ~ "20,000 TO 30,000"))%>%
  # pop80
    mutate(id=case_when(pop80 == 0 ~ 7,
                      pop80 == 1000 ~ 6,
                      pop80 == 2500 ~ 5,
                      pop80 == 5000 ~ 4,
                      pop80 == 10000 ~ 3,
                      pop80 == 15000 ~ 2,
                      pop80 == 20000 ~ 1),
         pop80=case_when(pop80 == 0 ~ "UNDER 1,000",
                         pop80 == 1000 ~ "1000 TO 2,500",
                         pop80 == 2500 ~ "2,500 TO 5,000",
                         pop80 == 5000 ~ "5,000 TO 10,000",
                         pop80 == 10000 ~ "10,000 TO 15,000",
                         pop80 == 15000 ~ "15,000 TO 20,000",
                         pop80 == 20000 ~ "20,000 TO 30,000"))
data%>%count(id,pop80)

library(sysfonts)
library(showtext)
sysfonts::font_add_google("Public Sans","Public Sans")
# font_add_google("Carter One", "Carter One")
showtext::showtext_auto()
showtext::showtext_opts(dpi=320)

"#e7d6c5"

c("#483c32","#bbaa98")

legend_colors <- c("#372c59","#7a5039","#c29e84","#d63352",
  "#e79d96","#edb456","#4b5c4f")

pop70_map <- data%>%
  ggplot()+
  geom_sf(aes(fill=pop70),
          show.legend = F,
          color="#483c32",alpha=0.9,
          linewidth=0.1)+
  scale_fill_manual(values=c("UNDER 1,000"="#4b5c4f",
                             "1000 TO 2,500"="#edb456",
                             "2,500 TO 5,000"="#e79d96",
                             "5,000 TO 10,000"="#d63352",
                             "10,000 TO 15,000"="#c29e84",
                             "15,000 TO 20,000"="#7a5039",
                             "20,000 TO 30,000"="#372c59"),na.value = "#e0cebb")+
    annotate("text", x = -84.45, y = 35.1,
           label = "1870",
           size = 3.5,color="#483c32",
           fontface = "bold",
           family =  "Public Sans" ) +
   coord_sf(crs=4326,clip = "off")+
  ggthemes::theme_map()+
  theme(plot.background = element_rect(color="#e7d6c5",fill="#e7d6c5"),
        panel.background = element_rect(color="#e7d6c5",fill="#e7d6c5"))
  
pop70_map

pop80_map <- data%>%
  ggplot()+
  geom_sf(aes(fill=pop80),
          show.legend = F,
          color="#483c32",alpha=0.9,
          linewidth=0.1)+
  scale_fill_manual(values=c("UNDER 1,000"="#4b5c4f",
                             "1000 TO 2,500"="#edb456",
                             "2,500 TO 5,000"="#e79d96",
                             "5,000 TO 10,000"="#d63352",
                             "10,000 TO 15,000"="#c29e84",
                             "15,000 TO 20,000"="#7a5039",
                             "20,000 TO 30,000"="#372c59"),na.value = "#e0cebb")+
      annotate("text", x = -84.45, y = 35.1,
           label = "1880",
           size = 3.5,color="#483c32",
           fontface = "bold",
           family =  "Public Sans" ) +
  coord_sf(crs=4326,clip = "off")+
  ggthemes::theme_map()+
  theme(plot.background = element_rect(color="#e7d6c5",fill="#e7d6c5"),
        panel.background = element_rect(color="#e7d6c5",fill="#e7d6c5"))
  
pop80_map

pop70_map+ ggplot() + ggplot()+ pop80_map + plot_layout(ncol = 2,nrow = 2)

legend1 <- tibble(x=0,y=c(4,3,2,1),
       label=c("5,000 TO 10,000",
                   "2,500 TO 5,000",
                    "1000 TO 2,500",
                   "UNDER 1,000"),
       pal=c("#d63352","#e79d96","#edb456","#4b5c4f"))%>%
  mutate(pal=as.factor(pal))
legend1

legend1_plot <- legend1%>%
  ggplot(aes(x,y))+
  geom_point(aes(fill=label),
             shape=21,stroke=0.1,
             size=8.5,
             show.legend = F)+
  scale_fill_manual(values=c("5,000 TO 10,000"="#d63352",
                                "2,500 TO 5,000"="#e79d96",
                                "1000 TO 2,500"="#edb456",
                                "UNDER 1,000"="#4b5c4f"))+
  geom_text(aes(label=label),
            family="Public Sans",
            size=3.5,color="#7a5039",
            nudge_x = 0,hjust=-0.2)+
  coord_cartesian(xlim=c(-0.2,1),ylim =c(-0,5) )+
  ggthemes::theme_map()+
  theme(plot.background = element_rect(color="#e7d6c5",fill="#e7d6c5"),
        panel.background = element_rect(color="#e7d6c5",fill="#e7d6c5"))
legend1_plot

legend2 <- tibble(x=0,y=c(1,2,3),
       label=c("10,000 TO 15,000",
               "15,000 TO 20,000",
               "BETWEEN 20,000 AND 30,000"),
       color=c("#c29e84","#7a5039","#372c59"))                             

legend2_plot <- legend2%>%
  ggplot(aes(x,y))+
  geom_point(aes(fill=label),
             shape=21,stroke=0.1,
             size=8.5,
             show.legend = F)+
  scale_fill_manual(values=c("10,000 TO 15,000"="#c29e84",
                             "15,000 TO 20,000"="#7a5039",
                             "BETWEEN 20,000 AND 30,000"="#372c59"))+
  geom_text(aes(label=label),
            size=3.5,color="#7a5039",
            family="Public Sans",
            nudge_x = 0.5,hjust=0)+
  coord_cartesian(xlim=c(-0.2,7),ylim =c(-1,4) )+
  ggthemes::theme_map()+
  theme(plot.background = element_rect(color="#e7d6c5",fill="#e7d6c5"),
        panel.background = element_rect(color="#e7d6c5",fill="#e7d6c5"))


legend2_plot

pop70_map+ legend2_plot + legend1_plot+ pop80_map + plot_layout(ncol = 2,nrow = 2)+plot_annotation(
  title = "NEGRO POPULATION OF GEORGIA BY COUNTIES.",
  caption="#DuboisChallenge24| Week1 | by Federica Gazzelloni",
  theme = theme_void(base_family = "Public Sans"))&
  theme(text=element_text(color="#483c32",face="bold"),
        plot.title = element_text(hjust=0.5),
        plot.caption = element_text(size=9),
        plot.background = element_rect(color="#e7d6c5",fill="#e7d6c5"),
        panel.background = element_rect(color="#e7d6c5",fill="#e7d6c5"))

ggsave("challenge01.png",bg="#e7d6c5",height = 8.8)

Example Scenario: Work Environment

Let’s consider a hypothetical work environment where the number of women (W) is greater than the number of men (M). However, when looking at the distribution of managerial positions (P), it seems that more men occupy higher-level positions compared to women.

Now, suppose there’s a characteristic Z, representing gender, and you suspect it might influence the choice of assigning a managerial position (P) because a specific time dedicated to a critical task (T) is primarily marketed toward men (M).

To illustrate this paradox, we’ll create synthetic data in R.

library(dplyr)

set.seed(123)

n <- 1000  # Number of employees 
W <- round(runif(n, 200, 800))  # Number of women
M <- n - W  # Number of men

P_W <- round(runif(W, 0, 1))  # 0 for no managerial position, 1 for managerial position for women
P_M <- round(runif(M, 0.2, 1))  # Higher chance of managerial position for men due to confounding variable

w <- tibble(gender="Women",count=W,manager=P_W)

m <- tibble(gender="Men",count=M,manager=P_M)

data <- rbind(w,m)
data%>%head

# A tibble: 6 × 3
  gender count manager
  <chr>  <dbl>   <dbl>
1 Women    373       0
2 Women    673       1
3 Women    445       0
4 Women    730       1
5 Women    764       1
6 Women    227       0

summary(data)

    gender              count        manager      
 Length:2000        Min.   :200   Min.   :0.0000  
 Class :character   1st Qu.:352   1st Qu.:0.0000  
 Mode  :character   Median :500   Median :1.0000  
                    Mean   :500   Mean   :0.5615  
                    3rd Qu.:648   3rd Qu.:1.0000  
                    Max.   :800   Max.   :1.0000  

Calculate the proportion of managerial positions for each gender

proportion_table <- data %>%
  group_by(gender) %>%
  summarize(proportion = mean(manager))

proportion_table

# A tibble: 2 × 2
  gender proportion
  <chr>       <dbl>
1 Men         0.626
2 Women       0.497

library(ggplot2)
proportion_table%>%
  ggplot(aes(gender,proportion,fill=gender))+
  geom_col(color="white",show.legend = F)+
  scale_fill_viridis_d()+
  labs(title = "Proportion of Managers by Gender",
       subtitle = "Example of the Simpson's Paradox",
       x="",
       caption = "Data: Syntetic | Graphics: Federica Gazzelloni") +
  coord_equal()+
  ggthemes::theme_pander()+
  theme(plot.caption = element_text(hjust = 0.5))

HIV average values (2010-2020)

This first dataset contains the average values, obtained by averaging the lower and upper bounds of 2010 and 2020 HIV infections for 173 countries.

aids_avg <- read.csv("data/aids_avg.csv")
aids_avg <- aids_avg%>%
  filter(!country=="Global")%>%
  filter(!country=="India")%>%
  rename(aids_cc = aids_change2)

aids_avg%>%dim

The percent change relative to the sum of changes for all countries is given by:

This will give you the percent change for each country relative to the sum of all changes. As well as the percentage contribution of each country's change to the total change can be obtained.

HIV Prevalence ratio (2010-2020)

prevalence_rt <- read.csv("data/Epidemic transition metrics_Incidence_prevalence ratio.csv")

aids_prevalence_rt<-prevalence_rt%>%
  filter(!Country=="Global")%>%
  select(!contains("Footnote"))%>%
  select(contains(c("Country","2010","2020")))%>%
  mutate(avg_2010=(as.numeric(X2010_upper)-as.numeric(X2010_lower))/2,
         avg_2020=(as.numeric(X2020_upper)-as.numeric(X2020_lower))/2,
         aids_change=(avg_2020-avg_2010),
         country_change=round(aids_change/avg_2010,5),
         aids_prev_cc=round(aids_change/sum(aids_change,na.rm = T),5))

HIV Incidence Mortality Ratio (2010-2020)

inc_mort_ratio <- read_csv("data/Epidemic transition metrics_Incidence_mortality ratio.csv")

aids_inc_mort_ratio <- inc_mort_ratio%>%
  janitor::clean_names()%>%
    filter(!country=="Global")%>%
  select(!contains("Footnote"))%>%
  select(contains(c("Country","2010","2020")))%>%
  mutate(avg_2010=(as.numeric(x2010_upper)-as.numeric(x2010_lower))/2,
         avg_2020=(as.numeric(x2020_upper)-as.numeric(x2020_lower))/2,
         aids_change=(avg_2020-avg_2010),
         country_change=round(aids_change/avg_2010,5),
         aids_imr_cc=round(aids_change/sum(aids_change,na.rm = T),5))