Skip to content

Icar and other code #1

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
Andrew9Lawson wants to merge 6 commits into
base: master
Choose a base branch
from
Open

Icar and other code #1

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
ad8d34f
Add files via upload
Andrew9Lawson Aug 13, 2019
a75a6bf
Add files via upload
Andrew9Lawson Aug 13, 2019
d36d032
Add files via upload
Andrew9Lawson Aug 13, 2019
b0a4626
Update README.md
Andrew9Lawson Aug 13, 2019
14d1ed1
Delete Gamma_Poisson_toy_data_Nimble.txt
Andrew9Lawson Oct 1, 2019
ea43d11
Delete Gamma_Poisson_Nimble_new.txt
Andrew9Lawson Oct 1, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
162 changes: 162 additions & 0 deletions BYM2_SC_scaling.txt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,162 @@

###SCcongen90 is dataframe including the vectors obs,expe,pov,inc######
#######################################################################
SCcongen90<-list(obs=c(0,7,1,5,1,1,5,16,0,17,4,0,0,1,1,7,1,3,0,0,8,2,13,7,0,8,0,3,2,4,1,11,0,1,2,3,3,8,6,14,3,11,6,0,1,5),
expe=c(1.0807,6.3775,0.622,6.6854,0.9142,1.0744,5.6518,8.1682,0.5749,18.0989,2.174,1.6619,1.9321,1.6148,
1.6713,3.0819,1.7562,4.9952,0.9362,1.2001,6.1293,2.5604,15.8589,2.9437,1.0399,7.276,0.9739,2.064,2.7206,2.8275,0.9425,
8.828,0.3644,1.775,1.5111,1.5111,2.5321,4.5836,3.9647,15.0264,0.732,10.8292,5.9848,1.4357,1.9949,6.9807),
pov=c(13.6,13.8,32.3,11,24.2,19.9,12.3,13.3,17,15.4,14.1,15.7,18,24.3,21.8,20.2,24.9,12,17.4,18.1,18.7,17.5,
10.6,13.8,22.8,13.7,21,12.6,14,14,26.9,9.4,17.8,23.1,23.1,14.4,10.8,22.1,10.1,13.6,15.9,11.2,18.3,14,26.4,10.6),
inc=c(36.786,38.534,20.727,37.205,24.3,27.607,45.822,40.161,32.247,38.458,33.232,31.715,29.505,25.896,28.919,
30.776,25.552,42.886,34.297,29.96,34.009,35.008,41.658,34.109,27.65,34.654,27.117,39.04,33.698,32.32,25.144,
45.14,29.805,25.008,25.993,32.231,36.912,28.624,37.054,39.587,31.324,37.092,31.948,30.801,23.748,44.619))
########################################################################
SCcon<-data.frame(SCcongen90)
#graphics....using SC_poly
library(INLA)
setwd("C:/A_NEW_FOLDER/A_NEW_FOLDER/A_PROGRAMS/GITHUB repository")
#SC_poly.txt is the graph file
g=inla.read.graph("SC_poly.txt")
Q=-inla.graph2matrix(g)
diag(Q) = 0
diag(Q) = -rowSums(Q)
n=dim(Q)[1] # n=46
Q.scaled=inla.scale.model(Q,constr=list(A=matrix(1,1,n),e=0))
scale=Q.scaled[1,1]/Q[1,1]
# scale of SC graph is 0.3783966
### BYM2 model code in Nimble
library(nimble)
BYM2<-nimbleCode({
for(i in 1: n){
obs[i]~dpois(mu[i])
log(mu[i])<-log(expe[i])+log(theta[i])
theta[i]<-exp(ac0+bym2[i])
vc[i]~dnorm(0,1)
Corr[i]<-sigma*uc[i]*sqrt(rho/scale)
UCorr[i]<-sigma*vc[i]*sqrt((1-rho))
bym2[i]<-Corr[i]+UCorr[i]
}
for (k in 1 :nsumN){wei[k]<-1}
uc[1:n]~dcar_normal(adj[1:nsumN],wei[1:nsumN],num[1:n],1,zero_mean=1)
sigma~dunif(0,10)
tau<-pow(sigma,-2)
rho~dbeta(1,1)
ac0~dnorm(0,tau0)
tau0<-pow(sd0,-2)
sd0~dunif(0,10)
})
nsumN=228
LSTdata<-list(obs=c(0,7,1,5,1,1,5,16,0,17,4,0,0,1,1,7,1,3,0,0,8,2,13,7,0,8,0,3,2,4,1,11,0,1,2,3,3,8,6,14,3,11,6,0,1,5))
LSTconsts<-list(n,scale,nsumN,expe=c(1.0807,6.3775,0.622,6.6854,0.9142,1.0744,5.6518,8.1682,0.5749,18.0989,2.174,1.6619,1.9321,1.6148,
1.6713,3.0819,1.7562,4.9952,0.9362,1.2001,6.1293,2.5604,15.8589,2.9437,1.0399,7.276,0.9739,2.064,2.7206,2.8275,0.9425,
8.828,0.3644,1.775,1.5111,1.5111,2.5321,4.5836,3.9647,15.0264,0.732,10.8292,5.9848,1.4357,1.9949,6.9807),
pov=c(13.6,13.8,32.3,11,24.2,19.9,12.3,13.3,17,15.4,14.1,15.7,18,24.3,21.8,20.2,24.9,12,17.4,18.1,18.7,17.5,
10.6,13.8,22.8,13.7,21,12.6,14,14,26.9,9.4,17.8,23.1,23.1,14.4,10.8,22.1,10.1,13.6,15.9,11.2,18.3,14,26.4,10.6),
inc=c(36.786,38.534,20.727,37.205,24.3,27.607,45.822,40.161,32.247,38.458,33.232,31.715,29.505,25.896,28.919,
30.776,25.552,42.886,34.297,29.96,34.009,35.008,41.658,34.109,27.65,34.654,27.117,39.04,33.698,32.32,25.144,
45.14,29.805,25.008,25.993,32.231,36.912,28.624,37.054,39.587,31.324,37.092,31.948,30.801,23.748,44.619),
num = c(5, 5, 4, 5, 5, 4, 3, 6, 5, 4, 3, 4, 5, 6, 7, 5, 4, 4, 4, 6,
8,5, 5, 6, 5, 3, 2, 7, 5, 7, 5, 6, 3, 5, 4, 7, 2, 9, 3, 6,5, 4, 6, 7, 5, 4),
adj = c(
33, 30, 24, 23, 4,
41, 38, 32, 19, 6,
25, 15, 6, 5,
39, 37, 30, 23, 1,
38, 25, 15, 6, 3,
38, 5, 3, 2,
27, 25, 15,
45, 38, 22, 18, 14, 10,
43, 40, 38, 32, 14,
22, 18, 15, 8,
46, 44, 42,
46, 44, 29, 20,
35, 31, 29, 28, 16,
45, 43, 38, 21, 9, 8,
38, 25, 18, 10, 7, 5, 3,
35, 31, 28, 21, 13,
35, 34, 26, 21,
38, 15, 10, 8,
41, 33, 24, 2,
44, 40, 36, 29, 28, 12,
45, 43, 35, 34, 31, 17, 16, 14,
45, 34, 26, 10, 8,
42, 39, 30, 4, 1,
41, 36, 33, 30, 19, 1,
27, 15, 7, 5, 3,
34, 22, 17,
25, 7,
43, 40, 31, 29, 20, 16, 13,
46, 28, 20, 13, 12,
44, 42, 36, 24, 23, 4, 1,
43, 28, 21, 16, 13,
41, 40, 38, 36, 9, 2,
24, 19, 1,
45, 26, 22, 21, 17,
21, 17, 16, 13,
44, 41, 40, 32, 30, 24, 20,
39, 4,
32, 18, 15, 14, 9, 8, 6, 5, 2,
37, 23, 4,
43, 36, 32, 28, 20, 9,
36, 32, 24, 19, 2,
44, 30, 23, 11,
40, 31, 28, 21, 14, 9,
46, 42, 36, 30, 20, 12, 11,
34, 22, 21, 14, 8,
44, 29, 12, 11))
LSTinits<-list(vc=c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
uc=c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0),sigma=0.1,rho=0.5,ac0=0.1,sd0=0.1)
names(LSTconsts)<-c("n","scale","nsumN","expe","pov","inc","num","adj")
LBYM2<-nimbleModel(code=BYM2,name="BYM2",constants=LSTconsts,
data=LSTdata,inits=LSTinits)
###################################################################
CLBYM2<-compileNimble(LBYM2)
#####################################################################
LBYM2Conf<-configureMCMC(LBYM2,print=TRUE)
LBYM2Conf$addMonitors(c("ac0","sigma","rho","vc","uc","Corr","UCorr","theta"))
LBYM2MCMC<-buildMCMC(LBYM2Conf)
CLBYM2MCMC<-compileNimble(LBYM2MCMC,project=LBYM2)
niter<-10000
set.seed(1)
samples<-runMCMC(CLBYM2MCMC,niter=niter,nburnin=7000,nchains=1,summary=TRUE,samplesAsCodaMCMC=TRUE)
samples$summary
names(samples$summary)
MCorr<-samples$summary[1:46,1]
MUCorr<-samples$summary[47:92,1]
Mac0<-samples$summary[93,1]
Mrho<-samples$summary[94,1]
Msd<-samples$summary[95,1]
Msigma<-samples$summary[96,1]
Mtheta<-samples$summary[97:142,1]
Muc<-samples$summary[143:188,1]
Mvc<-samples$summary[189:234,1]
hist(Muc);x11();hist(Mvc);x11();hist(Mtheta);x11()


###############################################
SCcon<-data.frame(MCorr,MUCorr,Muc,Mvc,Mtheta)
#SCcon is dataframe with vectors eg SCcon<-data.frame(......Muc,Mvc,Mtheta)
library(tmap)
areaID<-as.character(seq(1:46))
area<-paste(c("area"),areaID,sep="")
attr<-data.frame(SCcon,row.names=area)
library(maptools)
polySC<-readSplus("SC_SPLus_export_map.txt")
spg<-SpatialPolygonsDataFrame(polySC, attr, match.ID = TRUE)
#### this qtm call produces common legend #############################################
labels<-c("Uc","Vc","Theta")
qtm(spg,fill=c("Muc","Mvc","Mtheta"),fill.palette="Blues",ncol=3,free.scales=FALSE)
### use tm_layout with legend.outside=TRUE and separate titles ###########################
qtm(spg,fill=c("Muc","Mvc","Mtheta"),fill.palette="Blues",ncol=3)+tm_layout(legend.outside=TRUE,title="",panel.labels=labels)
### separate legends
qtm(spg,fill=c("Muc","Mvc","Mtheta"),fill.palette="Blues",ncol=3)+tm_layout(legend.position=c("LEFT","BOTTOM"),main.title="BYM2 results",panel.labels=labels)
#############################################################
####### mapping the UCorr and Corr components
labels<-c("Ucorr","Corr","Theta")
qtm(spg,fill=c("MUCorr","MCorr","Mtheta"),fill.palette="Blues",ncol=3)+tm_layout(legend.position=c("LEFT","BOTTOM"),main.title="BYM2 UCorr, Corr",panel.labels=labels)
######################################################
mcmc.out<-nimbleMCMC(code=BYM2,constants=LSTconsts,
data=LSTdata,inits=LSTinits,nchains=2,nburnin=7000,niter=10000,summary=TRUE,WAIC=TRUE)
149 changes: 149 additions & 0 deletions BYM_ordinary_SC_NOscaling.txt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,149 @@

###SCcongen90 is dataframe including the vectors obs,expe,pov,inc######
#######################################################################
SCcongen90<-list(obs=c(0,7,1,5,1,1,5,16,0,17,4,0,0,1,1,7,1,3,0,0,8,2,13,7,0,8,0,3,2,4,1,11,0,1,2,3,3,8,6,14,3,11,6,0,1,5),
expe=c(1.0807,6.3775,0.622,6.6854,0.9142,1.0744,5.6518,8.1682,0.5749,18.0989,2.174,1.6619,1.9321,1.6148,
1.6713,3.0819,1.7562,4.9952,0.9362,1.2001,6.1293,2.5604,15.8589,2.9437,1.0399,7.276,0.9739,2.064,2.7206,2.8275,0.9425,
8.828,0.3644,1.775,1.5111,1.5111,2.5321,4.5836,3.9647,15.0264,0.732,10.8292,5.9848,1.4357,1.9949,6.9807),
pov=c(13.6,13.8,32.3,11,24.2,19.9,12.3,13.3,17,15.4,14.1,15.7,18,24.3,21.8,20.2,24.9,12,17.4,18.1,18.7,17.5,
10.6,13.8,22.8,13.7,21,12.6,14,14,26.9,9.4,17.8,23.1,23.1,14.4,10.8,22.1,10.1,13.6,15.9,11.2,18.3,14,26.4,10.6),
inc=c(36.786,38.534,20.727,37.205,24.3,27.607,45.822,40.161,32.247,38.458,33.232,31.715,29.505,25.896,28.919,
30.776,25.552,42.886,34.297,29.96,34.009,35.008,41.658,34.109,27.65,34.654,27.117,39.04,33.698,32.32,25.144,
45.14,29.805,25.008,25.993,32.231,36.912,28.624,37.054,39.587,31.324,37.092,31.948,30.801,23.748,44.619))
########################################################################
SCcon<-data.frame(SCcongen90)
#graphics....using SC_poly
library(INLA)
setwd("C:/A_NEW_FOLDER/A_NEW_FOLDER/A_PROGRAMS/GITHUB repository")
#SC_poly.txt is the graph file


### BYM model code in Nimble
library(nimble)
BYM<-nimbleCode({
for(i in 1: n){
obs[i]~dpois(mu[i])
log(mu[i])<-log(expe[i])+log(theta[i])
theta[i]<-exp(ac0+bym[i])
vc[i]~dnorm(0,tauV)
bym[i]<-vc[i]+uc[i]
}
for (k in 1 :nsumN){wei[k]<-1}
uc[1:n]~dcar_normal(adj[1:nsumN],wei[1:nsumN],num[1:n],tauU,zero_mean=1)
tauU<-pow(sdU,-2)
tauV<-pow(sdV,-2)
sdV~dunif(0,10)
sdU~dunif(0,10)
ac0~dnorm(0,tau0)
sd0~dunif(0,10)
})
nsumN=228
LSTdata<-list(obs=c(0,7,1,5,1,1,5,16,0,17,4,0,0,1,1,7,1,3,0,0,8,2,13,7,0,8,0,3,2,4,1,11,0,1,2,3,3,8,6,14,3,11,6,0,1,5))
LSTconsts<-list(n,nsumN,expe=c(1.0807,6.3775,0.622,6.6854,0.9142,1.0744,5.6518,8.1682,0.5749,18.0989,2.174,1.6619,1.9321,1.6148,
1.6713,3.0819,1.7562,4.9952,0.9362,1.2001,6.1293,2.5604,15.8589,2.9437,1.0399,7.276,0.9739,2.064,2.7206,2.8275,0.9425,
8.828,0.3644,1.775,1.5111,1.5111,2.5321,4.5836,3.9647,15.0264,0.732,10.8292,5.9848,1.4357,1.9949,6.9807),
pov=c(13.6,13.8,32.3,11,24.2,19.9,12.3,13.3,17,15.4,14.1,15.7,18,24.3,21.8,20.2,24.9,12,17.4,18.1,18.7,17.5,
10.6,13.8,22.8,13.7,21,12.6,14,14,26.9,9.4,17.8,23.1,23.1,14.4,10.8,22.1,10.1,13.6,15.9,11.2,18.3,14,26.4,10.6),
inc=c(36.786,38.534,20.727,37.205,24.3,27.607,45.822,40.161,32.247,38.458,33.232,31.715,29.505,25.896,28.919,
30.776,25.552,42.886,34.297,29.96,34.009,35.008,41.658,34.109,27.65,34.654,27.117,39.04,33.698,32.32,25.144,
45.14,29.805,25.008,25.993,32.231,36.912,28.624,37.054,39.587,31.324,37.092,31.948,30.801,23.748,44.619),
num = c(5, 5, 4, 5, 5, 4, 3, 6, 5, 4, 3, 4, 5, 6, 7, 5, 4, 4, 4, 6,
8,5, 5, 6, 5, 3, 2, 7, 5, 7, 5, 6, 3, 5, 4, 7, 2, 9, 3, 6,5, 4, 6, 7, 5, 4),
adj = c(
33, 30, 24, 23, 4,
41, 38, 32, 19, 6,
25, 15, 6, 5,
39, 37, 30, 23, 1,
38, 25, 15, 6, 3,
38, 5, 3, 2,
27, 25, 15,
45, 38, 22, 18, 14, 10,
43, 40, 38, 32, 14,
22, 18, 15, 8,
46, 44, 42,
46, 44, 29, 20,
35, 31, 29, 28, 16,
45, 43, 38, 21, 9, 8,
38, 25, 18, 10, 7, 5, 3,
35, 31, 28, 21, 13,
35, 34, 26, 21,
38, 15, 10, 8,
41, 33, 24, 2,
44, 40, 36, 29, 28, 12,
45, 43, 35, 34, 31, 17, 16, 14,
45, 34, 26, 10, 8,
42, 39, 30, 4, 1,
41, 36, 33, 30, 19, 1,
27, 15, 7, 5, 3,
34, 22, 17,
25, 7,
43, 40, 31, 29, 20, 16, 13,
46, 28, 20, 13, 12,
44, 42, 36, 24, 23, 4, 1,
43, 28, 21, 16, 13,
41, 40, 38, 36, 9, 2,
24, 19, 1,
45, 26, 22, 21, 17,
21, 17, 16, 13,
44, 41, 40, 32, 30, 24, 20,
39, 4,
32, 18, 15, 14, 9, 8, 6, 5, 2,
37, 23, 4,
43, 36, 32, 28, 20, 9,
36, 32, 24, 19, 2,
44, 30, 23, 11,
40, 31, 28, 21, 14, 9,
46, 42, 36, 30, 20, 12, 11,
34, 22, 21, 14, 8,
44, 29, 12, 11))
LSTinits<-list(vc=c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
uc=c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0),ac0=0.1,sd0=0.1,sdV=0.1,sdU=0.1)
names(LSTconsts)<-c("n","nsumN","expe","pov","inc","num","adj")
LBYM<-nimbleModel(code=BYM,name="BYM",constants=LSTconsts,
data=LSTdata,inits=LSTinits)
###################################################################
CLBYM<-compileNimble(LBYM)
#####################################################################
LBYMConf<-configureMCMC(LBYM,print=TRUE)
LBYMConf$addMonitors(c("ac0","vc","uc","theta"))
LBYMMCMC<-buildMCMC(LBYMConf)
CLBYMMCMC<-compileNimble(LBYMMCMC,project=LBYM)
niter<-10000
set.seed(1)
samples<-runMCMC(CLBYMMCMC,niter=niter,nburnin=7000,nchains=1,summary=TRUE,samplesAsCodaMCMC=TRUE)
samples$summary

Mac0<-samples$summary[1,1]
Msd0<-samples$summary[2,1]
MsdU<-samples$summary[3,1]
MsdV<-samples$summary[4,1]
Mtheta<-samples$summary[5:50,1]
Muc<-samples$summary[51:96,1]
Mvc<-samples$summary[97:142,1]
hist(Muc);x11();hist(Mvc);x11();hist(Mtheta);x11()


###############################################
SCcon<-data.frame(Muc,Mvc,Mtheta)
#SCcon is dataframe with vectors eg SCcon<-data.frame(......Muc,Mvc,Mtheta)
library(tmap)
areaID<-as.character(seq(1:46))
area<-paste(c("area"),areaID,sep="")
attr<-data.frame(SCcon,row.names=area)
library(maptools)
polySC<-readSplus("SC_SPLus_export_map.txt")
spg<-SpatialPolygonsDataFrame(polySC, attr, match.ID = TRUE)
#### this qtm call produces common legend #############################################
labels<-c("Uc","Vc","Theta")
qtm(spg,fill=c("Muc","Mvc","Mtheta"),fill.palette="Blues",ncol=3,free.scales=FALSE)
### use tm_layout with legend.outside=TRUE and separate titles ###########################
qtm(spg,fill=c("Muc","Mvc","Mtheta"),fill.palette="Blues",ncol=3)+tm_layout(legend.outside=TRUE,title="",panel.labels=labels)
### separate legends ##############################################
qtm(spg,fill=c("Muc","Mvc","Mtheta"),fill.palette="Blues",ncol=3)+tm_layout(legend.position=c("LEFT","BOTTOM"),main.title="BYM results",panel.labels=labels)
#############################################################

mcmc.out<-nimbleMCMC(code=BYM,constants=LSTconsts,
data=LSTdata,inits=LSTinits,nchains=2,nburnin=7000,niter=10000,summary=TRUE,WAIC=TRUE)
Loading