r中三参数威布尔分布的极大似然估计

Question

我想估计3p Weibull分布的尺度，形状和阈值参数。

到目前为止我所做的是以下内容：

参考这篇文章， 在R中拟合一个3参数Weibull分布

我已经使用过这些功能了

    EPS = sqrt(.Machine$double.eps) # "epsilon" for very small numbers

llik.weibull <- function(shape, scale, thres, x)
{ 
  sum(dweibull(x - thres, shape, scale, log=T))
}

thetahat.weibull <- function(x)
{ 
  if(any(x <= 0)) stop("x values must be positive")

  toptim <- function(theta) -llik.weibull(theta[1], theta[2], theta[3], x)

  mu = mean(log(x))
  sigma2 = var(log(x))
  shape.guess = 1.2 / sqrt(sigma2)
  scale.guess = exp(mu + (0.572 / shape.guess))
  thres.guess = 1

  res = nlminb(c(shape.guess, scale.guess, thres.guess), toptim, lower=EPS)

  c(shape=res$par[1], scale=res$par[2], thres=res$par[3])
}

“预估”我的Weibull参数，这样我就可以在MASS-Package的“fitdistr”函数中将它们用作参数“start”的初始值。

您可能会问我为什么要两次估计参数...原因是我需要估计的方差 - 协方差矩阵，这也是由fitdistr函数估计的。

例：

    set.seed(1)

    thres <- 450
    dat <- rweibull(1000, 2.78, 750) + thres

pre_mle <- thetahat.weibull(dat)

    my_wb <- function(x, shape, scale, thres) { 
        dweibull(x - thres, shape, scale)
    }

    ml <- fitdistr(dat, densfun = my_wb, start = list(shape = round(pre_mle[1], digits = 0), scale = round(pre_mle[2], digits = 0), 
    thres = round(pre_mle[3], digits = 0)))

    ml

     > ml
       shape        scale        thres   
       2.942548   779.997177   419.996196   (  0.152129) ( 32.194294) ( 28.729323)

     > ml$vcov
                shape       scale       thres
    shape  0.02314322    4.335239   -3.836873
    scale  4.33523868 1036.472551 -889.497580
    thres -3.83687258 -889.497580  825.374029 

这对于s​​hape参数高于1的情况非常有效。不幸的是，我的方法应该处理shape参数可能小于1的情况。

这里描述了小于1的形状参数不可能的原因： http ： //www.weibull.com/hotwire/issue148/hottopics148.htm

在案例1中，所有三个参数都是未知的，如下所述：

“将ti的最小失效时间定义为tmin。然后当γ→tmin，ln（tmin-γ）→-∞。如果β小于1，则（β - 1）ln（tmin - γ）变为+ ∞。对于β，η和γ的给定解，我们总能找到另一组解（例如，使γ更接近tmin），这将给出更大的似然值。因此，没有β的MLE解， η和γ。“

这很有道理。 出于这个原因，我想按照他们在此页面上描述的方式进行操作。

“在Weibull ++中，基于梯度的算法用于找到β，η和γ的MLE解.γ范围的上限任意设置为tmin的0.99。根据数据集，要么是局部最优或0.99tmin作为γ的MLE解决方案返回。“

我想为gamma设置一个可行的间隔（在我的代码中称为'thres'），使得解决方案介于（0，.99 * tmin）之间。

有谁知道如何解决这个问题？

在函数fitdistr中，似乎没有机会进行约束MLE，约束一个参数。

另一种方法可以是通过得分向量的外积估计渐近方差。 得分向量可以从上面使用的函数thetahat.weibul（x）中获得。 但是手动计算外部产品（没有功能）似乎非常耗时并且不能解决受约束的ML估计的问题。

最好的问候，蒂姆

Answer 1

设置受约束的MLE并不困难。 我将在bbmle::mle2执行此bbmle::mle2 ; 你也可以在stats4::mle做到这stats4::mle ，但是bbmle有一些额外的功能。

更大的问题是，当理论在允许空间的边界上时， 理论上难以定义估计的抽样方差; 瓦尔德方差估计背后的理论破裂了。 您仍然可以通过可能性分析来计算置信区间...或者您可以进行自举。 这样做时我遇到了各种各样的优化问题......我没有真正考虑过具体的原因

为mle2使用重新格式化三参数Weibull函数（将x作为第一个参数，将log作为参数）：

dweib3 <- function(x, shape, scale, thres, log=TRUE) { 
    dweibull(x - thres, shape, scale, log=log)
}

启动功能（稍微重新格式化）：

weib3_start <- function(x) {
   mu <- mean(log(x))
   sigma2 <- var(log(x))
   logshape  <- log(1.2 / sqrt(sigma2))
   logscale <- mu + (0.572 / logshape)
   logthres <- log(0.5*min(x))
   list(logshape = logshape, logsc = logscale, logthres = logthres)
}

生成数据：

set.seed(1)
dat <- data.frame(x=rweibull(1000, 2.78, 750) + 450)

拟合模型：为了方便和稳定，我将参数拟合在对数刻度上，但您也可以使用零边界。

tmin <- log(0.99*min(dat$x))
library(bbmle)
m1 <- mle2(x~dweib3(exp(logshape),exp(logsc),exp(logthres)),
           data=dat,
           upper=c(logshape=Inf,logsc=Inf,
                   logthres=tmin),
           start=weib3_start(dat$x),
           method="L-BFGS-B")

vcov(m1) ，通常应该提供方差 - 协方差估计（除非估计在边界上，这不是这里的情况）给出NaN值......不确定为什么没有更多的挖掘。

library(emdbook)
tmpf <- function(x,y) m1@minuslogl(logshape=x,
                                         logsc=coef(m1)["logsc"],
                                         logthres=y)
tmpf(1.1,6)
s1 <- curve3d(tmpf,
              xlim=c(1,1.2),ylim=c(5.9,tmin),sys3d="image")
with(s1,contour(x,y,z,add=TRUE))

h <- lme4:::hessian(function(x) do.call(m1@minuslogl,as.list(x)),coef(m1))
vv <- solve(h)
diag(vv) ## [1] 0.002672240 0.001703674 0.004674833
(se <- sqrt(diag(vv))) ## standard errors
## [1] 0.05169371 0.04127558 0.06837275
cov2cor(vv)
##            [,1]       [,2]       [,3]
## [1,]  1.0000000  0.8852090 -0.8778424
## [2,]  0.8852090  1.0000000 -0.9616941
## [3,] -0.8778424 -0.9616941  1.0000000

这是对数标度变量的方差 - 协方差矩阵。 如果要在原始比例上转换为方差 - 协方差矩阵，则需要按（x_i）*（x_j）（即通过变换exp(x)的导数）进行缩放。

outer(exp(coef(m1)),exp(coef(m1))) * vv
##             logshape       logsc    logthres
## logshape  0.02312803    4.332993   -3.834145
## logsc     4.33299307 1035.966372 -888.980794
## logthres -3.83414498 -888.980794  824.831463

我不知道为什么这对numDeriv - 对上面的方差估计会非常小心 。 （可能太接近理查森外推的边界了吗？）

library(numDeriv)
hessian()
grad(function(x) do.call(m1@minuslogl,as.list(x)),coef(m1))  ## looks OK
vcov(m1)

配置文件看起来std.err ......（我们必须提供std.err因为Hessian不可逆）

pp <- profile(m1,std.err=c(0.01,0.01,0.01))
par(las=1,bty="l",mfcol=c(1,3))
plot(pp,show.points=TRUE)

confint(pp)
##              2.5 %   97.5 %
## logshape 0.9899645 1.193571
## logsc    6.5933070 6.755399
## logthres 5.8508827 6.134346

或者，我们可以在原始尺度上执行此操作...一种可能性是使用对数缩放来拟合，然后从原始比例的那些参数开始重新编译。

wstart <- as.list(exp(unlist(weib3_start(dat$x))))
names(wstart) <- gsub("log","",names(wstart))
m2 <- mle2(x~dweib3(shape,sc,thres),
           data=dat,
           lower=c(shape=0.001,sc=0.001,thres=0.001),
           upper=c(shape=Inf,sc=Inf,
                   thres=exp(tmin)),
           start=wstart,
           method="L-BFGS-B")
vcov(m2)
##             shape          sc       thres
## shape  0.02312399    4.332057   -3.833264
## sc     4.33205658 1035.743511 -888.770787
## thres -3.83326390 -888.770787  824.633714
all.equal(unname(coef(m2)),unname(exp(coef(m1))),tol=1e-4)

与上面的值大致相同。

如果我们更加谨慎地绑定参数，我们可以适应小的形状，但现在我们最终会达到阈值的边界，这将导致方差计算的许多问题。

set.seed(1)
dat <- data.frame(x = rweibull(1000, .53, 365) + 100)
tmin <- log(0.99 * min(dat$x))
m1 <- mle2(x ~ dweib3(exp(logshape), exp(logsc), exp(logthres)),
   lower=c(logshape=-10,logscale=0,logthres=0),
   upper = c(logshape = 20, logsc = 20, logthres = tmin),
   data = dat, 
   start = weib3_start(dat$x), method = "L-BFGS-B") 

对于删失数据，您需要将dweibull替换为pweibull ; 有关提示，请参阅在三参数Weibull cdf上运行最大似然估计的错误 。

Answer 2

另一种可能的解决方案是进行贝叶斯推理。 在形状和比例参数上使用比例先验和在位置参数上使用统一的先验，您可以轻松地按如下方式运行Metropolis-Hastings。 根据对数（形状），对数（比例）和对数（y_min - 位置）进行重新参数化可能是可取的，因为某些参数的后验变得强烈倾斜，特别是对于位置参数。 请注意，下面的输出显示了反向转换参数的后验。

library(MCMCpack)
logposterior <- function(par,y) {
  gamma <- min(y) - exp(par[3])
  sum(dweibull(y-gamma,exp(par[1]),exp(par[2]),log=TRUE)) + par[3]
}
y <- rweibull(100,shape=.8,scale=10) + 1
chain0 <- MCMCmetrop1R(logposterior, rep(0,3), y=y, V=.01*diag(3))
chain <- MCMCmetrop1R(logposterior, rep(0,3), y=y, V=var(chain0))
plot(exp(chain))
summary(exp(chain))

这会产生以下输出

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
The Metropolis acceptance rate was 0.43717
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

Iterations = 501:20500
Thinning interval = 1 
Number of chains = 1 
Sample size per chain = 20000 

1. Empirical mean and standard deviation for each variable,
   plus standard error of the mean:

         Mean      SD  Naive SE Time-series SE
[1,]  0.81530 0.06767 0.0004785       0.001668
[2,] 10.59015 1.39636 0.0098738       0.034495
[3,]  0.04236 0.05642 0.0003990       0.001174

2. Quantiles for each variable:

          2.5%      25%      50%     75%   97.5%
var1 0.6886083 0.768054  0.81236  0.8608  0.9498
var2 8.0756210 9.637392 10.50210 11.4631 13.5353
var3 0.0003397 0.007525  0.02221  0.0548  0.1939