Failing to optimise negative binomial model using optim

Question

I am trying to manually optimise a negative binomial regression model using the optim package in R trying to predict a count variable y using a matrix of factors X using the following code:

# generating some fake data

n <- 1000

X <- matrix(NA, ncol = 5, nrow = n)


X[,1] <- 1
X[,2] <- sample(size = n, x = c(0,1), replace = TRUE)
X[,3] <- sample(size = n, x = c(0,1), replace = TRUE)
X[,4] <- sample(size = n, x = c(0,1), replace = TRUE)
X[,5] <- sample(size = n, x = c(0,1), replace = TRUE)


beta0 <- 3
beta1 <- -2
beta2 <- -2
beta3 <- -4
beta4 <- -0.9
k <- 0.9 

## draws from negative binomial distribution
mu <- exp(beta0 + beta1 * X[,2] + beta2 * X[,3] + beta3 * X[,4] + beta4 * X[,5])
theta <- mu + mu ^2 / k

# dependent variable

y <- rnegbin(n, mu = mu, theta = theta)



# function to be optimised
negbin_ll <- function(y, X, theta){
  
  beta <- theta[1:ncol(X)]
  alpha <- theta[ncol(X) + 1]

  logll <- y * log(alpha) + y *( beta %*% t(X) ) - (y + (1 / alpha ) ) * log( 1 + alpha * exp(beta %*% t(X))) + lgamma(y + (1 / alpha)) - lgamma ( y + 1)  - lgamma ( 1 / alpha)

    
  logll <- sum( logll  )
  
  return(logll)
  
}

stval <- rep(0, ncol(X) + 1)

res <-
  optim(
    stval,
    negbin_ll,
    y = y,
    X = X,
    control = list(fnscale = -1),
    hessian = TRUE,
    method = "BFGS"
  )    

The code should produce point estimates from the optimisation process, but instead fails when executing the optim-function with the error in optim(stval, negbin_ll, y = y, X = X, control = list(fnscale = -1), : initial value in 'vmmin' is not finite.

I already tried to change log(gamma(...)) to lgamma(...) in the likelihood function and tried many other ways, but I fail to get estimates.

Changing the start values of optim also does not help.

Do you have any idea if there is any particularity to the likelihood function that leads to values being treated in any odd fashion?

Help would be much appreciated.

Answer 1

optim tries several points to get to the minimum, in your case it hits some non-positive values in the arguments inside the logs. One way is to discard the values that return any non-positive inside the problematic functions by returning a negative (in your case) large number, like -lenght(series)*10^6 . Remade the log-likelihood function, like this it kinda works:

negbin_ll <- function(y, X, theta){
  
  beta <- theta[1:ncol(X)]
  alpha <- theta[ncol(X) + 1]
  
  if(any(alpha<=0)) return(-length(y)*10^6)
  if(any(1 + alpha * exp(beta %*% t(X))<=0)) return(-length(y)*10^6)
  
  logll <- y * log(alpha) + y *( beta %*% t(X) ) - (y + (1 / alpha ) ) * log( 1 + alpha * exp(beta %*% t(X))) + lgamma(y + (1 / alpha)) - lgamma ( y + 1)  - lgamma ( 1 / alpha)
  
  
  logll <- sum( logll  )
  
  return(logll)
  
}