R: функція glm із специфікацією сімейства = “бінома” та “вага”

Мене дуже плутає те, як вага працює в glm з сім'єю = "двочлен". У моєму розумінні ймовірність glm з family = "binomial" визначається так:

$$f(y) = {n\choose{ny}} p^{ny} (1-p)^{n(1-y)} = \exp \left(n \left[ y \log \frac{p}{1-p} - \left(-\log (1-p)\right) \right] + \log {n \choose ny}\right)$$ де $y$ - "частка спостережуваного успіху", а $n$ - відома кількість випробувань.

Наскільки я розумію, ймовірність успіху $p$ параметризується деякими лінійними коефіцієнтами $\beta$ як $p=p(\beta)$ а функція glm із сім'єю = "двочлен" шукає:

$$\textrm{arg}\max_{\beta} \sum_i \log f(y_i).$$ Тоді цю проблему оптимізації можна спростити як:

$$\textrm{arg}\max_{\beta} \sum_i \log f(y_i)= \textrm{arg}\max_{\beta} \sum_i n_i \left[ y_i \log \frac{p(\beta)}{1-p(\beta)} - \left(-\log (1-p(\beta))\right) \right] + \log {n_i \choose n_iy_i}\\ = \textrm{arg}\max_{\beta} \sum_i n_i \left[ y_i \log \frac{p(\beta)}{1-p(\beta)} - \left(-\log (1-p(\beta))\right) \right] \\ $$
Тому якщо дозволити $n_i^*=n_ic$ для всіх $i=1,...,N$ для деякої постійної $c$ , то також повинно бути правдою, що: $$\textrm{arg}\max_{\beta} \sum_i \log f(y_i) = \textrm{arg}\max_{\beta} \sum_i n^*_i \left[ y_i \log \frac{p(\beta)}{1-p(\beta)} - \left(-\log (1-p(\beta))\right) \right] \\ $$ З цього я подумав, що масштабування кількості випробувань $n_i$з постійною НЕ впливає на максимальну оцінку ймовірності $\beta$ враховуючи частку успіху $y_i$ .

Файл довідки про glm говорить:

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

Тому я очікував, що масштабування ваги не вплине на оцінену $\beta$ враховуючи частку успіху як відповіді. Однак наступні два коди повертають різні значення коефіцієнта:

 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  

Я бачив багато інших подібних прикладів навіть при помірному масштабуванні ваг. Що тут відбувається?

Ваш приклад просто спричиняє помилку округлення в Р. Великі ваги погано спрацьовують 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

Я думаю , що це зводиться до первинних значень , які використовуються в glm.fitз family$initializeяких робить метод divergere. Наскільки мені відомо, glm.fitвирішіть задачу, сформувавши QR-розкладання де - матриця проектування, а - діагональ з квадратними коренями записів, як описано тут . Тобто використовується метод Ньютона-Рафсона.$\sqrt{W}X$$X$$\sqrt{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