7/solutions7.r (e587552) - SS2012-StatisticalMethods.git

solutions7.r

#Problem 1
library(Hmisc)
#definition of a straight line function
linrel=function(x,m,b) m*x+b
#sigvar = 0.4
sigvar = 1
#definition x-Vctor
x_vec=seq(-1,3,0.1)

#definition y-vector
y_vec=linrel(x_vec,1,0)
#plotting x-vector vs. y-vector
plot(x_vec, y_vec, type="l", col="black", xlab='x',ylab='f(x)=y')

#generating mock data point for 0 <= x <= 2 for 10 equaly spaced points
equ_points=10
mock_vec = rep(NA,10)
x_vec_2 =seq(0,2, 2/(equ_points-1))
mock_vec = rnorm({1:10},mean = x_vec_2, sd =  sigvar)
points(x_vec_2,mock_vec, col="red", type="p")

##Problem2
conrel =function(b) b
quarel =function(x,a,m,b) a*x**2 + m*x+b

reso = 50  #the resolution
a_vec = seq(-4,4,length.out = reso)
m_vec = seq(-4,8,length.out = reso)
b_vec = seq(-2,2,length.out = reso)

# Define function chi2_quad
chi2_qua = function(a,m,b) sum((mock_vec - quarel(mock_vec,a,m,b))**2/(sigvar)**2)
chi2_lin = function(m,b) sum((mock_vec - linrel(mock_vec,m,b))**2/(sigvar)**2)
chi2_con = function(b) sum((mock_vec - conrel(b))**2/(sigvar)**2)

# Calculate 3-dim grid for values a=-4..4, m=-4..8, b-2..2
qua_arr = array(NA, dim=c(length(b_vec),length(m_vec),length(a_vec)))
lin_arr = array(NA, dim=c(length(b_vec),length(m_vec)))
con_arr = array(NA, dim=c(length(b_vec)))
for (i in (1:length(b_vec))){
    con_arr[i] = chi2_con(b_vec[i])
	for (j in (1:length(m_vec))){
        lin_arr[i,j] = chi2_lin(m_vec[j],b_vec[i])
		for (k in (1:length(a_vec))){
			qua_arr[i,j,k] = chi2_qua(a_vec[k],m_vec[j],b_vec[i])
		}
	}
}
#find min
minimum_qua=min(qua_arr)
best_m_qua = m_vec[which(qua_arr == minimum_qua,arr.ind=TRUE)[2]]
best_b_qua = b_vec[which(qua_arr == minimum_qua,arr.ind=TRUE)[1]]
best_a_qua = a_vec[which(qua_arr == minimum_qua,arr.ind=TRUE)[3]]
points(x_vec, quarel(x_vec,best_a_qua,best_m_qua,best_b_qua), type="l", col="red", xlab='x',ylab='f(x)=y')

minimum_lin=min(lin_arr)
best_m_lin = m_vec[which(lin_arr == minimum_lin,arr.ind=TRUE)[2]]
best_b_lin = b_vec[which(lin_arr == minimum_lin,arr.ind=TRUE)[1]]
points(x_vec, linrel(x_vec,best_m_lin,best_b_lin), type="l", col="blue", xlab='x',ylab='f(x)=y')
minimum_con=min(con_arr)
best_b_con = b_vec[which(con_arr == minimum_con,arr.ind=TRUE)[1]]
points(x_vec, rep(conrel(best_b_con),41), type="l", col="yellow", xlab='x',ylab='f(x)=y')

#Probelm3
norm = function(a) 1/sum(a) * a

posterior_qua =  exp(-0.5 *(norm(qua_arr) - norm(qua_arr)[which(qua_arr == minimum_qua,arr.ind=TRUE)]))
posterior_lin =  exp(-0.5 *(norm(lin_arr) - norm(lin_arr)[which(lin_arr == minimum_lin,arr.ind=TRUE)]))
posterior_con =  exp(-0.5 *(norm(con_arr) - norm(con_arr)[which(con_arr == minimum_con,arr.ind=TRUE)]))

#integration numerically function
int = function(x_vec, y_vec){
	A=0
	step=(max(x_vec)-min(x_vec))/(length(x_vec))
	for (i in y_vec){
		A=A+step*i
		}
	return(A)
}

dim_m = length(m_vec)
dim_a = length(a_vec)
dim_b = length(b_vec)

err_qua_m = 0
err_qua_a = 0
err_qua_b = 0 
err_lin_b = 0
err_lin_m = 0
err_con_b = 0

#Marginalization of posterior_quad over a and m
int_qua_a=array(0, c(dim_m, dim_b))
for (i in (1:dim_m)){
	for (j in (1:dim_b)){
		I=int(a_vec, (posterior_qua)[j,i,])
		int_qua_a[i,j]=I
	}
}

int_qua_am=array(0, c(dim_b))
for (i in (1:dim_b)){
		I=int(m_vec, (int_qua_a)[,i])
		int_qua_am[i]=I
}
#Marginalization of posterior_quad over b and m
int_qua_b=array(0, c(dim_m, dim_a))
for (i in (1:dim_m)){
	for (j in (1:dim_a)){
		I=int(b_vec, (posterior_qua)[,i,j])
		int_qua_b[i,j]=I
	}
}

int_qua_bm=array(0, c(dim_a))
for (i in (1:dim_a)){
		I=int(m_vec, (int_qua_b)[,i])
		int_qua_bm[i]=I
}

#Marginalization of posterior_quad over b and a

int_qua_ba=array(0, c(dim_m))
for (i in (1:dim_m)){
		I=int(b_vec, (int_qua_a)[,i])
		int_qua_ba[i]=I
}

######

#Marginalization of posterior_lin over b and m
int_lin_b=array(0, dim=c(length(m_vec)))
for (i in (1:length(m_vec))){
	I=int(b_vec, (posterior_lin[i,]))
		int_lin_b[i]=I
}

int_lin_m=array(0, dim=c(length(b_vec)))
for (i in (1:length(b_vec))){
	I=int(m_vec, (posterior_lin[,i]))
		int_lin_m[i]=I
}

#Marginalization of posterior_con over b

int_lin_m=array(0, dim=c(dim_b))
I=int(b_vec, (posterior_con))
int_con_b=posterior_con

#search for best sigma
sdtest=seq(0.01,1,by=0.01)

sigma_test=function(A,mu,sd,xvec,f){
	chi=0
	for(j in (1:length(xvec)))
		{
			chi=chi+(f[j]-(A*exp(-0.5*(((xvec[j]-mu)**2)/(sd**2))))/sigvar)**2
        }
        return(chi)
    }

# create grids for vaious sigma functions
# later, find min of grid

grid_con_b <-array(0, dim=c(length(sdtest)))
grid_lin_b <-array(0, dim=c(length(sdtest)))
grid_lin_m <-array(0, dim=c(length(sdtest)))
grid_qua_b <-array(0, dim=c(length(sdtest)))
grid_qua_m <-array(0, dim=c(length(sdtest)))
grid_qua_a <-array(0, dim=c(length(sdtest)))

for(i in (1:length(sdtest)))
{
	grid_con_b[i] = sigma_test(max(int_con_b),best_b_con,sdtest[i], b_vec,int_con_b)
	grid_lin_b[i] = sigma_test(max(int_lin_b),best_b_lin,sdtest[i], b_vec,int_lin_b)
	grid_lin_m[i] = sigma_test(max(int_lin_m),best_m_lin,sdtest[i], m_vec,int_lin_m)
	grid_qua_b[i] = sigma_test(max(int_qua_am),best_b_qua,sdtest[i], b_vec,int_qua_am)
	grid_qua_m[i] = sigma_test(max(int_qua_ba),best_m_qua,sdtest[i], m_vec,int_qua_ba)
	grid_qua_a[i] = sigma_test(max(int_qua_bm),best_a_qua,sdtest[i], a_vec,int_qua_bm)
}
err_con_b=sdtest[which(grid_con_b==min(grid_con_b),arr.ind=TRUE)]
err_lin_b=sdtest[which(grid_lin_b==min(grid_lin_b),arr.ind=TRUE)]
err_lin_m=sdtest[which(grid_lin_m==min(grid_lin_m),arr.ind=TRUE)]
err_qua_b=sdtest[which(grid_qua_b==min(grid_qua_b),arr.ind=TRUE)]
err_qua_m=sdtest[which(grid_qua_m==min(grid_qua_m),arr.ind=TRUE)]
err_qua_a=sdtest[which(grid_qua_a==min(grid_qua_a),arr.ind=TRUE)]
err_lin_m = err_lin_m[1]

# The integration via fit (spinefun) is computationally expensive compared to the simple numerical integration by summing up.

strqua = paste("quadratic: ax^2 + mx +b with a=",round(best_a_qua,2),"+-",round(err_qua_a,2),",\n m=", round(best_m_qua,2),"+-",round(err_qua_m,2),", b=",round(best_b_qua,2),"+-",round(err_qua_b,2))
strlin = paste("linear: mx +b with m=", round(best_m_lin,2),"+-",round(err_lin_m,2),",\n b=",round(best_b_lin,2),"+-",round(err_lin_b,2))
strcon = paste("constant: b with b=",round(best_b_con,2),"+-",round(err_con_b,2))
print(strqua)
text(0,2.8,strqua)
text(0,2.1,strlin)
text(0,1.6,strcon)

#Plot errorbars quad. Here i'm not sure how to plot the error bars so I plot them like done below. An explanation about how to plot error bar in the tutorial would be nice.
for( x in (x_vec_2)){

tmperrup = quarel(x,best_a_qua,best_m_qua,best_b_qua) + (err_qua_a*x**2+x*err_qua_m+err_qua_b)
tmperrdo = quarel(x,best_a_qua,best_m_qua,best_b_qua) - (err_qua_a*x**2+x*err_qua_m+err_qua_b)
errbar(x,quarel(x,best_a_qua,best_m_qua,best_b_qua),tmperrup,tmperrdo,add=TRUE)

tmperrup = linrel(x,best_m_lin,best_b_lin) + (x*err_lin_m+err_lin_b)
tmperrdo = linrel(x,best_m_lin,best_b_lin) - (x*err_lin_m+err_lin_b)
errbar(x,linrel(x,best_m_lin,best_b_lin),tmperrup,tmperrdo,add=TRUE)

tmperrup = best_b_lin + err_con_b
tmperrdo = best_b_lin - err_con_b
#print(tmperrup)
#print(tmperrdo)
#print(x)
#print(best_b_con)
errbar(x,best_b_con,tmperrup,tmperrdo,add=TRUE)
}
#Problem 4
# calculate the evidence
evidence_qua=err_qua_a*err_qua_m*err_qua_b*max(posterior_qua)*(1/sum(posterior_qua))
evidence_lin=err_lin_m*err_lin_b*max(posterior_lin)*(1/sum(posterior_lin))
evidence_con=err_con_b*max(posterior_con)* (1/sum(posterior_con))
print('evidence')
print('quadratic')
print(evidence_qua)
print('linear')
print(evidence_lin)
print('const.')
print(evidence_con)

#the constant would be the best model. This is in contrast to the naive expectation that straight line model would fit best.

#Problem 5
#To run the script with sigma 1 change the variable sigvar to 1
#Theoretically the evidence should point to the quadratic model because it could better fit the new mock data with higher sigvar. We get the constant again as the best model. Forthermor we gat bigger error bars and so a better evidence.

SS2012-StatisticalMethods.git

Ther was an error in plot of reglin