Skip to content

Commit

Permalink
initial commit
Browse files Browse the repository at this point in the history
  • Loading branch information
mattiasvillani committed Nov 24, 2018
0 parents commit 2609718
Show file tree
Hide file tree
Showing 390 changed files with 567,792 additions and 0 deletions.
Binary file added Code/.RData
Binary file not shown.
Empty file added Code/.Rapp.history
Empty file.
512 changes: 512 additions & 0 deletions Code/.Rhistory

Large diffs are not rendered by default.

37 changes: 37 additions & 0 deletions Code/BetaNormalApprox.R
@@ -0,0 +1,37 @@
##########
# Compare Normal approximation of Beta posterior to the true posterior (MathExercise 3)
#
# Author: Per Siden
# Date: 2018-04-11
##########

# 3c
alpha = 1
beta = 1
n = 6
s = 1
f = n-s
normalMean = (alpha + s - 1)/(alpha+beta+n-2)
normalVar = (alpha + s - 1)*(beta + f - 1)/(alpha + beta + n - 2)^3

xgrid = seq(0,1,.001)
plot(xgrid,dbeta(xgrid,alpha+s,beta+f),type="l")
lines(xgrid,dnorm(xgrid,normalMean,sqrt(normalVar)),col=2)
legend("topright", box.lty = 1, legend = c("Beta posterior","Normal approx."),
col = c("black",'red'), lwd = 2)

# 3d
alpha = 1
beta = 1
n = 12
s = 2
f = n-s
normalMean = (alpha + s - 1)/(alpha+beta+n-2)
normalVar = (alpha + s - 1)*(beta + f - 1)/(alpha + beta + n - 2)^3

xgrid = seq(0,1,.001)
plot(xgrid,dbeta(xgrid,alpha+s,beta+f),type="l")
lines(xgrid,dnorm(xgrid,normalMean,sqrt(normalVar)),col=2)
legend("topright", box.lty = 1, legend = c("Beta posterior","Normal approx."),
col = c("black",'red'), lwd = 2)

206 changes: 206 additions & 0 deletions Code/CanadianWages.dat
@@ -0,0 +1,206 @@
logWage age
11.1563 21.0000
12.8131 22.0000
13.0960 22.0000
11.6952 22.0000
11.5327 22.0000
12.7657 22.0000
12.5879 22.0000
11.9829 22.0000
13.4588 22.0000
12.2061 23.0000
12.0436 23.0000
11.9250 23.0000
13.7001 23.0000
12.7939 23.0000
13.3471 23.0000
13.0562 23.0000
12.0668 23.0000
13.2879 23.0000
13.6808 24.0000
12.8992 24.0000
12.2061 24.0000
13.5008 24.0000
13.5924 24.0000
13.6774 24.0000
13.4298 24.0000
13.1993 24.0000
13.0368 24.0000
11.8277 24.0000
13.3535 24.0000
12.5981 24.0000
13.4786 25.0000
13.2534 25.0000
13.4284 25.0000
13.7102 25.0000
13.6635 25.0000
13.5924 25.0000
13.0815 25.0000
13.0836 25.0000
13.3519 25.0000
13.2249 25.0000
13.4313 26.0000
13.3342 26.0000
13.1993 26.0000
13.3847 26.0000
13.3047 26.0000
14.0233 26.0000
13.4800 26.0000
13.8353 27.0000
13.9457 27.0000
13.3661 27.0000
13.5278 27.0000
13.3047 27.0000
13.7102 27.0000
13.7102 27.0000
13.5411 28.0000
13.7212 28.0000
13.5658 28.0000
13.3359 28.0000
13.8869 29.0000
13.9810 29.0000
13.5158 30.0000
13.6292 30.0000
13.3047 30.0000
13.4150 30.0000
13.6797 30.0000
13.8643 31.0000
13.4588 31.0000
13.5899 31.0000
13.7113 31.0000
13.4588 31.0000
13.5411 32.0000
13.3047 32.0000
13.9978 32.0000
13.4603 32.0000
13.8925 32.0000
13.8165 32.0000
13.8738 32.0000
13.8451 33.0000
13.5924 33.0000
13.4488 33.0000
13.9622 33.0000
13.6956 33.0000
13.0170 34.0000
13.9377 34.0000
14.0103 34.0000
13.3047 34.0000
14.1527 35.0000
13.8155 35.0000
13.9553 35.0000
13.9978 35.0000
13.7788 35.0000
13.8304 35.0000
13.7642 36.0000
13.4150 36.0000
13.9810 36.0000
13.9987 36.0000
13.6831 37.0000
13.0836 37.0000
14.1871 37.0000
14.1520 38.0000
13.5949 38.0000
13.4588 38.0000
13.8633 38.0000
14.1193 38.0000
14.0330 38.0000
13.2067 38.0000
13.6624 38.0000
13.8509 39.0000
13.4617 39.0000
14.0012 39.0000
13.5411 39.0000
14.1520 40.0000
13.6292 40.0000
13.7102 40.0000
14.2210 40.0000
13.3407 40.0000
13.8155 40.0000
13.1863 40.0000
13.8822 41.0000
13.8155 41.0000
14.2698 41.0000
12.3194 41.0000
13.9987 41.0000
12.3884 41.0000
13.7451 42.0000
14.1520 42.0000
13.9044 42.0000
13.7589 42.0000
13.7504 42.0000
13.5076 43.0000
13.7201 43.0000
13.4588 44.0000
14.6622 44.0000
12.5062 44.0000
12.9408 44.0000
13.9518 45.0000
13.6268 45.0000
13.8075 45.0000
13.3816 45.0000
13.8165 46.0000
13.9108 46.0000
13.8155 47.0000
13.7621 47.0000
13.7321 47.0000
13.8155 47.0000
13.4660 47.0000
11.4076 47.0000
13.9978 47.0000
14.0585 48.0000
12.8992 48.0000
14.0306 48.0000
13.3064 48.0000
13.2534 48.0000
13.9987 49.0000
13.9404 49.0000
13.9421 50.0000
13.4588 50.0000
13.7012 50.0000
14.1052 50.0000
14.6340 50.0000
13.4800 50.0000
14.4991 50.0000
13.6060 51.0000
13.9492 52.0000
13.7736 52.0000
13.8314 52.0000
14.0779 52.0000
14.2150 52.0000
13.6412 52.0000
11.8056 52.0000
14.2544 53.0000
15.0582 53.0000
13.2067 53.0000
13.6530 53.0000
13.0562 54.0000
13.8614 54.0000
14.2615 54.0000
14.7318 54.0000
13.4603 55.0000
13.6219 55.0000
13.2879 55.0000
13.5144 55.0000
14.4226 55.0000
13.6542 56.0000
13.7963 56.0000
12.2737 57.0000
14.3538 58.0000
13.3692 58.0000
13.3359 58.0000
13.3229 58.0000
12.8992 59.0000
13.9631 59.0000
13.8095 59.0000
14.5087 60.0000
11.5991 60.0000
13.4716 60.0000
13.5278 60.0000
12.5879 61.0000
13.3391 62.0000
12.6947 62.0000
13.9682 63.0000
12.0782 63.0000
14.0916 63.0000
13.7102 64.0000
12.2549 65.0000
43 changes: 43 additions & 0 deletions Code/DirichletSampling.R
@@ -0,0 +1,43 @@
#################################################################################################
################# Example of conjugate prior inference of the multinomial model ################
#################################################################################################

####### Defining a function that simulates from a Dirichlet distribution
SimDirichlet <- function(nIter,param){
nCat <- length(param)
thetaDraws <- matrix(0,nIter,nCat) # Matrix where the posterior draws are stored
for (j in 1:nCat){
thetaDraws[,j] <- rgamma(nIter,param[j],1)
}
for (i in 1:nIter){
thetaDraws[i,] = thetaDraws[i,]/sum(thetaDraws[i,]) # Diving every column of ThetaDraws by the sum of the elements in that column.
}
return(thetaDraws)
}

########### Setting up data and prior #################
y <- c(36,87,77) # Data
alpha <- c(1,1,1) # Dirichlet prior hyperparameters
nIter <- 10000 # Number of posterior draws

########### Posterior sampling from Dirichlet #################
thetaDraws <- SimDirichlet(nIter,y + alpha)

################ Computing Summary statistics from the posterior sample ###################
mean(thetaDraws[,1])
mean(thetaDraws[,2])
mean(thetaDraws[,3])

sqrt(var(thetaDraws[,1]))
sqrt(var(thetaDraws[,2]))
sqrt(var(thetaDraws[,3]))

sum(thetaDraws[,2]>thetaDraws[,3])/nIter # p(theta2>theta3|Data)

# Plots histograms of the posterior draws
plot.new() # Opens a new graphical window
par(mfrow = c(2,2)) # Splits the graphical window in four parts (2-by-2 structure)
hist(thetaDraws[,1],25) # Plots the histogram of theta[,1] in the upper left subgraph
hist(thetaDraws[,2],25)
hist(thetaDraws[,3],25)

26 changes: 26 additions & 0 deletions Code/DirichletSamplingSlides.R
@@ -0,0 +1,26 @@
y <- c(180,230,62,41) # The cell phone survey data (K=4)
alpha <- c(15,15,10,10) # Dirichlet prior hyperparameters
nIter <- 1000 # Number of posterior draws

# Defining a function that simulates from a Dirichlet distribution
SimDirichlet <- function(nIter, param){
nCat <- length(param)
thetaDraws <- as.data.frame(matrix(NA, nIter, nCat)) # Storage.
for (j in 1:nCat){
thetaDraws[,j] <- rgamma(nIter,param[j],1)
}
for (i in 1:nIter){
thetaDraws[i,] = thetaDraws[i,]/sum(thetaDraws[i,])
}
return(thetaDraws)
}
# Posterior sampling from Dirichlet posterior
thetaDraws <- SimDirichlet(nIter,y + alpha)

# Posterior mean and standard deviation of Androids share (in %)
message(mean(100*thetaDraws[,2]))
message(sd(100*thetaDraws[,2]))

# Computing the posterior probability that Android is the largest
PrAndroidLargest <- sum(thetaDraws[,2]>apply(thetaDraws[,c(1,3,4)],1,max))/nIter
message(paste('Pr(Android has the largest market share) = ', PrAndroidLargest))
16 changes: 16 additions & 0 deletions Code/Dump.R
@@ -0,0 +1,16 @@
# Bivariate density estimator
#install.packages("ks") # bivariate kernel density estimates
par(mfrow=c(1,2))
library(ks)
Hpi1 <- Hscv(x = directDraws)
fEst <- kde(x = directDraws, H=Hpi1)
plot(fEst)
evalPoints <- t(rbind(fEst$eval.points[[1]],fEst$eval.points[[1]])) # Finding the points where the density estimate was evaluated in the plot

# Trick to compute the true density
bivariate <- function(x,y){
return (dmvnorm(c(x,y), mean = mu, sigma = Sigma))
}
trueDensity <- outer(evalPoints[,1],evalPoints[,2],bivariate)
contour(evalPoints[,1], evalPoints[,2], trueDensity, theta = 55, phi = 30, r = 40, d = 0.1, expand = 0.5,
ltheta = 90, lphi = 180, shade = 0.4, ticktype = "detailed", nticks=5)
20 changes: 20 additions & 0 deletions Code/EightSchools.stan
@@ -0,0 +1,20 @@
# Eight schools example in Rstan Vignette (https://cran.r-project.org/web/packages/rstan/vignettes/rstan.html)

data {
int<lower=0> J; // number of schools
real y[J]; // estimated treatment effects
real<lower=0> sigma[J]; // s.e. of effect estimates
}
parameters {
real mu;
real<lower=0> tau;
vector[J] eta;
}
transformed parameters {
vector[J] theta;
theta = mu + tau * eta;
}
model {
target += normal_lpdf(eta | 0, 1);
target += normal_lpdf(y | theta, sigma);
}

0 comments on commit 2609718

Please sign in to comment.