R语言中实现马尔可夫链蒙特卡罗MCMC模型

什么是MCMC，什么时候使用它？

MCMC只是一个从分布抽样的算法。

这只是众多算法之一。这个术语代表“马尔可夫链蒙特卡洛”，因为它是一种使用“马尔可夫链”（我们将在后面讨论）的“蒙特卡罗”（即随机）方法。MCMC只是蒙特卡洛方法的一种，尽管可以将许多其他常用方法看作是MCMC的简单特例。

正如上面的段落所示，这个话题有一个引导问题，我们会慢慢解决。

我为什么要从分配中抽样？

你可能没有意识到你想（实际上，你可能并不想）。但是，从分布中抽取样本是解决一些问题的最简单的方法。

可能MCMC最常用的方法是从贝叶斯推理中的某个模型的后验概率分布中抽取样本。通过这些样本，你可以问一些问题：“参数的平均值和可信度是多少？”。

如果这些样本是来自分布的独立样本，则 估计均值将会收敛在真实均值上。

假设我们的目标分布是一个具有均值m和标准差的正态分布s。显然，这种分布的意思是m，但我们试图通过从分布中抽取样本来展示。

作为一个例子，考虑用均值m和标准偏差s来估计正态分布的均值（在这里，我将使用对应于标准正态分布的参数）：

我们可以很容易地使用这个rnorm 函数从这个分布中抽样

1 2seasamples<-rn 000,m,s)

样本的平均值非常接近真实平均值（零）：

1mean(sa es)

1## [1] -0. 537

事实上，在这种情况下，$ n $样本估计的预期方差是$ 1 / n $，所以我们预计大部分值在$ \ pm 2 \，/ \ sqrt {n} = 0.02 $ 10000分的真实意思。

1summary(re 0,mean(rnorm(10000,m,s))))

1 2##    Min.  1st Qu.  Median    Mean  3rd Qu.    Max. ## -0.03250 -0.00580  0.00046  0.00042  0.00673  0.03550

这个函数计算累积平均值（即元素$ k $，元素$ 1,2，\ ldots，k $除以$ k $）之和。

1 2cummean<-fun msum(x)/seq_along(x)

 1 2plot(cummaaSample",ylab="Cumulative mean",panel.aabline(h=0,col="red"),las=1)

将x轴转换为对数坐标并显示另外30个随机方法：

a6set.seed(1)ploamean",panel.first=abline(h=0,col="red"),las=1,log="x")for(iinsea(1),.5))

 可以从您的一系列采样点中抽取样本分位数。

这是分析计算的点，其概率密度的2.5％低于：

1 2 3p<-0.025a.true<-qnorm(p,m,s)a.true

1## [1] -1.96

我们可以通过在这种情况下的直接整合来估计这个（使用上面的论点）

aion(x)dnorm(x,m,s)g<-function(a)integrate(f,-Inf,a)$valuea.int<-uniroot(function(x)g(a10,0))$roota.int

1## [1] -1.96

并用Monte Carlo积分估计点：

1 2a.mc<-unnasamples,p))a.mc

1## [1] -2.023

1a.true-a.mc

1## [1] 0.06329

但是，在样本量趋于无穷大的极限内，这将会收敛。此外，有可能就错误的性质作出陈述; 如果我们重复采样过程100次，那么我们得到一系列与均值附近的误差相同幅度的误差的估计：

1 2a.mc<-replicate(anorm(10000,m,s),p))summary(a.true-a.mc)

1 2##    Min.  1st Qu.  Median    Mean  3rd Qu.    Max. ## -0.05840 -0.01640 -0.00572 -0.00024  0.01400  0.07880

这种事情真的很常见。在大多数贝叶斯推理中，后验分布是一些（可能很大的）参数向量的函数，您想对这些参数的子集进行推理。在一个等级模型中，你可能会有大量的随机效应项被拟合，但是你最想对一个参数做出推论。在贝叶斯框架中，您可以计算您感兴趣的参数在所有其他参数上的边际分布（这是我们上面要做的）。 

为了说明这个问题，

考虑在边长为$ 2r $的方格内半径为$ r $的圆; 空间的“有趣”区域是一个随机选择的点位于圆圈内的一个很好的机会。

对于半径为$ 2r $ 的立方体中半径为$ r $ 的球体，球体的体积为$ 4 /（3 \ pi r ^ 3）$，立方体的体积为$（2d）^ 3 $ ，所以音量的$ 4/3 \ pi / 8 \ approx 52 \％$是“有趣的”

作为问题的维数，$ d $增加（使用超立方体中的超球面）

1 2 3 4d<-2:10plot(d,pi^(d/2)/(d*2^(d-1)*gamma(d/2)),logahere")

所以我们不需要增加很多维度来主要对潜在空间的一小部分感兴趣。 

1 2 3 4 a<-function(d,n)mean(repa00))

1 2 3 4 5 6 7 8 9 10 11##    dimension p.interesting## 1          1        0.5219## 2          2        0.2173## 3          3        0.0739## 4          4        0.0218## 5          5        0.0070## 6          6        0.0025## 7          7        0.0006## 8          8        0.0000## 9          9        0.0000## 10        10        0.0000

 即使只看4-5个维度，如果我们试图对参数空间进行彻底整合 

为什么“正常统计”不使用蒙特卡洛方法？

对于传统教学统计中的许多问题，而不是从分布中抽样，可以使函数最大化或最大化。所以我们需要一些函数来描述可能性并使其最大化（最大似然推理），或者一些计算平方和并使其最小化的函数。

然而，蒙特卡罗方法在贝叶斯统计中的作用与频率统计中的优化程序相同，这只是执行推理的算法。所以，一旦你基本知道MCMC正在做什么，你可以像大多数人把他们的优化程序当作黑匣子一样对待它，像一个黑匣子。

马尔可夫链蒙特卡罗

 假设我们想要抽取一些目标分布，但是我们不能像从前那样抽取独立样本。有一个使用马尔科夫链蒙特卡洛（MCMC）来做这个的解决方案。首先，我们必须定义一些事情，以便下一句话是有道理的：我们要做的是试图构造一个马尔科夫链，它的难以抽样的目标分布作为它的平稳分布。

定义

让$ X_t $表示在时间$ t $时的一些随机变量的值。马尔可夫链从某个点$ X_0 $开始，生成一系列样本$ [X0，X1，X2，\ ldots，Xt] $，然后遵循一系列随机步骤。

马尔可夫链满足马尔科夫性质。马尔可夫属性是“拉斯维加斯在拉斯维加斯发生了什么”的随机过程版本; 基本上无论你如何得到某个状态$ x $，转换出$ x $的概率都不变 

那么$ \ vec \ pi ^ $是这个马尔可夫链的平稳分布。直觉上，把它看作是系统将要设置的最终状态特征集; 运行足够长的时间以致系统已经“忘记”了它的初始状态，那么这个向量的$ i $ th元素就是系统处于$ i $状态的概率。

这里有一个快速的定义，使事情更加具体（但要注意，这与MCMC本身无关 - 这只是考虑马尔可夫链！）。假设我们有一个三态马尔科夫过程。让我们P为链中的转移概率矩阵：

1 2 3 4P<-rbind(a(.2,.1,.7),c(.25,.25,.5))P

1 2 3 4##      [,1] [,2] [,3]## [1,] 0.50 0.25 0.25## [2,] 0.20 0.10 0.70## [3,] 0.25 0.25 0.50

1rowSums(P)

1## [1] 1 1 1

 条目P[i,j]给出了从状态i到状态的概率j（所以这是上面提到的$ P（i \到j）$。

请注意，与行不同，列不一定总和为1：

1colSums(P)

1## [1] 0.95 0.60 1.45

这个函数采用一个状态向量x（其中x[i]是处于状态的概率i），并通过将其与转移矩阵相乘来迭代它P，使系统前进到n步骤。

1 2 3 4 5 6 7iterate.P<-function(x,P,n){res<-matrix(NA,n+1,lena<-xfor(iinseq_len(n))res[i+1,]<-x<-x%*%P    res}

从处于状态1的系统开始（x向量$ [1,0,0] $也是如此，表示处于状态1的概率为100％，并且不处于任何其他状态） 

同样，对于另外两种可能的起始状态：

1 2y2<-iterate.P(c(0,1,0),P,n)y3<-iterate.P(c(0,0,1),P,n)

这表明了平稳分布的收敛性。

1 2 3ma=1,xlab="Step",ylab="y",las=1)matlines(0:n,y2,lty=2)matlines(0:n,y3,lty=3)

我们可以使用R的eigen函数来提取系统的主要特征向量（t()这里转置矩阵以便得到左特征向量）。

1 2v<-eigen(t(P)ars[,1]v<-v/sum(v)# normalise eigenvector

然后在之前的数字上加上一点，表明我们有多接近收敛：

 4matplot(0:n,y1a3,lty=3)points(rep(10,3),v,col=1:3)

上面的过程迭代了不同状态的总体概率; 而不是通过系统的实际转换。所以，让我们迭代系统，而不是概率向量。 

1 2 3 4 5 6run<-function(i,P,n){res<-integer(n)for(a(n))res[[t]]<-i<-sample(nrow(P),1,pr=P[i,])    res}

这链条运行了100个步骤：

1 2samples<-run(1,P,100)ploaes,type="s",xlab="Step",ylab="State",las=1)

绘制我们在每个状态随时间变化的时间分数，而不是绘制状态：

1 2 3 4plot(cummean(samplesa2)lines(cummean(samples==3),col=3)

再运行一下（5000步）

1 2 3 4 5 6 7 8n<-5000set.seed(1)samples<-run(1,P,n)plot(cummeanasamples==2),col=2)lines(cummean(samples==3),col=3)abline(h=v,lty=2,col=1:3)

所以这里的关键是：马尔可夫链是整洁和理解的东西，有一些不错的属性。马尔可夫链有固定的分布，如果我们运行它们足够长的时间，我们可以看看链条在哪里花费时间，并对该平稳分布进行合理的估计。

Metropolis算法

这是最简单的MCMC算法。本节不打算展示如何设计高效的MCMC采样器，而只是为了看到他们确实在工作。 

算法进行如下。

从$ x_t $开始。

建议一个新的状态$ x ^ \ prime $

计算“接受概率”

从$ [0,1] $中抽取一些均匀分布的随机数$ u $; 如果$ u <\ alpha $接受该点，则设置$ x {t + 1} = x ^ \ prime $。否则拒绝它并设置$ x {t + 1} = x_t $。

请注意，在上面的步骤3中，未知归一化常数因为而退出

这将产生一系列样本$ {x 0，x 1，\ ldots} $。请注意，如果建议的样本被拒绝，相同的值将出现在连续的样本中。

还要注意，这些不是来自目标分布的独立样本; 他们是依赖样本 ; 也就是说，示例$ x_t $取决于$ x_ {t-1} $等等。然而，由于链条接***稳分布，只要我们抽取足够的点数，这种依赖性就不会有问题。

MCMC采样1d（单参数）问题

这是一个目标分配样本。这是两个正态分布的加权和。这种分布相当简单，可以从MCMC中抽取样本。 

相当随意的，这里是一些参数和目标密度的定义。

1 2 3 4 5 6p<-0.4ma1,2)sd<-c(.5,2)f<-function(x)p*dnora],sd[1])+(1-p)*dnorm(x,mu[2],sd[2])

 概率密度绘制 

1cuared",-4,8,n=301,las=1)

我们来定义一个非常简单的提议算法，该算法从以当前点为中心的标准偏差为4的正态分布中抽样

1q<-functiam(1,x,4)

这实现了核心算法，如上所述：

1 2 3 4 5 6 7 8 9 10 11step<-function(x,face arunif(1)

而这只需要运行MCMC的几个步骤。它将从点x返回一个矩阵，其nsteps行数和列数与x元素的列数相同。如果在标量上运行， x它将返回一个向量。

1 2 3 4 5 6run<-funagth(x))for(iinseq_len(nsteps))res[i,]<-x<-step(x,f,q)drop(res)}

我们选择一个地方开始（如何-10，只是选择一个非常糟糕的一点）

1res<-run(-10,f,q,1000)

这里是马尔可夫链的前1000步，目标密度在右边：

1 2 3 4 5 6layout(matrix(ca,type="s",xpd=NA,ylab="Parameter",xlab="Sample",las=1)usr<-par("usr")xx<-seq(usr[a4],length=301)plot(f(xx),xx,type="l",yaxs="i",axes=FALSE,xlab="")

即使只有一千个（非独立的）样本，我们也开始相当类似于目标分布。

 4hist(res,5aALSE,main="",ylim=c(0,.4),las=1,xlab="x",ylab="Probability density")z<-integrate(f,-Inf,Inf)$valuecurve(f(x)/z,add=TRUE,col="red",n=200)

运行更长时间，事情开始看起来更好：

1  aeed(1)res.long<-run(-10,f,q,50000)hist(res.long,100,freq=FALSE,main="",ylim=c(0,.4),las=1,xlab="x",ylabaadd=TRUE,col="red",n=200)

现在，运行不同的提案机制 - 一个标准差很大（33个单位），另一个标准差很小（3个单位）。

1 2res.fast<-run(-10action(x)rnorm(1,x,33),1000)res.slow<-run(-10,f,functanorm(1,x,.3),1000)

这里是与上面相同的情节 - 注意三条轨迹正在移动的不同方式。

1 2 3 4 5 6 7layout(max(c(1,2),1,2),widths=c(4,1))par(mar=c(4.1,.5,.5,.5),oma=c(0,4.1,0,0))plot(reafast,colaFALSE)

相反，红色的痕迹（大的提案）正在提示可能性空间中的可怕空间，并拒绝其中的大部分空间。这意味着它往往会一次空间留下来。

蓝色的踪迹提出了倾向于被接受的小动作，但是它随着大部分的轨迹随机行走。它需要数百次迭代才能达到概率密度的大部分。

您可以在随后的参数中看到不同提议步骤在自相关中的效果 - 这些图显示了不同延迟步骤之间自相关系数的衰减，蓝线表示统计独立性。

  4par(mfrow=c(1,3ain="Intermediate")acf(res.fast,las=1,main="Large steps")

由此可以计算独立样本的有效数量：

1coda::effectiveSize(res)

1 2## var1 ##  187

1coda::effectiveSize(res.fast)

1 2##  var1 ## 33.19

1coda::effectiveSize(res.slow)

1 2##  var1 ## 5.378

这更清楚地显示了链条运行时间更长的情况：

1 2 3 4 5 6 7naun(-10,f,q,n))xlim<-range(sapply(saa100)hh<-lapply(samples,function(x)hist(x,br,plot=FALSE))ylim<-c(0,max(f(xx)))

显示100,1,000,10,000和100,000步：

1 2 3 4 5 6par(mfrow=c(2,2),mar=rep(.5,4),oma=c(4,4,0,0))for(hinhh){plot(h,main="",freq=a=300)}

MCMC在两个维度

 给出了一个多元正态密度，给定一个均值向量（分布的中心）和方差 - 协方差矩阵。

1 2 3 4 5 6 7 8 9 10make.mvn<-function(mean,vcv){logdet<-as.numeric(detea+logdetvcv.i<-solve(vcv)function(x){dx<-x-meanexp(-(tmp+rowSums((dx%*%vcv.i)*dx))/2)}}

如上所述，将目标密度定义为两个mvns的总和（这次未加权）：

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16mu1<-c(-1,1)mu2<-c(2,-2)vcv1<-ma5,.25,1.5),2,2)vcv2<-matrix(c(2,-.5,-.5,2aunctioax)+f2(x)x<-seq(-5,6,length=71)y<-seq(-7,6,lena-expand.grid(x=x,y=y)z<-matrix(aaTRUE)

从多元正态分布取样也相当简单，但我们将使用MCMC从中抽取样本。

这里有一些不同的策略 - 我们可以同时在两个维度上提出动作，或者我们可以独立地沿着每个轴进行采样。这两种策略都能奏效，虽然它们的混合速度会有所不同。

假设我们实际上并不知道如何从mvn中抽样 ，让我们提出一个在两个维度上一致的提案分布，从每边的宽度为“d”的正方形取样。

1 2 3 4 5 6 7 8 9 1ation(x,d=8)x+runif(length(x),-d/2,d/2)x0<-c(-4,-4)set.seed(1)samples<-run(x0,f,q,az,xlim=range(x,samples[,1]),ylim=range(x,samples[,2]))caz,add=TRUE)lines(samples[,1],samples[,2],col="#00000088")

1 2set.seed(1)saax0,f,q,100000)

比较抽样分布与已知分布：

1 2smoothScatales)contour(x,y,z,add=TRUE)

 例如，参数1 的边际分布是多少？

1 2hisales[,1],freq=FALSa",xlab="x",ylab="Probability density")

 我们需要整合第一个参数的第二个参数的所有可能值。那么，因为目标函数本身并不是标准化的，所以我们必须将其分解为第一维积分值 。

1 2 3 4 5 6 7 8 9 10 11 12m<-function(x1){g<-Vectorize(function(x2)f(c(x1,ae(g,-Inf,Inf)$value}xx<-seq(mina]),max(sales[,1]),length=201)yy<-sapply(xx,m)z<-integrate(splinefun(xx,yy),min(xx),max(xx))$valuehist(samples[,1],freq=FALSE,ma,0.25))lines(xx,yy/z,col="red")