用于双S形曲线的Metropolis Hastings算法

Question

我正在尝试开发一种大都市hastings算法，该算法有助于估计双S形模型的参数，其形式如下：

y = a0/(1+exp(-a1*(x-b0))) + a2/(1+exp(-a3*(x-b1)))

我已经成功地为简单和多元线性回归模型编写了这些算法，但是在这种情况下我遇到了收敛问题。我有建议使用Wishart Prior作为协方差矩阵，但我不确定我是否正确实现它。我使用[https://theoreticalecology.wordpress.com/2010/09/17/metropolis-hastings-mcmc-in-r/]的设置作为动机。代码如下：

library(MCMCpack)
library(mvtnorm)
set.seed(1)

truea0 <- 67
truea1 <- 0.3
truea2 <- 100
truea3 <- 0.2
trueb0 <- 35
trueb1 <- 80

truesd <- 5

x <- c(28, 36, 42, 50, 58, 63, 71, 79, 85, 92, 99, 106, 112)
n <- length(x)
y <- truea0/(1+exp(-truea1*(x-trueb0))) + truea2/(1+exp(-truea3*(x-trueb1))) + rnorm(n, mean = 0, sd = trueSd) 

likelihood = function(param){
  a0 <- param[1]
  a1 <- param[2]
  a2 <- param[3]
  a3 <- param[4]
  b0 <- param[5]
  b1 <- param[6]
  sd <- param[7]

  pred = a0/(1+exp(-a1*(x-b0))) + a2/(1+exp(-a3*(x-b1)))
  singlelikelihoods = dnorm(y, mean = pred, sd = sd, log = T)
  sumll = sum(singlelikelihoods)
  return(sumll)
}

prior = function(){
  meanmat <- c(66,0.3,100,0.2,35,80)
  sdcol <- c(2,0.02,2,0.02,2,2)
  sigmamat <- sdcol*diag(1,6,6)
  paramprior <- rmvnorm(1,mean = meanmat, sigma = sigmamat)

  sdprior = rgamma(1,shape = 1, rate = 1)
  sigmaprior = rwish(7, diag(1,6,6))

  scalematrix <- c(1,1,1,1,1,1)*diag(1,6,6)
  prior <- dmvnorm(paramprior, sigma = sigmaprior, log = T) +
       dgamma(sdprior,shape = 1, rate = 1,log = T)
  return(prior)
}

proposalfunction = function(param){
  return(rnorm(7,mean = param, sd= c(0.5,0.05,0.5,0.05,0.5,0.5,0.5)))
}

posterior <- function(param){
  return (likelihood(param) + prior())
}

run_metropolis_MCMC = function(startvalue, iterations){
  chain = array(dim = c(iterations+1,7))
  chain[1,] = startvalue
  for (i in 1:iterations){
    proposal = proposalfunction(chain[i,])

    probab = exp(posterior(proposal) - posterior(chain[i,]))
    if (runif(1) < probab){
      chain[i+1,] = proposal
    }else{
      chain[i+1,] = chain[i,]
    }
  }
  return(chain)
}

startvalue = c(70,0.4,105,0.3,40,70,5)
chain = run_metropolis_MCMC(startvalue, 100000)

burnIn = 10000
acceptance = 1-mean(duplicated(chain[-(1:burnIn),]))

非常感谢任何帮助。