R：尝试重新创建均值-中值差异 gerrymander 测试

Question

我正在尝试重新创建此处描述的均值-中值差异测试：Archive of NYT article. I've downloaded House data from MIT's Election Lab，并将其缩减为 2012 年宾夕法尼亚州的比赛。使用 dplyr，我将其缩减为相关的列，现在看起来像这样：

Rows: 42
Columns: 5
$ district       <dbl> 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 11, 1~
$ party          <chr> "REPUBLICAN", "DEMOCRAT", "INDEPENDENT", "REPUBLICAN", "DEMOCRAT", "DEMOCRAT", ~
$ candidatevotes <dbl> 41708, 235394, 4829, 33381, 318176, 123933, 165826, 12755, 6210, 181603, 11524,~
$ totalvotes     <dbl> 277102, 277102, 356386, 356386, 356386, 302514, 302514, 302514, 303980, 303980,~
$ pct_votes      <dbl> 15.051497, 84.948503, 1.354991, 9.366530, 89.278479, 40.967691, 54.815975, 4.21~

每一行代表一个选区候选人。最后一列是使用 mutate 创建的，代表该选区中候选人的选票百分比。现在，我可以用

找到中位数和平均民主投票

PA2012_house_dem <- PA2012_house %>% filter(party == "DEMOCRAT") 
obs_median <- median(PA2012_house_dem$pct_votes)
obs_mean <- mean(PA2012_house_dem$pct_votes)
obs_median - obs_mean

让我发作的是计算“机会区”。我想做的是某种 Monte Carlo 模拟，将每个选民随机分配到一个选区，这样每个选区的选民人数不变，每个政党的总票数是不变，但共和党和民主党（以及其他政党）在每个选区的比例是随机的，就像在排列测试中一样。平均民主党选票应该保持不变，但我想不出一个很好的方法来执行这种随机化，以便我可以计算中间选区的民主党选票百分比。

在此先感谢您的帮助！

编辑澄清：我想进行随机化，比如说 10,000 次，并且对于每个试验，计算中位数-均值差。理想情况下，结果应该是具有 10,000 行的向量或数据框，然后我可以将其转换为直方图或其他东西。

编辑 2 -- 部分解决方案：

我有一些代码可以运行，但它没有给我一个合理的答案。使用 dplyr，我过滤掉了除 DEMOCRAT 选票之外的所有选票，因此每一行只给我一个选区的民主党选票份额。

Rows: 18
Columns: 5
$ district       <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18
$ party          <chr> "DEMOCRAT", "DEMOCRAT", "DEMOCRAT", "DEMOCRAT", "DEMOCRAT", "DEMOCRAT", "DEMOCRAT", "DEMOCRAT", "DEMOCR~
$ candidatevotes <dbl> 235394, 318176, 123933, 104643, 104725, 143803, 143509, 152859, 105128, 94227, 118231, 163589, 209901, ~
$ totalvotes     <dbl> 277102, 356386, 302514, 303980, 282465, 335528, 353451, 352238, 274305, 273790, 285198, 338941, 303819,~
$ pct_votes      <dbl> 84.94850, 89.27848, 40.96769, 34.42430, 37.07539, 42.85872, 40.60223, 43.39651, 38.32522, 34.41579, 41.~

这被保存为PA2012_reduced_dem。

现在，这是我的代码：

require(mosaic) # for the tally() function
data <- PA2012_reduced_dem
B <- 100
samples_diff <- vector("numeric", B)
samples_mean <- vector("numeric", B)
samples_median <- vector("numeric", B)

for(samp in 1:B) {
data_w_sample <- mutate(data, sample_vote = tally(sample(district, sum(candidatevotes),replace=T, prob = totalvotes)))
  data_w_sample <- mutate(data_w_sample, sample_vote_pct = (sample_vote / totalvotes *100))
  mean_sample <- weighted.mean(data_w_sample$sample_vote_pct, w = data_w_sample$totalvotes)
  median_sample <- median(data_w_sample$sample_vote_pct)
  diff_mean_median <- mean_sample - median_sample
  samples_diff[samp] <- diff_mean_median
  samples_mean[samp] <- mean_sample
  samples_median[samp] <- median_sample
}

samples <- data.frame(samples_mean,samples_median,samples_diff)

我的想法是，我将每个民主党选民随机分配到一个选区，按每个选区的总票数加权。由于我将总票数作为变量，因此我可以计算每个选区中民主党的选票份额（我忽略了独立和其他党派的选票）。

显然，这很慢，因为每次试验都是针对每张民主党选票（大约 280 万张）进行抽样，所以我现在只有运行 100 次试验。

但是，我的 Monte Carlo 模拟发现均值附近有一个非常小的“机会区域”，中位数仅比均值高或低 0.05%。同样，我只有运行 100 次试验，但我期待更大的机会范围。

Answer 1

我想通了！在每个选区随机安排选民是不正确的，老实说，我这样做很愚蠢。相反，我不得不使用 dplyr 创建一个数据框，其中包含 435 个众议院选区中每个选区的民主党和共和党选票数量，每行一个选区。然后，我按照 this paper. 第 12 页的建议创建了从这个 435 行数据框中抽样的 18 个地区的样本，如果平均投票份额与 PA 的差距超过 1%，则拒绝它们。结果具有更好的 95% 置信区间，与原始文章的结果相匹配。

data <- house_2012_reduced 
# created with dplyr, contains total and percentage of votes
# for Democrats and Republicans.
B <- 100000
del_districts <- 18 # 18 districts in PA
samples_diff <- vector("numeric", B)
samples_mean <- vector("numeric", B)
samples_median <- vector("numeric", B)

for(samp in 1:B) {
  sample_delegation <- sample_n(data, del_districts)
  sample_delegation_pct_dem_mean <- weighted.mean(sample_delegation$pct_dem_votes, w = sample_delegation$total_votes)
  sample_delegation_pct_dem_median <- median(sample_delegation$pct_dem_votes)
  if(near(mean_dem_pct_PA, sample_delegation_pct_dem_mean, 1)){
    samples_mean[samp] <- sample_delegation_pct_dem_mean
    samples_median[samp] <- sample_delegation_pct_dem_median
    samples_diff[samp] <- (sample_delegation_pct_dem_mean - sample_delegation_pct_dem_median)
  }
}

samples <- data.frame(samples_mean,samples_median,samples_diff)
samples <- filter_all(samples, any_vars(. != 0))
quantile(samples$samples_median, c(0.025,0.975))

R：尝试重新创建均值-中值差异 gerrymander 测试

R: Trying to recreate mean-median difference gerrymander tests

r

mean

median

montecarlo