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

Q14-1-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)

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

dplyr::filter() と dplyr::select() を使って、2012年の衆院選データだけを切り取り、分析で使う変数 (voteshare, exppv, previous) だけを選ぶ（select()という名前の関数はinterplotパッケージにもあるので、dplyr::select()と明示する。）。

hr2012 <- HR %>% 
  filter(year == 2012) %>% 
  dplyr::select(voteshare, exppv, previous)

summary() を使った記述統計

summary(hr2012)

##    voteshare         exppv             previous     
##  Min.   : 0.20   Min.   : 0.00126   Min.   : 0.000  
##  1st Qu.: 8.50   1st Qu.: 6.08015   1st Qu.: 0.000  
##  Median :18.95   Median :14.86205   Median : 0.000  
##  Mean   :23.18   Mean   :17.16598   Mean   : 1.519  
##  3rd Qu.:34.62   3rd Qu.:23.62160   3rd Qu.: 2.000  
##  Max.   :84.50   Max.   :94.59168   Max.   :15.000  
##                  NA's   :14

Q14-1-2

選挙費用 (exppv) と得票率 (voteshare) の散布図を描いてみる。

plt12_vs_ex <- ggplot(hr2012, aes(x = exppv, y = voteshare)) +
    geom_point() +
    geom_smooth(method = "lm") +
    labs(x = "有権者一人当たり選挙費用（円）", y = "得票率(%)")
print(plt12_vs_ex)

両者の間には正の相関がありそうだ。

同様に、当選回数 (previous) と得票率 (voteshare) の散布図を描いてみる。

plt12_vs_prev <- ggplot(hr2012, aes(x = previous, y = voteshare)) +
    geom_point() +
    geom_smooth(method = "lm") +
    labs(x = "当選回数", y = "得票率(%)")
print(plt12_vs_prev)

当選回数と得票率の間にも正の相関がありそうに見える。

相関係数も計算してみる。

cor(hr2012, use = "pairwise.complete.obs")

##           voteshare     exppv  previous
## voteshare 1.0000000 0.6537561 0.6522492
## exppv     0.6537561 1.0000000 0.4817358
## previous  0.6522492 0.4817358 1.0000000

やはり正の相関はあるが、それほど強い相関ではないことがわかる。

Q14-1-3

• 仮説：「当選回数が増えるほど、選挙費用が得票に与える影響は小さくなる」
• 理由：当選回数が増える程、候補者の認知度も徐々に上がっていく。認知度が上がれば、それほど選挙費用を使わなくても当選に必要な票が得られるため、得票に与える選挙費用の影響力は相対的に減少すると考えられるから。

Q14-1-4

選挙費用 (exppv) が得票率 (voteshare) に与える影響が当選回数 (previous) によって変わるかどうか検証するため、交差項 (exppv \(\times\) previous) を含めた次の重回帰分析を行う。 有意水準は1% (0.01) に設定する。

fit_2012 <- lm(voteshare ~ exppv * previous, data = hr2012)

分析結果を表示させる。

summary(fit_2012)

## 
## Call:
## lm(formula = voteshare ~ exppv * previous, data = hr2012)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -43.569  -5.288  -1.165   4.831  49.195 
## 
## Coefficients:
##                 Estimate Std. Error t value Pr(>|t|)
## (Intercept)     6.180379   0.539555   11.46   <2e-16
## exppv           0.731426   0.029632   24.68   <2e-16
## previous        5.442530   0.253682   21.45   <2e-16
## exppv:previous -0.091305   0.008298  -11.00   <2e-16
## 
## Residual standard error: 10.65 on 1276 degrees of freedom
##   (14 observations deleted due to missingness)
## Multiple R-squared:  0.6125, Adjusted R-squared:  0.6116 
## F-statistic: 672.4 on 3 and 1276 DF,  p-value: < 2.2e-16

交差項 (exppv:previous) の \(p\)値がほぼ 0 (2e-16未満) であり、有意水準である0.01より小さいことから、交差項の係数 (\(-0.09\)) は統計的に有意であると考えられる。すなわち、選挙費用が得票率に与える影響は、当選回数の多寡と関係があるということことがわかる。

Q14-1-5

上記の結果から、次の回帰式が得られる。 \[ \widehat{得票率} = 6.18 + 0.73 \cdot 1人当たり選挙費用 + 5.44 \cdot 当選回数 -0.09 \cdot 1人当たり選挙費用 \times 当選回数 \] 1人当たり選挙費用の係数をまとめると、 \[ \widehat{得票率} = 6.18 + (0.73 -0.09 \cdot 当選回数) \cdot 1人当たり選挙費用 + 5.44 \cdot 当選回数 \] となる。

この結果を解釈しよう。

• exppv を構成要素とする交差項があるので、exppv の係数 (\(0.73\)) は、交差項のもう一つの構成要素である当選回数 (previous) が 0回のときの効果である。つまり、当選回数が0の候補者が有権者1人当たりに使う選挙費用を1円増やすごとに、得票率が \(0.73\)ポイントずつ上がる。
• 選挙費用の効果について理解するためには、調整変数である当選回数 (previous) に複数の値を代入し、それぞれの場合における効果を確認する必要がある。

当選回数が0と4の場合について、選挙費用の効果を図示する（ Q14-1-1 より、過去の当選回数の平均値は1.52回、標準偏差は2.39回である）。

当選回数が0回の場合 (previous = 0) の回帰式は、 \[ \widehat{得票率} = 6.18 + (0.73 -0.09 \cdot 0) \cdot 1人当たり選挙費用 + 5.44 \cdot 0 \] \[ = 6.18 + 0.73 \cdot 1人当たり選挙費用 \] となる。

また、当選回数が4回の場合 (previous = 4) の回帰式は、 \[ \widehat{得票率} = 6.18 + (0.73 -0.09 \cdot 4) \cdot 1人当たり選挙費用 + 5.44 \cdot 4 \] \[ = 27.95 + 0.37 \cdot 1人当たり選挙費用 \] となる。

## Mac の場合
plt_int <- ggplot(hr2012, aes(x = exppv, y = voteshare)) + 
    geom_point(pch = 16) +
    geom_abline(intercept = 6.18, slope = 0.73,
                linetype = "dashed") +
    geom_abline(intercept = 27.95, slope = 0.37) +
    ylim(0, 100) +
    labs(x = "選挙費用（有権者一人当たり：円）", y = "得票率 (%)") + 
    geom_text(label = "得票率 = 6.18 + 0.73・選挙費用
                       (当選回数 = 0 回)", 
              x = 70, y = 95, family = "HiraginoSans-W3") +
    geom_text(label = "得票率 = 27.95 + 0.37・選挙費用
                       (当選回数 = 4 回)", 
              x = 70, y = 2, family = "HiraginoSans-W3")
## Windows の場合
#plt_int <- ggplot(hr2012, aes(x = exppv, y = voteshare)) + 
#    geom_point(pch = 16) +
#    geom_abline(intercept = 6.18, slope = 0.73,
#                linetype = "dashed") +
#    geom_abline(intercept = 27.95, slope = 0.37) + 
#    ylim(0, 100) +
#    labs(x = "選挙費用（有権者一人当たり：円）", y = "得票率 (%)") + 
#    geom_text(label = "得票率 = 6.18 + 0.73・選挙費用
#                       (当選回数 = 0 回)", 
#              x = 70, y = 95) +
#    geom_text(label = "得票率 = 28 + 0.37・選挙費用
#                       (当選回数 = 4 回)", 
#              x = 70, y = 2)
print(plt_int)

Q14-1-6

plt_int2 <- interplot(m = fit_2012,       # 重回帰分析結果 (fit_2012) を指定
                      var1 = "exppv",     # 係数を表示する変数を指定
                      var2 = "previous",  # 条件付けする変数を指定
  ci = 0.99) +                            # 有意水準が1%なので99%信頼区間を図示
  geom_hline(yintercept = 0, linetype = "dashed") +
  labs(x = "過去の当選回数",
       y = "選挙費用の限界効果",
       title = "選挙費用が得票率に与える影響と当選回数の関係")
print(plt_int2)

調整変数である当選回数 (previous) の値が 7から10の範囲付近では 99% 信頼区間が 0を含んでいるため、この範囲においては限界効果が統計的に有意ではない。

sim_slopes(fit_2012, pred = exppv, modx = previous,
           jnalpha = 0.01)

## JOHNSON-NEYMAN INTERVAL 
## 
## When previous is OUTSIDE the interval [6.68, 10.05], the slope of
## exppv is p < .01.
## 
## Note: The range of observed values of previous is [0.00, 15.00]
## 
## SIMPLE SLOPES ANALYSIS 
## 
## Slope of exppv when previous =  3.93 (+ 1 SD): 
##  Est. S.E. t val.    p
##  0.37 0.03  12.28 0.00
## 
## Slope of exppv when previous =  1.53 (Mean): 
##  Est. S.E. t val.    p
##  0.59 0.03  23.37 0.00
## 
## Slope of exppv when previous = -0.87 (- 1 SD): 
##  Est. S.E. t val.    p
##  0.81 0.03  23.84 0.00

johnson_neyman(fit_2012, pred = exppv, modx = previous,
               alpha = 0.01)

## JOHNSON-NEYMAN INTERVAL 
## 
## When previous is OUTSIDE the interval [6.68, 10.05], the slope of
## exppv is p < .01.
## 
## Note: The range of observed values of previous is [0.00, 15.00]