R: функция glm со спецификацией family = «binomial» и «weight»


14

Меня очень смущает то, как вес работает в glm с family = "binomial". В моем понимании вероятность появления glm с family = "binomial" определяется следующим образом: где - «доля наблюдаемого успеха», а n - известное количество испытаний.

е(Y)знак равно(NNY)пNY(1-п)N(1-Y)знак равноехр(N[Yжурналп1-п-(-журнал(1-п))]+журнал(NNY))
YN

В моем понимании вероятность успеха п параметризована некоторыми линейными коэффициентами β такими как пзнак равноп(β) и функцией glm с family = "binomial", для поиска:

ArgМаксимумβΣяжурнале(Yя),
Тогда эту задачу оптимизации можно упростить как:

ArgМаксимумβΣяжурнале(Yя)знак равноArgМаксимумβΣяNя[Yяжурналп(β)1-п(β)-(-журнал(1-п(β)))]+журнал(NяNяYя)знак равноArgМаксимумβΣяNя[Yяжурналп(β)1-п(β)-(-журнал(1-п(β)))]

Поэтому, если мы допустим Nя*знак равноNяс для всех язнак равно1,,,,,N для некоторой константы с , то также должно быть верно, что:
ArgМаксимумβΣяжурнале(Yя)знак равноArgМаксимумβΣяNя*[Yяжурналп(β)1-п(β)-(-журнал(1-п(β)))]
Из этого я подумал, что масштабирование числа испытаний Nяс константой НЕ влияет на оценки максимального правдоподобия β учетом доли успеха Yя .

Файл справки glm говорит:

 "For a binomial GLM prior weights are used to give the number of trials 
  when the response is the proportion of successes" 

Поэтому я ожидал, что масштабирование веса не повлияет на оценку β учитывая долю успеха в качестве ответа. Однако следующие два кода возвращают разные значения коэффициентов:

 Y <- c(1,0,0,0) ## proportion of observed success
 w <- 1:length(Y) ## weight= the number of trials
 glm(Y~1,weights=w,family=binomial)

Это дает:

 Call:  glm(formula = Y ~ 1, family = "binomial", weights = w)

 Coefficients:
 (Intercept)  
      -2.197     

тогда как если я умножу все веса на 1000, оценочные коэффициенты будут другими:

 glm(Y~1,weights=w*1000,family=binomial)

 Call:  glm(formula = Y ~ 1, family = binomial, weights = w * 1000)

 Coefficients:
 (Intercept)  
    -3.153e+15  

Я видел много других примеров, подобных этому, даже с некоторым умеренным масштабированием весов. Что здесь происходит?


3
Что бы это ни стоило, weightsаргумент заканчивается в двух местах внутри glm.fitфункции (в glm.R ), что и делает работа в R: 1) в остатках отклонения, через функцию C binomial_dev_residsfamily.c ) и 2) на этапе IWLS посредством Cdqrlslm.c ). Я не знаю достаточно C, чтобы больше помочь в отслеживании логики
shadowtalker

3
Проверьте ответы здесь .
Стат

@ssdecontrol Я читаю glm.fit по ссылке, которую вы мне дали, но я не могу найти, где в glm.fit вызывается функция C "binomial_dev_resids". Вы не против, если вы укажете на это?
FairyOnIce

@ssdecontrol Ой, прости, я думаю, что понимаю. Каждое «семейство» - это список, а один из элементов - «dev.resids». Когда я набираю binomial в консоли R, я вижу определение объекта binomial, и у него есть строка: dev.resids <- function (y, mu, wt) .Call (C_binomial_dev_resids, y, mu, wt)
FairyOnIce

Ответы:


4

Ваш пример просто вызывает ошибку округления в R. Большие веса не работают хорошо в glm . Это правда, что масштабирование wпрактически на любое меньшее число, например 100, приводит к тем же оценкам, что и немасштабированное w.

Если вы хотите более надежного поведения с весовыми аргументами, попробуйте использовать svyglmфункцию из surveyпакета.

Посмотреть здесь:

    > svyglm(Y~1, design=svydesign(ids=~1, weights=~w, data=data.frame(w=w*1000, Y=Y)), family=binomial)
Independent Sampling design (with replacement)
svydesign(ids = ~1, weights = ~w, data = data.frame(w = w * 1000, 
    Y = Y))

Call:  svyglm(formula = Y ~ 1, design = svydesign(ids = ~1, weights = ~w2, 
    data = data.frame(w2 = w * 1000, Y = Y)), family = binomial)

Coefficients:
(Intercept)  
     -2.197  

Degrees of Freedom: 3 Total (i.e. Null);  3 Residual
Null Deviance:      2.601 
Residual Deviance: 2.601    AIC: 2.843

1

Я думаю , что это сводится к первоначальным значениям , которые используются в glm.fitиз family$initializeкоторых делает метод divergere. Насколько я знаю, glm.fitрешить эту проблему, сформировав QR-разложение где - матрица проектирования, а - диагональ с квадратными корнями из элементов, как описаноWИксИксW здесь . То есть использует метод Ньютона-Рафсона.

Соответствующий $intializeкод:

if (NCOL(y) == 1) {
    if (is.factor(y)) 
        y <- y != levels(y)[1L]
    n <- rep.int(1, nobs)
    y[weights == 0] <- 0
    if (any(y < 0 | y > 1)) 
        stop("y values must be 0 <= y <= 1")
    mustart <- (weights * y + 0.5)/(weights + 1)
    m <- weights * y
    if (any(abs(m - round(m)) > 0.001)) 
        warning("non-integer #successes in a binomial glm!")
}

Вот упрощенная версия, glm.fitкоторая показывает мою точку зрения

> #####
> # setup
> y <- matrix(c(1,0,0,0), ncol = 1)
> weights <- 1:nrow(y) * 1000
> nobs <- length(y)
> family <- binomial()
> X <- matrix(rep(1, nobs), ncol = 1) # design matrix used later
> 
> # set mu start as with family$initialize
> if (NCOL(y) == 1) {
+   n <- rep.int(1, nobs)
+   y[weights == 0] <- 0
+   mustart <- (weights * y + 0.5)/(weights + 1)
+   m <- weights * y
+   if (any(abs(m - round(m)) > 0.001)) 
+     warning("non-integer #successes in a binomial glm!")
+ }
> 
> mustart # starting value
             [,1]
[1,] 0.9995004995
[2,] 0.0002498751
[3,] 0.0001666111
[4,] 0.0001249688
> (eta <- family$linkfun(mustart))
          [,1]
[1,]  7.601402
[2,] -8.294300
[3,] -8.699681
[4,] -8.987322
> 
> #####
> # Start loop to fit
> mu <- family$linkinv(eta)
> mu_eta <- family$mu.eta(eta)
> z <- drop(eta + (y - mu) / mu_eta)
> w <- drop(sqrt(weights * mu_eta^2 / family$variance(mu = mu)))
> 
> # code is simpler here as (X^T W X) is a scalar
> X_w <- X * w
> (.coef <- drop(crossprod(X_w)^-1 * ((w * z) %*% X_w)))
[1] -5.098297
> (eta <- .coef * X)
          [,1]
[1,] -5.098297
[2,] -5.098297
[3,] -5.098297
[4,] -5.098297
> 
> # repeat a few times from "start loop to fit"

Мы можем повторить последнюю часть еще два раза, чтобы увидеть, что метод Ньютона-Рафсона расходится:

> #####
> # Start loop to fit
> mu <- family$linkinv(eta)
> mu_eta <- family$mu.eta(eta)
> z <- drop(eta + (y - mu) / mu_eta)
> w <- drop(sqrt(weights * mu_eta^2 / family$variance(mu = mu)))
> 
> # code is simpler here as (X^T W X) is a scalar
> X_w <- X * w
> (.coef <- drop(crossprod(X_w)^-1 * ((w * z) %*% X_w)))
[1] 10.47049
> (eta <- .coef * X)
         [,1]
[1,] 10.47049
[2,] 10.47049
[3,] 10.47049
[4,] 10.47049
> 
> 
> #####
> # Start loop to fit
> mu <- family$linkinv(eta)
> mu_eta <- family$mu.eta(eta)
> z <- drop(eta + (y - mu) / mu_eta)
> w <- drop(sqrt(weights * mu_eta^2 / family$variance(mu = mu)))
> 
> # code is simpler here as (X^T W X) is a scalar
> X_w <- X * w
> (.coef <- drop(crossprod(X_w)^-1 * ((w * z) %*% X_w)))
[1] -31723.76
> (eta <- .coef * X)
          [,1]
[1,] -31723.76
[2,] -31723.76
[3,] -31723.76
[4,] -31723.76

Этого не произойдет, если вы начнете с weights <- 1:nrow(y)или говорите weights <- 1:nrow(y) * 100.

Обратите внимание, что вы можете избежать расхождений, установив mustartаргумент. Например сделать

> glm(Y ~ 1,weights = w * 1000, family = binomial, mustart = rep(0.5, 4))

Call:  glm(formula = Y ~ 1, family = binomial, weights = w * 1000, mustart = rep(0.5, 
    4))

Coefficients:
(Intercept)  
     -2.197  

Degrees of Freedom: 3 Total (i.e. Null);  3 Residual
Null Deviance:      6502 
Residual Deviance: 6502     AIC: 6504

Я думаю, что вес влияет больше, чем аргументы для инициализации. С помощью логистической регрессии Ньютон Рафсон оценивает максимальную вероятность, которая существует и является уникальной, когда данные не разделены. Предоставление оптимизаторам различных начальных значений не приведет к различным значениям, но, возможно, потребуется больше времени, чтобы добраться до них.
AdamO

Msgstr "Предоставление оптимизаторам разных начальных значений не приведет к разным значениям ..." . Ну, метод Ньютона не расходится и находит уникальный максимум в последнем примере, где я устанавливаю начальные значения (см. Пример, где я предоставляю mustart аргумент). Это похоже на вопрос, связанный с плохой первоначальной оценкой .
Бенджамин Кристофферсен
Используя наш сайт, вы подтверждаете, что прочитали и поняли нашу Политику в отношении файлов cookie и Политику конфиденциальности.
Licensed under cc by-sa 3.0 with attribution required.