You need to enable JavaScript to run this app.
优惠活动
大模型
产品
解决方案
定价
更多

EM算法报错:含积分的似然估计中出现非有限函数值

修正威布尔分布MLE的蒙特卡洛模拟中EM算法的积分报错问题

我在R中实现基于蒙特卡洛模拟的极大似然估计(MLE),从修正威布尔分布抽样,用EM算法估计参数。似然函数包含积分,所有组件单独测试都正常,但运行时始终报以下错误:

Error in integrate(ll1, x1e[j], Inf, rel.tol = 1e-06) : non-finite function value

完整代码

###### R Codes for Monte Carlo Simulation####
##########################
##########################
##########################
# Install and load required libraries
#
library(pracma)
library('bbmle') 
library(numDeriv)

##################################################################
N= 15;n=300; m=100;tau=.4;tau_2=3;lambda=1.5;phi=0.5;paii=0.2;gamma=3;delta=.5; initial_values1 <- c(1.2, 1.6, 2, 1.5);p=.4; k1 <- c(-.5,.5)  
 
inverse_transform_sampling <- function(n, pdf, lower_bound, upper_bound) {
  # Generate uniform random numbers
  u <- runif(n);    x <- numeric(n)
  for (t in 1:n) {
    inverse_cdf <- function(x) integrate(pdf, lower_bound, x)$value - u[t]
    x[t] <- uniroot(inverse_cdf, lower = lower_bound, upper = upper_bound)$root
  }
  return(x)
}
pdf_modified_weibull <- function(x) {
  phi * x^(gamma - 1) * (gamma + delta * x) * exp(-phi * x^gamma * exp(delta * x) + delta * x)
}
T   <- inverse_transform_sampling(n, pdf_modified_weibull, 0, 1000)
###############################################

drawn_observations <- r <-  numeric() ###vector("list", length = m)
removed_observations <- vector("list", length = m)
# Perform the iterations
for (j in 1:m) {
  
  observation <- min(T) #sample(y[y > max(c(prev_observation, -Inf)) ], 1)
  drawn_observations[j] <- observation
  
  # Remove r observations at each iteration (except the last one)
  if (j < m) {
    rr <- rbinom(1, 5 , p)  # Draw the number of observations to remove
    r[j] <- rr
    removed_obs <- sample(setdiff(T, observation), rr, replace = FALSE)
    removed_observations[[j]] <- removed_obs
    rm<- c(observation, removed_obs)
    T <- T[!(T %in% rm)]# setdiff(y, removed_obs);y[y!=observation]
  } else {  # On the last iteration, remove all remaining observations
    removed_observations[[j]] <- T
    r[j] <- length(T)
    T <- NULL  # Clear y as all observations have been drawn
  }
  
  # Update the previously drawn observation
  prev_observation <- observation
}

x1 <- drawn_observations[drawn_observations <= tau ]
xm <- drawn_observations[!(drawn_observations %in% x1)]
m <- length(r); n1 <- length(x1); m1 <- length(xm)
rn1 <- r[1:n1]; rm <- r[ (n1+1) : m]; yc <- max(xm)    
##################################################################
rn1e <- rn1#[rn1 != 0]
rme <- rm#[rm != 0]
x1e <- x1#[rn1 != 0]
xme <- xm#[rm != 0]
# EM Algorithm
    # Define the functions for the log-likelihood and its gradient
    loglik <- function(params) {
      # Extract parameters
      gamm <- params[1]
      delt <- params[2]
      ph <- params[3]
      lambd <- params[4]

    rn1e <- rn1#[rn1 != 0]
rme <- rm#[rm != 0]
x1e <- x1#[rn1 != 0]
xme <- xm#[rm != 0]
    # Calculate intermediate values length(llik2)   ph; lambd=lamd

      gdx1 <- gamm + delt * x1e
      tplxm <- tau + lambd * (xme -tau)
      gdtplxm <- gamm + delt * (tplxm)
      edtplxm <- exp(delt * (tplxm))

      # Calculate the log-likelihood
      loglik <- m * log(ph) + (m - n1) * log(lambd) + sum((gamm - 1) * log(x1e) + log(gdx1)) -
        ph * sum(x1e ^ gamm * exp(delt * x1e)) + delt * sum(x1e) +
        sum((gamm - 1) * log(tplxm) + log(gdtplxm)) -
        ph * sum(tplxm ^ gamm * edtplxm) + delt * sum(tplxm)  

   llik1 <- c(); llik2 <- c();
      for (j in 1:length(x1e)) {

        ll1 <- function(z) {
          lll11 <- (2 * gamm - 1)* log(z) +log(gamm + delt * z) 
          lll12 <- (-ph * z^gamm * exp(delt * z) + 2 * delt * z)
          return(ifelse(z==0, 0, exp(lll11+lll12)))
        }

        llik1[j] <- (ph * rn1e[j] * integrate(ll1, x1e[j], 1.3, rel.tol = 1e-6)$value) / exp(-ph * x1e[j] ^ gamm * exp(delt * x1e[j]))
      }
  for (j in 1:length(xme) ) {  # ; j=12
          ll2<- function(z){
             lll21 <-   (2 * gamm - 1)*log(tau + lambd * (z - tau)) + log(gamm + delt * (tau + lambd * (z - tau))) 
          lll22 <-   (-ph * (tau + lambd * (z - tau)) ^ gamm * exp(delt * (tau + lambd * (z - tau))) + 2 * delt * (tau + lambd * (z - tau)))
            return(ifelse(z==0, 0, exp(lll21+lll22)))
          }

        #    j=1
        llik2[j] <-  (ph * rme[j] * integrate(ll2, xme[j], 30, rel.tol = 1e-6)$value) / exp(-ph * tplxm[j] ^ gamm * exp(delt * tplxm[j]))   
           }
      logli <- loglik - sum(llik1)- sum(llik2)
      return(logli)
}
    # Estimation under EM Algorithm using optim
    opt_result <- nlminb(c(gamma, delta, phi,lambda), loglik  , lower = 0, upper = Inf)
# Estimation under EM Algorithm using optim
print(opt_result) 

单独测试积分可行的代码

当我用真实参数单独计算这些积分时,能得到正常结果:

# Calculate intermediate values
      gdx1 <- gamma + delta * x1e
      tplxm <- tau + lambda * (xme - tau)
      gdtplxm <- gamma + delta * (tplxm)
      edtplxm <- exp(delta * (tplxm))
      
      # Calculate the log-likelihood
      loglik <- m * log(phi) + (m - n1) * log(lambda) + sum((gamma - 1) * log(x1e) + log(gdx1)) -
        phi * sum(x1e ^ gamma * exp(delta * x1e)) + delta * sum(x1e) +
        sum((gamma - 1) * log(tplxm) + log(gdtplxm)) -
        phi * sum(tplxm ^ gamma * edtplxm) + delta * sum(tplxm)  

            llik1 <- c(); llik2 <- c(); 
      for (j in 1:length(x1e)) {
        
        ll1 <- function(z) {
          
          lll11 <- (2 * gamma - 1)* log(z) +log(gamma + delta * z) 
          lll12 <- (-phi * z^gamma * exp(delta * z) + 2 * delta * z)
          return(ifelse(z==0, 0, exp(lll11+lll12)))
        }
         
        llik1[j] <- (phi * rn1e[j] * integrate(ll1, x1e[j], 3, rel.tol = 1e-6)$value) / exp(-phi * x1e[j] ^ gamma * exp(delta * x1e[j]))
        
      }
      
      for (j in 1:length(xme) ) {  # ; j=12
       
          ll2<- function(z){
             lll21 <-   (2 * gamma - 1)*log(tau + lambda * (z - tau)) + log(gamma + delta * (tau + lambda * (z - tau))) 
            lll22 <-   (-phi * (tau + lambda * (z - tau)) ^ gamma * exp(delta * (tau + lambda * (z - tau))) + 2 * delta * (tau + lambda * (z - tau)))
            return(ifelse(z==0, 0, exp(lll21+lll22)))
          }
        #    j=1
        llik2[j] <-  (phi * rme[j] * integrate(ll2, xme[j], 3, rel.tol = 1e-6)$value) / exp(-phi * tplxm[j] ^ gamma * exp(delta * tplxm[j]))   
           }
     

logli <- loglik - sum(llik1)- sum(llik2)
logli

求帮忙定位问题或提供替代解决方法,感谢!

内容的提问来源于stack exchange,提问作者Qasim Ramzan

相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级,最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分), 限时 9.9 元起

最近更新时间:2026.07.01 17:45:53