Rによる計量政治学：練習問題の解答例

Q15-1

Rds形式の衆院選データ (hr-data.Rds) を読み込み、「HR」というデータフレーム名を付ける。手元にない場合はまずダウンロードする。

# dir.create("data") # dataディレクトリがない場合は作る
#download.file(url = "https://git.io/fp00p",
#              destfile = "data/hr-data.Rds")
HR <- read_rds("data/hr-data.Rds")
## Rdsファイルの読み込みがうまくいかない場合は以下を実行してCSVファイルを使う
#download.file(url = "https://git.io/fxhQU",
#              destfile = "data/hr-data.csv")
#HR <- read_csv("data/hr-data.csv")

データが正しく読み込めたか確認する。

glimpse(HR)

## Rows: 8,803
## Columns: 22
## $ year       <dbl> 1996, 1996, 1996, 1996, 1996, 1996, 1996, 1996, 1996, 1996,…
## $ ku         <chr> "aichi", "aichi", "aichi", "aichi", "aichi", "aichi", "aich…
## $ kun        <dbl> 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3,…
## $ status     <fct> 現職, 元職, 現職, 新人, 新人, 新人, 新人, 現職, 元職, 新人, 新人, 新人, 新人, 新人, 新人,…
## $ name       <chr> "KAWAMURA, TAKASHI", "IMAEDA, NORIO", "SATO, TAISUKE", "IWA…
## $ party      <chr> "NFP", "LDP", "DPJ", "JCP", "others", "kokuminto", "indepen…
## $ party_code <dbl> 8, 1, 3, 2, 100, 22, 99, 8, 1, 3, 2, 10, 100, 99, 22, 8, 1,…
## $ previous   <dbl> 2, 3, 2, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 3, 1, 0, 0,…
## $ wl         <fct> 当選, 落選, 落選, 落選, 落選, 落選, 落選, 当選, 落選, 復活当選, 落選, 落選, 落選, 落選, 落…
## $ voteshare  <dbl> 40.0, 25.7, 20.1, 13.3, 0.4, 0.3, 0.2, 32.9, 26.4, 25.7, 12…
## $ age        <dbl> 47, 72, 53, 43, 51, 51, 45, 51, 71, 30, 31, 44, 61, 47, 43,…
## $ nocand     <dbl> 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 7,…
## $ rank       <dbl> 1, 2, 3, 4, 5, 6, 7, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5,…
## $ vote       <dbl> 66876, 42969, 33503, 22209, 616, 566, 312, 56101, 44938, 43…
## $ eligible   <dbl> 346774, 346774, 346774, 346774, 346774, 346774, 346774, 338…
## $ turnout    <dbl> 49.2, 49.2, 49.2, 49.2, 49.2, 49.2, 49.2, 51.8, 51.8, 51.8,…
## $ exp        <dbl> 9828097, 9311555, 9231284, 2177203, NA, NA, NA, 12940178, 1…
## $ expm       <dbl> 9.828097, 9.311555, 9.231284, 2.177203, NA, NA, NA, 12.9401…
## $ vs         <dbl> 0.400, 0.257, 0.201, 0.133, 0.004, 0.003, 0.002, 0.329, 0.2…
## $ exppv      <dbl> 28.341505, 26.851941, 26.620462, 6.278449, NA, NA, NA, 38.2…
## $ smd        <fct> 当選, 落選, 落選, 落選, 落選, 落選, 落選, 当選, 落選, 落選, 落選, 落選, 落選, 落選, 落選,…
## $ party_jpn  <chr> "新進党", "自民党", "民主党", "共産党", "その他", "国民党", "無所属", "新進党", "自民…

filter() と select()を使って、2009年の衆院選データだけを切り取り、分析で使う変数 (voteshare, expm, previous) だけを指定して「hr2012」というデータフレーム名を付ける。

hr2012 <- HR %>% 
  filter(year == 2009) %>% 
  select(smd, previous, expm)

summary() を使って記述統計を確認する。

summary(hr2012)

##    smd         previous           expm         
##  落選:839   Min.   : 0.000   Min.   : 0.01002  
##  当選:300   1st Qu.: 0.000   1st Qu.: 1.79454  
##             Median : 0.000   Median : 4.80944  
##             Mean   : 1.722   Mean   : 6.11818  
##             3rd Qu.: 3.000   3rd Qu.: 9.10911  
##             Max.   :16.000   Max.   :25.35407  
##                              NA's   :15

Q15-1-1

小選挙区での当落 (smd) を縦軸、選挙費用 (expm) を横軸にとった散布図を描く。

plt1 <- ggplot(hr2012, aes(x = expm, 
                           y = as.numeric(smd == "当選"))) +
  geom_smooth(method = "lm", se = FALSE) +
  geom_hline(yintercept = c(0, 1), color = "grey") +
  geom_jitter(height = 0.05) +
  scale_y_continuous(breaks = 0:1) +
  labs(x = "選挙費用（百万円）", y = "小選挙区での当落")
print(plt1)

Q15-1-2

小選挙区での当落 (smd) を縦軸、過去の当選回数 (previous) を横軸にとった散布図を描く。

plt2 <- ggplot(hr2012, aes(x = previous, 
                           y = as.numeric(smd == "当選"))) +
  geom_smooth(method = "lm", se = FALSE) +
  geom_hline(yintercept = c(0, 1), color = "grey") +
  geom_jitter(height = 0.05) +
  scale_y_continuous(breaks = 0:1) +
  labs(x = "過去の当選回数", y = "小選挙区で当落")
print(plt2)

過去の当選回数と小選挙区の当落との間には正の相関があることが確認できる。

Q15-1-3

ロジスティック回帰分析を実行する。有意水準は5% (0.05) に設定する。

hr2012 <- na.omit(hr2012)  # 望ましい方法ではないが、欠測がある観測を除外する
model_4 <- glm(smd ~ previous + expm, data = hr2012,
               family = binomial(link = "logit"))
summary(model_4)

## 
## Call:
## glm(formula = smd ~ previous + expm, family = binomial(link = "logit"), 
##     data = hr2012)
## 
## Coefficients:
##             Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.02049    0.13138 -15.379  < 2e-16
## previous     0.31908    0.03674   8.685  < 2e-16
## expm         0.04977    0.01803   2.761  0.00576
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 1300.1  on 1123  degrees of freedom
## Residual deviance: 1092.6  on 1121  degrees of freedom
## AIC: 1098.6
## 
## Number of Fisher Scoring iterations: 4

previousとexpmとう二つの変数の\(p\)値がどちらも0.05より小さいので、これらの変数の係数の推定値が統計的に有意であることがわかる。しかし、このままでは係数の意味がわかりにくい。
様々な工夫をすることによって、結果を読み解く作業が必要である。

Q15-1-4

上で推定した結果を式にまとめる。 \[ \widehat{当選確率}_i = \frac{1}{1 + \exp[-(-2.02 + 0.32\cdot 当選回数_i + 0.05\cdot 選挙費用_i)]} \]

Q15-1-5

上の式を可視化し、「当選確率」を縦軸、「過去の当選回数 (previous)」を横軸にしたグラフを描く。

pred_prev <-  data_frame(
    previous = seq(min(hr2012$previous), max(hr2012$previous), by = 1),
    expm = mean(hr2012$expm)
)
pred_prev$fit <- predict(model_4, type = "response", newdata = pred_prev)
plt_prev <- ggplot(hr2012, aes(x = previous)) +
    geom_hline(yintercept = c(0, 1), color = "gray") +
    geom_jitter(aes(y = as.numeric(smd == "当選")), 
                width = 0.05, height = 0.05) +
    geom_line(data = pred_prev, aes(y = fit)) +
    geom_point(data = pred_prev, aes(y = fit), pch = 18) +
    labs(x = "過去の当選回数", y = "当選確率")
print(plt_prev)

Q15-1-6

上の式を可視化し、「当選確率」を縦軸、「選挙費用 (expm)」を横軸にしたグラフを描く。

pred_expm <-  data_frame(
    expm = seq(0, max(hr2012$expm), length.out = 100),
    previous = mean(hr2012$previous)
)
pred_expm$fit <- predict(model_4, type = "response", newdata = pred_expm)
plt_expm <- ggplot(hr2012, aes(x = expm)) +
    geom_hline(yintercept = c(0, 1), color = "gray") +
    geom_jitter(aes(y = as.numeric(smd == "当選")), height = 0.05) +
    geom_line(data = pred_expm, aes(y = fit)) +
    labs(x = "選挙費用（100万円）", y = "当選確率")
print(plt_expm)

Q15-1-7

model_5 <- glm(smd ~ previous * expm, data = hr2012,
               family = binomial(link = "logit"))
summary(model_5)

## 
## Call:
## glm(formula = smd ~ previous * expm, family = binomial(link = "logit"), 
##     data = hr2012)
## 
## Coefficients:
##                Estimate Std. Error z value Pr(>|z|)
## (Intercept)   -3.046484   0.193960 -15.707  < 2e-16
## previous       0.985940   0.081859  12.044  < 2e-16
## expm           0.196461   0.024170   8.128 4.35e-16
## previous:expm -0.065827   0.006906  -9.532  < 2e-16
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 1300.1  on 1123  degrees of freedom
## Residual deviance:  970.0  on 1120  degrees of freedom
## AIC: 978
## 
## Number of Fisher Scoring iterations: 5

previous:expm の係数 (\(-0.0658266\)) の推定値が統計的に有意（5%の有意水準で帰無仮説が棄却できる）であることがわかる。
このことは、previous の値次第で expm が voteshare に与える影響が異なる、あるいは expm の値次第で previous が voteshare に与える影響が異なるということを意味している。
しかし、このままでは係数の意味がわかりにくいため、様々な工夫をすることによって、結果を読み解く作業が必要である。

Q15-1-8

交差項を含まない model_4 と交差項を含む model_5 のどちらの当てはまりがよいかを、ROC 曲線を描いて考える。ROC曲線を描くためにROCRパッケージを使う。prediction() という名前の関数はROCRパッケージだけでなくmarginsパッケージにもあるので、どちらの関数を使うか明記する。

pi4 <- predict(model_4, type = "response")
pi5 <- predict(model_5, type = "response")
pr4 <- ROCR::prediction(pi4, labels = hr2012$smd == "当選")
pr5 <- ROCR::prediction(pi5, labels = hr2012$smd == "当選")
roc4 <- performance(pr4, measure = "tpr", x.measure = "fpr")
roc5 <- performance(pr5, measure = "tpr", x.measure = "fpr")
df_roc <- data_frame(fpr = c(roc4@x.values[[1]], roc5@x.values[[1]]),
                     tpr = c(roc4@y.values[[1]], roc5@y.values[[1]])) %>% 
  mutate(model = rep(c("モデル4", "モデル5"), c(n()/2, n()/2)))
roc <- ggplot(df_roc, aes(x = fpr, y = tpr,
                          color = model, linetype = model)) + 
  geom_line() +
  scale_linetype_discrete(name = "") +
  scale_color_discrete(name = "") +
  coord_fixed() +
  labs(x = "偽陽性率（1 - 特異度）", y = "真陽性率（感度）")
print(roc)

ROC曲線で見る限り、二つのモデルの当てはまりのよさに大きな差はなさそうである。

念のため、AUCを計算する。

auc4 <- performance(pr4, measure = "auc")
auc4@y.values[[1]]   # model_4 のAUC

## [1] 0.8379796

auc5 <- performance(pr5, measure = "auc")
auc5@y.values[[1]]   # model_5 のAUC

## [1] 0.8451623

AUCにもほとんど差はないが、わずかにモデル5 (model_5) の当てはまりの方がよさそうだ。

Q15-1-9

mplt1 <- cplot(model_5, x = "expm", dx = "expm", 
               what = "effect", draw = FALSE) %>% 
    as_data_frame() %>% 
    ggplot(aes(x = xvals, y = yvals, ymin = lower, ymax = upper)) +
      geom_ribbon(fill = "gray") +
      geom_line()  +
      labs(x = "選挙費用 (100万円）",
           y = "選挙費用の平均限界効果") 
print(mplt1)

選挙費用が増えるにつれて「選挙費用が当落に与える影響力（選挙費用の平均限界効果）」が徐々に大きくなっていることがわかる。しかし、その影響力は、選挙費用が2,000万円を越えると小さくなっていく。灰色で示された95%信頼区間がの幅が広いので、推定の不確実性が大きいことがわかる。

Q15-1-10

mplt2 <- cplot(model_5, x = "previous", dx = "expm",
                 what = "effect", draw = FALSE) %>% 
    as_data_frame() %>% 
    ggplot(aes(x = xvals, y = yvals,  ymin = lower, ymax = upper)) +
      geom_ribbon(fill = "gray") +
      geom_line() +
      labs(x = "選挙費用（100万円）",
           y = "当選回数の平均限界効果")
print(mplt2)

選挙費用が500万円までは、選挙費用が増えることによって当選回数が得票率に与える影響が急激に小さくなることがわかる。しかし、選挙費用が500万円を越えると、当選回数が当落に与える影響力は徐々に大きくなっていく。

Q15-1-11

mplt3 <- cplot(model_5, x = "expm", dx = "previous",
                 what = "effect", draw = FALSE) %>% 
    as_data_frame() %>% 
    ggplot(aes(x = xvals, y = yvals, ymin = lower, ymax = upper)) +
      geom_ribbon(fill = "gray") +
      geom_line() +
    labs(x = "当選回数",
         y = "選挙費用の平均限界効果")
print(mplt3)

当選回数が増えるにつれて「選挙費用が当落に与える影響力（選挙費用の平均限界効果）」が徐々に小さくなっていくことがわかる。

Q15-1-12

mplt4 <- cplot(model_5, x = "previous", dx = "previous",
                 what = "effect", draw = FALSE) %>% 
    as_data_frame() %>% 
    ggplot(aes(x = xvals, y = yvals, ymin = lower, ymax = upper)) +
      geom_ribbon(fill = "gray") +
      geom_line() +
      labs(x = "当選回数",
           y = "当選回数の平均限界効果")
print(mplt4)

当選回数が3回程度までは、当選回数が増えるにつれて「当選回数が当落に与える影響力（当選回数の平均限界効果）」が大きくなっていく。しかし、当選回数がそれ以上になると、当選回数が得票率に与える影響はどんどん小さくなり、当選回数10回を越えると、その効果はほとんどなくなる。

Q15-1-13

df_pre <- expand.grid(
    previous = seq(0, 16, by = 2),
    expm = seq(0, 25, by = 0.1)) %>%
    as_data_frame()
pred <- predict(model_5, type = "response",
                newdata = df_pre, se.fit = TRUE)
df_pre$fit <- pred$fit
df_pre$lower <- with(pred, fit - 2 * se.fit)
df_pre$upper <- with(pred, fit + 2 * se.fit)
df_pre <- df_pre %>% 
    mutate(lower = ifelse(lower < 0, 0, lower),
           upper = ifelse(upper > 1, 1, upper))
plt_prob  <- ggplot(df_pre, aes(x = expm, y = fit)) +
    geom_ribbon(aes(ymin = lower, ymax = upper), fill = "gray") +
    geom_line() +
    facet_wrap(. ~ previous) +
    labs(x = "選挙費用（100万円）", y = "当選確率の予測値")
print(plt_prob)

Q15-1-14

2005年衆院選の分析結果（テキスト329ページの図15.12）と比較すると、2009年衆院選では新人候補者 (previous = 0) や当選回数の少ない候補者 (previous = 2 or 4) が選挙費用を使っても当選確率の上昇率が小さいことがわかる。
また、当選回数が多くなると、選挙費用が上がるほど得票率が下がることがわかる。これは、必ずしも因果関係ではない。当選回数が多くても負けそうな候補者が選挙費用をたくさん使い（そしてそれでも得票は増加せず）、当選回数が多くて選挙に勝てそうな（そして実際に得票率が高かった）候補者が選挙費用を使う必要がなかっただけかもしれない。

Rによる計量政治学：練習問題の解答例

第15章ロジスティック回帰分析

浅野正彦, 矢内勇生

2018-11-29

パッケージの読み込み

Q15-1

Q15-1-1

Q15-1-2

Q15-1-3

Q15-1-4

Q15-1-5

Q15-1-6

Q15-1-7

Q15-1-8

Q15-1-9

Q15-1-10

Q15-1-11

Q15-1-12

Q15-1-13

Q15-1-14

Rによる計量政治学：練習問題の解答例

第15章 ロジスティック回帰分析

浅野正彦, 矢内勇生

2018-11-29

パッケージの読み込み

Q15-1

Q15-1-1

Q15-1-2

Q15-1-3

Q15-1-4

Q15-1-5

Q15-1-6

Q15-1-7

Q15-1-8

Q15-1-9

Q15-1-10

Q15-1-11

Q15-1-12

Q15-1-13

Q15-1-14

第15章ロジスティック回帰分析