- Simulated data from a transect from closed forest into a canopy gap. We plant 10 seeds in each quadrat and then simulate survival of 0.1 in the forest and 0.8 in the canopy gap. We will randomly place the gqp-forest bourndary somewhere near the mid-point of the transect.
aPrime<-a+33; bPrime<-b+100-33
x<-seq(from=0,to=1,len=1000)
postF<-dbeta(x,shape1=aPrime,shape2 = bPrime)
library(MCMCpack)
Loading required package: coda
Loading required package: MASS
##
## Markov Chain Monte Carlo Package (MCMCpack)
## Copyright (C) 2003-2017 Andrew D. Martin, Kevin M. Quinn, and Jong Hee Park
##
## Support provided by the U.S. National Science Foundation
## (Grants SES-0350646 and SES-0350613)
##
- Make a figure similiar to Fig. 6.4: Beta-Binomial conjugagte updating.
You plant 100 acorns. 33 germinate. What is your posterior estimate for the transition probability?
First, a flat prior using the beta distribution:
# Beta Prior
a<-40; b<-20
x<-seq(from=0,to=1,len=1000)
priorF<-dbeta(x,shape1=a,shape2 = b)
par(mfrow=c(3,1),mar=c(3.0,3.5,1.5,1.5)+1)
plot(x,priorF,xlab='P',ylab='Density',type='l')
# Binomial Likelihood
likF<-dbinom(33,size=100,prob = x)
plot(x,likF,xlab='P',ylab='Density',type='l')
# Conjugate Beta Posterior
aPrime<-a+33; bPrime<-b+100-33
x<-seq(from=0,to=1,len=1000)
postF<-dbeta(x,shape1=aPrime,shape2 = bPrime)
plot(x,postF,xlab='P',ylab='Density',type='l')
- Find the posterior distribution using MCMC
Likeilihood function:
likBinom<-function(p,s,n){
lik<-dbinom(s,size=n,prob = p)
# nllik<- -sum(dbinom(s,size=n,prob = parVec,log=TRUE))
# cat("nllik= ",nllik,sep=" ",fill=T);cat(" ",sep=" ",fill=T)
return(lik)
}
Prior function:
priorBeta<-function(p,a,b){
prob<-dbeta(p,shape1=a,shape2 = b)
# nllik<- -sum(dbinom(s,size=n,prob = parVec,log=TRUE))
# cat("nllik= ",nllik,sep=" ",fill=T);cat(" ",sep=" ",fill=T)
return(prob)
}
Proposal distribution:
proDist<-function(currentP,sd){
p<-rnorm(n=1,mean=currentP,sd=sd)
if(p>0 & p<1) return(p)
proDist(currentP,sd)
}
proDist(0.2,0.2)
Metropolis Algorithym
Intialize the chain at some initial value of p
Generate a proposed value of p
Calculate acceptabce probability r
Accept proposed value of p with probability r
Repeat n times
Coding this in R:
nIter<-10000
mySD<-0.2; a<-1;b<-1
p<-vector()
p[1]<-0.5
for(i in 1:nIter){
proposedP<-proDist(p[i],mySD)
r<-min(1, ( likBinom(proposedP,33,100)*priorBeta(proposedP,a,b) ) / ( likBinom(p[i],33,100) *priorBeta(p[i],a,b) ) )
if(runif(1)<r) {
p[i+1]<-proposedP
} else {
p[i+1]<-p[i]
}
}
hist(p[-1])
This is an R Markdown Notebook. When you execute code within the notebook, the results appear beneath the code.
Try executing this chunk by clicking the Run button within the chunk or by placing your cursor inside it and pressing Cmd+Shift+Enter.
plot(cars)
Add a new chunk by clicking the Insert Chunk button on the toolbar or by pressing Cmd+Option+I.
When you save the notebook, an HTML file containing the code and output will be saved alongside it (click the Preview button or press Cmd+Shift+K to preview the HTML file).
LS0tCnRpdGxlOiAiTUNNQyBFeGVyY2lzZSAyOiAiCm91dHB1dDogaHRtbF9ub3RlYm9vawotLS0KCjEuICBTaW11bGF0ZWQgZGF0YSBmcm9tIGEgdHJhbnNlY3QgZnJvbSBjbG9zZWQgZm9yZXN0IGludG8gYSBjYW5vcHkgZ2FwLiAgV2UgcGxhbnQgMTAgc2VlZHMgaW4gZWFjaCBxdWFkcmF0IGFuZCB0aGVuIHNpbXVsYXRlIHN1cnZpdmFsIG9mIDAuMSBpbiB0aGUgZm9yZXN0IGFuZCAwLjggaW4gdGhlIGNhbm9weSBnYXAuICBXZSB3aWxsIHJhbmRvbWx5IHBsYWNlIHRoZSBncXAtZm9yZXN0IGJvdXJuZGFyeSBzb21ld2hlcmUgbmVhciB0aGUgbWlkLXBvaW50IG9mIHRoZSB0cmFuc2VjdC4KCmBgYHtyfQpuUXVhZHM8LTIwCm5Rc3dpdGNoPC0xMwpmb3Jlc3Q8LXJiaW5vbShuPTEzLHNpemU9MTAscHJvYj0wLjEpCmdhcDwtcmJpbm9tKG49NyxzaXplPTEwLHByb2I9MC44KQp0cmFuc2VjdDwtYyhmb3Jlc3QsZ2FwKQpgYGAKCmBgYHtyfQphUHJpbWU8LWErMzM7IGJQcmltZTwtYisxMDAtMzMKeDwtc2VxKGZyb209MCx0bz0xLGxlbj0xMDAwKQpwb3N0RjwtZGJldGEoeCxzaGFwZTE9YVByaW1lLHNoYXBlMiA9IGJQcmltZSkKYGBgCgoKYGBge3J9CmxpYnJhcnkoTUNNQ3BhY2spCgptdWx0VjwtcmVwKDAsMjApCm11bHRWWzEzXTwtMQpkbXVsdGlub20oeD1tdWx0Viwgc2l6ZSA9IDEsIHByb2I9bXVsdFYsIGxvZyA9IEZBTFNFKQpybXVsdGlub20oNSwxLG11bHRWKQpgYGAKCgoxLiBNYWtlIGEgZmlndXJlIHNpbWlsaWFyIHRvIEZpZy4gNi40OiAgQmV0YS1CaW5vbWlhbCBjb25qdWdhZ3RlIHVwZGF0aW5nLgoKWW91IHBsYW50IDEwMCBhY29ybnMuICAzMyBnZXJtaW5hdGUuICBXaGF0IGlzIHlvdXIgcG9zdGVyaW9yIGVzdGltYXRlIGZvciB0aGUgdHJhbnNpdGlvbiBwcm9iYWJpbGl0eT8KCkZpcnN0LCBhIGZsYXQgcHJpb3IgdXNpbmcgdGhlIGJldGEgZGlzdHJpYnV0aW9uOgpgYGB7cn0KIyBCZXRhIFByaW9yCmE8LTQwOyBiPC0yMAp4PC1zZXEoZnJvbT0wLHRvPTEsbGVuPTEwMDApCnByaW9yRjwtZGJldGEoeCxzaGFwZTE9YSxzaGFwZTIgPSBiKQpwYXIobWZyb3c9YygzLDEpLG1hcj1jKDMuMCwzLjUsMS41LDEuNSkrMSkKcGxvdCh4LHByaW9yRix4bGFiPSdQJyx5bGFiPSdEZW5zaXR5Jyx0eXBlPSdsJykKCiMgQmlub21pYWwgTGlrZWxpaG9vZApsaWtGPC1kYmlub20oMzMsc2l6ZT0xMDAscHJvYiA9IHgpCnBsb3QoeCxsaWtGLHhsYWI9J1AnLHlsYWI9J0RlbnNpdHknLHR5cGU9J2wnKQoKIyBDb25qdWdhdGUgQmV0YSBQb3N0ZXJpb3IKYVByaW1lPC1hKzMzOyBiUHJpbWU8LWIrMTAwLTMzCng8LXNlcShmcm9tPTAsdG89MSxsZW49MTAwMCkKcG9zdEY8LWRiZXRhKHgsc2hhcGUxPWFQcmltZSxzaGFwZTIgPSBiUHJpbWUpCnBsb3QoeCxwb3N0Rix4bGFiPSdQJyx5bGFiPSdEZW5zaXR5Jyx0eXBlPSdsJykKYGBgCgoKMi4gIEZpbmQgdGhlIHBvc3RlcmlvciBkaXN0cmlidXRpb24gdXNpbmcgTUNNQwoKTGlrZWlsaWhvb2QgZnVuY3Rpb246CgpgYGB7cn0KbGlrQmlub208LWZ1bmN0aW9uKHAscyxuKXsKICBsaWs8LWRiaW5vbShzLHNpemU9bixwcm9iID0gcCkKICAjIG5sbGlrPC0gLXN1bShkYmlub20ocyxzaXplPW4scHJvYiA9IHBhclZlYyxsb2c9VFJVRSkpCiAgIyBjYXQoIm5sbGlrPSAiLG5sbGlrLHNlcD0iICIsZmlsbD1UKTtjYXQoIiAiLHNlcD0iICIsZmlsbD1UKQogIHJldHVybihsaWspCn0KYGBgCgpQcmlvciBmdW5jdGlvbjoKCmBgYHtyfQpwcmlvckJldGE8LWZ1bmN0aW9uKHAsYSxiKXsKICBwcm9iPC1kYmV0YShwLHNoYXBlMT1hLHNoYXBlMiA9IGIpCiAgIyBubGxpazwtIC1zdW0oZGJpbm9tKHMsc2l6ZT1uLHByb2IgPSBwYXJWZWMsbG9nPVRSVUUpKQogICMgY2F0KCJubGxpaz0gIixubGxpayxzZXA9IiAiLGZpbGw9VCk7Y2F0KCIgIixzZXA9IiAiLGZpbGw9VCkKICByZXR1cm4ocHJvYikKfQpgYGAKClByb3Bvc2FsIGRpc3RyaWJ1dGlvbjoKCmBgYHtyfQpwcm9EaXN0PC1mdW5jdGlvbihjdXJyZW50UCxzZCl7CiAgcDwtcm5vcm0obj0xLG1lYW49Y3VycmVudFAsc2Q9c2QpCiAgaWYocD4wICYgcDwxKSByZXR1cm4ocCkKICBwcm9EaXN0KGN1cnJlbnRQLHNkKQp9CiAgCnByb0Rpc3QoMC4yLDAuMikKYGBgCgpNZXRyb3BvbGlzIEFsZ29yaXRoeW0gCgoxLiBJbnRpYWxpemUgdGhlIGNoYWluIGF0IHNvbWUgaW5pdGlhbCB2YWx1ZSBvZiBwCgoyLiBHZW5lcmF0ZSBhIHByb3Bvc2VkIHZhbHVlIG9mIHAKCjMuIENhbGN1bGF0ZSBhY2NlcHRhYmNlIHByb2JhYmlsaXR5IHIKCjQuIEFjY2VwdCBwcm9wb3NlZCB2YWx1ZSBvZiBwIHdpdGggcHJvYmFiaWxpdHkgcgoKNS4gUmVwZWF0IG4gdGltZXMKCkNvZGluZyB0aGlzIGluIFI6CgpgYGB7cn0Kbkl0ZXI8LTEwMDAwCm15U0Q8LTAuMjsgYTwtMTtiPC0xCnA8LXZlY3RvcigpCnBbMV08LTAuNQpmb3IoaSBpbiAxOm5JdGVyKXsKICBwcm9wb3NlZFA8LXByb0Rpc3QocFtpXSxteVNEKQogIHI8LW1pbigxLCAoIGxpa0Jpbm9tKHByb3Bvc2VkUCwzMywxMDApKnByaW9yQmV0YShwcm9wb3NlZFAsYSxiKSApIC8gKCBsaWtCaW5vbShwW2ldLDMzLDEwMCkgKnByaW9yQmV0YShwW2ldLGEsYikgKSApCiAgaWYocnVuaWYoMSk8cikgewogICAgcFtpKzFdPC1wcm9wb3NlZFAKICB9IGVsc2UgewogICAgcFtpKzFdPC1wW2ldCiAgfSAKfQoKaGlzdChwWy0xXSkKYGBgCgoKCgoKCgoKCgoKCgoKVGhpcyBpcyBhbiBbUiBNYXJrZG93bl0oaHR0cDovL3JtYXJrZG93bi5yc3R1ZGlvLmNvbSkgTm90ZWJvb2suIFdoZW4geW91IGV4ZWN1dGUgY29kZSB3aXRoaW4gdGhlIG5vdGVib29rLCB0aGUgcmVzdWx0cyBhcHBlYXIgYmVuZWF0aCB0aGUgY29kZS4gCgpUcnkgZXhlY3V0aW5nIHRoaXMgY2h1bmsgYnkgY2xpY2tpbmcgdGhlICpSdW4qIGJ1dHRvbiB3aXRoaW4gdGhlIGNodW5rIG9yIGJ5IHBsYWNpbmcgeW91ciBjdXJzb3IgaW5zaWRlIGl0IGFuZCBwcmVzc2luZyAqQ21kK1NoaWZ0K0VudGVyKi4gCgpgYGB7cn0KcGxvdChjYXJzKQpgYGAKCkFkZCBhIG5ldyBjaHVuayBieSBjbGlja2luZyB0aGUgKkluc2VydCBDaHVuayogYnV0dG9uIG9uIHRoZSB0b29sYmFyIG9yIGJ5IHByZXNzaW5nICpDbWQrT3B0aW9uK0kqLgoKV2hlbiB5b3Ugc2F2ZSB0aGUgbm90ZWJvb2ssIGFuIEhUTUwgZmlsZSBjb250YWluaW5nIHRoZSBjb2RlIGFuZCBvdXRwdXQgd2lsbCBiZSBzYXZlZCBhbG9uZ3NpZGUgaXQgKGNsaWNrIHRoZSAqUHJldmlldyogYnV0dG9uIG9yIHByZXNzICpDbWQrU2hpZnQrSyogdG8gcHJldmlldyB0aGUgSFRNTCBmaWxlKS4K