Chuyển đổi mã SAS NLMIXED để hồi quy gamma bằng 0 thành R

Tôi đang cố gắng chạy hồi quy không tăng cho biến phản hồi liên tục trong R. Tôi biết về việc triển khai gamlss, nhưng tôi thực sự muốn thử thuật toán này của Dale McLerran về mặt khái niệm đơn giản hơn một chút. Thật không may, mã nằm trong SAS và tôi không chắc làm thế nào để viết lại nó cho một cái gì đó như nlme.

Mã này như sau:

proc nlmixed data=mydata;
  parms b0_f=0 b1_f=0 
        b0_h=0 b1_h=0 
        log_theta=0;


  eta_f = b0_f + b1_f*x1 ;
  p_yEQ0 = 1 / (1 + exp(-eta_f));


  eta_h = b0_h + b1_h*x1;
  mu    = exp(eta_h);
  theta = exp(log_theta);
  r = mu/theta;


  if y=0 then
     ll = log(p_yEQ0);
  else
     ll = log(1 - p_yEQ0)
          - lgamma(theta) + (theta-1)*log(y) - theta*log(r) - y/r;


  model y ~ general(ll);
  predict (1 - p_yEQ0)*mu out=expect_zig;
  predict r out=shape;
  estimate "scale" theta;
run;

Từ: http://listserv.uga.edu/cgi-bin/wa?A2=ind0805A&L=sas-l&P=R20779

THÊM VÀO:

Lưu ý: Không có hiệu ứng hỗn hợp nào hiện diện ở đây - chỉ cố định.

Ưu điểm của sự phù hợp này là (mặc dù các hệ số giống như khi bạn tách riêng một hồi quy logistic thành P (y = 0) và hồi quy lỗi gamma với liên kết nhật ký đến E (y | y> 0)) bạn có thể ước tính hàm kết hợp E (y) bao gồm các số 0. Người ta có thể dự đoán giá trị này trong SAS (với CI) bằng cách sử dụng dòng predict (1 - p_yEQ0)*mu.

Hơn nữa, người ta có thể viết các câu lệnh tương phản tùy chỉnh để kiểm tra tầm quan trọng của các biến dự đoán trên E (y). Ví dụ, đây là một phiên bản khác của mã SAS tôi đã sử dụng:

proc nlmixed data=TestZIG;
      parms b0_f=0 b1_f=0 b2_f=0 b3_f=0
            b0_h=0 b1_h=0 b2_h=0 b3_h=0
            log_theta=0;


        if gifts = 1 then x1=1; else x1 =0;
        if gifts = 2 then x2=1; else x2 =0;
        if gifts = 3 then x3=1; else x3 =0;


      eta_f = b0_f + b1_f*x1 + b2_f*x2 + b3_f*x3;
      p_yEQ0 = 1 / (1 + exp(-eta_f));

      eta_h = b0_h + b1_h*x1 + b2_h*x2 + b3_h*x3;
      mu    = exp(eta_h);
      theta = exp(log_theta);
      r = mu/theta;

      if amount=0 then
         ll = log(p_yEQ0);
      else
         ll = log(1 - p_yEQ0)
              - lgamma(theta) + (theta-1)*log(amount) -                      theta*log(r) - amount/r;

      model amount ~ general(ll);
      predict (1 - p_yEQ0)*mu out=expect_zig;
      estimate "scale" theta;
    run; 

Sau đó, để ước tính "gift1" so với "gift2" (b1 so với b2), chúng ta có thể viết tuyên bố ước tính này:

estimate "gift1 versus gift 2" 
 (1-(1 / (1 + exp(-b0_f -b1_f))))*(exp(b0_h + b1_h)) - (1-(1 / (1 + exp(-b0_f -b2_f))))*(exp(b0_h + b2_h)) ; 

R có thể làm điều này?

Đã dành một chút thời gian cho mã này, về cơ bản nó xuất hiện:

1) Có hồi quy logistic với phía bên tay phải b0_f + b1_f*x1và y > 0như một biến mục tiêu không,

2) Đối với những quan sát mà y> 0, thực hiện hồi quy với phía bên tay phải b0_h + b1_h*x1, khả năng Gamma và link=log,

3) Cũng ước tính tham số hình dạng của phân phối Gamma.

Nó tối đa hóa khả năng cùng nhau, điều này là tốt, bởi vì bạn chỉ phải thực hiện một cuộc gọi chức năng. Tuy nhiên, dù sao thì khả năng sẽ tách ra, do đó bạn không nhận được ước tính tham số được cải thiện.

Đây là một số mã R sử dụng glmhàm để tiết kiệm công sức lập trình. Đây có thể không phải là những gì bạn thích, vì nó che khuất thuật toán chính nó. Mã chắc chắn không sạch như nó có thể / nên được.

McLerran <- function(y, x)
{
  z <- y > 0
  y.gt.0 <- y[y>0]
  x.gt.0 <- x[y>0]

  m1 <- glm(z~x, family=binomial)
  m2 <- glm(y.gt.0~x.gt.0, family=Gamma(link=log))

  list("p.ygt0"=m1,"ygt0"=m2)
}

# Sample data
x <- runif(100)
y <- rgamma(100, 3, 1)      # Not a function of x (coef. of x = 0)
b <- rbinom(100, 1, 0.5*x)  # p(y==0) is a function of x
y[b==1] <- 0

foo <- McLerran(y,x)
summary(foo$ygt0)

Call:
glm(formula = y.gt.0 ~ x.gt.0, family = Gamma(link = log))

Deviance Residuals: 
     Min        1Q    Median        3Q       Max  
-2.08888  -0.44446  -0.06589   0.28111   1.31066  

Coefficients:
            Estimate Std. Error t value Pr(>|t|)    
(Intercept)   1.2033     0.1377   8.737 1.44e-12 ***
x.gt.0       -0.2440     0.2352  -1.037    0.303    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 

(Dispersion parameter for Gamma family taken to be 0.3448334)

    Null deviance: 26.675  on 66  degrees of freedom
Residual deviance: 26.280  on 65  degrees of freedom
AIC: 256.42

Number of Fisher Scoring iterations: 6

Tham số hình dạng cho phân phối Gamma bằng 1 / tham số phân tán cho họ Gamma. Các hệ số và những thứ khác mà bạn có thể muốn truy cập theo chương trình có thể được truy cập trên các thành phần riêng lẻ của danh sách giá trị trả về:

> coefficients(foo$p.ygt0)
(Intercept)           x 
   2.140239   -2.393388 

Dự đoán có thể được thực hiện bằng cách sử dụng đầu ra của thói quen. Dưới đây là một số mã R khác cho thấy cách tạo các giá trị dự kiến ​​và một số thông tin khác:

# Predict expected value
predict.McLerren <- function(model, x.new)
{
  x <- as.data.frame(x.new)
  colnames(x) <- "x"
  x$x.gt.0 <- x$x

  pred.p.ygt0 <- predict(model$p.ygt0, newdata=x, type="response", se.fit=TRUE)
  pred.ygt0 <- predict(model$ygt0, newdata=x, type="response", se.fit=TRUE)  

  p0 <- 1 - pred.p.ygt0$fit
  ev <- (1-p0) * pred.ygt0$fit

  se.p0 <- pred.p.ygt0$se.fit
  se.ev <- pred.ygt0$se.fit

  se.fit <- sqrt(((1-p0)*se.ev)^2 + (ev*se.p0)^2 + (se.p0*se.ev)^2)

  list("fit"=ev, "p0"=p0, "se.fit" = se.fit,
       "pred.p.ygt0"=pred.p.ygt0, "pred.ygt0"=pred.ygt0)
}

Và một mẫu chạy:

> x.new <- seq(0.05,0.95,length=5)
> 
> foo.pred <- predict.McLerren(foo, x.new)
> foo.pred$fit
       1        2        3        4        5 
2.408946 2.333231 2.201889 2.009979 1.763201 
> foo.pred$se.fit
        1         2         3         4         5 
0.3409576 0.2378386 0.1753987 0.2022401 0.2785045 
> foo.pred$p0
        1         2         3         4         5 
0.1205351 0.1733806 0.2429933 0.3294175 0.4291541 

Bây giờ để trích xuất hệ số và độ tương phản:

coef.McLerren <- function(model)
{
  temp1 <- coefficients(model$p.ygt0)
  temp2 <- coefficients(model$ygt0)
  names(temp1) <- NULL
  names(temp2) <- NULL
  retval <- c(temp1, temp2)
  names(retval) <- c("b0.f","b1.f","b0.h","b1.h")
  retval
}

contrast.McLerren <- function(b0_f, b1_f, b2_f, b0_h, b1_h, b2_h)
{
  (1-(1 / (1 + exp(-b0_f -b1_f))))*(exp(b0_h + b1_h)) - (1-(1 / (1 + exp(-b0_f -b2_f))))*(exp(b0_h + b2_h))
}


> coef.McLerren(foo)
      b0.f       b1.f       b0.h       b1.h 
 2.0819321 -1.8911883  1.0009568  0.1334845