在 r 中編碼似然和對數似然函數以執行優化

Question

我正在寫一篇論文，要求我找到 Gumbel 的 I 型二元指數分布的 MLE。 我已經證明了似然性和對數似然函數似然性和對數似然性，但我正在努力在 r 中實現它以使用 Optim 函數執行優化。 我的代碼生成 NA 值。 以下是我的代碼。

# likelihood function of x
likelihood.x = function(params, data) {
  lambda1 = params[1]
  lambda2 = params[2]
  theta = params[3]
  A = (1 - theta) * (lambda1 * lambda2)
  B = theta * (lambda1 ^ 2) * lambda2 * data$X1
  C = theta * lambda1 * (lambda2 ^ 2) * data$X2
  D = (theta ^ 2) * (lambda1 ^ 2) * (lambda2 ^ 2) * data$X1 * data$X2
  E = (lambda1 * data$X1) + (lambda2 * data$X2) + (theta * lambda1 * lambda2 * data$X1 * data$X2)
  f = sum(log(A + B + C + D)) - sum(E)
  return(exp(f))
}

# Log-likelihood function of x
log.likelihood.x = function(params, data){
  lambda1 = params[1]
  lambda2 = params[2]
  theta = params[3]
  A = (1 - theta) * (lambda1 * lambda2)
  B = theta * (lambda1 ^ 2) * lambda2 * data$X1
  C = theta * lambda1 * (lambda2 ^ 2) * data$X2
  D = (theta ^ 2) * (lambda1 ^ 2) * (lambda2 ^ 2) * data$X1 * data$X2
  E = (lambda1 * data$X1) + (lambda2 * data$X2) + (theta * lambda1 * lambda2 * data$X1 * data$X2)
  f = sum(log(A + B + C + D)) - sum(E)
  return(-f)
}

這是生成數據的函數

# Simulating data
rGBVE = function(n, lambda1, lambda2, theta) {
  x1 = rexp(n, lambda1)
  lambda12 = lambda1 * lambda2
  pprod = lambda12 * theta
  C = exp(lambda1 * x1)
  A = (lambda12 - pprod + pprod * lambda1 * x1) / C
  B = (pprod * lambda2 + pprod ^ 2 * x1) / C
  D = lambda2 + pprod * x1
  wExp = A / D
  wGamma = B / D ^ 2
  data.frame(x1, x2 = rgamma(n, (runif(n) > wExp / (wExp + wGamma)) + 1, D))
}

data = rGBVE(n=100, lambda1 = 1.2, lambda2 = 1.4, theta = 0.5)
colnames(data) = c("X1", "X2") 

我的目標是在 r 中使用 Optim() 為 lambda1、lambda2 和 theta 找到 MLE。

請幫助我在 r 中實現我的似然性和對數似然函數。 謝謝你。

Answer 1

您的擔憂似乎與警告信息有關

在 log(A+B+C+D) 中：產生了 NaN

這樣的警告通常是無害的——它只是意味着優化算法在違反條件A+B+C+D ≥ 0的過程中嘗試了一組參數。 由於這些是相當復雜的表達式，因此需要花費一些精力來弄清楚如何約束參數（或重新參數化函數，例如在對數刻度上擬合一些參數）以避免警告，但猜測一下保持參數非負會有所幫助，我們可以嘗試使用L-BFGS-B算法（這是optim()中唯一允許多維有界優化的算法）。

r1 <- optim(par = c(1,2,1),
      fn = log.likelihood.x,
      dat  = data)

r2 <- optim(par = c(1,2,1),
      fn = log.likelihood.x,
      lower = rep(0,3),
      method = "L-BFGS-B",
      dat  = data)

第二個不生成警告，結果很接近（如果不相同）：

all.equal(r1$par, r2$par)
## "Mean relative difference: 0.0001451953"      

您可能想要使用bbmle ，它具有一些用於似然建模的附加功能：

library(bbmle)
fwrap <- function(x) log.likelihood.x(x, dat = data)
parnames(fwrap) <- c("lambda1", "lambda2", "theta")
m1 <- mle2(fwrap, start = c(lambda1 = 1, lambda2 = 2, theta = 1), vecpar = TRUE,
           method = "L-BFGS-B", lower = c(0, 0, -0.5))
pp <- profile(m1)
plot(pp)
confint(pp)
confint(m1, method = "quad")