How Far Does APOD Take Us?

Distribution of distances mentioned in NASA’s Astronomy Picture of the Day (2007-2025). Most content focuses on our galaxy, peaking where nebulae and star clusters reside.

Analyzing 19 years of NASA’s Astronomy Picture of the Day archive to explore the cosmic distances featured in explanations. A histogram reveals APOD’s ‘sweet spot’ between 1,000-2,000 light-years where nebulae and star clusters dominate, with reference lines marking key landmarks from Proxima Centauri to the Andromeda Galaxy.

Figure 1: Histogram showing the distribution of distances mentioned in NASA’s Astronomy Picture of the Day explanations from 2007-2025, plotted on a logarithmic scale from 1 to 10 billion light-years. The distribution peaks sharply between 1,000 and 2,000 light-years (labeled “The Nebula Peak”), where nebulae and star clusters reside. Five vertical reference lines mark key cosmic landmarks: Proxima Centauri at 4 light-years, the Orion Nebula at 1,500 light-years, the Galactic center at 26,000 light-years, the Milky Way diameter at 100,000 light-years, and the Andromeda Galaxy at 2.5 million light-years. A secondary peak appears around 10-100 million light-years, representing distant galaxies.

Steps to Create this Graphic

1. Load Packages & Setup

```{r}
#| label: load
#| warning: false
#| message: false
#| results: "hide"

## 1. LOAD PACKAGES & SETUP ----
suppressPackageStartupMessages({
if (!require("pacman")) install.packages("pacman")
pacman::p_load(
    tidyverse,     # Easily Install and Load the 'Tidyverse'
    ggtext,        # Improved Text Rendering Support for 'ggplot2'
    showtext,      # Using Fonts More Easily in R Graphs
    ggrepel,       # Non-overlapping Text Labels
    janitor,       # Simple Tools for Examining and Cleaning Dirty Data
    scales,        # Scale Functions for Visualization
    glue           # Interpreted String Literals
)
})

### |- figure size ----
camcorder::gg_record(
  dir    = here::here("temp_plots"),
  device = "png",
  width  = 8,
  height = 6,
  units  = "in",
  dpi    = 320
)

# Source utility functions
suppressMessages(source(here::here("R/utils/fonts.R")))
source(here::here("R/utils/social_icons.R"))
source(here::here("R/utils/image_utils.R"))
source(here::here("R/themes/base_theme.R"))
```

2. Read in the Data

```{r}
#| label: read
#| include: true
#| eval: true
#| warning: false

tt <- tidytuesdayR::tt_load(2026, week = 03)
apod_raw <- tt$apod |> clean_names()
rm(tt)
```

3. Examine the Data

```{r}
#| label: examine
#| include: true
#| eval: true
#| results: 'hide'
#| warning: false

glimpse(apod_raw)
```

4. Tidy Data

```{r}
#| label: tidy-fixed
#| warning: false

# Extract light-year distances from explanations
extract_distances <- function(text) {
  if (is.na(text)) {
    return(NA_real_)
  }
  pattern <- "(\\d{1,3}(?:,\\d{3})*(?:\\.\\d+)?)\\s*(million|billion)?\\s*light[\\-\\s]years?"
  matches <- str_match_all(tolower(text), pattern)[[1]]
  if (nrow(matches) == 0) {
    return(NA_real_)
  }

  val <- str_remove_all(matches[, 2], ",") |> as.numeric()
  multiplier <- case_when(
    matches[, 3] == "million" ~ 1e6,
    matches[, 3] == "billion" ~ 1e9,
    TRUE ~ 1
  )
  return(val * multiplier)
}

# Build distance dataset
distances_clean <- apod_raw |>
  mutate(dist_val = map(explanation, extract_distances)) |>
  unnest(dist_val) |>
  filter(!is.na(dist_val), dist_val > 0, dist_val < 1e10)

landmarks <- tibble(
  distance = c(4.24, 1500, 26000, 100000, 2500000),
  label = c(
    "Nearest star\n(Proxima Centauri)",
    "Orion Nebula\n(APOD favorite)",
    "Galactic\ncenter",
    "Milky Way\ndiameter",
    "Andromeda\nGalaxy"
  ),
  y_pos = c(255, 255, 275, 255, 255)
)
```

5. Visualization Parameters

```{r}
#| label: params
#| include: true
#| warning: false

### |-  plot aesthetics ----
colors <- get_theme_colors(
  palette = list(
      bar =   "#b066a2",     
      line =  "#58a6ff"
  )
)

### |- titles and caption ----
title_text = "How Far Does APOD Take Us?"

subtitle_text = str_glue(
    "Distribution of distances mentioned in NASA's **Astronomy Picture of the Day** (2007-2025).<br>",
    "Most content focuses on our galaxy, peaking where **nebulae and star clusters** reside."
    )

caption_text <- create_social_caption(
    tt_year = 2026,
    tt_week = 03,
    source_text = "NASA APOD Archive via NASA API"
)

### |-  fonts ----
setup_fonts()
fonts <- get_font_families()

### |-  plot theme ----
# Start with base theme
base_theme <- create_base_theme(colors)

# Add weekly-specific theme elements
weekly_theme <- extend_weekly_theme(
  base_theme,
  theme(
    # Text styling
    plot.title = element_text(
      face = "bold", family = fonts$title, size = rel(1.4),
      color = colors$title, margin = margin(b = 10), hjust = 0
    ),
    plot.subtitle = element_markdown(
      face = "italic", family = fonts$subtitle, lineheight = 1.2,
      color = colors$subtitle, size = rel(0.9), margin = margin(b = 20), hjust = 0
    ),

    # Grid
    panel.grid.minor = element_blank(),
    panel.grid.major.x = element_blank(),
    panel.grid.major = element_line(color = "gray90", linewidth = 0.25),

    # Axes
    axis.title = element_text(size = rel(0.8), color = "gray30"),
    axis.text = element_text(color = "gray30"),
    axis.text.y = element_text(size = rel(0.85)),
    axis.ticks = element_blank(),

    # Facets
    strip.background = element_rect(fill = "gray95", color = NA),
    strip.text = element_text(
      face = "bold",
      color = "gray20",
      size = rel(0.9),
      margin = margin(t = 6, b = 4)
    ),
    panel.spacing = unit(1.5, "lines"),

    # Legend elements
    legend.position = "plot",
    legend.title = element_text(
      family = fonts$subtitle,
      color = colors$text, size = rel(0.8), face = "bold"
    ),
    legend.text = element_text(
      family = fonts$tsubtitle,
      color = colors$text, size = rel(0.7)
    ),
    legend.margin = margin(t = 15),

    # Plot margin
    plot.margin = margin(10, 20, 10, 20),
    
  )
)

# Set theme
theme_set(weekly_theme)
```

6. Plot

```{r}
#| label: plot
#| warning: false

### |- Plot ----
p <- ggplot(distances_clean, aes(x = dist_val)) +
  # Annotate
  annotate("rect",
    xmin = 800, xmax = 3000, ymin = 0, ymax = 300,
    fill = colors$palette$bar, alpha = 0.08
  ) +
  annotate("text",
    x = 1800, y = 290, label = "THE NEBULA PEAK",
    family = fonts$text, size = 4, color = colors$palette$bar, fontface = "bold"
  ) +
  # Geoms
  geom_histogram(
    fill = colors$palette$bar, color = "white",
    bins = 60, alpha = 0.9
  ) +
  geom_segment(
    data = landmarks,
    aes(x = distance, xend = distance, y = 0, yend = 300),
    linetype = "dotted",
    color = colors$palette$line,
    linewidth = 0.5
  ) +
  geom_text(
    data = landmarks, aes(x = distance, y = y_pos, label = label),
    size = 2.8, family = fonts$text, fontface = "bold",
    lineheight = 0.85, vjust = 1, color = colors$text
  ) +
  # Scales
  scale_x_log10(
    expand = expansion(mult = c(0.02, 0.05)),
    breaks = 10^(0:10),
    labels = label_log()
  ) +
  scale_y_continuous(expand = expansion(mult = c(0, 0.15))) +
  coord_cartesian(clip = "off") +
  # Labs
  labs(
    title = title_text,
    subtitle = subtitle_text,
    caption = caption_text,
    x = "Distance (light-years)",
    y = "Number of\nMentions"
  ) +
  # Theme
  theme(
    axis.title.y = element_text(angle = 0, vjust = 0.95, hjust = 0, size = rel(0.8), face = "bold", color = colors$text),
    axis.title.x = element_text(size = rel(0.8), face = "bold", color = colors$text),
    axis.text = element_text(, color = colors$text, size = rel(0.6)),
    plot.title = element_markdown(
      size = rel(1.8),
      family = fonts$title,
      face = "bold",
      color = colors$title,
      lineheight = 1.15,
      margin = margin(t = 5, b = 5)
    ),
    plot.subtitle = element_markdown(
      size = rel(0.65),
      family = fonts$subtitle,
      color = colors$subtitle,
      lineheight = 1.5,
      margin = margin(t = 5, b = 5)
    ),
    plot.caption = element_markdown(
      size = rel(0.45),
      family = fonts$subtitle,
      color = colors$caption,
      hjust = 0,
      lineheight = 1.4,
      margin = margin(t = 10, b = 5)
    ),
  )
```

7. Save

```{r}
#| label: save
#| warning: false

### |-  plot image ----  
save_plot(
  plot = p, 
  type = "tidytuesday", 
  year = 2026, 
  week = 03, 
  width  = 8,
  height = 6,
  )
```

8. Session Info

Expand for Session Info

R version 4.4.1 (2024-06-14 ucrt)
Platform: x86_64-w64-mingw32/x64
Running under: Windows 11 x64 (build 26100)

Matrix products: default


locale:
[1] LC_COLLATE=English_United States.utf8 
[2] LC_CTYPE=English_United States.utf8   
[3] LC_MONETARY=English_United States.utf8
[4] LC_NUMERIC=C                          
[5] LC_TIME=English_United States.utf8    

time zone: America/New_York
tzcode source: internal

attached base packages:
[1] stats     graphics  grDevices datasets  utils     methods   base     

other attached packages:
 [1] here_1.0.1      glue_1.8.0      scales_1.3.0    janitor_2.2.0  
 [5] ggrepel_0.9.6   showtext_0.9-7  showtextdb_3.0  sysfonts_0.8.9 
 [9] ggtext_0.1.2    lubridate_1.9.3 forcats_1.0.0   stringr_1.5.1  
[13] dplyr_1.1.4     purrr_1.0.2     readr_2.1.5     tidyr_1.3.1    
[17] tibble_3.2.1    ggplot2_3.5.1   tidyverse_2.0.0 pacman_0.5.1   

loaded via a namespace (and not attached):
 [1] gtable_0.3.6       httr2_1.0.6        xfun_0.49          htmlwidgets_1.6.4 
 [5] gh_1.4.1           tzdb_0.5.0         vctrs_0.6.5        tools_4.4.0       
 [9] generics_0.1.3     parallel_4.4.0     curl_6.0.0         gifski_1.32.0-1   
[13] fansi_1.0.6        pkgconfig_2.0.3    lifecycle_1.0.4    farver_2.1.2      
[17] compiler_4.4.0     textshaping_0.4.0  munsell_0.5.1      codetools_0.2-20  
[21] snakecase_0.11.1   htmltools_0.5.8.1  yaml_2.3.10        crayon_1.5.3      
[25] pillar_1.9.0       camcorder_0.1.0    magick_2.8.5       commonmark_1.9.2  
[29] tidyselect_1.2.1   digest_0.6.37      stringi_1.8.4      labeling_0.4.3    
[33] rsvg_2.6.1         rprojroot_2.0.4    fastmap_1.2.0      grid_4.4.0        
[37] colorspace_2.1-1   cli_3.6.4          magrittr_2.0.3     utf8_1.2.4        
[41] withr_3.0.2        rappdirs_0.3.3     bit64_4.5.2        timechange_0.3.0  
[45] rmarkdown_2.29     tidytuesdayR_1.1.2 gitcreds_0.1.2     bit_4.5.0         
[49] ragg_1.3.3         hms_1.1.3          evaluate_1.0.1     knitr_1.49        
[53] markdown_1.13      rlang_1.1.6        gridtext_0.1.5     Rcpp_1.0.13-1     
[57] xml2_1.3.6         renv_1.0.3         vroom_1.6.5        svglite_2.1.3     
[61] rstudioapi_0.17.1  jsonlite_1.8.9     R6_2.5.1           systemfonts_1.1.0 

9. GitHub Repository

Expand for GitHub Repo

The complete code for this analysis is available in tt_2026_03.qmd.

For the full repository, click here.

10. References

Expand for References

1. Data Source:
   • TidyTuesday 2026 Week 03: Astronomy Picture of the Day (APOD) Archive
2. Cosmic Distance Landmarks:
   • NASA Imagine the Universe: Milky Way Galaxy
   • NASA Science: Orion Nebula (M42)
   • NASA Science: Andromeda Galaxy (M31)
   • ESA Gaia Mission: Proxima Centauri parallax measurements
3. Article:
   • NASA Science: How Big is Space?

11. Custom Functions Documentation

📦 Custom Helper Functions

This analysis uses custom functions from my personal module library for efficiency and consistency across projects.

Functions Used:

• fonts.R: setup_fonts(), get_font_families() - Font management with showtext
• social_icons.R: create_social_caption() - Generates formatted social media captions
• image_utils.R: save_plot() - Consistent plot saving with naming conventions
• base_theme.R: create_base_theme(), extend_weekly_theme(), get_theme_colors() - Custom ggplot2 themes

Why custom functions?
These utilities standardize theming, fonts, and output across all my data visualizations. The core analysis (data tidying and visualization logic) uses only standard tidyverse packages.

Source Code:
View all custom functions → GitHub: R/utils