У меня есть проблема оптимизации, которую решает метод Nelder-Mead, но я также хотел бы решить, используя BFGS или Newton-Raphson, или что-то, что принимает функцию градиента, для большей скорости и, надеюсь, более точного По оценкам. Я написал такую функцию градиента, следующую (я подумал) пример в документации optim/optimx, но когда я использую ее с BFGS, мои начальные значения либо не перемещаются (optim()), либо функция не работает (optimx(), которая возвращает Error: Gradient function might be wrong - check it!). Мне жаль, что в этом воспроизведении немного кода, но здесь говорится:
Это функция, которую я хочу получить для оценки параметров (это для сглаживания показателей смертности по старости, где x - возраст, начиная с 80 лет):
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 и b положительными.
Примеры данных (1962 Япония, если кому интересно):
.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
Это градиентная функция, с которой я пришел:
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)
}
Выход представляет собой вектор длины 2, изменение по параметрам 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 на выходе, он говорит, что KannistoLik1() был вызван 31 раз и Kannisto.gr() всего 1 раз. $convergence 0, поэтому я думаю, он думает, что он сходится (если я даю менее разумные старты, они также остаются на месте). Я уменьшил допуск и т.д., И ничего не изменилось. Когда я пытаюсь выполнить тот же вызов в optimx() (не показан), я получаю waring, о котором я упоминал выше, и никакой объект не возвращается. Я получаю те же результаты при указании gr = Kannisto.gr с помощью "CG". С помощью метода "L-BFGS-B" я получаю те же начальные значения, что и оценка, но также сообщается, что как функция, так и градиент были вызваны 21 раз, и появляется сообщение об ошибке:
"ERROR: BNORMAL_TERMINATION_IN_LNSRCH"
Я надеюсь, что есть некоторые мелкие детали в том, как написана градиентная функция, которая решит это, так как это более позднее предупреждение и поведение optimx прямо намекают, что функция просто неверна (я думаю). Я также попробовал максимизатор maxNR() из пакета maxLik и наблюдал подобное поведение (начальные значения не перемещаются). Может ли кто-нибудь дать мне указатель? Очень важно
[Изменить] @Vincent предложил сравнить с выходом из численного приближения:
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
такой разный знак, и выключен в 10 раз? Я меняю функцию градиента следующим образом:
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
Попробуйте в оптимизаторе:
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(), чтобы сохранить параметры положительными. Самые последние и более эффективные функции объектива и градиента:
KannistoLik2 <- function(pars, .Dx, .Exp, .x. = .5:30.5){
mu <- KannistoMu.c(abs(pars), x = .x.)
# take negative and minimize it (default optimizer behavior)
-sum(.Dx * log(mu) - .Exp * mu, na.rm = TRUE)
}
# gradient, to be down-scaled in `optim()` call
Kannisto.gr3 <- function(pars, .Dx, .Exp, x = .5:30.5){
a <- abs(pars["a"])
b <- abs(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)
}
# try it out:
BFGSab2 <- optim(
c(a = .1, b = .1),
fn = KannistoLik2,
gr = function(...) Kannisto.gr3(...) * 1e-7,
method = "BFGS",
.Dx = .Dx, .Exp = .Exp
)
# reasonable:
BFGSab2$par
a b
0.1243249 0.1163924
# better:
KannistoLik2(exp(NMab1$par),.Dx = .Dx, .Exp = .Exp) > KannistoLik2(BFGSab2$par,.Dx = .Dx, .Exp = .Exp)
[1] TRUE
Это было решено гораздо быстрее, чем я ожидал, и я узнал больше, чем пару трюков. Спасибо Винсент!
