いわゆる「厳密検定」または「順列検定」の逆説的な振る舞いに出会いました。その原型はフィッシャー検定です。ここにあります。

400人の個人の2つのグループ（例：対照400例と例400）があり、2つのモダリティ（例：曝露/非曝露）の共変量があるとします。露出した個人は5人だけで、すべて2番目のグループです。フィッシャーテストは次のようになります。

> x <- matrix( c(400, 395, 0, 5) , ncol = 2)
> x
     [,1] [,2]
[1,]  400    0
[2,]  395    5
> fisher.test(x)

    Fisher's Exact Test for Count Data

data:  x
p-value = 0.06172
(...)

しかし今、2番目のグループ（症例）には、疾患の形態や求人センターなど、いくつかの不均一性があります。それは100人の4グループに分けることができます。このようなことが起こりそうです：

> x <- matrix( c(400, 99, 99 , 99, 98, 0, 1, 1, 1, 2) , ncol = 2)
> x
     [,1] [,2]
[1,]  400    0
[2,]   99    1
[3,]   99    1
[4,]   99    1
[5,]   98    2
> fisher.test(x)

    Fisher's Exact Test for Count Data

data:  x 
p-value = 0.03319
alternative hypothesis: two.sided
(...)

$p < 0.05$

これは単なる例です。しかし、最初の400人の個人では、曝露の頻度は0であり、残りの400人では0.0125であると想定して、2つの分析戦略の検出力をシミュレートできます。

400人の2つのグループを使用して、分析の能力を推定できます。

> p1 <- replicate(1000, { n <- rbinom(1, 400, 0.0125); 
                          x <- matrix( c(400, 400 - n, 0, n), ncol = 2); 
                          fisher.test(x)$p.value} )
> mean(p1 < 0.05)
[1] 0.372

そして、400人の1グループと100人の4グループ：

> p2 <- replicate(1000, { n <- rbinom(4, 100, 0.0125); 
                          x <- matrix( c(400, 100 - n, 0, n), ncol = 2);
                          fisher.test(x)$p.value} )
> mean(p2 < 0.05)
[1] 0.629

パワーにはかなりの違いがあります。ケースを4つのサブグループに分割すると、これらのサブグループ間に分布の違いがなくても、より強力な検定が得られます。もちろん、この電力の増加は、タイプIのエラー率の増加によるものではありません。

この現象はよく知られていますか？それは、最初の戦略が不十分であるということですか？ブートストラップされたp値はより良い解決策でしょうか？コメントは大歓迎です。

後記

$H_0 : p_0 = p_1 = 0.005$$H1 : p_0 = 0.05 \ne p1 = 0.0125$

これが私のコードです。

B <- 1e5
p0 <- 0.005
p1 <- 0.0125

# simulation under H0 with p = p0 = 0.005 in all groups
# a = 2 groups 400:400, b = 5 groupe 400:100:100:100:100

p.H0.a <- replicate(B, { n <- rbinom( 2, c(400,400), p0);
                           x <- matrix( c( c(400,400) -n, n ), ncol = 2);
                          fisher.test(x)$p.value} )

p.H0.b <- replicate(B, { n <- rbinom( 5, c(400,rep(100,4)), p0);
                           x <- matrix( c( c(400,rep(100,4)) -n, n ), ncol = 2);
                          fisher.test(x)$p.value} )

# simulation under H1 with p0 = 0.005 (controls) and p1 = 0.0125 (cases)

p.H1.a <- replicate(B, { n <- rbinom( 2, c(400,400), c(p0,p1) );
                           x <- matrix( c( c(400,400) -n, n ), ncol = 2);
                          fisher.test(x)$p.value} )

p.H1.b <- replicate(B, { n <- rbinom( 5, c(400,rep(100,4)), c(p0,rep(p1,4)) );
                           x <- matrix( c( c(400,rep(100,4)) -n, n ), ncol = 2);
                          fisher.test(x)$p.value} )

# roc curve 

ROC <- function(p.H0, p.H1) {
  p.threshold <- seq(0, 1.001, length=501)
  alpha <- sapply(p.threshold, function(th) mean(p.H0 <= th) )
  power <- sapply(p.threshold, function(th) mean(p.H1 <= th) )
  list(x = alpha, y = power)
}

par(mfrow=c(1,2))
plot( ROC(p.H0.a, p.H1.a) , type="b", xlab = "alpha", ylab = "1-beta" , xlim=c(0,1), ylim=c(0,1), asp = 1)
lines( ROC(p.H0.b, p.H1.b) , col="red", type="b" )
abline(0,1)

plot( ROC(p.H0.a, p.H1.a) , type="b", xlab = "alpha", ylab = "1-beta" , xlim=c(0,.1) )
lines( ROC(p.H0.b, p.H1.b) , col="red", type="b" )
abline(0,1)

結果は次のとおりです。

したがって、同じ真のタイプIのエラーでの比較でも、（実際にははるかに小さい）差が生じることがわかります。

p値が異なる理由

次の2つの影響があります。

• $\chi^2$

  $\chi^2$

  これがp値がほぼ2倍異なる理由です（正確には次の点のためではありません）。

• 同様に極端なケースとして5 0 0 0 0を失う一方で、0 2 1 1 1よりも極端なケースとして1 4 0 0 0を獲得します。

$\chi^2$

コード例：

# probability of distribution a and b exposures among 2 groups of 400
draw2 <- function(a,b) {
  choose(400,a)*choose(400,b)/choose(800,5)
}

# probability of distribution a, b, c, d and e exposures among 5 groups of resp 400, 100, 100, 100, 100
draw5 <- function(a,b,c,d,e) {
choose(400,a)*choose(100,b)*choose(100,c)*choose(100,d)*choose(100,e)/choose(800,5)
}

# looping all possible distributions of 5 exposers among 5 groups
# summing the probability when it's p-value is smaller or equal to the observed value 0 2 1 1 1
sumx <- 0
for (f in c(0:5)) {
  for(g in c(0:(5-f))) {
    for(h in c(0:(5-f-g))) {
      for(i in c(0:(5-f-g-h))) {
        j = 5-f-g-h-i
        if (draw5(f, g, h, i, j) <= draw5(0, 2, 1, 1, 1)) {
          sumx <- sumx + draw5(f, g, h, i, j)
        }
      }
    }
  } 
}
sumx  #output is 0.3318617

# the split up case (5 groups, 400 100 100 100 100) can be calculated manually
# as a sum of probabilities for cases 0 5 and 1 4 0 0 0 (0 5 includes all cases 1 a b c d with the sum of the latter four equal to 5)
fisher.test(matrix( c(400, 98, 99 , 99, 99, 0, 2, 1, 1, 1) , ncol = 2))[1]
draw2(0,5) + 4*draw(1,4,0,0,0)

# the original case of 2 groups (400 400) can be calculated manually
# as a sum of probabilities for the cases 0 5 and 5 0 
fisher.test(matrix( c(400, 395, 0, 5) , ncol = 2))[1]
draw2(0,5) + draw2(5,0)

その最後のビットの出力

> fisher.test(matrix( c(400, 98, 99 , 99, 99, 0, 2, 1, 1, 1) , ncol = 2))[1]
$p.value
[1] 0.03318617

> draw2(0,5) + 4*draw(1,4,0,0,0)
[1] 0.03318617

> fisher.test(matrix( c(400, 395, 0, 5) , ncol = 2))[1]
$p.value
[1] 0.06171924

> draw2(0,5) + draw2(5,0)
[1] 0.06171924

グループを分割するときのパワーへの影響

• p値の「利用可能な」レベルとフィッシャーズの正確検定の保守性には個別のステップがあるため、いくつかの違いがあります（これらの違いは非常に大きくなる可能性があります）。

• また、フィッシャーテストでは、データに基づいて（不明な）モデルを近似し、このモデルを使用してp値を計算します。例のモデルは、露出した個人がちょうど5人いることです。異なるグループの二項式を使用してデータをモデル化すると、5人以上または5人未満になる場合があります。これにフィッシャーテストを適用すると、一部のエラーがフィッティングされ、残差は固定限界を使用したテストと比較して小さくなります。その結果、テストは保守的であり、正確ではありません。

$\alpha$

$H_0$$H_0$$H_a$

これがすべての可能な状況に当てはまるかどうかという問題が残っています。

電力分析の3回のコード調整（および3つの画像）：

5被曝者の場合に限定して二項式を使用する

$H_0$

400-100-100-100-100-100ケース（青）に対して400-400ケース（赤）の効果がはるかに強いことがわかります。したがって、実際にこの分割を使用して電力を増やし、H_0を拒否する可能性を高くすることができます。（タイプIのエラーが発生する可能性をあまり気にしませんが、パワーを上げるためにこの分割を行うポイントは、必ずしもそれほど強力ではない場合があります）

5人の被曝者に限定されない二項式を使用する

あなたがしたように二項式を使用する場合、400-400（赤）または400-100-100-100-100（青）の2つのケースはどちらも正確なp値を与えません。これは、Fisherの正確検定では行と列の合計が固定されていることを前提としていますが、二項モデルではこれらを自由にすることができるためです。フィッシャーテストは、行と列の合計を「近似」して、残差項を真の誤差項より小さくします。

増加した電力は犠牲になりますか？

$H_0$$H_a$$H_a$

# using binomial distribution for 400, 100, 100, 100, 100
# x uses separate cases
# y uses the sum of the 100 groups
p <- replicate(4000, { n <- rbinom(4, 100, 0.006125); m <- rbinom(1, 400, 0.006125); 
x <- matrix( c(400 - m, 100 - n, m, n), ncol = 2);
y <- matrix( c(400 - m, 400 - sum(n), m, sum(n)), ncol = 2);
c(sum(n,m),fisher.test(x)$p.value,fisher.test(y)$p.value)} )

# calculate hypothesis test using only tables with sum of 5 for the 1st row
ps <- c(1:1000)/1000
m1 <- sapply(ps,FUN = function(x) mean(p[2,p[1,]==5] < x))
m2 <- sapply(ps,FUN = function(x) mean(p[3,p[1,]==5] < x))

plot(ps,ps,type="l",
     xlab = "chosen alpha level",
     ylab = "p rejection")
lines(ps,m1,col=4)
lines(ps,m2,col=2)

title("due to concervative test p-value will be smaller\n leading to differences")

# using all samples also when the sum exposed individuals is not 5
ps <- c(1:1000)/1000
m1 <- sapply(ps,FUN = function(x) mean(p[2,] < x))
m2 <- sapply(ps,FUN = function(x) mean(p[3,] < x))

plot(ps,ps,type="l", 
     xlab = "chosen alpha level",
     ylab = "p rejection")
lines(ps,m1,col=4)
lines(ps,m2,col=2)

title("overly conservative, low effective p-values \n fitting marginals makes residuals smaller than real error")


#   
# Third graph comparing H_0 and H_a
#
# using binomial distribution for 400, 100, 100, 100, 100
# x uses separate cases
# y uses the sum of the 100 groups
offset <- 0.5
p <- replicate(10000, { n <- rbinom(4, 100, offset*0.0125); m <- rbinom(1, 400, (1-offset)*0.0125); 
x <- matrix( c(400 - m, 100 - n, m, n), ncol = 2);
y <- matrix( c(400 - m, 400 - sum(n), m, sum(n)), ncol = 2);
c(sum(n,m),fisher.test(x)$p.value,fisher.test(y)$p.value)} )

# calculate hypothesis test using only tables with sum of 5 for the 1st row
ps <- c(1:10000)/10000
m1 <- sapply(ps,FUN = function(x) mean(p[2,p[1,]==5] < x))
m2 <- sapply(ps,FUN = function(x) mean(p[3,p[1,]==5] < x))

offset <- 0.6
p <- replicate(10000, { n <- rbinom(4, 100, offset*0.0125); m <- rbinom(1, 400, (1-offset)*0.0125); 
x <- matrix( c(400 - m, 100 - n, m, n), ncol = 2);
y <- matrix( c(400 - m, 400 - sum(n), m, sum(n)), ncol = 2);
c(sum(n,m),fisher.test(x)$p.value,fisher.test(y)$p.value)} )

# calculate hypothesis test using only tables with sum of 5 for the 1st row
ps <- c(1:10000)/10000
m1a <- sapply(ps,FUN = function(x) mean(p[2,p[1,]==5] < x))
m2a <- sapply(ps,FUN = function(x) mean(p[3,p[1,]==5] < x))

plot(ps,ps,type="l",
     xlab = "p rejecting if H_0 true",
     ylab = "p rejecting if H_a true",log="xy")
points(m1,m1a,col=4)
points(m2,m2a,col=2)

legend(0.01,0.001,c("400-400","400-100-100-100-100"),pch=c(1,1),col=c(2,4))

title("comparing H_0:p=0.5 \n with H_a:p=0.6")

なぜそれは力に影響を与えるのですか

問題の鍵は、「有意」となるように選択された結果の値の違いにあると私は信じています。状況は、400人、100人、100人、100人、100人のサイズの5つのグループから抽出された5人の露出した個人です。「極端」と見なされるさまざまな選択を行うことができます。2番目の戦略を実行すると、明らかに（有効なタイプIエラーが同じであっても）電力が増加します。

最初の戦略と2番目の戦略の違いをグラフィカルにスケッチするとします。次に、5つの軸を持つ座標系（400 100 100 100および100のグループの場合）があり、仮説値の点と、確率が特定のレベルを下回る偏差の距離を表す面を想像します。最初の戦略では、この表面は円柱であり、2番目の戦略では、この表面は球体です。真の値とその周辺のエラーについても同じことが言えます。必要なのは、オーバーラップをできるだけ小さくすることです。

少し異なる問題（次元が低い）を考慮すると、実際のグラフィックを作成できます。

$H_0: p=0.5$

このプロットは、（1000の単一グループではなく）500と500のグループがどのように分布しているかを示しています。

標準の仮説検定では、XとYの合計が531より大きいか、469より小さいかを（95％のアルファレベルに対して）評価します。

しかし、これにはXとYの不均等な分布が含まれます。

$H_0$$H_a$

ただし、グループの分割をランダムに選択しない場合や、グループに意味がある場合は（必ずしも）真実ではありません。