low=0.01
up=0.99
# Indikatoren, ob AuxMix oder IndMH
#indA=as.numeric(Ni<=N0)                     # AuxMix
indA=as.numeric((yi/Ni)<=low|(yi/Ni)>=up)
indApos=which(indA==1)
indAcount=length(indApos)
indAsr2=numeric(t)
XindA=X*indA
#indS=as.numeric(Ni>N0)                      # MH
indS=as.numeric((yi/Ni)>low&(yi/Ni)<up)
indSpos=which(indS==1)
indScount=length(indSpos)
XindS=X*indS
# --------------------------------------------------------------------------------------------------
# Approximation of the type III generalized logistic distribution by Gaussian mixtures
# Computes mixture parameters, given degrees of freedom
# Mixture Parameters for degrees of freedom <=60
A=as.matrix(read.csv(file="NV_Approximation/genlogdist.csv",header=F,sep=";",dec="."))
coeff_v=as.matrix(read.csv(file="NV_Approximation/coeff_v.csv",header=F,sep=";",dec="."))
K=A[,1]             # degrees of freedom
NC=A[,2]            # number of components
# Function polyval
polyval=function(a,x) sum(a*x^((length(a)-1):0))
# Function for rational approximation
ratval=function(p,x){
m=which(p==1)
a=p[1:m]
b=p[(m+1):length(p)]
y=polyval(a,x)/polyval(b,x)
return(y)
}
# Function computing parameters
compmix=function(k){
if(k<1) print('Argument must be at least 1')    # error
if(k>=1 & k<=60){                               # look up table
nc=NC[k]
mixcomp=data.frame(probs=A[k,3:(3+nc-1)],var=A[k,8:(8+nc-1)])
}
if(k>60 & k<=500){                              # rational approximation to the parameters
nc=2
v=numeric(2)
p=numeric(2)
for(i in 1:nc){
v[i]=ratval(coeff_v[,i],k)
}
p[2]=(1-v[1])/(v[2]-v[1])
p[1]=1-p[2]
mixcomp=data.frame(probs=p,var=v)
}
if(k>500){                                      # approximation by standard normal distribution
nc=1
mixcomp=data.frame(probs=1,var=1)
}
# Compute non-standardized components
mixcomp$var=mixcomp$var*2*psigamma(k,1)
# Return data.frame
return(mixcomp)
}
# Matrix with probs and vars                            # überflüssig...?
mixture=cbind(matrix(0,nrow=t,ncol=5),matrix(1,nrow=t,ncol=5))
for(i in which(indA==1)){
mixture[i,1:length(compmix(Ni[i])$probs)]=compmix(Ni[i])$probs
mixture[i,6:(6+length(compmix(Ni[i])$probs)-1)]=compmix(Ni[i])$var
}
mixture=matrix(mixture[indApos,],nrow=indAcount)
# --------------------------------------------------------------------------------------------------
# ML-Schätzung des Logit Modells (gruppierte Daten)
ml=summary(glm(yi/Ni~X-1,family=binomial(link="logit"),data=as.data.frame(data),weights=Ni))
ml$coeff
# Parameter der a priori Vtlg. für Beta
b0=rep(0,dim)
B0=diag(10,nrow=dim,ncol=dim)
B0inv=solve(B0)
B0invb0=B0inv%*%b0
# Teilberechnung des Parameters BN der posteriori
tX=t(X)
trigam=2*trigamma(Ni)
trigamS=indS/trigam
BSinv=B0inv+tX%*%(X*trigamS)
BS=solve(BSinv)
# Teilberechnung des Parameters bN der posteriori
partsum=t(XindS)/trigam          # korr.: partsum=t(XindS)/(2*trigam)
# Teilberechnung Akzeptanzrate
NiX=Ni*X
NiXS=Ni*XindS
negtwoNis=-2*Ni*indS
negtwoNi=-2*Ni[indSpos]
trigamSpos=trigam[indSpos]
# Speicher für die gezogenen Betas und aggregierten Utilities
beta=matrix(NA,dim,sim)
yiStar=matrix(NA,t,sim)
# Grenzen für die Grafik der Ziehungen
minbeta=numeric(sim)
maxbeta=numeric(sim)
# Zähler für die Akzeptanzrate
count=numeric(sim)
alpha=numeric(sim)
# Parameter der Komponenten der Normal Mixture Density
H=5                             # Max. Anzahl der Komponenten der Finite Mixture Approximation
probs=mixture[,1:5]
vars=mixture[,6:10]
vecvars=as.vector(t(vars))
st=H*(0:(indAcount-1))
sd=sqrt(vars)
logpr=log(probs)
logsd=log(sd)
pos=numeric(indAcount)
sr2=numeric(indAcount)
# Vorbereitungen für effizientere Ziehung der Scaling Factors
trickmat=outer(seq_len(H),seq_len(H),"<=")         # erzeugt obere Dreiecksmatrix mit TRUEs
vertfkt=matrix(0,nrow=indAcount,ncol=H)                    # Matrix für die Verteilungsfunktionen
pre=probs/sd           # korr.: pre=probs/vars
twovar=-2*vars
# Startwerte
# aus der Stichprobe geschätzte WSK für die Kategorien
pidach=pmin(pmax(yi/Ni,0.05),0.95)
# Startwerte für lambda (=exp(X*beta))
lam0=pidach/(1-pidach)
# Startwerte für lambda (=exp(X*beta))             ?????
#cut=5/100
#lam0=pmin(pmax(yi/Ni,cut),1-cut)
# Indikatoren zur Berechnung von yi*
indi1=as.numeric(yi>0)
indi2=as.numeric(yi<Ni)
# Startwerte für yi*
U=rgamma(t,shape=Ni,rate=1+lam0)
V=rgamma(t,shape=yi,rate=1)
W=rgamma(t,shape=Ni-yi,rate=lam0)
yiStar0=-log((U+indi2*W)/(U+indi1*V))
# Startwerte für die Regressionsparameter
beta0=rep(0,dim)
#beta0=as.numeric(ml$coeff)          # ML-Schätzung als Startwerte
reg=summary(lm(yiStar0~X-1))
#beta0=as.numeric(reg$coeff[,1])          # OLS-Schätzung auf utilities
#beta0=c(0.03,1.8,1.3,-3.2,-0.04,-1.4,2.7,-2.2,0.7,-0.1)
#Pr=pre*exp(rep.int((yiStar0[indApos]-log(lam0[indApos]))^2,H)/twovar)
#vertfkt=Pr%*%trickmat
#pos=rowSums(vertfkt[,H]*runif(indAcount) > vertfkt)+1
#sr2=vecvars[st+pos]
#indAsr2[indApos]=1/sr2
#sum1=matrix(tX[,indApos],nrow=dim)%*%matrix(X[indApos,]/sr2,ncol=dim)
#BN=solve(BSinv+sum1)
#tC=t(chol(BN))
#XtYstar=X*yiStar0
#sum2=colSums(XtYstar*(trigamS+indAsr2))
#mN=B0invb0+sum2
#bN=BN%*%mN
#beta0=as.vector(bN+tC%*%rnorm(dim,0,1))
beta0
# Übergeben der Startwerte
beta_old=beta_new=beta0
lam_new=lam0
yiStar_new=yiStar0
# Definition der Funktionen für den HAM-Sampler
# Funktion zur Berechnung der yi* (aggregierte Utilities)
yStar = function(lam_new){
U=rgamma(t,shape=Ni,rate=1+lam_new)
V=rgamma(t,shape=yi,rate=1)
W=rgamma(t,shape=Ni-yi,rate=lam_new)
-log((U+indi2*W)/(U+indi1*V))
}
# B: Funktion zur Berechnung der logarithmierten Akzeptanzwahrscheinlichkeit
logprob=function(beta_new,beta_old,XtYstar){
mS=B0invb0+colSums(XtYstar*trigamS)
bS=BS%*%mS
dbeta=beta_new-beta_old
tdbeta=t(dbeta)
sumbeta=beta_new+beta_old
(sum(NiXS%*%dbeta)
+sum(negtwoNis*log(1+exp(-yiStar_new+X%*%beta_new)))
-sum(negtwoNis*log(1+exp(-yiStar_new+X%*%beta_old)))
-1/2*tdbeta%*%B0inv%*%(sumbeta-2*b0)
+1/2*tdbeta%*%BSinv%*%(sumbeta-2*bS))
}
#system.time(for(i in 1:10000){exp(logprob(beta_new,beta_old,XtYstar))})
# C: Funktion zur Berechnung der logarithmierten Akzeptanzwahrscheinlichkeit (schnellere Version als B, wenn indScount klein)
#logprob=function(beta_new,beta_old,XtYstar){
#            mS=B0invb0+colSums(XtYstar*trigamS)    # schneller als:  colSums(XtYstar[indSpos,]/trigamSpos)
#            bS=BS%*%mS
#            (sum(NiX[indSpos,]%*%(beta_new-beta_old))
#            +sum(negtwoNi*log(1+exp(-yiStar_new[indSpos]+X[indSpos,]%*%beta_new)))
#            -sum(negtwoNi*log(1+exp(-yiStar_new[indSpos]+X[indSpos,]%*%beta_old)))
#            -1/2*t(beta_new-beta_old)%*%B0inv%*%(beta_new+beta_old-2*b0)
#            +1/2*t(beta_new-beta_old)%*%BSinv%*%(beta_new+beta_old-2*bS))
#        }
# Durchlauf des Auxiliary Mixture Sampling
stop1=proc.time()[3]
for(s in 1:sim){
if(s==(burn+1)){stop2=proc.time()[3]}
# Step 1 - Scaling Factors für AuxMix
# Matrix mit den nicht normierten Wahrscheinlichkeiten
Pr=pre*exp(rep.int((yiStar_new[indApos]-log(lam_new[indApos]))^2,H)/twovar)
# nicht normierte Verteilungsfunktionen
vertfkt=Pr%*%trickmat
# Inversionsmethode
pos=rowSums(vertfkt[,H]*runif(indAcount) > vertfkt)+1
sr2=vecvars[st+pos]                  # aktuelle Scaling Factors
indAsr2[indApos]=1/sr2
# Step 2 - Betas
sum1=matrix(tX[,indApos],nrow=dim)%*%matrix(X[indApos,]/sr2,ncol=dim)
BN=solve(BSinv+sum1)
tC=t(chol(BN))
XtYstar=X*yiStar_new
sum2=colSums(XtYstar*(trigamS+indAsr2))
mN=B0invb0+sum2
bN=BN%*%mN
beta_new=as.vector(bN+tC%*%rnorm(dim,0,1))
#beta_new=as.vector(mvrnorm(1,bN,BN))
if(indScount>0){
u=runif(1,0,1)
prob=exp(logprob(beta_new,beta_old,XtYstar))
alpha[s]=prob                              # runden usw. außerhalb der Schleife
if(u<prob){                                # ersetzt: if(u<min(1,prob))
count[s]=1
} else {
count[s]=0
beta_new=beta_old
}}
# Step 3 - Utilities
lam_new=exp(X%*%beta_new)
yiStar_new=yStar(lam_new)
# Abspeichern der neuen Samples
minbeta[s]=min(beta_new)
maxbeta[s]=max(beta_new)
beta[,s]=beta_new
beta_old=beta_new
#yiStar[,s]=yiStar_new
# Zwischenreports
if(identical(all.equal(s%%s_out,0), TRUE) || is.element(s,c(1:5,10,20,50,100,200,500))){
cat("sim =", s, "; duration of iter proc so far:",
round( diff <- proc.time()[3] - start, 2 ), "sec.,  exp time to end:", round( (diff/(s-1)*sim - diff)/60, 2 ), " min. \n")
flush.console()
}
}
finish=proc.time()[3] #Sys.time()
dauer=finish-start
dauer_oBI=finish-stop2
dauer
dauer_oBI
cat("Total time:", dauer%/%3600, "hours", (dauer%%3600)%/%60, "min \n")
# Plot der Modellparameter-Posterioris und Berechnung der posteriori Schätzer
windows()
par(mfrow=c(2,dim/2))
invisible(sapply(1:dim,function(x) plot(density(beta[x,(burn+1):sim]),xlab=paste(c("beta",x+1)), main="beta")))
median_beta=as.matrix(sapply(1:dim,function(x) median(beta[x,(burn+1):sim])))
mw_beta=as.matrix(sapply(1:dim,function(x) mean(beta[x,(burn+1):sim])))
var_beta=as.matrix(sapply(1:dim,function(x) var(beta[x,(burn+1):sim])))
median_beta
mw_beta
var_beta
# Plot der Autokorrelationen
windows()
par(mfrow=c(2,dim/2))
for(i in 1:dim){
acf(beta[i,(burn+1):sim])
}
# Plot der beta (inkl. Burn-In)
windows()
par(mfrow=c(2,dim/2))
invisible(sapply(1:dim,function(x) plot(1:sim,beta[x,],ylim=c(min(minbeta),max(maxbeta)),type="l",pch=20,col="red")))
# Plot Burn-In
windows()
par(mfrow=c(2,dim/2))
invisible(sapply(1:dim,function(x) plot(1:burn,beta[x,][1:burn],pch=20,col="red",type="l")))
# Plot ohne Burn-In
windows()
par(mfrow=c(2,dim/2))
invisible(sapply(1:dim,function(x) plot((burn+1):sim,beta[x,][(burn+1):sim],pch=20,col="red",type="l")))
# Akzeptanzrate (ohne Burn-In)
rate1=round(sum(count[(burn+1):sim])/(sim-burn)*100,2); rate1
alpha=round(pmin(1,alpha)*100,2)
rate2=round(mean(alpha[(burn+1):sim]),2); rate2
# Effizienzkriterien
# Autokorrelationsmatrix (je Koeffizient eine Zeile)
ac_matrix=ac_matrix1=matrix(NA,dim,lag+1)
for(d in 1:dim){
ac_matrix[d,]=as.numeric(acf(beta[d,(1+burn):sim], plot=FALSE,lag.max=lag, type="correlation")$acf)
}
# Version A=Helga, Version B=Rossi
version='A'
# Ineff. factors, ESS, ESR
efficiency()
save.image(file = "C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/Diss/Paper 1/Revision/R Outputs/PaperRev_Gramacy_Ham.RData")
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/dRUMAuxMix.R')
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/dRUMIndMH.R')
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/dRUMHAM.R')
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/IndivdRUMIndMH.R')
# new package
package.skeleton()
# Unterprogramme laden
#source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/compmix.R')
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/dRUMAuxMix.R')
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/dRUMIndMH.R')
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/dRUMHAM.R')
source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/IndivdRUMIndMH.R')
#source('C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/Package binomlogit/efficiency.R')
# new package
package.skeleton(name="binomlogit",path="C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/")
# new package
package.skeleton(name="binomlogit",path="C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R")
package.skeleton(name="binomlogit",path="C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R",force=TRUE)
?lm
?reglogit
install.packages("reglogit")
install.packages("bayesm")
install.packages("bayesMCClust")
load("C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/binomlogit/data/caesarean.rda")
View(data)
View(data)
View(data)
View(data)
load("C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/binomlogit/data/caesarean_aux.rda")
View(data)
load("C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/binomlogit/data/caesarean_binary.rda")
View(data)
load("C:/Dokumente und Einstellungen/AK110836/Eigene Dateien/R/binomlogit/data/caesarean_aux.rda")
View(data)
library("binomlogit")
help(package=binomlogit)
## Auxiliary mixture sampling in the aggregated dRUM representation of a binomial logit model
## load caesarean birth data
data(caesarean)
yi <- as.numeric(caesarean[,1])
Ni <- as.numeric(caesarean[,2])
X <- as.matrix(caesarean[,-(1:2)])
data(caesarean)
ls()
data
getwd()
setwd("R")
ls()
list.files()
setwd("binomlogit/")
setwd("data")
list.files()
caesarean = data
save(caesarean, file = "caesarean.rda")
rm(data, caesarean)
load("caesarean_aux.rda")
data
caesarean_aux = data
save(caesarean_aux, file = "caesarean_aux.rda")
rm(data, caesarean_aux)
list.files()
load("caesarean_binary.rda")
caesarean_binary = data
save(caesarean_binary, file = "caesarean_binary.rda")
rm(data, caesarean_binary)
load("simul.rda")
simul = data
save(simul, file = "simul.rda")
rm(data, simul)
load("simul_binary.rda")
simul_binary = data
save(simul_binary, file = "simul_binary.rda")
detac(package:binomlogit)
detach(package:binomlogit)
library("binomlogit")
example(dRUMAuxMix)
?dRUMAuxMix
dRUMAuxMix
?dRUMAuxMix
?ls
?dRUMIndMH
coda:::mcmc.plot
coda:::plot.mcmc
oldpar <- NULL
on.exit(par(oldpar))
coda:::set.mfrow
## Auxiliary mixture sampling in the aggregated dRUM representation of a binomial logit model
## load caesarean birth data
data(caesarean)
yi <- as.numeric(caesarean[,1])
Ni <- as.numeric(caesarean[,2])
X <- as.matrix(caesarean[,-(1:2)])
## start auxiliary mixture sampler
aux1=dRUMAuxMix(yi,Ni,X)
plot(aux1)
?dRUMIndMH
## load simulated data set
data(simul_binary)
y <- as.numeric(simul_binary[,1])
X <- as.matrix(simul_binary[,-1])
## use a small acc>0 (e.g. acc=50), otherwise the sampler gets stuck at the starting values
indivMH2 <- IndivdRUMIndMH(y,X,acc=50)
plot(indivMH2)
plot.binomlogit <- function(x, auto.layout = TRUE, ...){     #ask = dev.interactive(),
oldpar=NULL
on.exit(par(oldpar))
if(auto.layout){
if(x$dims<4){
mfrow=c(2,x$dims)
} else {
mfrow=c(2,4)
}
mai=c(0.5,0.5,0.2,0.2)             # c(bottom, left, top, right)
oldpar=par(mfrow=mfrow,mai=mai)
}
for(i in 1:x$dims){
plot((x$burn+1):x$sim,x$beta[i,][(x$burn+1):x$sim],pch=20,col="red",type="l",main=paste("Draws beta",i-1,sep=" "),xlab="",ylab="")
acf(x$beta[i,(x$burn+1):x$sim],xlab="",ylab="")
}
#if(i==1) oldpar=c(oldpar,par(ask=ask))
}
plot.binomlogit(indivMH2)
plot.binomlogit <- function(x, auto.layout = TRUE, ask = dev.interactive(), ...){     #
oldpar=NULL
on.exit(par(oldpar))
if(auto.layout){
if(x$dims<4){
mfrow=c(2,x$dims)
} else {
mfrow=c(2,4)
}
mai=c(0.5,0.5,0.2,0.2)             # c(bottom, left, top, right)
oldpar=par(mfrow=mfrow,mai=mai)
}
for(i in 1:x$dims){
plot((x$burn+1):x$sim,x$beta[i,][(x$burn+1):x$sim],pch=20,col="red",type="l",main=paste("Draws beta",i-1,sep=" "),xlab="",ylab="")
acf(x$beta[i,(x$burn+1):x$sim],xlab="",ylab="")
}
if(i==1) oldpar=c(oldpar,par(ask=ask))
}
plot.binomlogit(indivMH2)
plot.binomlogit(indivMH2)
plot.binomlogit <- function(x, auto.layout = TRUE, ask = dev.interactive(), ...){     #
oldpar=NULL
on.exit(par(oldpar))
if(auto.layout){
if(x$dims<4){
mfrow=c(2,x$dims)
} else {
mfrow=c(2,4)
}
mai=c(0.5,0.5,0.2,0.2)             # c(bottom, left, top, right)
oldpar=par(mfrow=mfrow,mai=mai)
}
for(i in 1:x$dims){
plot((x$burn+1):x$sim,x$beta[i,][(x$burn+1):x$sim],pch=20,col="red",type="l",main=paste("Draws beta",i-1,sep=" "),xlab="",ylab="")
}
for(i in 1:x$dims){
acf(x$beta[i,(x$burn+1):x$sim],xlab="",ylab="")
}
if(i==1) oldpar=c(oldpar,par(ask=ask))
}
plot.binomlogit(indivMH2)
plot.binomlogit <- function(x, auto.layout = TRUE, ask = dev.interactive(), ...){     #
oldpar=NULL
on.exit(par(oldpar))
if(auto.layout){
if(x$dims<4){
mfrow=c(2,x$dims)
} else {
mfrow=c(2,4)
}
mai=c(0.5,0.5,0.2,0.2)             # c(bottom, left, top, right)
oldpar=par(mfrow=mfrow,mai=mai)
}
for(i in 1:x$dims){
plot((x$burn+1):x$sim,x$beta[i,][(x$burn+1):x$sim],pch=20,col="red",type="l",main=paste("Draws beta",i-1,sep=" "),xlab="",ylab="")
acf(x$beta[i,(x$burn+1):x$sim],xlab="",ylab="")
}
if(i==1) oldpar=c(oldpar,par(ask=ask))
}
plot.binomlogit(indivMH2)
plot.binomlogit(indivMH2)
plot.binomlogit <- function(x, auto.layout = TRUE, ask = dev.interactive(), ...){     #
oldpar=NULL
on.exit(par(oldpar))
if(auto.layout){
if(x$dims<4){
mfcol=c(2,x$dims)
#mfrow=c(2,x$dims)
} else {
mfcol=c(2,4)
#mfrow=c(2,4)
}
mai=c(0.5,0.5,0.2,0.2)             # c(bottom, left, top, right)
oldpar=par(mfcol=mfcol,mai=mai)
}
for(i in 1:x$dims){
plot((x$burn+1):x$sim,x$beta[i,][(x$burn+1):x$sim],pch=20,col="red",type="l",main=paste("Draws beta",i-1,sep=" "),xlab="",ylab="")
acf(x$beta[i,(x$burn+1):x$sim],xlab="",ylab="")
}
if(i==1) oldpar=c(oldpar,par(ask=ask))
}
plot.binomlogit(indivMH2)
plot.binomlogit <- function(x, auto.layout = TRUE, ask = dev.interactive(), ...){
oldpar=NULL
on.exit(par(oldpar))
if(auto.layout){
if(x$dims<4){
mfcol=c(2,x$dims)
} else {
mfcol=c(2,4)
}
mai=c(0.5,0.5,0.2,0.2)             # c(bottom, left, top, right)
oldpar=par(mfcol=mfcol,mai=mai)
}
for(i in 1:x$dims){
plot((x$burn+1):x$sim,x$beta[i,][(x$burn+1):x$sim],pch=20,col="red",type="l",main=paste("Draws beta",i-1,sep=" "),xlab="",ylab="")
acf(x$beta[i,(x$burn+1):x$sim],xlab="",ylab="")
if(i==1) oldpar=c(oldpar,par(ask=ask))
}
}
plot.binomlogit(indivMH2)
View(caesarean)
data(caesarean_aux)
View(caesarean_aux)
data(caesarean_binary)
View(caesarean_binary)
