NobelPrize.org API

# httr2 requests the data; jsonlite reads it; tidyverse helps clean and plot it.
library(httr2)
library(jsonlite)
library(tidyverse)
library(knitr)
library(scales)

blue_color <- "#0072B2"
teal_color <- "#009E73"
theme_set(theme_minimal(base_size = 12) + theme(plot.title.position = "plot"))

api_url <- "https://api.nobelprize.org/2.1/nobelPrizes"
snapshot_path <- "data/nobel_prizes_snapshot.json"

api_result <- tryCatch({
  response <- request(api_url) |>
    req_url_query(limit = 1000) |>
    req_timeout(seconds = 20) |>
    req_perform()
  list(json = resp_body_string(response), status = resp_status(response))
}, error = function(e) NULL)

if (is.null(api_result)) {
  if (!file.exists(snapshot_path)) {
    stop("API request failed and data/nobel_prizes_snapshot.json is missing. Save a real API snapshot or restore connectivity.")
  }
  raw_json <- paste(readLines(snapshot_path, warn = FALSE), collapse = "\n")
  data_source_used <- "Local API snapshot"
  request_status <- NA_integer_
} else {
  raw_json <- api_result$json
  data_source_used <- "Live Nobel Prize API"
  request_status <- api_result$status
}

nobel_raw <- fromJSON(raw_json, simplifyVector = FALSE)
stopifnot(is.list(nobel_raw$nobelPrizes), length(nobel_raw$nobelPrizes) > 0)
if (length(nobel_raw$nobelPrizes) >= 1000) {
  warning("The API returned 1000 prize records. Check pagination before treating these results as complete.")
}

request_check <- tibble(
  check = c("Source used", "HTTP status", "Prize records", "API version"),
  result = c(data_source_used,
             if (is.na(request_status)) "Not available" else as.character(request_status),
             as.character(length(nobel_raw$nobelPrizes)), "2.1")
)
kable(request_check, caption = "API retrieval check")

# Names can appear under different fields for individuals and organizations.
get_english <- function(x) {
  if (is.null(x) || is.null(x$en)) return(NA_character_)
  x$en
}

prizes_clean <- map_dfr(nobel_raw$nobelPrizes, function(prize) {
  category_name <- get_english(prize$category)
  award_year <- as.integer(prize$awardYear)
  tibble(
    prize_id = paste(category_name, award_year, sep = "-"),
    award_year = award_year,
    category = category_name,
    date_awarded = if (is.null(prize$dateAwarded)) NA_character_ else prize$dateAwarded,
    laureate_count = if (is.null(prize$laureates)) 0L else length(prize$laureates)
  )
})
stopifnot(!anyDuplicated(prizes_clean$prize_id))
stopifnot(!anyNA(prizes_clean$category), !anyNA(prizes_clean$award_year))
kable(head(prizes_clean, 8), caption = "First eight rows of the prize table")

laureates_clean <- map_dfr(nobel_raw$nobelPrizes, function(prize) {
  if (is.null(prize$laureates) || length(prize$laureates) == 0) return(tibble())
  category_name <- get_english(prize$category)
  award_year <- as.integer(prize$awardYear)
  prize_id <- paste(category_name, award_year, sep = "-")
  map_dfr(prize$laureates, function(laureate) {
    laureate_name <- coalesce(get_english(laureate$knownName),
                              get_english(laureate$orgName),
                              get_english(laureate$fullName))
    tibble(prize_id = prize_id,
           laureate_id = if (is.null(laureate$id)) NA_character_ else as.character(laureate$id),
           laureate_name = laureate_name,
           portion = if (is.null(laureate$portion)) NA_character_ else as.character(laureate$portion))
  })
})
stopifnot(nrow(laureates_clean) == sum(prizes_clean$laureate_count))
stopifnot(all(laureates_clean$prize_id %in% prizes_clean$prize_id))
kable(head(laureates_clean, 8), caption = "First eight rows of the laureate table")

data_quality <- tibble(
  check = c("Prize rows", "Duplicate prize IDs", "Laureate rows",
            "Missing laureate names", "Prize records with no listed laureate",
            "First award year", "Last award year"),
  result = c(nrow(prizes_clean), sum(duplicated(prizes_clean$prize_id)),
             nrow(laureates_clean), sum(is.na(laureates_clean$laureate_name)),
             sum(prizes_clean$laureate_count == 0),
             min(prizes_clean$award_year), max(prizes_clean$award_year))
)
kable(data_quality, caption = "Data checks before analysis")

category_totals <- prizes_clean |>
  group_by(category) |>
  summarise(prize_records = n(), laureate_entries = sum(laureate_count), .groups = "drop") |>
  arrange(desc(laureate_entries))
kable(category_totals,
      col.names = c("Category", "Prize records", "Laureate entries"),
      caption = "Prize records and laureate entries by category")

ggplot(category_totals,
       aes(x = laureate_entries, y = fct_reorder(category, laureate_entries))) +
  geom_col(fill = blue_color, width = 0.7) +
  geom_text(aes(label = comma(laureate_entries)), hjust = -0.15, size = 3.6) +
  scale_x_continuous(expand = expansion(mult = c(0, 0.12))) +
  labs(title = "Laureate entries by category", x = "Laureate entries", y = NULL)

decade_summary <- prizes_clean |>
  filter(laureate_count > 0) |>
  mutate(decade = (award_year %/% 10) * 10) |>
  group_by(decade) |>
  summarise(awarded_prizes = n(), average_laureates = mean(laureate_count),
            .groups = "drop") |>
  arrange(decade)
kable(decade_summary, digits = 2,
      col.names = c("Decade", "Prize records with laureates", "Average laureates per prize"),
      caption = "Average listed laureates per prize by decade")

ggplot(decade_summary, aes(x = decade, y = average_laureates)) +
  geom_line(color = teal_color, linewidth = 1) +
  geom_point(color = teal_color, size = 2.5) +
  scale_x_continuous(breaks = decade_summary$decade) +
  labs(title = "Average laureates per prize by decade",
       subtitle = "The 2020s are not a complete decade",
       x = "Decade", y = "Average laureates per prize") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

unawarded_by_category <- prizes_clean |>
  filter(laureate_count == 0) |>
  count(category, name = "records_without_laureate", sort = TRUE)
kable(unawarded_by_category,
      col.names = c("Category", "Records without a listed laureate"),
      caption = "Prize records with no listed laureate")

laureate_awards <- laureates_clean |>
  inner_join(prizes_clean |> select(prize_id, award_year, category),
             by = "prize_id", relationship = "many-to-one")
repeat_laureates <- laureate_awards |>
  filter(!is.na(laureate_id)) |>
  group_by(laureate_id) |>
  summarise(laureate_name = first(na.omit(laureate_name), default = NA_character_),
            prize_records = n_distinct(prize_id),
            awards = paste(unique(paste(award_year, category)), collapse = "; "),
            .groups = "drop") |>
  filter(prize_records > 1) |>
  arrange(desc(prize_records), laureate_name)
kable(repeat_laureates |> select(laureate_name, prize_records, awards),
      col.names = c("Laureate", "Prize records", "Years and categories"),
      caption = "Laureates appearing in more than one prize record")