如何正确指定在optim()或其他优化器中使用的渐变函数

时间:2012-07-24 01:39:47

标签: r optimization

我有一个Nelder-Mead方法会解决的优化问题,但是我还想使用BFGS或Newton-Raphson解决,或者采用渐变函数的方法,以提高速度,并希望更准确的估计。我在optim / optimx文档中编写了这样的渐变函数(我认为),但是当我将其与BFGS一起使用时,我的起始值要么不移动({{ 1}}),否则函数完全不运行(optim(),返回optimx())。对不起,有一些代码涉及复制这个,但是这里有:

这是我想要获得参数估计的函数(这是为了平滑老年死亡率,其中x是年龄,从80岁开始):

Error: Gradient function might be wrong - check it!

这是一个对数似然函数,用于根据观察到的速率(定义为死亡, KannistoMu <- function(pars, x = .5:30.5){ a <- pars["a"] b <- pars["b"] (a * exp(b * x)) / (1 + a * exp(b * x)) } 过度暴露,.Dx)估算它:

.Exp

您在其中看到 KannistoLik1 <- function(pars, .Dx, .Exp, .x. = .5:30.5){ mu <- KannistoMu(exp(pars), x = .x.) # take negative and minimize it (default optimizer behavior) -sum(.Dx * log(mu) - .Exp * mu, na.rm = TRUE) } 因为我要exp(pars)进行优化,以便将最终的log(pars)a限制为正。

示例数据(1962年日本女性,如果有人好奇的话):

b

以下适用于 .Dx <- structure(c(10036.12, 9629.12, 8810.11, 8556.1, 7593.1, 6975.08, 6045.08, 4980.06, 4246.06, 3334.04, 2416.03, 1676.02, 1327.02, 980.02, 709, 432, 350, 217, 134, 56, 24, 21, 10, 8, 3, 1, 2, 1, 0, 0, 0), .Names = c("80", "81", "82", "83", "84", "85", "86", "87", "88", "89", "90", "91", "92", "93", "94", "95", "96", "97", "98", "99", "100", "101", "102", "103", "104", "105", "106", "107", "108", "109", "110")) .Exp <- structure(c(85476.0333333333, 74002.0866666667, 63027.5183333333, 53756.8983333333, 44270.9, 36749.85, 29024.9333333333, 21811.07, 16912.315, 11917.9583333333, 7899.33833333333, 5417.67, 3743.67833333333, 2722.435, 1758.95, 1043.985, 705.49, 443.818333333333, 223.828333333333, 93.8233333333333, 53.1566666666667, 27.3333333333333, 16.1666666666667, 10.5, 4.33333333333333, 3.16666666666667, 3, 2.16666666666667, 1.5, 0, 1), .Names = c("80", "81", "82", "83", "84", "85", "86", "87", "88", "89", "90", "91", "92", "93", "94", "95", "96", "97", "98", "99", "100", "101", "102", "103", "104", "105", "106", "107", "108", "109", "110")) 方法:

Nelder-Mead

这是我提出的渐变功能:

    NMab <- optim(log(c(a = .1, b = .1)), 
      fn = KannistoLik1, method = "Nelder-Mead",
      .Dx = .Dx, .Exp = .Exp)
    exp(NMab$par) 
    # these are reasonable estimates
       a         b 
    0.1243144 0.1163926

输出是长度为2的向量,相对于参数 Kannisto.gr <- function(pars, .Dx, .Exp, x = .5:30.5){ a <- exp(pars["a"]) b <- exp(pars["b"]) d.a <- (a * exp(b * x) * .Exp + (-a * exp(b * x) - 1) * .Dx) / (a ^ 3 * exp(2 * b * x) + 2 * a ^ 2 * exp(b * x) + a) d.b <- (a * x * exp(b * x) * .Exp + (-a * x * exp(b * x) - x) * .Dx) / (a ^ 2 * exp(2 * b * x) + 2 * a * exp(b * x) + 1) -colSums(cbind(a = d.a, b = d.b), na.rm = TRUE) } a的变化。通过利用b的输出,我也得到了一个丑陋的版本,它返回相同的答案,我没有发布(只是为了确认衍生物是正确的)。

如果按照以下方式将deriv()提供给optim(),则估算值不会从起始值移动:

BFGS

当我查看输出的 BFGSab <- optim(log(c(a = .1, b = .1)), fn = KannistoLik1, gr = Kannisto.gr, method = "BFGS", .Dx = .Dx, .Exp = .Exp) # estimates do not change from starting values: exp(BFGSab$par) a b 0.1 0.1 元素时,它表示$counts被调用31次而KannistoLik1()只被调用1次。 Kannisto.gr()$convergence,所以我猜它认为它会收敛(如果我给出的合理开始时间较短,它们也会保持不变)。我减少了容忍度等,没有任何变化。当我在0(未显示)中尝试相同的调用时,我收到了上面提到的警告,并且没有返回任何对象。使用optimx()指定gr = Kannisto.gr时,我得到相同的结果。使用"CG"方法,我得到与估计值相同的起始值,但也报告函数和梯度都被调用了21次,并且有一条错误消息:  "L-BFGS-B"

我希望写入渐变函数的方式有一些细节可以解决这个问题,因为后来的警告和"ERROR: BNORMAL_TERMINATION_IN_LNSRCH"行为直截了当地暗示函数根本就不对(我认为)。我还尝试了optimx包中的maxNR()最大化器并观察到类似行为(起始值不移动)。任何人都可以给我指针吗?很有责任

[编辑] @Vincent建议我与数值近似的输出进行比较:

maxLik

如此不同的标志,并减少了10倍?我改变了渐变函数:

    library(numDeriv)
    grad( function(u) KannistoLik1( c(a=u[1], b=u[2]), .Dx, .Exp ), log(c(.1,.1)) )
    [1] -14477.40  -7458.34
    Kannisto.gr(log(c(a=.1,b=.1)), .Dx, .Exp)
     a        b 
    144774.0  74583.4 

在优化器中尝试:

    Kannisto.gr2 <- function(pars, .Dx, .Exp, x = .5:30.5){
      a <- exp(pars["a"])
      b <- exp(pars["b"])
      d.a <- (a * exp(b * x) * .Exp + (-a * exp(b * x) - 1) * .Dx) /
        (a ^ 3 * exp(2 * b * x) + 2 * a ^ 2 * exp(b * x) + a)
      d.b <- (a * x * exp(b * x) * .Exp + (-a * x * exp(b * x) - x) * .Dx) /
        (a ^ 2 * exp(2 * b * x) + 2 * a * exp(b * x) + 1)
      colSums(cbind(a=d.a,b=d.b), na.rm = TRUE) / 10
    }
    Kannisto.gr2(log(c(a=.1,b=.1)), .Dx, .Exp)
    # same as numerical:
      a         b 
    -14477.40  -7458.34 

根据Vincent的回答,我重新调整了渐变函数,并使用 BFGSab <- optim(log(c(a = .1, b = .1)), fn = KannistoLik1, gr = Kannisto.gr2, method = "BFGS", .Dx = .Dx, .Exp = .Exp) # not reasonable results: exp(BFGSab$par) a b Inf Inf # and in fact, when not exp()'d, they look oddly familiar: BFGSab$par a b -14477.40 -7458.34 代替abs()来保持参数为正。最近的,性能更好的目标和梯度函数:

exp()

这个解决得比我预期的要快得多,而且我学到的不仅仅是几个技巧。谢谢文森特!

1 个答案:

答案 0 :(得分:11)

要检查渐变是否正确, 你可以将它与数值近似值进行比较:

library(numDeriv); 
grad( function(u) KannistoLik1( c(a=u[1], b=u[2]), .Dx, .Exp ), c(1,1) ); 
Kannisto.gr(c(a=1,b=1), .Dx, .Exp)

迹象是错误的:算法没有看到任何改进 当它向这个方向移动时,因此不会移动。

你可以使用一些计算机代数系统(这里,千里马) 为你做计算:

display2d: false;
f(a,b,x) := a * exp(b*x) / ( 1 + a * exp(b*x) );
l(a,b,d,e,x) := - d * log(f(a,b,x)) + e * f(a,b,x);
factor(diff(l(exp(a),exp(b),d,e,x),a));
factor(diff(l(exp(a),exp(b),d,e,x),b));

我只是将结果复制并粘贴到R:

f_gradient <- function(u, .Dx, .Exp, .x.=.5:30.5) {
  a <- u[1]
  b <- u[1]
  x <- .x.
  d <- .Dx
  e <- .Exp
  c(
    sum( (e*exp(exp(b)*x+a)-d*exp(exp(b)*x+a)-d)/(exp(exp(b)*x+a)+1)^2 ),
    sum( exp(b)*x*(e*exp(exp(b)*x+a)-d*exp(exp(b)*x+a)-d)/(exp(exp(b)*x+a)+1)^2 )
  )  
}

library(numDeriv)
grad( function(u) KannistoLik1( c(a=u[1], b=u[2]), .Dx, .Exp ), c(1,1) )
f_gradient(c(a=1,b=1), .Dx, .Exp)  # Identical

如果你盲目地将渐变放在优化中, 有一个数值不稳定问题:给出的解决方案是(Inf,Inf) ... 要防止它,您可以重新缩放渐变 (一个更好的解决方法是使用比指数更小的爆炸性转换, 确保参数保持正值。

BFGSab <- optim(
  log(c(a = .1, b = .1)), 
  fn = KannistoLik1, 
  gr = function(...) f_gradient(...) * 1e-3, 
  method = "BFGS",
  .Dx = .Dx, .Exp = .Exp
)
exp(BFGSab$par) # Less precise than Nelder-Mead