nlm函数因分析Hessian而失败

时间：2018-01-19 01:21:36

标签： r

一些背景知识：nlm中的R函数是一个使用牛顿方法的通用优化例程。为了优化函数，牛顿方法需要函数，以及函数的一阶和二阶导数（分别为梯度向量和Hessian矩阵）。在R中，nlm函数允许您指定与梯度和Hessian的计算相对应的R函数，或者可以保留这些未指定的函数，并且基于数值导数提供数值解（通过{{1功能）。通过提供计算梯度和Hessian的函数，可以找到更精确的解决方案，因此它是一个有用的功能。

我的问题：deriv函数较慢，并且在提供分析Hessian时通常无法在合理的时间内收敛。我猜这是底层代码中的某种错误，但我很高兴出错。有没有办法通过分析Hessian矩阵使nlm更好地工作？

示例：下面的nlm代码使用逻辑回归示例演示了此问题，其中

log（Pr（Y = 1）/ Pr（Y = 0））= b0 + Xb

其中X是维数N乘以p的多元法线，b是长度为p的系数的向量。

R

第一个例子，p = 3：

library(mvtnorm)
# example demonstrating a problem with NLM
expit <- function(mu) {1/(1+exp(-mu))}
mk.logit.data <- function(N,p){
  set.seed(1232)
  U = matrix(runif(p*p), nrow=p, ncol=p)
  S = 0.5*(U+t(U)) + p*diag(rep(1,p))
  X = rmvnorm(N, mean = runif(p, -1, 1), sigma = S)  
  Design = cbind(rep(1, N), X)
  beta = sort(sample(c(rep(0,p), runif(1))))
  y = rbinom(N, 1, expit(Design%*%beta))
 list(X=X,y=as.numeric(y),N=N,p=p) 
}

# function to calculate gradient vector at given coefficient values
logistic_gr <- function(beta, y, x, min=TRUE){
  mu = beta[1] + x %*% beta[-1]
  p = length(beta)
  n = length(y)
  D = cbind(rep(1,n), x)
  gri = matrix(nrow=n, ncol=p)
  for(j in 1:p){
    gri[,j] = D[,j]*(exp(-mu)*y-1+y)/(1+exp(-mu))
  }
  gr = apply(gri, 2, sum)
  if(min) gr = -gr
  gr
}

# function to calculate Hessian matrix at given coefficient values
logistic_hess <- function(beta, y, x, min=TRUE){
  # allow to fail with NA, NaN, Inf values
  mu = beta[1] + x %*% beta[-1]
  p = length(beta)
  n = length(y)
  D = cbind(rep(1,n), x)
  h = matrix(nrow=p, ncol=p)
  for(j in 1:p){
   for(k in 1:p){
     h[j,k] = -sum(D[,j]*D[,k]*(exp(-mu))/(1+exp(-mu))^2)
   }
  }
  if(min) h = -h
  h
}

# function to calculate likelihood (up to a constant) at given coefficient values
logistic_ll <- function(beta, y,x, gr=FALSE, he=FALSE, min=TRUE){
  mu = beta[1] + x %*% beta[-1]
  lli = log(expit(mu))*y + log(1-expit(mu))*(1-y)
  ll = sum(lli)
  if(is.na(ll) | is.infinite(ll)) ll = -1e16
  if(min) ll=-ll
  # the below specification is required for using analytic gradient/Hessian in nlm function
  if(gr) attr(ll, "gradient") <- logistic_gr(beta, y=y, x=x, min=min)
  if(he) attr(ll, "hessian") <- logistic_hess(beta, y=y, x=x, min=min)
  ll
}

dat = mk.logit.data(N=100, p=3) 函数估计值仅供参考。 glm应该给出相同的答案，允许由于近似而导致的小错误。 

nlm

但是当p更大时问题变得明显，这里是10 

(glm.sol <- glm(dat$y~dat$X, family=binomial()))$coefficients

> (Intercept)      dat$X1      dat$X2      dat$X3 
>  0.00981465  0.01068939  0.04417671  0.01625381 

# works when correct analytic gradient is specified
(nlm.sol1 <- nlm(p=runif(dat$p+1), f=logistic_ll, gr=TRUE,  y=dat$y, x=dat$X))$estimate
> [1] 0.009814547 0.010689396 0.044176627 0.016253966

# works, but less accurate when correct analytic hessian is specified (even though the routine notes convergence is probable)
(nlm.sol2 <- nlm(p=runif(dat$p+1), f=logistic_ll, gr=TRUE, he=TRUE, y=dat$y, x=dat$X, hessian = TRUE, check.analyticals=TRUE))$estimate
> [1] 0.009827701 0.010687278 0.044178416 0.016255630

再次，dat = mk.logit.data(N=100, p=10) 解决方案供参考。 glm应该给出相同的答案，允许因近似而导致的小错误。

nlm

编辑：我还应该补充一点，我已通过多种不同的方法确认我有正确的Hessian矩阵

2 个答案:

答案 0 :(得分：2)

我尝试了代码，但是起初它似乎使用了与我在CRAN上找不到的rmvnorm不同的方法。我在dae软件包中找到了一个rmvnorm，然后在mvtnorm软件包中找到了一个。后者是要使用的。

nlm（）在上述发布时间被修补。我目前正在尝试验证补丁，现在看来工作正常。请注意，我是许多R的优化代码的作者，其中包括optim（）中的3/5。

nashjc at uottawa.ca

代码在下面。

答案 1 :(得分：0)

修改后的代码：

# example demonstrating a problem with NLM
expit <- function(mu) {1/(1+exp(-mu))}
mk.logit.data <- function(N,p){
  set.seed(1232)
  U = matrix(runif(p*p), nrow=p, ncol=p)
  S = 0.5*(U+t(U)) + p*diag(rep(1,p))
  X = rmvnorm(N, mean = runif(p, -1, 1), sigma = S)  
  Design = cbind(rep(1, N), X)
  beta = sort(sample(c(rep(0,p), runif(1))))
  y = rbinom(N, 1, expit(Design%*%beta))
  list(X=X,y=as.numeric(y),N=N,p=p) 
}

# function to calculate gradient vector at given coefficient values
logistic_gr <- function(beta, y, x, min=TRUE){
  mu = beta[1] + x %*% beta[-1]
  p = length(beta)
  n = length(y)
  D = cbind(rep(1,n), x)
  gri = matrix(nrow=n, ncol=p)
  for(j in 1:p){
    gri[,j] = D[,j]*(exp(-mu)*y-1+y)/(1+exp(-mu))
  }
  gr = apply(gri, 2, sum)
  if(min) gr = -gr
  gr
}

# function to calculate Hessian matrix at given coefficient values
logistic_hess <- function(beta, y, x, min=TRUE){
  # allow to fail with NA, NaN, Inf values
  mu = beta[1] + x %*% beta[-1]
  p = length(beta)
  n = length(y)
  D = cbind(rep(1,n), x)
  h = matrix(nrow=p, ncol=p)
  for(j in 1:p){
    for(k in 1:p){
      h[j,k] = -sum(D[,j]*D[,k]*(exp(-mu))/(1+exp(-mu))^2)
    }
  }
  if(min) h = -h
  h
}

# function to calculate likelihood (up to a constant) at given coefficient values
logistic_ll <- function(beta, y,x, gr=FALSE, he=FALSE, min=TRUE){
  mu = beta[1] + x %*% beta[-1]
  lli = log(expit(mu))*y + log(1-expit(mu))*(1-y)
  ll = sum(lli)
  if(is.na(ll) | is.infinite(ll)) ll = -1e16
  if(min) ll=-ll
  # the below specification is required for using analytic gradient/Hessian in nlm function
  if(gr) attr(ll, "gradient") <- logistic_gr(beta, y=y, x=x, min=min)
  if(he) attr(ll, "hessian") <- logistic_hess(beta, y=y, x=x, min=min)
  ll
}

##!!!! NOTE: Must have this library loaded
library(mvtnorm)
dat = mk.logit.data(N=100, p=3)
(glm.sol <- glm(dat$y~dat$X, family=binomial()))$coefficients
# works when correct analytic gradient is specified
(nlm.sol1 <- nlm(p=runif(dat$p+1), f=logistic_ll, gr=TRUE,  y=dat$y, x=dat$X))$estimate
# works, but less accurate when correct analytic hessian is specified (even though the routine notes convergence is probable)
(nlm.sol2 <- nlm(p=runif(dat$p+1), f=logistic_ll, gr=TRUE, he=TRUE, y=dat$y, x=dat$X, hessian = TRUE, check.analyticals=TRUE))$estimate

dat = mk.logit.data(N=100, p=10)

# Again, glm solution for reference. nlm should give the same answer, allowing for small errors due to approximation.

(glm.sol <- glm(dat$y~dat$X, family=binomial()))$coefficients

# works when correct analytic gradient is specified
(nlm.sol1 <- nlm(p=runif(dat$p+1), f=logistic_ll, gr=TRUE,  y=dat$y, x=dat$X))$estimate

# fails to converge in 5000 iterations when correct analytic hessian is specified
(nlm.sol2 <- nlm(p=runif(dat$p+1), f=logistic_ll, gr=TRUE, he=TRUE,   y=dat$y, x=dat$X, hessian = TRUE, iterlim=5000, check.analyticals=TRUE))$estimate
相关问题
最新问题