Я встретил парадоксальное поведение так называемых «точных тестов» или «тестов перестановки», прототипом которых является тест Фишера. Вот.

Представьте, что у вас есть две группы по 400 человек (например, 400 контрольных против 400 случаев) и ковариата с двумя модальностями (например, открытая / неэкспонированная). Есть только 5 разоблаченных людей, все во второй группе. Тест Фишера выглядит так:

> 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
(...)

Но теперь во второй группе (случаях) есть некоторая неоднородность, например, форма заболевания или центр рекрутинга. Его можно разделить на 4 группы по 100 человек. Нечто подобное может произойти:

> 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.

Мы можем оценить силу анализа с двумя группами по 400 человек:

> 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 и 4 группами по 100 человек:

> 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 все еще приводит к (действительно намного меньшим) различиям.

Почему р-значения разные

Происходит два эффекта:

• $\chi^2$

  $\chi^2$

  Вот почему значение р отличается почти в 2 раза (не совсем из-за следующего пункта)

• Пока вы теряете 5 0 0 0 0 как столь же экстремальный случай, вы получаете 1 4 0 0 0 как более экстремальный случай, чем 0 2 1 1 1.

$\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 человек. Когда вы примените к этому критерий Фишера, некоторые ошибки будут учтены, а остатки будут меньше по сравнению с тестами с фиксированными маргинальными значениями. В результате тест слишком консервативный, а не точный.

$\alpha$

$H_0$$H_0$$H_a$

Остается вопрос, верно ли это для всех возможных ситуаций.

3-кратная корректировка кода вашего анализа мощности (и 3 изображения):

с использованием биномиального ограничения на случай 5 подверженных лиц

$H_0$

Интересно видеть, что эффект гораздо сильнее для случая 400-400 (красный) по сравнению с 400-100-100-100-100 (синий). Таким образом, мы действительно можем использовать это разделение для увеличения мощности, чтобы сделать более вероятным отклонение H_0. (хотя мы не очень заботимся о том, чтобы сделать ошибку типа I более вероятной, поэтому смысл такого разделения для увеличения мощности не всегда может быть таким сильным)

использование биномиального не ограничивающего 5 человек

Если мы используем бином, как вы, то ни один из двух случаев 400-400 (красный) или 400-100-100-100-100 (синий) не дает точного значения p. Это связано с тем, что точный тест Фишера предполагает фиксированные итоги по строкам и столбцам, но биноминальная модель позволяет им быть свободными. Тест Фишера «подгоняет» итоги строки и столбца, делая остаточный член меньшим, чем истинный член ошибки.

увеличенная мощность приходит за плату?

$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")

Почему это влияет на власть

Я считаю, что суть проблемы заключается в разнице значений результатов, которые выбраны как «значимые». Ситуация такова, что пять подвергшихся воздействию лиц были взяты из 5 групп размером 400, 100, 100, 100 и 100 человек. Можно сделать разные выборы, которые считаются «экстремальными». очевидно, мощность увеличивается (даже если эффективная ошибка типа I такая же), когда мы переходим ко второй стратегии.

Если бы мы наметили разницу между первой и второй стратегией графически. Затем я представляю систему координат с 5 осями (для групп 400, 100, 100, 100 и 100) с точкой для значений гипотезы и поверхностью, которая изображает расстояние отклонения, за которым вероятность находится ниже определенного уровня. При первой стратегии эта поверхность является цилиндром, а при второй стратегии эта поверхность является сферой. То же самое верно для истинных значений и поверхности вокруг нее для ошибки. Мы хотим, чтобы перекрытие было как можно меньше.

Мы можем сделать реальную графику, когда рассмотрим немного другую проблему (с меньшей размерностью).

$H_0: p=0.5$

На графике показано, как распределяются группы из 500 и 500 (вместо одной группы из 1000).

Стандартный тест гипотезы оценил бы (для альфа-уровня 95%), является ли сумма X и Y больше 531 или меньше 469.

Но это включает очень маловероятное неравное распределение X и Y.

$H_0$$H_a$

Это, однако, неверно (необязательно), когда мы не выбираем расщепление групп случайным образом и когда в них может быть смысл.