出生数と合計特殊出生率の推移

概要

人口動態調査を使って，1899年からの出生数の推移と，戦後の合計特殊出生率のグラフを描く。

コードと実行結果

library(tidyverse)

── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.1.4     ✔ readr     2.1.5
✔ forcats   1.0.0     ✔ stringr   1.5.1
✔ ggplot2   3.5.1     ✔ tibble    3.2.1
✔ lubridate 1.9.3     ✔ tidyr     1.3.1
✔ purrr     1.0.2     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(estatapi)

このサービスは、政府統計総合窓口(e-Stat)のAPI機能を使用していますが、サービスの内容は国によって保証されたものではありません。

library(patchwork)

# e-statのappIDが必要
#   以下のページで利用申請(無料)をすればだれでも入手できる
#   https://www.e-stat.go.jp/api/
# appID = "入手したappIDをここに設定（行頭の#を外す）"

# グラフの軸を有効数字形式にする関数
# https://stats.biopapyrus.jp/r/ggplot/scientific-notation.html より

scientific_notation <- function(x) {
  x <- format(x, scientific = TRUE)
  x <- gsub("^(.*)e", "'\\1'e", x)
  x <- gsub("e", "%*%10^", x)
  x <- gsub("\\+", "", x)
  parse(text = x)
}

# e-Statからデータ取得
estat_vital <- estat_getStatsData(
  appId = appID,
  statsDataId = "0003411595", # 人口動態調査・人口動態統計・確定数・出生・4−1・上巻
  cdCat01 = c("00100", "00150")
)

Fetching record 1-242... (total: 242 records)

vital <- estat_vital %>%
  mutate(
    year = as.numeric(time_code) / 1000000,
    name = `出生数・出生率・出生性比`
  ) %>%
  select(year, name, value) %>%
  filter(year >= 1947) %>%
  pivot_wider(names_from = name)

# 最新データ追加

d2023 <- c(2023, 727277, 1.20) # 2023年の数値はまだ登録されていなかったので手動で追加

vital = rbind(vital, d2023)

# グラフ作成
birth <- vital %>%
  ggplot(aes(x = year, y = `出生数_総数`)) +
  geom_bar(stat = "identity", color = "gray", fill = "lightgray") +
  scale_y_continuous(
    labels = scientific_notation,
    limits = c(0, 3500000)
  ) +
  geom_text(
    aes(
      label = paste(format(`出生数_総数`, big.mark = ","), "\n (", year, ")", sep = "")
    ),
    nudge_y = 50000,
    color = "red",
    size = 4,
    data = subset(vital, year %in% c(1949, 1966, 1989, 2005, 2023))
  ) +
  labs(x = "", y = "出生数")

tfr <- vital %>%
  ggplot(aes(x = year, y = `合計特殊出生率`)) +
  geom_line(color = "gray") +
  geom_point(size = 1, color = "blue") +
  ylim(0.5, 5) +
  geom_text(
    aes(
      label = paste(`合計特殊出生率`, "\n (", year, ")", sep = "")
    ),
    nudge_y = -0.4,
    color = "red",
    size = 4,
    data = subset(vital, year %in% c(1947, 1966, 1989, 2005, 2023))
  ) +
  labs(x = "年", y = "合計特殊出生率")

# patchworkパッケージを使ったプロット
birth + tfr + plot_layout(ncol = 1)