所得分布のモデル化

対数ロジスティック分布は，経済学ではFisk分布としても知られており，所得分布を表すのによく用いられています． この確率分布の利点は，所得の中央値とジニ係数から簡単にパラメータを推定できる点にあります．

具体的には，この確率分布は尺度（scale）パラメータと形状（shape）パラメータの2つのパラメータをもちますが， これらのパラメータについて以下のような関係が成り立つことが知られています． これらの関係式より，所得の中央値とジニ係数から簡単に対数ロジスティック分布のパラメータを設定することができます．

• 尺度パラメータが所得の中央値に等しい

• 形状パラメータはジニ係数の逆数に等しい

使用データ

この記事では，OECDが公開しているSociety at a Glance 2024: OECD Social Indicatorsに掲載されている以下のデータを使用します．

• 家計所得の中央値³: Annual median equivalised disposable income, in 2021, USD at PPP rates
• ジニ係数: Gini coefficient of household disposable income and gap between richest and poorest 10%, in 2021

まず，以下のコードでデータをダウンロードします．

library(fs)
library(tidyverse)

file_median_income <- "income-distribution-from-median-and-gini-log-logistic/median_income_oecd_2021.xlsx"
if (!file_exists(file_median_income)) {
 curl::curl_download("https://stat.link/1or2b8", file_median_income) 
}

file_gini_coefficient <- "income-distribution-from-median-and-gini-log-logistic/gini_coefficient_oecd_2021.xlsx"
if (!file_exists(file_gini_coefficient)) {
 curl::curl_download("https://stat.link/3f18vc", file_gini_coefficient)
}

所得分布の可視化

まず，ダウンロードしたExcelファイルから必要なデータを読み込みます．

library(readxl)

median_income <- read_excel(
  file_median_income,
  sheet = "Data4.1",
  range = cell_limits(ul = c(12, 1), lr = c(NA, 3)),
  col_names = c("country_name", "country_code", "median_income_usd_ppp"),
  col_types = c(rep("text", 2), "numeric")
) |> 
  drop_na(country_name) |> 
  arrange(country_name)

gini_coefficient <- read_excel(
  file_gini_coefficient,
  sheet = "data",
  range = cell_limits(ul = c(12, 4), lr = c(NA, 5)),
  col_names = c("country_name", "gini_coefficient"),
  col_types = c("text", "numeric")
) |> 
  drop_na(country_name) |> 
  arrange(country_name)

読み込んだデータは以下の通りです．

median_income

gini_coefficient

次に，読み込んだデータを結合し，対数ロジスティック分布のパラメータを計算します．

income_distribution_params <- median_income |> 
  inner_join(gini_coefficient, by = join_by(country_name)) |> 
  mutate(
    scale_param = median_income_usd_ppp,
    shape_param = 1 / gini_coefficient,
    .keep = "unused"
  )
income_distribution_params

次に，各国の所得分布を可視化します． 以下のコードでは，対数ロジスティック分布の確率密度関数を用いて， G7各国の所得分布をプロットしています．

data_income_distribution_params <- income_distribution_params |>
  # G7
  filter(
    country_name %in%
      c(
        "Canada",
        "France",
        "Germany",
        "Italy",
        "Japan",
        "United Kingdom",
        "United States"
      )
  ) |>
  expand_grid(
    income = seq(0, 150000, by = 1000)
  ) |>
  mutate(
    density = VGAM::dfisk(
      income,
      scale = scale_param,
      shape1.a = shape_param
    )
  ) |>
  select(!c(scale_param, shape_param))

plot_income_distribution <- data_income_distribution_params |> 
  ggplot(aes(x = income, y = density, color = country_name)) +
  geom_line() +
  scale_x_continuous(labels = scales::dollar_format(prefix = "$", big.mark = ",", accuracy = 1)) +
  scale_y_continuous(labels = scales::comma_format(accuracy = 0.0001)) +
  labs(
    title = "OECD各国の所得分布の推定（対数ロジスティック分布）",
    x = "所得（USD PPP）",
    y = "確率密度",
    color = "国名"
  ) +
  theme_minimal()

plotly::ggplotly(plot_income_distribution)

おわりに

この記事では，対数ロジスティック分布を用いて所得の中央値とジニ係数から所得分布を再現する方法を紹介しました． 対数ロジスティック分布を用いることで，所得の中央値とジニ係数という2つの指標から所得分布の概形を捉えることができます．

なお，この方法は，実際の所得分布とは異なる場合があることに注意してください． より正確な所得分布を推定するには，追加のデータやより複雑なモデルが必要となります．

例

次のデータ処理を，ステップバイステップのデータ処理に変換してみましょう．この処理では，penguins データを使って，島・種・年ごとのペンギンの平均体重を算出します．

library(tidyverse)

as_tibble(penguins) |>
  select(species, island, body_mass, year) |>
  filter(!is.na(body_mass)) |>
  mutate(
    # body_massをkgに変換
    body_mass = units::set_units(body_mass, g) |>
      units::set_units("kg")
  ) |>
  summarise(
    mean_body_mass = mean(body_mass),
    .by = c(island, species, year)
  ) |>
  arrange(island, species, year)

# A tibble: 15 × 4
   island    species    year mean_body_mass
   <fct>     <fct>     <int>           [kg]
 1 Biscoe    Adelie     2007           3.62
 2 Biscoe    Adelie     2008           3.63
 3 Biscoe    Adelie     2009           3.86
 4 Biscoe    Gentoo     2007           5.07
 5 Biscoe    Gentoo     2008           5.02
 6 Biscoe    Gentoo     2009           5.14
 7 Dream     Adelie     2007           3.67
 8 Dream     Adelie     2008           3.76
 9 Dream     Adelie     2009           3.65
10 Dream     Chinstrap  2007           3.69
11 Dream     Chinstrap  2008           3.8 
12 Dream     Chinstrap  2009           3.72
13 Torgersen Adelie     2007           3.76
14 Torgersen Adelie     2008           3.86
15 Torgersen Adelie     2009           3.49

library(adverbial)

data_wrangler <- step_by_step(
  c(
    select_step = "データフレームから列を選択",
    filter_step = "データフレームから行を絞り込み",
    mutate_step = "データフレームの列を変換",
    summarise_step = "データフレームを集計",
    arrange_step = "データフレームの行を並べ替え"
  )
)

select_step <- as_step(select, "select_step")
filter_step <- as_step(filter, "filter_step")
mutate_step <- as_step(mutate, "mutate_step")
summarise_step <- as_step(summarise, "summarise_step")
arrange_step <- as_step(arrange, "arrange_step")

data_wrangler(as_tibble(penguins))

# Steps:
# ☐ 1. select_step:    データフレームから列を選択
# ☐ 2. filter_step:    データフレームから行を絞り込み
# ☐ 3. mutate_step:    データフレームの列を変換
# ☐ 4. summarise_step: データフレームを集計
# ☐ 5. arrange_step:   データフレームの行を並べ替え
# ℹ Please call `select_step()` to continue.
#
# A tibble: 344 × 8
   species island    bill_len bill_dep flipper_len body_mass sex     year
 * <fct>   <fct>        <dbl>    <dbl>       <int>     <int> <fct>  <int>
 1 Adelie  Torgersen     39.1     18.7         181      3750 male    2007
 2 Adelie  Torgersen     39.5     17.4         186      3800 female  2007
 3 Adelie  Torgersen     40.3     18           195      3250 female  2007
 4 Adelie  Torgersen     NA       NA            NA        NA <NA>    2007
 5 Adelie  Torgersen     36.7     19.3         193      3450 female  2007
 6 Adelie  Torgersen     39.3     20.6         190      3650 male    2007
 7 Adelie  Torgersen     38.9     17.8         181      3625 female  2007
 8 Adelie  Torgersen     39.2     19.6         195      4675 male    2007
 9 Adelie  Torgersen     34.1     18.1         193      3475 <NA>    2007
10 Adelie  Torgersen     42       20.2         190      4250 <NA>    2007
# ℹ 334 more rows

data_wrangler(as_tibble(penguins)) |>
  select_step(species, island, body_mass, year) |>
  filter_step(!is.na(body_mass)) |>
  mutate_step(
    # body_massをkgに変換
    body_mass = units::set_units(body_mass, g) |>
      units::set_units("kg")
  ) |>
  # ステップバイステップの処理中に別の関数を使うこともできます
  as_step(head)(n = 3)

# Steps:
# ☒ 1. select_step:    データフレームから列を選択
# ☒ 2. filter_step:    データフレームから行を絞り込み
# ☒ 3. mutate_step:    データフレームの列を変換
# ☐ 4. summarise_step: データフレームを集計
# ☐ 5. arrange_step:   データフレームの行を並べ替え
# ℹ Please call `summarise_step()` to continue.
#
# A tibble: 3 × 4
  species island    body_mass  year
* <fct>   <fct>          [kg] <int>
1 Adelie  Torgersen      3.75  2007
2 Adelie  Torgersen      3.8   2007
3 Adelie  Torgersen      3.25  2007

data_wrangler(as_tibble(penguins)) |>
  select_step(species, island, body_mass, year) |>
  filter_step(!is.na(body_mass)) |>
  mutate_step(
    # body_massをkgに変換
    body_mass = units::set_units(body_mass, g) |>
      units::set_units("kg")
  ) |>
  summarise_step(
    mean_body_mass = mean(body_mass),
    .by = c(island, species, year)
  ) |>
  arrange_step(island, species, year) |>
  end_step()

# A tibble: 15 × 4
   island    species    year mean_body_mass
 * <fct>     <fct>     <int>           [kg]
 1 Biscoe    Adelie     2007           3.62
 2 Biscoe    Adelie     2008           3.63
 3 Biscoe    Adelie     2009           3.86
 4 Biscoe    Gentoo     2007           5.07
 5 Biscoe    Gentoo     2008           5.02
 6 Biscoe    Gentoo     2009           5.14
 7 Dream     Adelie     2007           3.67
 8 Dream     Adelie     2008           3.76
 9 Dream     Adelie     2009           3.65
10 Dream     Chinstrap  2007           3.69
11 Dream     Chinstrap  2008           3.8 
12 Dream     Chinstrap  2009           3.72
13 Torgersen Adelie     2007           3.76
14 Torgersen Adelie     2008           3.86
15 Torgersen Adelie     2009           3.49

まとめ

adverbial パッケージは，データ処理タスクをより小さく管理しやすいステップに分解する手段を提供します．このアプローチにより，ユーザーは全体のワークフローを理解し，自分のニーズに合わせて調整できるようになります．データ処理の各ステップを頭の中で覚えておくという，労力のかかる作業を作業者に強いる必要をなくすことが目的です．

コブ・ダグラス型効用関数の実装

効用関数は，消費量ベクトルを引数として受け取り，効用（スカラー値）を返す関数と捉えることができます． 一方で，効用関数を設定する際には，消費量ベクトル以外に弾力性パラメータ等のパラメータを事前に設定する必要があります．

パラメータは効用関数によって異なるため，効用関数を抽象型AbstractEconomicUtilityとして定義し，そのサブタイプとしてコブ・ダグラス型効用関数CobbDouglasUtilityの型を定義します． CobbDouglasUtilityは，弾力性パラメータweightsを持つ型として定義します．

abstract type AbstractEconomicUtility end

struct CobbDouglasUtility <: AbstractEconomicUtility
    weights::Vector{Float64}
end

次に，function-like objectsを定義することで，効用関数の型fに対してf(quantities)と呼ぶことで効用を計算できるようにします． 効用関数のパラメータは，型fから取得することができるため，関数の引数がquantitiesのみとなっていることに注意してください． これにより，様々な効用関数の型fに対してf(quantities)のような同一のコードを呼び出すことができるようになります．

以上により，コブ・ダグラス型効用関数を定義することができます．

function(f::CobbDouglasUtility)(quantities)
    return prod(quantities .^ f.weights)
end

# 効用関数の定義
cobb_douglas = CobbDouglasUtility([0.3, 0.4, 0.3])

# 効用の算出
cobb_douglas([2., 3., 5.])

3.0963389922845703

さらに，過去の記事と同様にマーシャルの需要関数demand_marshallian()を定義します．

demand_marshallian()により，コブ・ダグラス型効用関数の効用最大化問題の解析的な解を求めることができます．

function demand_marshallian(
  f::CobbDouglasUtility;
  prices,
  income
)
  return income * f.weights / sum(f.weights) ./ prices
end

demand_marshallian (generic function with 1 method)

quantities_analytical_cobb_douglas = demand_marshallian(
  cobb_douglas;
  prices = [1., 2., 3.],
  income = 100.
)

3-element Vector{Float64}:
 30.0
 20.0
 10.0

効用最大化問題の数値的な解

過去の記事のコードを少し変更することで，効用最大化問題を数値的に解くことができます．

過去の記事では，コブ・ダグラス型効用関数専用のコードを定義していましたが， 以下の関数demand_marshallian_numericalは，抽象型AbstractEconomicUtilityを引数に取ることで， 様々な効用関数に対して同一のコードを使うことができます．

import Pkg
Pkg.add("JuMP")
Pkg.add("Ipopt")

using JuMP
using Ipopt

function demand_marshallian_numerical(
  f::AbstractEconomicUtility;
  prices::Vector{Float64},
  income::Float64
)
    n = length(prices)
    model = Model(Ipopt.Optimizer) 
    set_silent(model)
    @variable(model, quantities[1:n] >= 0)
    @objective(model, Max, f(quantities))
    @constraint(model, sum(prices .* quantities) <= income)
    optimize!(model)
    return value.(quantities)
end

demand_marshallian_numerical (generic function with 1 method)

上で定義したcobb_douglasに対してdemand_marshallian_numerical()を適用することで， 過去の記事と同様に，コブ・ダグラス型効用関数の効用最大化問題の解析的な解と数値的な解がおおよそ一致することを確認できます．

quantities_numerical_cobb_douglas = demand_marshallian_numerical(
  cobb_douglas;
  prices = [1., 2., 3.],
  income = 100.
)

3-element Vector{Float64}:
 30.000000297265977
 20.00000019590169
 10.000000099089569

quantities_analytical_cobb_douglas

3-element Vector{Float64}:
 30.0
 20.0
 10.0

CES型効用関数の実装

コンストラクタを使うメリットを実感するために， コブ・ダグラス型効用関数以外の効用関数を実装してみます．

以下では，CES型効用関数を実装してみましょう． CES型効用関数は，コブ・ダグラス型効用関数の一般化であり，代替性の程度を表すパラメータsubstitutionを持ちます． コブ・ダグラス型効用関数と同様に，CES型効用関数は，以下のように定義することができます．

マーシャルの需要関数の導出は割愛しますが引数の型f::CESUtilityを指定することで， 効用関数に応じてdemand_marshallian()の結果を変化させることができます． このような仕組みは多重ディスパッチと呼ばれています．

struct CESUtility <: AbstractEconomicUtility
    substitution::Float64
    weights::Vector{Float64}
end

function(f::CESUtility)(quantities)
    return sum(f.weights .* quantities .^ f.substitution) ^ (1 / f.substitution)
end

function demand_marshallian(
  f::CESUtility;
  prices,
  income
)
  return f.weights .^ (1 / (1 - f.substitution)) .* prices .^ (1 / (f.substitution - 1)) *
    income / sum(f.weights .^ (1 / (1 - f.substitution)) .* prices .^ (f.substitution / (f.substitution - 1)))
end

demand_marshallian (generic function with 2 methods)

ces = CESUtility(0.5, [0.3, 0.4, 0.3])
ces([2., 3., 5.])

3.196603520188051

上で定義したcesに対してdemand_marshallian()とdemand_marshallian_numerical()を適用することで， CES型効用関数の効用最大化問題の解析的な解と数値的な解を求めることができます．

quantities_analytical_ces = demand_marshallian(
  ces;
  prices = [1., 2., 3.],
  income = 100.
)

quantities_numerical_ces = demand_marshallian_numerical(
  ces;
  prices = [1., 2., 3.],
  income = 100.
)

3-element Vector{Float64}:
 45.00000043558223
 20.000000194987294
  5.000000053970372

quantities_analytical_ces

3-element Vector{Float64}:
 45.0
 20.000000000000004
  4.999999999999999

まとめ

この記事では，過去の記事で紹介した効用最大化問題をJuliaのコンストラクタを用いて拡張することで，様々な効用関数に対して同一のコードを使うことができることを示しました．

このような仕組みを活用することで効用関数を実装した際に， 自動的に最適化問題の解析的な解と数値的な解の整合性を確認することができ， 効用関数に対するテストを実装するのが容易になることが期待されます¹．

ベイズの定理を用いた平滑化

カウントデータがポアソン分布，割合の真値がポアソン分布の共役事前分布であるガンマ分布に従うと仮定します．

すると，ベイズの定理を用いて，の事後分布，すなわち観測値が与えられたときのの分布は以下のようになります．

そのため，の事後分布の期待値は以下のような簡単な式で表され，この式を用いることで，観測ノイズを除去（平滑化）することができます．

一方で，こうした平滑化を行うためには，との値を決める必要があります． 以下では，事前分布のパラメータとを観測値から推定する方法について説明します．

経験ベイズ法による事前分布のパラメータ推定

経験ベイズ法は，観測値から事前分布のパラメータを（経験的に）推定する方法です． 経験ベイズ法における事前分布のパラメータの推定方法として，モーメント法や最尤法を用いる方法が考えられますが，以下では，最尤法を用いた方法について説明します．

最尤法を行うにあたって，事前にが従う分布を確かめておきましょう． は，以下のようなガンマ分布とポアソン分布の混合分布に従うと考えられます． 通常，混合分布を求めるには積分計算が必要となってしまいますが，ガンマ分布とポアソン分布の混合分布は，負の二項分布に従うことが知られています． そのため，あらかじめ以下のようにの確率分布を求めておきます．

以上の式より，は以下のような負の二項分布に従うことがわかります． ただし，負の二項分布にはいくつかのパラメータ設定方法があるため注意が必要です． ここでのパラメータ設定方法は，stanのNegBinomial2と同様です．

このように，は，負の二項分布と呼ばれる一般的な確率分布に従うことがわかるため，Rで提供されている既存の関数を用いて最尤法を行うことができます． 以下では，実験的に作成したテストデータを対象に，R MASSパッケージのglm.nb()関数を用いて最尤法を行い，割合データの平滑化を行ってみます．

平滑化の実例

library(tidyverse)

theme_set(theme_bw())

set.seed(1234)

# サンプルサイズ
n <- 1e4

# 割合 (真値)
alpha_true <- 5
beta_true <- 50
rate_true <- rgamma(n, shape = alpha_true, rate = beta_true)

tibble(rate_true = rate_true) |> 
  ggplot(aes(rate_true)) +
  geom_histogram(binwidth = 1e-2)

# 人口 (分母)
x <- 1:100
population <- sample(x, n, replace = TRUE)

# カウントデータ (分子)
count <- rpois(n, rate_true * population)

data <- tibble(
  population = population,
  rate_true = rate_true,
  count = count
)
head(data, n = 10)

data_crude <- data |> 
  mutate(
    rate_crude = count / population
  )
head(data_crude, n = 10)

data_crude |> 
  ggplot(aes(population, rate_crude)) +
  geom_point()

data_crude |> 
  ggplot(aes(rate_true, rate_crude, color = population)) +
  geom_point() +
  geom_abline(color = "red") +
  scale_color_viridis_c(option = "turbo") +
  tune::coord_obs_pred()

負の二項分布を用いた平滑化

それでは，負の二項分布を用いて平滑化を行ってみましょう． ここでは，Rで簡単に利用可能なMASSパッケージのglm.nb()関数を用いて，最尤法を行います． glm.nb()により，目的変数が負の二項分布に従うような一般化線形モデルを推定することができます．

以下のような簡単なコードで負の二項分布のパラメータ推定ができます． ここでは，期待値がpopulationに比例するよう，log(population)をオフセット項に指定しています．

model <- MASS::glm.nb(
  count ~ offset(log(population)),
  data = data
)

次に，glm.nb()の出力値を格納したmodelからガンマ分布のパラメータを取得します． ガンマ分布のは，model$thetaで取得できます． の推定値alpha_estimatedは，真値のalpha_trueとおおよそ一致することがわかります．

alpha_estimated <- model$theta

alpha_true

[1] 5

alpha_estimated

[1] 5.014545

また，ガンマ分布のは，上に示したの関係式より以下で求められます． はサンプルサイズの数だけ出力されますが，の推定値beta_estimatedが全てほぼ同等の値をもち，さらに，真値のbeta_trueとおおよそ一致することがわかります．

mu <- predict(model, type = "response")
beta_estimated <- alpha_estimated * population / mu

beta_true

[1] 50

all(near(beta_estimated, beta_estimated[[1]]))

[1] TRUE

head(beta_estimated)

       1        2        3        4        5        6 
50.07359 50.07359 50.07359 50.07359 50.07359 50.07359 

それでは，最後に求められたガンマ分布のとを使って割合の平滑化を行ってみましょう． 以下に，平滑化に使用する式を再掲します． この式に従って平滑化した割合rate_smoothedを対象に，先ほどと同様のグラフを描画してみます． すると，populationが小さい場合であっても，割合が過大・過小になる傾向がみられないことがわかり，少数問題が解消されていることが確認できました．

data_smoothed <- data |> 
  mutate(
    rate_smoothed = (count + alpha_estimated) / (population + beta_estimated)
  )
head(data_smoothed, n = 10)

data_smoothed |>
  ggplot(aes(population, rate_smoothed)) +
  geom_point()

data_smoothed |> 
  ggplot(aes(rate_true, rate_smoothed, color = population)) +
  geom_point() +
  geom_abline(color = "red") +
  scale_color_viridis_c(option = "turbo") +
  tune::coord_obs_pred()

おわりに

この記事では，割合データにおける少数問題への対処法として，経験ベイズ法を用いた平滑化手法について説明しました． 分母の人口等が小さい場合に割合データのばらつきが大きくなる現象は，実務でもしばしば問題になると思われます． そうした場合には，何らかのしきい値で分母の小さいデータを除外する方法も考えられますが， この記事で説明した方法を使うと全てのデータを活用できるという利点もあります．

この記事で用いたMASSパッケージのglm.nb()は，一般化線形モデル用の関数であるため，分母にあたるoffset(log(population))以外の項も説明変数として含むことが可能です． これにより，地域特性等によってが異なる状況を再現できる可能性があります．

また，汎用性の高いと思われるポアソン分布を対象としましたが，二項分布でも同様の枠組みが利用できます． 二項分布の場合，事前分布としてベータ分布を用いると，平滑化の式は以下のようになります． また，混合分布はベータ・二項分布となるため，既存のRパッケージ（例：bbmle）等を用いれば，比較的簡単にパラメータ推定が可能だと思われます．

コブ・ダグラス型効用関数

コブ・ダグラス型効用関数は以下のように定義されます． ここで，は生産要素の消費量， は生産要素の弾力性パラメータです．

この効用関数をJuliaで実装すると以下のようになります．

function cobb_douglas(quantities; weights)
    return prod(quantities .^ weights)
end

cobb_douglas (generic function with 1 method)

実装したcobb_douglas関数に，消費量quantitiesと弾力性パラメータweightsを 渡すことで，以下のように，効用を計算することができます．

cobb_douglas(
  [2, 3, 5], 
  weights=[0.3, 0.4, 0.3]
)

3.0963389922845703

効用最大化問題の解析的な解

一般的に，効用最大化問題は，価格と所得が与えられたときに， 効用を最大化するような消費量を求める問題として定式化されます．

こうした消費量（需要量）は，マーシャルの需要関数として知られています． コブ・ダグラス型効用関数の場合，マーシャルの需要関数は以下のように導出されます¹． ここで，は生産要素の価格，は所得です．

function demand_marshallian_cobb_douglas_analytical(prices, income; weights)
    return income .* weights ./ sum(weights) ./ prices
end

demand_marshallian_cobb_douglas_analytical (generic function with 1 method)

実装したdemand_marshallian_cobb_douglas_analytical関数に，価格pricesと 所得income，弾力性パラメータweightsを渡すことで，以下のように，需要量を 計算することができます．

quantities_analytical = demand_marshallian_cobb_douglas_analytical(
  [1, 2, 3], 
  100, 
  weights=[0.3, 0.4, 0.3]
)

3-element Vector{Float64}:
 30.0
 20.0
 10.0

効用最大化問題の数値的な解

次に，Julia JuMPを用いて，効用最大化問題を数値的に解いてみます． 事前に，JuMPパッケージとIpoptパッケージをインストールしておきましょう． Ipoptは，非線形最適化問題を解くためのソルバーを提供しています．

import Pkg
Pkg.add("JuMP")
Pkg.add("Ipopt")

コブ・ダグラス型効用関数を用いた効用最大化問題は以下のように定式化されます． JuMPでは，すでに定義したcobb_douglas関数を用いて， 簡単に，効用最大化問題を記述し，数値的に解くことができます．

using JuMP
using Ipopt

function demand_marshallian_cobb_douglas_numerical(prices, income; weights)
    n = length(prices)
    model = Model(Ipopt.Optimizer) 
    set_silent(model)
    @variable(model, quantities[1:n] >= 0) # 消費量を変数として定義
    @objective(model, Max, cobb_douglas(quantities; weights)) # 効用最大化
    @constraint(model, sum(prices .* quantities) <= income) # 予算制約式
    optimize!(model)
    return value.(quantities)
end

demand_marshallian_cobb_douglas_numerical (generic function with 1 method)

効用最大化問題の定式化では，以下のことを行っています．

1. @variableマクロを用いて，消費量quantitiesを変数として定義
2. @objectiveマクロを用いて，効用を最大化するような目的関数を定義
3. @constraintマクロを用いて，予算制約式を定義

それでは，実装したdemand_marshallian_cobb_douglas_numerical関数を用いて， 数値的な解を求めてみましょう．

quantities_numerical = demand_marshallian_cobb_douglas_numerical(
  [1, 2, 3], 
  100, 
  weights=[0.3, 0.4, 0.3]
)

******************************************************************************
This program contains Ipopt, a library for large-scale nonlinear optimization.
 Ipopt is released as open source code under the Eclipse Public License (EPL).
         For more information visit https://github.com/coin-or/Ipopt
******************************************************************************

3-element Vector{Float64}:
 30.000000297265977
 20.00000019590169
 10.000000099089569

最終的な結果は以下のようになり， 数値的な解が解析的な解とほぼ一致していることがわかります．

quantities_numerical

3-element Vector{Float64}:
 30.000000297265977
 20.00000019590169
 10.000000099089569

quantities_analytical

3-element Vector{Float64}:
 30.0
 20.0
 10.0

まとめ

この記事では，Julia JuMPを用いて，コブ・ダグラス型効用関数を用いた 効用最大化問題を解いてみました．

Julia JuMPを用いることで，非線形最適化問題を簡単に定式化し， 数値的に解くことができることを確認しました．

Julia JuMPでは，シンプルな関数であれば，定義済みの関数をそのまま目的変数等として 扱うことができるため，経済モデルの実装にも有用かもしれません．

Excelファイルを整形する前に

本題に入る前に, 一点注意しておきたいことがあります．それは, 分析に使用したいデータが, より機械判読に適した形式で提供されていないかを確認することです．

Excelファイルはデータの閲覧には便利ですが, 機械判読しにくいことが少なくありません．そのため, より適切な形式で提供されているデータがないか, 事前に確認するのが望ましいでしょう．たとえば, 政府統計の総合窓口であるe-Statでは, API機能を利用して, 一般的なExcelファイルよりも機械判読しやすいデータを取得できる場合があります．

データ形式を巡る「人と機械の溝」

私たちにとって読みやすいデータが, 機械にとっても読みやすいとは限りません．その典型例として, 週間天気予報のデータが挙げられます¹．

たとえば, 以下のようなダミーの週間天気予報データがあるとしましょう．人間がこのデータを見れば, すぐに「地域・日付別の天気」であることを理解できます．しかし, 機械的に以下の情報を把握するのは意外に難しいかもしれません．

• 2列目以降の列名が日付を表していること
• 2列目以降の列の値が天気を表していること

library(tidyverse)

region <- c("札幌", "東京", "名古屋", "大阪", "福岡", "那覇")
date <- seq(ymd("2024-12-20"), ymd("2024-12-26"), by = "day") |>
  format("%m/%d")
weather <- c("🌞", "⛅", "☔")

set.seed(1234)
weather_forecast <- expand_grid(region = region, date = date) |>
  mutate(weather = sample(weather, n(), replace = TRUE))

weather_forecast_wider <- weather_forecast |>
  pivot_wider(names_from = date, values_from = weather)
weather_forecast_wider

上のデータが「地域・日付別の天気」であることをより明確にするには, 以下のようなデータのほうが適しています．このデータでは, 地域と日付という軸（次元）に対し, 観測値である天気が適切に対応しており, こうした縦長のデータはtidy data（整然データ）と呼ばれます． しかし，このような縦長のデータがニュースで流れたら，多くの人は読みづらいと感じるでしょう²．

weather_forecast

なぜ, このような「人と機械の溝」が生じるのでしょうか？

以下の図は, 上の縦長データをggplot2で散布図として表したものです．この散布図と先ほどの表を見比べると, 見た目がよく似ていることがわかります．私たちにとっては, 縦方向だけでなく横方向にも軸を持つ表のほうが直感的に理解しやすいのかもしれません．

weather_forecast |>
  ggplot(aes(date, region, label = weather)) +
  geom_text() +
  scale_x_discrete(position = "top") +
  scale_y_discrete(limits = rev)

Excelファイルのテーブル構造を読み解く

このような「人と機械の溝」を踏まえて，実際のExcelファイルのテーブル構造を読み解いてみましょう．

このような「人と機械の溝」を踏まえ, 実際のExcelファイルのテーブル構造を読み解いてみましょう． 「地域・日付別の天気」のようなシンプルなデータであれば, テーブル構造はそれほど複雑ではありません．しかし, 例えば「西暦・地域・性別・年齢別の人口」のようなデータの場合はどうでしょうか？ 実際に, e-Statに公開されているこちらのExcelファイルを見てみましょう．以下の画像は, Excelファイルの上部を一部抜粋したものです．

データ上部の説明を省くと, 以下のようなデータ形式であることがわかります．そこで, データの軸（次元）にあたる西暦・地域・性別・年齢を水色（■）, 観測値の種別・単位にあたる人口・人口割合・人口性比を青色（■）で塗り分けると, 以下の図のようになります．データ形式の詳細をまとめると以下のようになります．

• 1・2列目に，それぞれ地域・年齢階級の軸（次元）の情報が格納されている
• 3列目以降の列名にあたる部分には，軸（次元）と観測値の情報が混在している
  • 1・3行目に，それぞれ西暦・性別の軸（次元）の情報が格納されている
  • 2・4行目は，それぞれ人口・人口割合・人口性比の観測値の種別と単位が記載されている

Excelファイルを整形する際には, 以下の点を意識する必要があります．

• 列名が複数行にわたる場合, 各行の情報が軸（次元）に対応するのか, それとも観測値なのかを事前に整理しておく必要がある
• 列名の重複を避けるため, 一部の列名が省略されている, またはセルが結合されていることが多い

readxlでExcelファイルを整形してみよう

それでは，実際にExcelファイルを整形してみましょう．以下では，上で紹介した「西暦・地域・性別・年齢別の人口」のExcelファイルを整形するためのコードを示します．

Excelファイルを読み込むのに役立つパッケージとして，readxlパッケージがあります³． ここでは，readxlパッケージを使ってExcelファイルを整形するため， 事前に，readxlパッケージとtidyverseパッケージをロードしておきます．

# 必要に応じてパッケージをインストールしてください
# install.packages("pak")
# pak::pak("readxl")
# pak::pak("tidyverse")

library(readxl)
library(tidyverse)

library(fs)

exdir <- "tips-tidying-excel-data-with-r"
dir_create(exdir)

destfile <- path(exdir, "population_by_year_sex_age_class", ext = "xlsx")
if (!file_exists(destfile)) {
  curl::curl_download(
    "https://www.e-stat.go.jp/stat-search/file-download?statInfId=000001085927&fileKind=0",
    destfile = destfile
  )
}

# 事前にダウンロードしたExcelファイルの保存場所
file <- "tips-tidying-excel-file-with-r/population_by_year_sex_age_class.xlsx"
sheet <- "da03"

data_col_names <- read_excel(
  file,
  sheet = sheet, # シート名
  skip = 10, # 説明部分をスキップ
  n_max = 5, # 列名部分のみを読み込む
  col_names = FALSE,
  col_types = "text",
  .name_repair = "minimal"
) |>
  # 転置してからデータフレームに変換
  t() |>
  as_tibble(
    .name_repair = ~ c("year", "value_type", "sex", "", "value_unit")
  ) |>
  select(year, value_type, sex, value_unit) |>

  # 最初の2行（地域・年齢階級）を除外
  slice_tail(n = -2)

head(data_col_names, n = 10)

data_col_names <- data_col_names |>
  # 西暦の年数のみを抽出
  mutate(
    year = year |>
      str_extract("^\\d+(?=年$)") |>
      as.integer(),

    # value_unitが"-"の場合は空文字に置換
    value_unit = if_else(value_unit == "-", "", value_unit)
  ) |>

  # 西暦年とvalue_typeのNAを埋める
  fill(year, value_type)

head(data_col_names, n = 10)

col_names <- data_col_names |>
  unite("value_type", value_type, value_unit, sep = "") |>
  unite("col_name", year, sex, value_type, sep = "/") |>
  pull(col_name)
col_names <- c("region", "age_class", col_names)

head(col_names, n = 10)

 [1] "region"                           "age_class"                       
 [3] "1920/総数/人口（人）"             "1920/男/人口（人）"              
 [5] "1920/女/人口（人）"               "1920/総数/年齢，男女別割合（％）"
 [7] "1920/男/年齢，男女別割合（％）"   "1920/女/年齢，男女別割合（％）"  
 [9] "1920/NA/人口性比"                 "1925/総数/人口（人）"            

data <- read_excel(
  file,
  sheet = sheet,
  skip = 10 + 5,
  col_names = col_names,
  col_types = "text",
  .name_repair = "minimal"
) |>

  # 末尾の列に重複がみられるため重複箇所を削除 (元データ作成時のミスと思われる)
  select(all_of(vctrs::vec_unique_loc(col_names)))

head(data, n = 10)

data <- data |>
  pivot_longer(
    !c(region, age_class),
    names_to = c("year", "sex", ".value"),
    names_sep = "/",
    names_transform = list(
      sex = \(x)
        x |>
          na_if("NA")
    )
  ) |>
  # 人口・人口割合・人口性比の列を数値に変換
  mutate(across(c(`人口（人）`, `年齢，男女別割合（％）`, 人口性比), \(x) {
    parse_number(x, na = "-")
  })) |>
  relocate(year, region, sex, age_class)

head(data, n = 10)

data_population <- data |> 
  drop_na(sex) |> 
  select(!人口性比)

head(data_population, n = 5)

data_sex_ratio <- data |> 
  filter(is.na(sex)) |> 
  select(!c(sex, `人口（人）`, `年齢，男女別割合（％）`))

head(data_sex_ratio, n = 5)

tidyxlとunpivotrでExcelファイルを整形してみよう

次に，tidyxlパッケージとunpivotrパッケージを使ってExcelファイルを整形する方法を紹介します．

readxlパッケージでは，列名の作成・データの読み込み・tidy dataへの変換という多くのステップを踏む必要がありました． tidyxlパッケージとunpivotrパッケージでは，Excelファイルのテーブルを「行・列別の値」に展開した縦長データを用いることで， readxlよりも柔軟かつ効率的にデータ整形を行うことができます．

まずは，必要となるパッケージをロードしておきましょう．

# 必要に応じてパッケージをインストールしてください
# install.packages("pak")
# pak::pak("tidyxl")
# pak::pak("unpivotr")
# pak::pak("tidyverse")

library(tidyxl)
library(unpivotr)
library(tidyverse)

cells <- xlsx_cells(file, sheets = sheet)

head(cells, n = 10)

data2 <- cells |> 
  # 説明部分にあたる最初の10行を除外
  filter(row > 10) |>
  
  # 1列目は地域を表す (データから見てleft側)
  behead("left", "region") |> 
  
  # 2列目は年齢階級を表す (データから見てleft側)
  behead("left", "age_class") |> 
  
  # 1行目は西暦を表す (データから見てup-left側)
  filter(row != 10 + 1 | str_detect(character, "^\\d+年$")) |> # 和暦を削除
  behead("up-left", "year") |> 
  
  # 2行目は値の種別を表す (データから見てup-left側)
  behead("up-left", "value_type") |> 
  
  # 3行目は性別を表す (データから見てup側)
  behead("up", "sex") |>
  
  # 5行目は単位を表す (データから見てup側)
  behead("up", ".") |> # 4行目の空白の行に適当な名前を付与 (後で削除)
  behead("up", "value_unit") |> 
  
  select(year, region, age_class, sex, value_type, value_unit, numeric)

head(data2, n = 5)

data2 <- data2 |>
  # readxlを使った場合と同様にvalue_type列を作成
  mutate(value_unit = if_else(value_unit == "-", "", value_unit)) |>
  unite("value_type", value_type, value_unit, sep = "") |>

  # 重複箇所を削除
  slice_head(n = 1, by = c(year, region, age_class, sex, value_type)) |>

  # 値の種別を行方向に展開して横長データに変換
  pivot_wider(names_from = value_type, values_from = numeric)

head(data2, n = 10)

まとめ

この記事では，Excelファイルを整形する際のTipsを紹介しました． データ整形のアプローチとして，readxlパッケージを使う方法とtidyxlパッケージとunpivotrパッケージを使う方法を紹介しましたが， いずれの場合でも，データのテーブル構造を読み解くことが重要です．

この記事で紹介したデータ整形の流れについて改善点・追加すべき内容・ご質問等があれば，コメント等をいただけると幸いです．

参考記事

• Rで市区町村データをスマートに整形しよう（市町村合併や政令指定都市の集計処理など）

都道府県別の市町村合併の可視化結果

以下に市町村合併の可視化結果を示します．データ上の不備等に気づかれた方はコメント等でお知らせいただければ幸いです． ラベルが重なって見づらい箇所があることをご了承ください．

library(tidyverse)
library(tidygraph)
library(ggraph)

date_end <- ymd("2024-04-01")

graph_city <- jpcity:::graph_city$graph_city |> 
  
  activate(nodes) |> 
  filter(!node_is_isolated(),
         is.infinite(interval) | int_end(interval) <= date_end) |> 
  arrange(desc(interval)) |>
  
  replace_na(list(city_desig_name = "",
                  city_name = "")) |>
  mutate(city_name = str_c(city_desig_name, city_name)) |>
  select(!city_desig_name) |> 
  
  mutate(group = group_components()) |> 
  
  activate(edges) |>
  filter(!type %in% c("分離", "分割"))

jpcity::parse_pref(1:47) |> 
  walk(\(pref) {
    pref_name <- jpcity::pref_name(pref)
    
    plot <- graph_city |> 
      activate(nodes) |> 
      filter(pref_name == .env$pref_name) |> 
      
      create_layout("fabric") |>
      
      # ラベル位置を時系列に合わせることも可能だが見えづらいため省略
      # mutate(y = int_start(interval)) |>
      
      ggraph() +
      geom_edge_diagonal(color = "gray",
                         arrow = arrow(length = unit(2, 'mm')), 
                         end_cap = circle(8, 'mm')) +
      geom_node_label(aes(label = city_name,
                          fill = as_factor(group)),
                      size = 3,
                      show.legend = FALSE) +
      scale_fill_hue(l = 100) +
      coord_flip() +
      
      labs(title = pref_name) +
      theme_void()
    
    print(plot)
  })

市区町村データの分析で注意すべきことは？

市区町村別の統計データを分析する際には，どのようなことに気をつけるべきでしょうか． 以下では，主な注意点を3つに絞って紹介します．

library(tidyverse)
library(jpcity)

get_city("2020-01-01") |> 
  jpcity:::city_data() |> 
  mutate(n = n(),
         .by = c(city_desig_name, city_name)) |> 
  filter(n > 1) |> 
  arrange(desc(n), city_desig_name, city_name) |> 
  select(!c(starts_with("city_desig_name"), n)) |> 
  rmarkdown::paged_table()

tibble(city_after = get_city("2020-01-01"),
       city_before = city_after |> 
         city_convert("2020-01-01", "1970-04-01")) |> 
  mutate(size_city_before = vctrs::list_sizes(city_before)) |> 
  slice_max(size_city_before, 
            n = 1) |> 
  select(!size_city_before) |> 
  unnest(city_before) |> 
  mutate(city_code_before = city_code(city_before),
         city_name_before = city_name(city_before),
         city_code_after = city_code(city_after),
         city_name_after = city_name(city_after),
         .keep = "unused") |> 
  rmarkdown::paged_table()

tibble(city = find_city("横浜市", "2020-01-01") |> 
         city_desig_merge() |> 
         vctrs::vec_unique(),
       city_desig = city |> 
         city_desig_split()) |> 
  unnest(city_desig) |> 
  mutate(city_code = city_code(city),
         city_name = city_name(city),
         city_desig_code = city_code(city_desig),
         city_desig_name = city_name(city_desig),
         .keep = "unused") |> 
  rmarkdown::paged_table()

Rで市区町村データをスマートに整形する

ここまでの注意点を踏まえて，Rを用いて市区町村データをスマートに整形する方法を紹介します． 実は，上に示した事例は，いずれもe-Statの 「市区町村を探す」と 「廃置分合等情報を探す」で 公開されている情報に基づいています．

しかし，「廃置分合等情報を探す」では，市町村合併等による市区町村コードの変更内容がテキスト形式で記載されているため， そのままではデータ整形に利用しにくいという問題があります．

そこで，こうした複雑なデータ整形を行うことなく，簡単に廃置分合処理や政令指定都市の市区の対応付けを行うために， 新たに，jpcityパッケージを作成しました²． ちなみに，上に示した表はすべてjpcityパッケージを用いて作成したものです． jpcityは，CRANに登録済みであるため，以下のコードを実行することでインストールすることができます． ここからは，jpcityの使い方について簡単に説明していきます．

install.packages("jpcity")

library(tidyverse)
library(jpcity)

city <- tibble(city_parsed = parse_city("15222", "2020-01-01"),
               city_found = find_city("上越市", "2020-01-01"))

city

# A tibble: 1 × 2
  city_parsed          city_found          
  <city>               <city>              
1 15222 [新潟県上越市] 15222 [新潟県上越市]

city |> 
  select(city_parsed) |> 
  mutate(city_converted = city_parsed |> 
           city_convert("2020-01-01", "2000-01-01")) |> 
  unnest(city_converted)

# A tibble: 14 × 2
   city_parsed          city_converted        
   <city>               <city>                
 1 15222 [新潟県上越市] 15521 [新潟県安塚町]  
 2 15222 [新潟県上越市] 15522 [新潟県浦川原村]
 3 15222 [新潟県上越市] 15525 [新潟県大島村]  
 4 15222 [新潟県上越市] 15526 [新潟県牧村]    
 5 15222 [新潟県上越市] 15541 [新潟県柿崎町]  
 6 15222 [新潟県上越市] 15542 [新潟県大潟町]  
 7 15222 [新潟県上越市] 15543 [新潟県頸城村]  
 8 15222 [新潟県上越市] 15544 [新潟県吉川町]  
 9 15222 [新潟県上越市] 15546 [新潟県中郷村]  
10 15222 [新潟県上越市] 15548 [新潟県板倉町]  
11 15222 [新潟県上越市] 15549 [新潟県清里村]  
12 15222 [新潟県上越市] 15550 [新潟県三和村]  
13 15222 [新潟県上越市] 15561 [新潟県名立町]  
14 15222 [新潟県上越市] 15222 [新潟県上越市]  

# 政令指定都市の市を区に分割
city_desig <- tibble(city = parse_city("14100", "2020-01-01"),
                     city_desig = city_desig_split(city)) |> 
  unnest(city_desig)
city_desig

# A tibble: 14 × 2
   city                   city_desig                      
   <city>                 <city>                          
 1 14100 [神奈川県横浜市] 14101 [神奈川県横浜市鶴見区]    
 2 14100 [神奈川県横浜市] 14102 [神奈川県横浜市神奈川区]  
 3 14100 [神奈川県横浜市] 14103 [神奈川県横浜市西区]      
 4 14100 [神奈川県横浜市] 14104 [神奈川県横浜市中区]      
 5 14100 [神奈川県横浜市] 14105 [神奈川県横浜市南区]      
 6 14100 [神奈川県横浜市] 14106 [神奈川県横浜市保土ケ谷区]
 7 14100 [神奈川県横浜市] 14107 [神奈川県横浜市磯子区]    
 8 14100 [神奈川県横浜市] 14108 [神奈川県横浜市金沢区]    
 9 14100 [神奈川県横浜市] 14109 [神奈川県横浜市港北区]    
10 14100 [神奈川県横浜市] 14110 [神奈川県横浜市戸塚区]    
11 14100 [神奈川県横浜市] 14111 [神奈川県横浜市港南区]    
12 14100 [神奈川県横浜市] 14112 [神奈川県横浜市旭区]      
13 14100 [神奈川県横浜市] 14113 [神奈川県横浜市緑区]      
14 14100 [神奈川県横浜市] 14114 [神奈川県横浜市瀬谷区]    

# 政令指定都市の区を市に統合 (最初の数行だけ表示)
city_desig |>
  select(city_desig) |> 
  mutate(city = city_desig_merge(city_desig)) |> 
  head()

# A tibble: 6 × 2
  city_desig                       city                  
  <city>                           <city>                
1 14101 [神奈川県横浜市鶴見区]     14100 [神奈川県横浜市]
2 14102 [神奈川県横浜市神奈川区]   14100 [神奈川県横浜市]
3 14103 [神奈川県横浜市西区]       14100 [神奈川県横浜市]
4 14104 [神奈川県横浜市中区]       14100 [神奈川県横浜市]
5 14105 [神奈川県横浜市南区]       14100 [神奈川県横浜市]
6 14106 [神奈川県横浜市保土ケ谷区] 14100 [神奈川県横浜市]

まとめ

この記事では，市区町村データの分析で注意すべき点と，Rのjpcityパッケージを用いて市区町村データをスマートに整形する方法について紹介しました． jpcityパッケージに対する要望・バグ報告や質問などがあれば，GitHubか以下のコメント欄からお気軽にご意見をお寄せください．

関数形がLiNGAMの推定に与える影響について

LiNGAMは，関数形が線形かつ誤差項がガウス分布以外に従うという前提のもとで因果関係を推定する手法です．そのため，関数形が線形でない（線形近似が難しい）場合には，誤った因果関係が推定される可能性があります．パッケージや市販のソフトウェアを使えばLiNGAMを簡単に実行することができてしまいますが，利用者はこうした前提があることを理解してLiNGAMを使う必要があると思われます．

ここでは，上に挙げた因果グラフよりも簡単な以下のような因果関係をもつデータに対してLiNGAMを適用してみましょう．具体的には， 以下のフローチャートのfunに，非線形な関数が入ったときにLiNGAMの結果がどのように変わるかを確認します．

ただし，この記事では最も一般的なLiNGAMであるDirect LiNGAM，誤差項として非ガウス分布の一様分布を用いています． また，係数の絶対値が0.001未満の因果関係は無視するものとしました．

flowchart LR
  x11 --> add1(+)
  x12 --> add1
  add1 --> x21
  x21 --> fun2(fun)
  x22 --> fun2
  fun2 --> x31
style fun2 stroke:red,color:red

因果グラフの推定に先立ってx11・x12・x22列をもつ1,000行のデータフレームおよび因果探索用の関数を用意しておきましょう．

import numpy as np
import os
import pandas as pd
import lingam

rng = np.random.default_rng(1234)

n = 1000
data = pd.DataFrame({
  'x11': 1 + rng.random(n),
  'x12': 2 + rng.random(n),
  'x22': 3 + rng.random(n)
})

# DirectLiNGAMの結果をデータフレームとして返す関数
def discover_causality(data):
  model = lingam.DirectLiNGAM()
  model.fit(data)

  return pd.DataFrame(
    model.adjacency_matrix_,
    columns=data.columns,
    index=data.columns
  )\
  .reset_index(names = 'node_to')\
  .melt(
    id_vars='node_to',
    var_name='node_from'
  )\
  .pipe(lambda df: df[np.logical_not(np.isclose(df.value, 0, rtol=0, atol=1e-3))])\
  .reindex(columns=['node_from', 'node_to', 'value'])

# mermaidファイルを出力する関数
def write_mermaid(df, file):
  with open(file, 'w') as f:
    f.write('flowchart LR\n')
    for row in df.itertuples():
      f.write('  {}-->|{:.3f}|{}\n'.format(row.node_from, row.value, row.node_to))

# 出力先のフォルダ
dir = 'be-careful-with-function-forms-in-lingam'
if not os.path.exists(dir):
  os.makedirs(dir)

data_nonlinear_prod = data\
 .assign(
    x21=lambda df: df.x11 + df.x12 + rng.random(n),
    x31=lambda df: df.x21 * df.x22 + rng.random(n),
  )

causality_nonlinear_prod = discover_causality(data_nonlinear_prod)
print(causality_nonlinear_prod)

   node_from node_to     value
3        x11     x21  0.975641
8        x12     x21  0.999905
14       x22     x31  4.524066
19       x21     x31  3.477884

write_mermaid(causality_nonlinear_prod, os.path.join(dir, 'dag_lingam_nonlinear_prod.mmd'))

flowchart LR
  x11-->|0.976|x21
  x12-->|1.000|x21
  x22-->|4.524|x31
  x21-->|3.478|x31

data_nonlinear_power = data\
 .assign(
    x21=lambda df: df.x11 + df.x12 + rng.random(n),
    x31=lambda df: df.x21 ** df.x22 + rng.random(n),
  )

causality_nonlinear_power = discover_causality(data_nonlinear_power)
print(causality_nonlinear_power)

   node_from node_to     value
1        x11     x12 -0.147973
3        x11     x21  0.832946
8        x12     x21  0.798157
17       x21     x22 -0.400541
22       x31     x22  0.002306

write_mermaid(causality_nonlinear_power, os.path.join(dir, 'dag_lingam_nonlinear_power.mmd'))

flowchart LR
  x11-->|-0.148|x12
  x11-->|0.833|x21
  x12-->|0.798|x21
  x21-->|-0.401|x22
  x31-->|0.002|x22

まとめ

この記事では，非線形な関数をもつデータに対してLiNGAMを適用すると，誤った因果関係が推定される可能性があることを示しました． そのため，LiNGAMの適用にあたっては，因果関係が線形で表せることを確認することが重要です．

一方で，因果関係がわからない状況なのに，因果関係が線形で表せることがわかるという状況はまれであると思われます． そのため，事後的な線形性の確認や実験などを通じて，慎重に因果関係を特定することが求められます．

read_html_live()を使ってみよう

ここからは，こちらのRSeleniumのチュートリアルで紹介されているものと同じ処理をread_html_live()で行ってみましょう．

こちらのチュートリアルでは，こちらのサイトにアメリカの郵便番号（ZIP code）を入力して地元テレビ局の情報を取得するという一連の処理を自動化しています． read_html_live()を使えば，RSeleniumでのサイトのアクセスを以下のように書き換えられます．

# RSelenium
# Source: https://joshuamccrain.com/tutorials/web_scraping_R_selenium.html
library(RSelenium)

rD <- rsDriver(browser="firefox", port=4545L, verbose=F)
remDr <- rD[["client"]]
remDr$navigate("https://www.fcc.gov/media/engineering/dtvmaps")

⏬

# rvest
library(rvest)
library(tidyverse)

html <- read_html_live("https://www.fcc.gov/media/engineering/dtvmaps")

読み込まれたオブジェクトは，$view()でブラウザで確認することができます．サイト上のエレメントを選択（Ctrl+Shift+C）したのち，該当箇所を右クリック⏩Copy⏩Copy selectorでCSSセレクタをコピーすれば，$type()や$click()の引数として使うことができます．

# rvest
html$view()

次に，中央のフォームに郵便番号（ZIP code）を入力⏩Go!ボタンをクリックし地元テレビ局の情報を表示させるコードは以下のように書き換えられます．

# RSelenium
# Source: https://joshuamccrain.com/tutorials/web_scraping_R_selenium.html
zip <- "30308"
remDr$findElement(using = "id", value = "startpoint")$sendKeysToElement(list(zip))
remDr$findElements("id", "btnSub")[[1]]$clickElement()

⏬

# rvest
zip <- "30308"
html$type("#startpoint", zip)
html$click("#btnSub")

最後に，上記のRSeleniumのチュートリアルと同じデータが取得できたことを確認しましょう．

# rvest
html |> 
  html_elements("table.tbl_mapReception") |> 
  insistently(chuck)(3) |> 
  html_table() |> 
  select(!c(1, IA)) |> 
  rename_with(str_to_lower) |> 
  rename(ch_num = `ch#`) |> 
  slice_tail(n = -1) |> 
  filter(callsign != "")

まとめ

以上のようにrvest 1.0.4で追加されたread_html_live()を使うことで，rvestだけでシームレスに静的サイトと動的サイトのスクレイピングが可能となるだけでなく，RSeleniumと比べてシンプルなコードでブラウザ上の操作を再現することができることがわかりました．

Rには，rvestの他にもseleniderというWebスクレイピング用のパッケージも開発されているようです．こういったパッケージの開発が進むことで，RでのWebスクレイピングがさらに便利になることが期待されます．

dmによるリレーショナルデータモデル

dmの提供するリレーショナルデータモデルは，複数のデータ間の関係性を私たちの代わりに管理してくれます．

この記事では，repurrrsiveパッケージで提供されているStar Warsのデータセットを通じて，dmの提供するリレーショナルデータモデルの使い方や利点について説明します．あらかじめ，tidyverse，dm，repurrrsiveの3つのパッケージを読み込んでおきます．

library(tidyverse)
library(dm)
library(repurrrsive)

repurrrsiveで提供されているStar Warsのデータセットには，以下のようなものが含まれています³．

data(package = "repurrrsive") |> 
  chuck("results") |> 
  as_tibble() |> 
  filter(str_starts(Item, "sw_")) |> 
  pull(Item)

[1] "sw_films"     "sw_people"    "sw_planets"   "sw_species"   "sw_starships"
[6] "sw_vehicles" 

複数のデータ間の関係を扱う必要のある，以下の2つの分析事例を通じて，リレーショナルデータモデルを活用する方法を見ていきましょう．

1. 基礎編：dmでリレーショナルデータモデルを構築する
2. 応用編：dmでモデルを拡張したりキーを検証したりする

films <- tibble(film = sw_films) |> 
  unnest_wider(film) |> 
  select(url, title, characters)
people <- tibble(person = sw_people) |>
  unnest_wider(person) |> 
  select(url, name, homeworld, species)
planets <- tibble(planet = sw_planets) |>
  unnest_wider(planet) |> 
  select(url, name)

films

people

planets

flowchart TB
  films.characters --> people.url
  people.homeworld --> planets.url
  subgraph films
    films.url[url]
    films.title[title]
    films.characters[List of characters] 
  end
  subgraph people
    people.url[url]
    people.name[name]
    people.homeworld[homeworld]
  end
  subgraph planets
    planets.url[url]
    planets.name[name]
  end

flowchart TB
  films_x_characters.url --> films.url
  films_x_characters.characters ---> people.url
  people.homeworld --> planets.url
  subgraph films_x_characters
    films_x_characters.url[url]
    films_x_characters.characters[characters]
  end
  subgraph films
    films.url[url]
    films.title[title]
  end
  subgraph people
    people.url[url]
    people.name[name]
    people.homeworld[homeworld]
  end
  subgraph planets
    planets.url[url]
    planets.name[name]
  end

# Create films_x_characters and remove characters column from films
films_x_characters <- films |> 
  select(url, characters) |> 
  unnest_longer(characters)
films <- films |> 
  select(!characters)

films_x_characters

dm_starwars_1 <- dm(films, people, planets, films_x_characters) |> 
  
  # 1. Add primary keys
  dm_add_pk(films, url) |>
  dm_add_pk(people, url) |>
  dm_add_pk(planets, url) |>
  dm_add_pk(films_x_characters, c(url, characters)) |>
  
  # 2. Add foreign keys
  dm_add_fk(films_x_characters, url, films) |> 
  dm_add_fk(films_x_characters, characters, people) |>
  dm_add_fk(people, homeworld, planets) 

dm_starwars_1

── Metadata ────────────────────────────────────────────────────────────────────
Tables: `films`, `people`, `planets`, `films_x_characters`
Columns: 10
Primary keys: 4
Foreign keys: 3

dm_draw(dm_starwars_1)

data_films_x_characters_1 <- dm_starwars_1 |> 
  dm_flatten_to_tbl(films_x_characters,
                    .recursive = TRUE) 

Renaming ambiguous columns: %>%
  dm_rename(people, name.people = name) %>%
  dm_rename(planets, name.planets = name)

data_films_x_characters_1

data_films_x_characters_1 |> 
  mutate(name.planets = fct_lump_n(name.planets, 7,
                                   ties.method = "first") |> 
           fct_relevel("Other", 
                       after = Inf)) |> 
  count(title, name.planets) |> 
  mutate(prop = n / sum(n),
         .by = title,
         .keep = "unused") |> 
  ggplot(aes(fct_rev(title), prop,
             fill = name.planets)) +
  geom_col(position = position_stack(reverse = TRUE)) +
  geom_text(aes(label = if_else(prop < 5e-2, 
                                "",
                                scales::label_percent(accuracy = 1)(prop))),
            position = position_stack(vjust = 0.5,
                                      reverse = TRUE)) +
  scale_x_discrete("作品タイトル") +
  scale_y_continuous("登場人物の故郷の惑星の構成比",
                     labels = scales::percent) +
  scale_fill_brewer("惑星名",
                    palette = "Set2") +
  coord_flip() +
  theme(legend.position = "bottom") +
  guides(fill = guide_legend(nrow = 2,
                             byrow = TRUE))

species <- tibble(species = sw_species) |> 
  unnest_wider(species) |> 
  select(url, name)

species

dm_starwars_2 <- dm_starwars_1 |> 
  dm(species) |> 
  dm_add_pk(species, url) |> 
  dm_add_fk(people, species, species)

dm_draw(dm_starwars_2)

dm_starwars_2_wrong_data <- dm_starwars_1 |> 
  dm(species = species |> 
       slice(-1)) |> 
  dm_add_pk(species, url) |> 
  dm_add_fk(people, species, species)

dm_starwars_2_wrong_pk <- dm_starwars_1 |> 
  dm(species) |> 
  dm_add_pk(species, name) |> 
  dm_add_fk(people, species, species)

print(dm_examine_constraints(dm_starwars_2))

ℹ All constraints satisfied.

print(dm_examine_constraints(dm_starwars_2_wrong_data))

! Unsatisfied constraints:

• Table `people`: foreign key `species` into table `species`: values of `people$species` not in `species$url`: http://swapi.co/api/species/5/ (1)

print(dm_examine_constraints(dm_starwars_2_wrong_pk))

! Unsatisfied constraints:

• Table `people`: foreign key `species` into table `species`: values of `people$species` not in `species$name`: http://swapi.co/api/species/1/ (35), http://swapi.co/api/species/2/ (5), http://swapi.co/api/species/12/ (3), http://swapi.co/api/species/15/ (2), http://swapi.co/api/species/22/ (2), …

dm_starwars_2 |> 
  dm_flatten_to_tbl(films_x_characters,
                    .recursive = TRUE) |> 
  mutate(name.species = name.species |> 
           fct_na_value_to_level("Other") |> 
           fct_lump_n(7,
                      ties.method = "first") |> 
           fct_relevel("Other", 
                       after = Inf)) |> 
  count(title, name.species) |> 
  mutate(prop = n / sum(n),
         .by = title,
         .keep = "unused") |> 
  ggplot(aes(fct_rev(title), prop,
             fill = name.species)) +
  geom_col(position = position_stack(reverse = TRUE)) +
  geom_text(aes(label = if_else(prop < 5e-2, 
                                "",
                                scales::label_percent(accuracy = 1)(prop))),
            position = position_stack(vjust = 0.5,
                                      reverse = TRUE)) +
  scale_x_discrete("作品タイトル") +
  scale_y_continuous("登場人物の種族の構成比",
                     labels = scales::percent) +
  scale_fill_brewer("種族名",
                    palette = "Set2") +
  coord_flip() +
  theme(legend.position = "bottom") +
  guides(fill = guide_legend(nrow = 2,
                             byrow = TRUE))

まとめ

この記事では，dmを使ってリレーショナルデータモデルを構築する方法を紹介しました． dmを使って，ひとたびリレーショナルデータモデルを構築してしまえば， データ間の関係を自ら管理する必要がなくなり，dm_flatten_to_tbl()でデータの結合を自動的に行うことができます． それ以外にも，dmでは，dm()によるモデル拡張やdm_examine_constraints()結合のためのキーの整合性の確認など， データ前処理の質を高めるための便利な機能が提供されています．

参考文献

• dmパッケージのサイト
• 前処理大全［データ分析のためのSQL/R/Python実践テクニック］
• starwarsdb
  • Star WarsのリレーショナルデータモデルがCRANからダウンロードできます

半円を描く関数

半径の半円を描く関数は 式 1 と表せます．Rで書くとsemicircle() 関数のようになります．

semicircle <- function(x, radius) {
  sqrt(radius^2 - x^2)
}

実装したsemicircle() 関数で半径の半円を描いてみましょう．

radius <- 5
curve(semicircle(x, radius), -radius, radius,
      asp = 1) # アスペクト比を1:1にする

数値積分で円の面積を求める

次に，stats::integrate() 関数を用いて，さきほど書いたsemicircle() を数値積分してみましょう．半径の場合，積分すると半円の面積とほぼ等しくなることが確認できます．

# 半径を5とする
radius <- 5
integrate(semicircle, -radius, radius, # -radiusからradiusまでの範囲で積分する
          radius = radius)

39.26991 with absolute error < 2.5e-08

pi * 5^2 / 2

[1] 39.26991

そのため，円の面積を近似的に求めるcircle_area_approx()が以下のように書けます（数値積分の結果は，stats::integrate() 関数の戻り値のvalue に格納されています）．

circle_area_approx <- function(radius) {
  out <- integrate(semicircle, -radius, radius,
                   radius = radius)
  out$value * 2
}

circle_area_approx(5)

[1] 78.53982

最後に，半径の範囲で近似値circle_area_approx()と理論値circle_area_true()（）を比較してみましょう．

計算の結果，近似値と理論値で円の面積がほぼ等しいことが確認できました．

circle_area_true <- function(radius) {
  pi * radius ^ 2
}

data <- data.frame(radius = 1:10)
data$circle_area_approx <- sapply(data$radius, circle_area_approx)
data$circle_area_true <- sapply(data$radius, circle_area_true)
knitr::kable(data)

おわりに

stats::integrate() 関数を使えば，簡単に一次元関数の数値積分ができることがわかりました．

# OK
integrate(dnorm, -Inf, Inf)

1 with absolute error < 9.4e-05

# NG
integrate(dnorm, -1e6, 1e6)

0 with absolute error < 0

スライド作成について

これまでQuartoをGitHubのREADMEやサイト作成などに活用してきましたが，今回，はじめてスライド作成に挑戦してみました．

以下のページを参考にしながら，自作パッケージのjpstatを紹介するスライドを試しに作ってみたところ，案外，簡単にスライドが作成でき，折角なのでR勉強会で発表してみました．

• https://quarto.org/docs/presentations/

• https://quarto.org/docs/presentations/revealjs/

ソースコードはこちらです．Quartoは，こちらのqmd（Quarto Markdown）ファイルで記述されてます．

以下では，Quartoとreveal.jsによるスライド作成で今回，特に便利と感じた機能を紹介します．

```{r}
#| echo: true
#| code-line-numbers: "2-3"

estat(statsDataId = "0003343671") |> 
  activate(cat01) |> 
  filter(str_detect(name, "チョコレート"))
```

---
title: "e-Stat🤝R"
subtitle: "Tokyo.R #108"
author: UchidaMizuki
date: "2023-09-02"
footer: <https://github.com/UchidaMizuki/jpstat>
format: 
  revealjs
---

まとめ

Quartoを使うことでLT発表にちょうどよいプレゼンテーション資料を簡単につくれることが実感できました．

ちなみに，これまでもQuartoで作成したページのGitHub Pagesへの公開を行ってきましたが，今回のreveal.jsのスライドもPublish Commandを利用することで簡単に公開することができました²．

なぜベイズの定理が重要なのか？

式 2 に基づき，ベイズの定理の重要性について考えてみましょう． 実は， 式 2 に示したベイズの定理に出てくる3つの確率は，どれも非常に重要な指標と対応しています（下表参照）． つまり， 式 2 からは，検査の精度（感度・特異度）が高くても，検査前確率が低ければ陽性的中率が低くなることなどがわかります．

確率	医療分野で対応する指標
	検査後確率：統計学では事後確率と呼ばれる 陽性的中率：陽性と診断されたとき実際に感染 陰性的中率：陰性と診断されたとき実際に未感染
	感度：感染者が陽性と診断される確率↔︎偽陰性に関連 特異度：未感染者が陰性と診断される確率↔︎偽陽性に関連
	検査前確率：統計学では事前確率と呼ばれる 検査対象者のなかでの感染者の割合

たとえば，以下のような状況を考えてみましょう．

• 感度・特異度はともに99 %（偽陰性・偽陽性がいずれも1 %の確率で生じる）
• 検査前確率は1 %（感染者は100 人中1 人で残りの99 人は未感染者）

この場合，陽性と診断された場合に感染者である確率と，陽性と診断された場合に未感染者である確率は， それぞれ 式 3 となります．

式 3 より，とは等しいことがわかり， 陽性的中率は50 %となります． つまり，陽性と診断された検査対象者のなかで，実際に，感染者である人は2人に1人しかいないことがわかります．

このように，ベイズの定理を用いることで 「検査の精度（感度・特異度）が高くても検査前確率が低ければ陽性的中率が低くなってしまう」といった 重要な関係性が明らかとなります．

まとめ

コロナ禍で普及したPCR検査を例に，ベイズの定理の重要性について説明しました．

現実に即した計算事例に興味がある場合は， 統計局の公開しているコラムもご一読されることをおすすめします．

世代間の「1票の格差」とは？

ここまで紹介した地域間の「1票の格差」に加えて，世代間にも「1票の格差」が存在するといわれています⁴．これは，少子高齢化により，若年層の有権者数に対して高齢者層の有権者数が多くなることにより引き起こされるものです⁵．

さきほど示した都市・地方部の関係と同様に，若年層と高齢者層は，以下の表のような関係にあると考えられます．地方における人口減少・人手不足が深刻となった最近になってようやく，国は，少子化対策を国の最重要課題に位置づけましたが，これまで，こうした若年層向けの政策が十分に行われなかった⁶のは世代間の「1票の格差」の影響によるものかもしれません．

世代間の「1票の格差」を定量化してみる

地域間の「1票の格差」は，（都市部基準で）約〇倍といった定量化がなされることが一般的ですが，世代間の「1票の格差」については，これまで，あまり定量化されていないようです．

単純な定量化の方法としては，年齢層別の人口を何らかの基準人口で割るといったものが考えられますが，このような方法では，加齢により亡くなる方がいることが考慮されず，「人口が少ないので100歳以上の1票の価値が軽い」といった評価をすることになってしまいます．

そこで，2020年国勢調査人口と2020年生命表を用いて，世代間の「1票の格差」を定量化してみようと思います．生命表とは，「ある期間における死亡状況が今後変化しないとの仮定のもとで各年齢の者が1年以内に死亡する確率などの指標を表したもの」です⁷．

以下で示す世代間の「1票の格差」は，あくまで，オープンデータに基づく簡易的な試算であることにご注意ください．

library(tidyverse)
library(fs)
library(arrow)
library(readxl)
library(jpstat)

theme_set(theme_light())

dir_create("quantify-vote-disparity-between-generations")

# jpstatパッケージを使って2020年国勢調査データをダウンロードしています
if (!file_exists("quantify-vote-disparity-between-generations/pop_2020.parquet")) {
  # 注意: jpstatパッケージはe-Stat APIを利用するためAPIキーが必要です
  # あらかじめ Sys.setenv(ESTAT_API_KEY = "取得したappId") を実行しておいてください
  census_2020 <- estat(statsDataId = "https://www.e-stat.go.jp/dbview?sid=0003445139")

  pop_2020 <- census_2020 |>
    activate(tab) |>
    select() |>
  
    activate(cat01) |>
    filter(name == "うち日本人") |>
    select() |>
  
    activate(cat02) |>
    rekey("sex") |>
    filter(name %in% c("男", "女")) |>
    select(name) |>
  
    activate(cat03) |>
    rekey("age") |>
    select(name) |>
  
    activate(area) |>
    filter(name == "全国") |>
    select() |>
  
    activate(time) |>
    select() |>
  
    collect(n = "pop")
  
  pop_2020 <- pop_2020 |> 
    filter(str_detect(age_name, "^\\d+歳$") | age_name == "100歳以上") |> 
    mutate(sex = as_factor(sex_name),
           age = case_when(str_detect(age_name, "^\\d+歳$") ~ age_name |> 
                             str_extract("\\d+"),
                           age_name == "100歳以上" ~ "100--Inf") |> 
             as_factor(),
           pop = parse_number(pop),
           .keep = "unused") |> 
    relocate(sex, age, pop)
  
  write_parquet(pop_2020, "quantify-vote-disparity-between-generations/pop_2020.parquet") 
}

# 第23回生命表（男）
file_lifetable_male_2020 <- "quantify-vote-disparity-between-generations/lifetable_male_2020.xlsx"
if (!file_exists(file_lifetable_male_2020)) {
  curl::curl_download("https://www.e-stat.go.jp/stat-search/file-download?statInfId=000032173232&fileKind=0", file_lifetable_male_2020) 
}

# 第23回生命表（女）
file_lifetable_female_2020 <- "quantify-vote-disparity-between-generations/lifetable_female_2020.xlsx"
if (!file_exists(file_lifetable_female_2020)) {
  curl::curl_download("https://www.e-stat.go.jp/stat-search/file-download?statInfId=000032173233&fileKind=0", file_lifetable_female_2020)
}

col_names_lifetable <- read_excel(file_lifetable_male_2020, 
                        range = "B3:J5",
                        col_names = as.character(1:9)) |> 
  t() |> 
  as_tibble(.name_repair = \(x) c("col_name_1", "col_name_2", "col_name_3")) |> 
  unite("col_name", starts_with("col_name"),
        na.rm = TRUE) |> 
  mutate(col_name = col_name |> 
           str_remove_all("\\s")) |> 
  pull(col_name)

range_lifetable <- "B6:J127"

lifetable_male_2020 <- read_excel(file_lifetable_male_2020,
                                  range = range_lifetable,
                                  col_names = col_names_lifetable)

lifetable_female_2020 <- read_excel(file_lifetable_female_2020,
                                    range = range_lifetable,
                                    col_names = col_names_lifetable)

static_pop_2020 <- list(男 = lifetable_male_2020,
                        女 = lifetable_female_2020) |> 
  bind_rows(.id = "sex") |> 
  rename(age = 年齢_x,
         static_pop = 定常人口_nLx_人) |> 
  select(sex, age, static_pop) |> 
  filter(str_ends(age, "年")) |> 
  mutate(sex = as_factor(sex),
         age = age |> 
           str_extract("^\\d+") |> 
           parse_integer(),
         # 100歳以上はまとめる
         age = if_else(age >= 100,
                       "100--Inf",
                       as.character(age)) |> 
           as_factor()) |> 
  summarise(static_pop = sum(static_pop),
            .by = c(sex, age))

write_parquet(static_pop_2020, "quantify-vote-disparity-between-generations/static_pop_2020.parquet")

# 100歳以上を数値100で置き換える
as_integer_age <- function(age) {
  if_else(age == "100--Inf",
          100,
          parse_integer(as.character(age),
                        na = "100--Inf"))
}

pop_2020 <- read_parquet("quantify-vote-disparity-between-generations/pop_2020.parquet") |> 
  mutate(age = as_integer_age(age))
static_pop_2020 <- read_parquet("quantify-vote-disparity-between-generations/static_pop_2020.parquet") |> 
  mutate(age = as_integer_age(age))

ratio_pop_static_pop <- static_pop_2020 |> 
  filter(age == 0) |> 
  select(!age) |> 
  left_join(pop_2020 |> 
              filter(age == 0) |> 
              select(!age),
            by = join_by(sex)) |> 
  mutate(ratio_pop_static_pop = pop / static_pop,
         .keep = "unused")

static_pop_2020 <- static_pop_2020 |> 
  left_join(ratio_pop_static_pop,
            by = join_by(sex)) |> 
  mutate(pop = static_pop * ratio_pop_static_pop,
         .keep = "unused")

pop_2020 |>
  mutate(pop = if_else(sex == "男",
                       -pop,
                       pop)) |> 
  ggplot(aes(age, pop,
             fill = sex)) +
  geom_col() +
  geom_line(data = static_pop_2020 |> 
               mutate(pop = if_else(sex == "男",
                                    -pop,
                                    pop)),
            aes(group = sex,
                color = "定常人口\n（参考値）")) +
  scale_x_continuous("年齢",
                     breaks = seq(0, 100, 10)) +
  scale_y_continuous("人口［千人］",
                     labels = \(x) {
                       scales::label_comma(scale = 1e-3)(abs(x))
                     }) +
  scale_fill_manual("性別",
                    values = c(男 = "cornflowerblue",
                               女 = "lightcoral")) +
  scale_color_manual(NULL,
                     values = c(`定常人口\n（参考値）` = "red")) +
  coord_flip() +
  guides(fill = guide_legend(order = 1),
         color = guide_legend(order = 2))

vote_disparity <- pop_2020 |> 
  left_join(static_pop_2020 |> 
              rename(static_pop = pop),
            by = join_by(sex, age)) |>
  filter(age >= 18) |> 
  mutate(ageclass = case_when(between(age, 18, 29) ~ "18～29歳",
                              between(age, 30, 39) ~ "30代",
                              between(age, 40, 49) ~ "40代",
                              between(age, 50, 59) ~ "50代",
                              between(age, 60, 69) ~ "60代",
                              between(age, 70, 79) ~ "70代",
                              between(age, 80, 89) ~ "80代",
                              90 <= age ~ "90代以上")) |> 
  summarise(across(c(pop, static_pop),
                   sum),
            .by = ageclass) |> 
  mutate(vote_disparity = pop / static_pop,
         .keep = "unused")

vote_disparity <- vote_disparity |> 
  bind_cols(vote_disparity |> 
              filter(ageclass == "18～29歳") |> 
              select(!ageclass) |> 
              rename(vote_disparity_18to29 = vote_disparity)) |> 
  mutate(vote_disparity = vote_disparity / vote_disparity_18to29,
         .keep = "unused")

plot_vote_disparity <- vote_disparity |> 
  ggplot(aes(ageclass, vote_disparity)) +
  geom_col(fill = "lightblue") +
  geom_text(aes(label = scales::label_comma(accuracy = 1e-2)(vote_disparity)),
            y = 1,
            vjust = -0.5,
            color = "red") +
  geom_hline(yintercept = 1,
             color = "red",
             linetype = "dashed") +
  scale_x_discrete("年齢層") +
  scale_y_continuous("世代間の「1票の格差」（18～29歳基準）")


ggsave("quantify-vote-disparity-between-generations/plot_vote_disparity.png",
       plot = plot_vote_disparity)

plot_vote_disparity

まとめ

オープンデータである国勢調査と生命表を用いて，世代間の「1票の格差」を定量化してみました．

実は，若者の投票率の低さも世代間の「1票の格差」の大きな要因となっているといわれています．今後は，世代間の「1票の格差」に対する議論を深めつつ，若者の投票率が上がるような魅力的な政策を多く打ち出していくことが必要であると考えられます．

アプリの提供機能について

library(jpgrid)
library(tidyverse)

JGD2011 <- 6668

grid_city_2020 |>
  filter(city_name_ja %in% c("千葉市中央区", "千葉市花見川区", "千葉市稲毛区")) |>
  grid_as_sf(crs = 6668) |> 
  ggplot(aes(fill = city_name_ja)) +
  geom_sf() +
  scale_fill_brewer(palette = "Set2")

おわりに

R Shinyで作成した地域メッシュデータのためのWEBアプリについて紹介しました．

WEBアプリの作成に利用したjpgridパッケージでは，このアプリで提供していない様々な機能が提供されています．詳しくは，こちらをご覧ください．

例として，ジオメトリをメッシュに変換するgeometry_to_grid() などがあります．

ぜひ地域メッシュデータの分析にjpgridパッケージも活用してみてください．

japan <- rnaturalearth::ne_countries(country = "japan",
                                     scale = "medium",
                                     returnclass = "sf")

The rnaturalearthdata package needs to be installed.
Installing the rnaturalearthdata package.
Installing package into 'C:/Users/uchid/AppData/Local/R/win-library/4.6'
(as 'lib' is unspecified)

grid_japan <- japan |> 
  geometry_to_grid("80km") |> 
  dplyr::first() |> 
  grid_as_sf(crs = sf::st_crs(japan))

japan |> 
  ggplot() +
  geom_sf() +
  geom_sf(data = grid_japan,
          fill = "transparent")

国勢調査の時系列データの取得

まず，e-Statで公開されている国勢調査の男女・5最階級別人口の時系列データをRのjpstatパッケージを用いて取得します．

jpstatパッケージからe-Stat APIを用いるためには，アプリケーションID（appId）を取得する必要があります．

library(tidyverse)
library(jpstat)

# ご自身のappIdに置き換えてください
Sys.setenv(ESTAT_API_KEY = "Your appId")

census <- estat(statsDataId = "https://www.e-stat.go.jp/dbview?sid=0003410380")

pop <- census |> 
  activate(tab) |> 
  filter(name == "人口") |> 
  select() |> 
  
  # 性別の抽出
  activate(cat01) |> 
  rekey("sex") |> 
  filter(name %in% c("男", "女")) |> 
  select(name) |> 
  
  # 年齢階級の抽出
  activate(cat02) |> 
  rekey("ageclass") |> 
  filter(str_detect(name, "^\\d+～\\d+歳$") |
           name == "85歳以上" |
           name == "110歳以上") |> 
  select(name) |> 
  
  # 年の抽出
  activate(time) |> 
  rekey("year") |> 
  filter(str_detect(name, "^\\d+年$")) |> 
  select(name) |> 
  
  # e-Statデータの取得
  collect(n = "pop") |> 
  
  rename_with(~ .x |> 
                str_remove("_name$")) |> 
  mutate(sex = as_factor(sex),
         year = parse_number(year),
         
         # 各年齢階級の最低年齢を取得
         age_from = ageclass |> 
           str_extract("^\\d+") |> 
           stringi::stri_trans_nfkc() |> 
           as.integer(),
         
         # 最高の年齢階級を「85歳以上」とする
         ageclass = case_when(age_from >= 85 ~ "85歳以上",
                              TRUE ~ ageclass) |> 
           as_factor(),
         
         # 年齢層を追加
         agegroup = case_when(between(age_from, 0, 10) ~ "年少人口",
                              between(age_from, 15, 60) ~ "生産年齢人口",
                              between(age_from, 65, 70) ~ "前期老年人口",
                              age_from >= 75 ~ "後期老年人口") |> 
           as_factor(),
         pop = parse_number(pop)) |> 
  
  # 「85歳以上」人口を集計
  group_by(year, sex, ageclass, agegroup) |> 
  summarise(pop = sum(pop),
            .groups = "drop")

The total number of data is 796.

knitr::kable(head(pop))

人口ピラミッドアニメーションの作成

Rのgganimateパッケージを用いることでggplot2のグラフをアニメーションにすることができます．

library(gganimate)

Warning: package 'gganimate' was built under R version 4.6.1

# 年齢層を表示するためのデータ
agegroup <- pop |> 
  group_by(sex, agegroup) |>
  summarise(ageclass = mean(as.integer(ageclass)),
            .groups = "drop") |> 
  mutate(hjust = case_when(sex == "男" ~ 1.25,
                           sex == "女" ~ -0.25))

poppyramid <- pop |> 
  
  # 人口ピラミッドを作成するため男性人口をマイナスに変換
  mutate(pop = if_else(sex == "男", -pop, pop)) |> 
  
  ggplot(aes(ageclass, pop,
             group = sex,
             fill = agegroup)) +
  geom_col(show.legend = FALSE) +
  geom_text(data = agegroup,
            aes(label = agegroup,
                hjust = hjust),
            y = 0) +
  scale_x_discrete(NULL) +
  scale_y_continuous("人口［千人］",
                     
                     # ラベルを絶対値・千人単位に変換
                     labels = purrr::compose(scales::label_comma(scale = 1e-3), abs)) +
  scale_fill_brewer(palette = "Set2") +
  coord_flip() +
  facet_wrap(~ sex,
             scales = "free_x") +
  labs(title = "{frame_time %/% 5 * 5}年") +
  theme(plot.title = element_text(hjust = 0.5)) +
  
  # アニメーションに変換
  transition_time(year)

# 幅・高さを変更
animate(poppyramid,
        width = 800,
        height = 600,
        units = "px",
        res = 150,
        renderer = gifski_renderer())

e-Statについて

e-Statには，様々な政府統計のデータベースが整理されていますが，ここでは，2015年国民健康・栄養調査の調査結果から睡眠時間に関するデータベースを見てみましょう．

データベースを開くと以下のように統計表が表示され，右上の「ダウンロード」ボタンからデータをダウンロードすることができます．

画面左上の「表示項目選択」ボタンをクリックすると，表示するデータの項目（年齢階級・性別など）を選択することができます．

たとえば，年齢階級を選択したい場合は，年齢階級の「項目を選択」ボタンをクリックすると以下のような画面で年齢階級を選択することができます．

表示項目を選択した後に，「ダウンロード」ボタンをクリックすると，選択した項目のデータのみをダウンロードすることができます．

このように，e-Statでは，簡単にデータを抽出・ダウンロードすることができます．しかし，データ取得作業の再現性を高めたり，プログラムを用いたデータ抽出・取得の効率化を行ったりしたい場合は，e-Stat APIを用いるのがおすすめです．

jpstatパッケージでe-Stat APIを使う

上で説明したe-Statでのデータの抽出・ダウンロードをe-Stat APIで行うためには，以下のようなステップを踏む必要があります．

1. メタ情報取得・パラメータ設定：表示項目データを取得・選択，選択項目に対応するAPIパラメータを設定
2. 統計データ取得：選択したデータを取得・表データに整形する

jpstatパッケージは，これらの一連の作業をR上で効率的に行うため開発されたものです¹．jpstatパッケージは，CRANからインストールすることができます．

ここでは，男女・年齢階級別の睡眠時間をグラフ化することを目標として，さきほど取り上げた睡眠時間に関するデータベース（2015年）からデータを取得してみましょう．まず，必要なパッケージを読み込みます．

install.packages("jpstat")

library(tidyverse)
library(jpstat)

# ご自身のappIdに置き換えてください
Sys.setenv(ESTAT_API_KEY = "Your appId")

estat_sleeptime_2015 <- estat(statsDataId = "https://www.e-stat.go.jp/dbview?sid=0003224282")

# メタ情報の閲覧・選択
estat_sleeptime_2015 |> 
  activate(cat01) |> 
  filter(name != "総数")

# ☐ tab:   表章項目     [2] <code, name, level, unit>
# ☒ cat01: 年齢階級     [6] <code, name, level, parentCode>
# ☐ cat02: 睡眠の質     [8] <code, name, level, parentCode>
# ☐ cat03: 性別         [3] <code, name, level, parentCode>
# ☐ cat04: 平均睡眠時間 [6] <code, name, level, parentCode>
# ☐ time:  時間軸(年次) [1] <code, name, level>
# 
# A tibble: 6 × 4
  code  name      level parentCode
  <chr> <chr>     <chr> <chr>     
1 160   20歳-29歳 2     100       
2 170   30歳-39歳 2     100       
3 180   40歳-49歳 2     100       
4 190   50歳-59歳 2     100       
5 210   60歳-69歳 2     100       
6 220   70歳以上  2     100       

estat_sleeptime_2015_filtered <- estat_sleeptime_2015 |> 
  
  # 表章項目
  activate(tab) |> 
  filter(name == "人数") |> 
  
  # 年齢階級
  activate(cat01) |> 
  filter(name != "総数") |> 
  
  # 睡眠の質
  activate(cat02) |> 
  filter(name == "総数") |> 
  
  # 性別
  activate(cat03) |> 
  filter(name %in% c("男性", "女性"))

data_sleeptime_2015 <- estat_sleeptime_2015_filtered |> 
  
  # データ取得・数値に変換
  collect(n = "person") |> 
  mutate(person = parse_number(person))

The total number of data is 72.

knitr::kable(head(data_sleeptime_2015, 10))

data_sleeptime_2015 <- estat_sleeptime_2015 |> 
  activate(tab) |> 
  filter(name == "人数") |> 
  select() |> 
  
  activate(cat01) |> 
  rekey("ageclass") |> 
  filter(name != "総数") |> 
  select(name) |> 
  
  activate(cat02) |> 
  filter(name == "総数") |> 
  select() |> 
  
  activate(cat03) |> 
  rekey("sex") |> 
  filter(name %in% c("男性", "女性")) |> 
  select(name) |> 
  
  activate(cat04) |> 
  rekey("sleeptime") |> 
  select(name) |> 
  
  activate(time) |> 
  select() |> 
  
  collect(n = "person") |> 
  mutate(person = parse_number(person))

The total number of data is 72.

knitr::kable(head(data_sleeptime_2015, 10))

data_sleeptime_2015 |> 
  mutate(ageclass_name = as_factor(ageclass_name),
         sex_name = as_factor(sex_name),
         sleeptime_name = as_factor(sleeptime_name)) |> 
  group_by(ageclass_name, sex_name) |> 
  mutate(prop = person / sum(person)) |> 
  ungroup() |> 
  ggplot(aes(ageclass_name, prop,
             fill = fct_rev(sleeptime_name))) +
  geom_col() +
  geom_text(aes(label = if_else(prop > 0.05,
                                scales::label_percent(accuracy = 1)(prop),
                                "")),
            position = position_stack(vjust = 0.5)) +
  scale_x_discrete("年齢階級") +
  scale_y_continuous("割合", 
                     labels = scales::label_percent(accuracy = 1)) +
  scale_fill_brewer("睡眠時間",
                    palette = "Spectral") +
  facet_wrap(~ sex_name) +
  guides(x = guide_axis(n.dodge = 2))

まとめ

本記事では，e-Stat APIとjpstatパッケージで日本の統計データを効率的に取得する方法について紹介しました．

Rで統計データを取得することで，作業の再現性や効率性を高めることができます．また，jpstatパッケージを使うことで，データ取得とデータ整形を同時に行うことができるため便利です．みなさんもぜひ使ってみてください．

サンプルデータの準備

CSVとParquetを比較するため，まずは，データ分析にありがちなサンプルデータを用意しましょう．今回は，tidyrパッケージで提供されているwho （世界保健機関（WHO）結核データ）からサンプルデータをつくります．

近年，データ分析では，整然データ（tidy data）の概念が普及しています．tidy dataは，個々の変数が1つの列をなし，個々の観測（値）が1つの行をなすようなデータです．

それでは，whoは，tidy dataと言えるでしょうか？whoには，"new_sp_m014" ～"newrel_f65" といったたくさんの列が存在しますが，これらには，1列ごとに，診断結果（spやsel）・性別（mとf）・年齢階級（014や65）といった複数の変数が含まれています．そのため，who は，tidy dataでないといえます．そこで，こちらに従ってtidy dataであるwho_longerに変形します．

データ分析では，who よりtidy dataであるwho_longer のほうを分析が行いやすい一方で，行数はwho（約7,000行）よりwho_longer （約400,000行）のほうが約50倍多いことがわかります．そのため，tidy dataであるwho_longerのようなデータをテキストファイルであるCSVで保存すると容量が増大してしまいます．

このように，tidy dataはデータ分析に適している一方で，CSVのようなテキストファイルでの保存に適していないことがわかります．しかし，このようなデータ保存上の課題はParquetを使えば解決することができます．

ここで，tidy dataでないwho とtidy dataであるwho_longer を見比べてみましょう．

library(tidyverse)

Warning: package 'ggplot2' was built under R version 4.2.3

Warning: package 'tibble' was built under R version 4.2.3

Warning: package 'dplyr' was built under R version 4.2.3

library(fs)

levels_gender <- c("f", "m")
levels_age <- c("014", "1524", "2534", "3544", "4554", "5564", "65")

who_longer <- who |> 
  pivot_longer(cols = new_sp_m014:newrel_f65,
               names_to = c("diagnosis", "gender", "age"), 
               names_pattern = "new_?(.*)_(.)(.*)",
               names_transform = list(gender = ~ .x |> 
                                        readr::parse_factor(levels = levels_gender),
                                      age = ~ .x |> 
                                        readr::parse_factor(levels = levels_age,
                                                            ordered = TRUE)),
               values_to = "count")

# データ整形前
print(who, n = 5)

# A tibble: 7,240 × 60
  country   iso2  iso3   year new_sp_m014 new_sp_m1524 new_sp_m2534 new_sp_m3544
  <chr>     <chr> <chr> <dbl>       <dbl>        <dbl>        <dbl>        <dbl>
1 Afghanis… AF    AFG    1980          NA           NA           NA           NA
2 Afghanis… AF    AFG    1981          NA           NA           NA           NA
3 Afghanis… AF    AFG    1982          NA           NA           NA           NA
4 Afghanis… AF    AFG    1983          NA           NA           NA           NA
5 Afghanis… AF    AFG    1984          NA           NA           NA           NA
# ℹ 7,235 more rows
# ℹ 52 more variables: new_sp_m4554 <dbl>, new_sp_m5564 <dbl>,
#   new_sp_m65 <dbl>, new_sp_f014 <dbl>, new_sp_f1524 <dbl>,
#   new_sp_f2534 <dbl>, new_sp_f3544 <dbl>, new_sp_f4554 <dbl>,
#   new_sp_f5564 <dbl>, new_sp_f65 <dbl>, new_sn_m014 <dbl>,
#   new_sn_m1524 <dbl>, new_sn_m2534 <dbl>, new_sn_m3544 <dbl>,
#   new_sn_m4554 <dbl>, new_sn_m5564 <dbl>, new_sn_m65 <dbl>, …

# データ整形後
print(who_longer, n = 5)

# A tibble: 405,440 × 8
  country     iso2  iso3   year diagnosis gender age   count
  <chr>       <chr> <chr> <dbl> <chr>     <fct>  <ord> <dbl>
1 Afghanistan AF    AFG    1980 sp        m      014      NA
2 Afghanistan AF    AFG    1980 sp        m      1524     NA
3 Afghanistan AF    AFG    1980 sp        m      2534     NA
4 Afghanistan AF    AFG    1980 sp        m      3544     NA
5 Afghanistan AF    AFG    1980 sp        m      4554     NA
# ℹ 405,435 more rows

CSV・Parquetの保存方法

Rでは，write_csv() でCSVを保存できます．同様に，arrowパッケージのwrite_parquet() でParquetを保存することができます．who_longerをCSVとParquetで保存してみましょう．

CSVとParquetでは，どちらも簡単にデータ保存ができることがわかります．

library(arrow)

Warning: package 'arrow' was built under R version 4.2.3

# CSVを保存
write_csv(who_longer, "who_longer.csv")

# Parquetを保存
write_parquet(who_longer, "who_longer.parquet")

Parquetのメリット・CSVとの比較

ここからは，保存したwho_longer のCSV・Parquetファイルを比較して，CSVに対するParquetのメリットを紹介していきます．

# CSV
file_size("who_longer.csv")

14.1M

# Parquet
file_size("who_longer.parquet")

156K

units::set_units(file_size("who_longer.parquet") / file_size("who_longer.csv")) |> 
  units::set_units(`%`)

1.080502 [%]

# CSVの読み込み
read_csv("who_longer.csv",
         col_types = cols(.default = "c",
                          year = "i",
                          count = "i"))

# Parquetの読み込み
read_parquet("who_longer.parquet")

read_parquet("who_longer.parquet",
             as_data_frame = FALSE) |> 
  filter(country == "Japan",
         !is.na(count)) |> 
  group_by(country, year, diagnosis) |> 
  summarise(count = sum(count),
            .groups = "drop") |> 
  collect()

# A tibble: 33 × 4
   country  year diagnosis count
   <chr>   <dbl> <chr>     <dbl>
 1 Japan    1995 sp        14367
 2 Japan    1996 sp        12867
 3 Japan    1997 sp        13571
 4 Japan    1998 sp        11935
 5 Japan    2001 sp        11408
 6 Japan    2002 sp        10807
 7 Japan    2003 sp        10843
 8 Japan    2004 sp        10471
 9 Japan    1999 sp        12909
10 Japan    2000 sp        11853
# ℹ 23 more rows

dir_create("who_longer_byage")
who_longer |> 
  group_by(age) |> 
  group_walk(~ .x |> 
               write_parquet(str_glue("who_longer_byage/who_longer_{.y$age}.parquet")),
  .keep = TRUE)

open_dataset("who_longer_byage") |> 
  filter(country == "Japan",
         !is.na(count)) |> 
  group_by(country, year, diagnosis) |> 
  summarise(count = sum(count),
            .groups = "drop") |> 
  collect()

# A tibble: 33 × 4
   country  year diagnosis count
   <chr>   <dbl> <chr>     <dbl>
 1 Japan    1995 sp        14367
 2 Japan    1996 sp        12867
 3 Japan    1997 sp        13571
 4 Japan    1998 sp        11935
 5 Japan    2001 sp        11408
 6 Japan    2002 sp        10807
 7 Japan    2003 sp        10843
 8 Japan    2004 sp        10471
 9 Japan    2005 sp        10931
10 Japan    2006 sp        10159
# ℹ 23 more rows

import pandas as pd

pd.read_parquet('who_longer.parquet')

            country iso2 iso3    year diagnosis gender   age   count
0       Afghanistan   AF  AFG  1980.0        sp      m   014     NaN
1       Afghanistan   AF  AFG  1980.0        sp      m  1524     NaN
2       Afghanistan   AF  AFG  1980.0        sp      m  2534     NaN
3       Afghanistan   AF  AFG  1980.0        sp      m  3544     NaN
4       Afghanistan   AF  AFG  1980.0        sp      m  4554     NaN
...             ...  ...  ...     ...       ...    ...   ...     ...
405435     Zimbabwe   ZW  ZWE  2013.0       rel      f  2534  4649.0
405436     Zimbabwe   ZW  ZWE  2013.0       rel      f  3544  3526.0
405437     Zimbabwe   ZW  ZWE  2013.0       rel      f  4554  1453.0
405438     Zimbabwe   ZW  ZWE  2013.0       rel      f  5564   811.0
405439     Zimbabwe   ZW  ZWE  2013.0       rel      f    65   725.0

[405440 rows x 8 columns]

まとめ

ここまで，R・Pythonで利用可能なParquetのメリットを紹介しました．Parquetは，近年，データ分析で普及しているtidy dataの保存・集計に適しています．

また，最近では，地理データを扱えるsfパッケージのデータをparquetとして保存できるsfarrowなども登場しています．

CSVの代わりにParquetを用いることでデータ分析がさらに簡単になることが期待されます．