{"id":57,"date":"2026-09-25T13:55:36","date_gmt":"2026-09-25T20:55:36","guid":{"rendered":"https:\/\/blogs.reed.edu\/datalab\/?p=57"},"modified":"2026-09-25T16:07:36","modified_gmt":"2026-09-25T23:07:36","slug":"whos-the-fattest-of-them-all","status":"publish","type":"post","link":"https:\/\/blogs.reed.edu\/datalab\/2026\/09\/25\/whos-the-fattest-of-them-all\/","title":{"rendered":"Who’s the fattest of them all?"},"content":{"rendered":"\n
\n
\"a<\/figure>\n\n\n\n
\"another<\/figure>\n<\/figure>\n\n\n\n

Two fat bears: 435 Holly (left) and 747 (right)<\/p>\n\n\n\n

If you haven’t heard, Fat Bear Week is an annual online contest run by Katmai National Park and Preserve in Alaska. The public votes on which brown bear has done the best job of fattening up for winter. The site Explore.org runs live webcams at along the Brooks River where the bears hunt salmon, so people all over the world can watch the bears fish throughout the season.<\/p>\n\n\n\n

The contest of bear fatness started in 2014 as a day of single voting, but has expanded into a bracket style tournament that lasts a week. The contest continues until September 29th, so go vote for the fattest bear<\/a>!<\/p>\n\n\n\n

Our graphic this week shows the history of past champions and the correlation between votes in the contest and money raised for the nature preserve. <\/p>\n\n\n\n

\n
\"\"<\/figure>\n<\/figure>\n\n\n\n

Where did we find the data?<\/strong><\/h2>\n\n\n\n

There’s no official Fat Bear Week repository, so honestly getting the data was kind of a pain. Vote totals and winners were compiled by hand from the National Park Service, Explore.org (which hosts the bear cams and the voting), and news coverage of each year’s contest. The revenue of the Katmai Conservancy was much easier to find and comes from their IRS Form 990 filings. All nonprofits (including schools like Reed) have to file these publicly, which makes them a good source for data. You can find them on ProPublica’s website<\/a>. <\/p>\n\n\n\n

Some information was not possible to find. I couldn’t find the full list of bears entered in the competition for years before 2020, only the champion and runner up were available. The vote counts are also rough estimates that were reported from news sites, not hard numbers from Explore.org. I also couldn’t find any estimates for 2015-2017, but 1700 votes were cast in the first year of the contest. <\/p>\n\n\n\n

If you’re interested in looking at the raw data, you can find csv files with data for each year on the Quest repository of the Data@Reed Github page<\/a>. The ‘summary.csv’ file contains the information used to make the graph, and the other files contain information about individual bears, their relation to one another, and the sources I used to find this data. <\/p>\n\n\n\n

Making the Graphic<\/strong><\/h2>\n\n\n\n

The code to the graphic is in ‘scripts\/analysis.R’ on the Github page, but I will copy the relevant portions of it below. There’s an additional script that pulls together data for the summary file and another that compiles the sources, but these aren’t really material to the analysis.<\/p>\n\n\n\n

The final figure is two charts stacked on top of each other and sharing one year axis. I used four packages besides the tidyverse: {ggstar}<\/a> for star-shaped markers, {patchwork}<\/a> for stacking plots, {ggtext}<\/a> for the boxed subtitle and caption, and {scales}<\/a> for axis labels.<\/p>\n\n\n\n

The first bit of the script just to see which bears had the most appearances in the contest so that we could only graph those. When I did this, bear 409 was not included because the data about entries wasn’t great for the first few years. So I forced the appearances to include Beadnose because she was a two-time champion. Then I added some labeling columns so that things would appear nicely on the graph and set how the years would be displayed on the x-axis in order to save room. <\/p>\n\n\n\n

\nClick to see the wrangling R script<\/summary>\n
\nlibrary(tidyverse)\nlibrary(ggstar)\nlibrary(patchwork)\nlibrary(ggtext)\n\n# --- Update summary.csv with labeled entries\/champion\/runner_up ---------\nappearances <- read_csv("data\/appearances.csv", show_col_types = FALSE)\nsummary_df <- read_csv("data\/summary.csv", show_col_types = FALSE)\nbears <- read_csv("data\/bears.csv", show_col_types = FALSE)\n\nbear_names \n  mutate(bear_id = as.character(bear_id)) |>\n  select(bear_id, name)\n\n# \" \" labels, falling back to just the bear_id\nlabel_bears \n    left_join(bear_names, by = \"bear_id\") |>\n    mutate(label = if_else(is.na(name), bear_id, str_c(bear_id, name, sep = \" \"))) |>\n    pull(label)\n}\n\n# Per-year entry list (2014-2020 = finalists only)\nentries_per_year \n  mutate(bear_label = label_bears(bear_id)) |>\n  arrange(bear_label) |>\n  summarize(entries = str_flatten(bear_label, collapse = \", \"), .by = year)\n\nsummary_out \n  select(-any_of(\"entries\")) |>\n  left_join(entries_per_year, by = \"year\") |>\n  relocate(entries, .after = year) |>\n  mutate(\n    year = as.integer(year),\n    champion = label_bears(champion),\n    runner_up = label_bears(runner_up)\n  )\n\nwrite_csv(summary_out, \"data\/summary.csv\")\n\n# --- Per-bear contest chart ---------------------------------------------\n# TODO: bump a bear now that 409 is force-included (8 shown)\nmin_appearances <- 4\nforce_include <- c("409")\n\ncompleted_appearances \n  filter(year != 2026)\n\nqualifying \n  count(bear_id, name = \"n_appearances\") |>\n  filter(n_appearances >= min_appearances | bear_id %in% force_include)\n\ncontest_data \n  inner_join(qualifying, by = \"bear_id\") |>\n  mutate(\n    label = label_bears(bear_id),\n    status = case_when(\n      result == \"champion\" ~ \"Champion\",\n      result == \"runner_up\" ~ \"Runner-up\",\n      TRUE ~ \"Entered\"\n    ) |> factor(levels = c(\"Entered\", \"Runner-up\", \"Champion\"))\n  ) |>\n  mutate(first_year = min(year), .by = bear_id) |>\n  mutate(label = fct_reorder(label, -first_year, .fun = min))\n\ncontest_span \n  summarize(min_year = min(year), max_year = max(year), .by = c(bear_id, label))\n\ncontest_years <- min(contest_data$year):max(contest_data$year)\n\n<\/details>\n<\/code><\/pre>\n<\/details>\n<\/ br>\n\n\n\n
Next I started arranging the plot. I created each component of the chart separately and then used the package {patchwork} to arrange them into one figure. I first started with just the title and the boxed text that I wanted to appear at the top and bottom. <\/p>\n\n\n\n
\nShow the graph headings code<\/summary>\n
\ntitle_text <- "It's Fat Bear Week!"\nsubtitle_text <- "Below are the historical top competitors for fattest bear in Katmai National Park Alaska, which has occurred annually since 2014. All bears have a numerical ID and some bears also have a name."\ntitle_style <- element_text(face = "bold", size = 28, hjust = 0.5)\n\n# Shared boxed-text style for subtitle\/caption\nboxed_text <- function(outer_margin) {\n  element_textbox_simple(\n    size = 11, face = "bold", color = "black", hjust = 0.5, halign = 0.5,\n    margin = outer_margin, padding = margin(5, 8, 5, 8),\n    linetype = 1, box.color = "grey60", linewidth = 0.4, fill = NA\n  )\n}\n<\/details>\n<\/code><\/pre>\n<\/details>\n<\/ br>\n\n\n\n
Then I made the top chart by using the geom_segment() command. A start shape isn’t an option within basic ggplot, so that’s where the {ggstar} package came in. Then I just did a lot of adjusting the theme to get things to look exactly<\/em> how I wanted them. That’s one of the greatest things about R is you can really customize things down to a very fine level. <\/p>\n\n\n\n
\nShow code to make the contest chart<\/summary>\n
\ntitle_text <- "It's Fat Bear Week!"\nsubtitle_text <- "Below are the historical top competitors for fattest bear in Katmai National Park Alaska, which has occurred annually since 2014. All bears have a numerical ID and some bears also have a name."\ntitle_style <- element_text(face = "bold", size = 28, hjust = 0.5)\n\n# Shared boxed-text style for subtitle\/caption\nboxed_text <- function(outer_margin) {\n  element_textbox_simple(\n    size = 11, face = "bold", color = "black", hjust = 0.5, halign = 0.5,\n    margin = outer_margin, padding = margin(5, 8, 5, 8),\n    linetype = 1, box.color = "grey60", linewidth = 0.4, fill = NA\n  )\n}\n<\/details>\n<\/code><\/pre>\n<\/details>\n<\/ br>\n\n\n\n
Next I made the revenue plot with the votes displayed on the same figure as an overlay. To do this, the y-axis on the left was set to show revenue and the y-axis on the right shows total vote. I got lucky here because these numbers scale almost identically. That often doesn’t happen, so then you’d need to use transformations to make your it work on the same figure, or just separate the two data sources to their own figures. <\/p>\n\n\n\n
\nShow code to make the revenue and votes graph\n<\/summary>\n
\ntitle_text <- "It's Fat Bear Week!"\nsubtitle_text <- "Below are the historical top competitors for fattest bear in Katmai National Park Alaska, which has occurred annually since 2014. All bears have a numerical ID and some bears also have a name."\ntitle_style <- element_text(face = "bold", size = 28, hjust = 0.5)\n\n# Shared boxed-text style for subtitle\/caption\nboxed_text <- function(outer_margin) {\n  element_textbox_simple(\n    size = 11, face = "bold", color = "black", hjust = 0.5, halign = 0.5,\n    margin = outer_margin, padding = margin(5, 8, 5, 8),\n    linetype = 1, box.color = "grey60", linewidth = 0.4, fill = NA\n  )\n}\n<\/details>\n<\/code><\/pre>\n<\/details>\n<\/ br>\n\n\n\n
There’s a little bit of code in there that also runs cor() which calculates the Pearson’s correlation coefficient to test the linear correlation between the two datasets. Note that this isn’t saying anything about the cause of the trends, just that they do go up at a very similar rate, 0.93, where 1 is a perfect relationship. <\/p>\n\n\n\n
Then I added code to stack the figures and display only one x-axis at the bottom of the graph. <\/p>\n\n\n\n
\nShow code to make the contest chart<\/summary>\n
\n# --- Combined stacked figure -----------------------------------------\n# Drop top chart's x-axis (shown below instead)\ncontest_chart_top <- contest_chart +\n  theme(\n    axis.text.x = element_blank(),\n    axis.ticks.x = element_blank(),\n    plot.margin = margin(b = 2)\n  )\n\n# Shared year axis between the two panels\noverlay_chart_bottom <- overlay_chart +\n  scale_x_continuous(\n    breaks = contest_years, labels = abbreviate_years, limits = range(contest_years),\n    position = "top"\n  ) +\n  theme(\n    axis.text.x.top = element_text(color = "black", size = 12, face = "bold"),\n    axis.ticks.x.top = element_blank(),\n    plot.margin = margin(t = 2)\n  )\n\ncontest_and_overlay <- contest_chart_top \/ overlay_chart_bottom +\n  plot_layout(heights = c(3, 1.5), axis_titles = "collect") +\n  plot_annotation(\n    title = title_text,\n    subtitle = subtitle_text,\n    caption = caption_text,\n    theme = theme(\n      plot.title = title_style,\n      plot.subtitle = boxed_text(margin(t = 4, b = 6)),\n      plot.caption = boxed_text(margin(t = 6, b = 2))\n    )\n  )\ncontest_and_overlay\n<\/details>\n<\/code><\/pre>\n<\/details>\n<\/ br>\n\n\n\n
Adding the text boxes was the fiddliest bit. Honestly, that’s something that probably could have been done easier in an imaging program like PowerPoint or Adobe, but I get stubborn when I know something can be done in R, so I pushed until everything was tweaked just how I wanted it. <\/p>\n\n\n\n
Things you could do with this data<\/h2>\n\n\n\n
Inside the spreadsheets, there’s more data about each bear. There’s information on their family members, their sex, and the year they were born. A more thorough internet search could probably reveal even more than is already in there. Here are a few ideas of other things you could do with this data: <\/p>\n\n\n\n