Solutions to selected problems from

"Bayesian Logical Data Analysis for the Physical Sciences"
P. C. Gregory
University of British Columbia
Cambridge University Press 2005

Last revised Nov. 4, 2011

Ch. 1: Problem 3

CleanUp

Clear["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Based on the saliva test the probability of H ≡ "the person has UD", is  p(H|(Subscript[D, 1]),I) = 0.0042. 
This posterior probability is the prior for analysing (Subscript[D, 2]), the blood test results for UD, i.e.,  p(H|(Subscript[D, 1]),I) = p(H|(Subscript[I, 1])) 
The false negative rate for the blood test is = 1.4%, therefore p(H|(Subscript[D, 2]), I)  = 98.6
The false positive rate for the blood test is = 0.5%, therefore p((OverBar[H])|(Subscript[D, 2]), I)  = 0.005

p ≡ p (H|(Subscript[D, 2]),(Subscript[D, 1]),I)= p (H|(Subscript[D, 2]),(Subscript[I, 1]))=((p(H|(Subscript[I, 1])) p ((Subscript[D, 2])|H,(Subscript[I, 1])))/(p ((Subscript[D, 2])|(Subscript[I, 1]))))

p ≡p (H|(Subscript[D, 1]),(Subscript[D, 2]),I)= ((p(H|(Subscript[I, 1])) p ((Subscript[D, 2])|H,(Subscript[I, 1])))/(p(H|(Subscript[I, 1])) p ((Subscript[D, 2])|H,(Subscript[I, 1]))+p((Overscript[H, -])|(Subscript[I, 1])) p ((Subscript[D, 2])|(Overscript[H, -]),(Subscript[I, 1]))))

p=((0.0042* 0.986)/(.0042* 0.986+(1-.0042)* 0.005))

Ch. 1: Problem 4

CleanUp

Remove["Global`*"]

Note: Remove command is more powerful than the Clear command but will give a nuisance error message 
         if there is nothing to be removed.

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Generate and ContourPlot a two dimensional probability density function

As given, the probability density function is the sum of two Gaussians for 0 ≤ x ≤ 1 and 0 ≤ y ≤ 1, and 0 outside this range.        
Here is the non normalized density function

pdf0=A1  (E^(-((((x-x1))^2)/(2 ((((Subscript[σ, 1x])))^2)))-((((y-y1))^2)/(2  ((((Subscript[σ, 1y])))^2)))))+A2 (E^(-((((((x-x2))^2)+(((y-y2))^2)))/(2 ((Subscript[σ, 2])^2)))));

The values of the constants are given on the next line of input.

A1=4.82033;x1=0.5;y1=0.5;(Subscript[σ, 1x])=0.2;(Subscript[σ, 1y])=0.2;A2=4.43181;x2=0.65;y2=0.75;(Subscript[σ, 2])=0.04;

Check normalization of joint probability distribution.

intpdf=(∫_0^1)(∫_0^1)pdf0\[DifferentialD]y\[DifferentialD]x

If it is not normalized to 1, then divide  pdf0  by  intpdf.

pdf=pdf0/intpdf

Evaluate the joint probability distribution at the point x->0.65,y->0.5

pdf/.{x->0.65,y->0.5}

Plot a contour plot of the joint probability distribution.

plcont=ContourPlot[pdf,{x,0,1},{y,0,1},PlotPoints->50,PlotRange->All,ContourShading->False,PlotLabel->Style["Joint PDF",{"Helvetica-Bold",12}],FrameLabel->{Style["x axis",{"Helvetica-Bold",12}],
		Style["y axis",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Redo above but give the contourplot a name and add the option "DisplayFunction->Identity" at the end to turn contour plot into a graphics primitive for use at the end.

plcont=ContourPlot[pdf,{x,0,1},{y,0,1},PlotPoints->50,PlotRange->All,ContourShading->False,PlotLabel->Style[" (A) Joint Probability",{"Helvetica-Bold",12}],FrameLabel->{Style["x axis",{"Helvetica-Bold",12}],
		Style["y axis",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Generate a 3 dimensional plot of the joint density function

Plot3D[pdf,{x,0,1},{y,0,1},PlotPoints->50,PlotRange->All,AxesLabel->{Style["x axis",{"Helvetica-Bold",12}],
		Style["y axis",{"Helvetica-Bold",12}],Style["Probability",{"Helvetica-Bold",12}]},BaseStyle->{12,FontFamily->"Helvetica-Bold"},MeshStyle->Thickness[0.003]]

Plot projection of  joint probability distribution along the x axis

Make a simple two dimensional table of 1's with 3 rows and 2 columns.

tval=Table[1,{i,1,3},{j,1,2}]

tval[[1]]

Use Table to make a discrete version of the joint probability distribution

First specify the resolution in the two axes

dx=0.01;dy=0.01;

pdftab=Table[pdf,{y,0,1,dy},{x,0,1,dx}];

This makes an array (list of lists), where the different rows correspond to different values of the y coord

ListContourPlot[pdftab]

ListPlot the 25th row

ListPlot[pdftab[[25]]]

Compute the number of samples along the y-axis & x-axis

ny=Length[pdftab]

nx=Length[pdftab[[1]]]

Define the numerical value of each  x  value

xval=Table[(i-1) dx,{i,1,nx}];

For each value of  x we want to find the maximum value of the joint probability distribution along the y-axis.
We will make a table of the maximum values but first we need to Transpose pdftab distribution so the columns become rows.

xproj=Table[Max[Transpose[pdftab][[i]]],{i,1,ny}];

Normalize to convert xproj to a probability scale, by dividing by (dx * the sum of the xproj values)

nxproj=xproj/(dx*Total[xproj]);

Creat a paired list of {x,prob} values to ListPlot

xplmax=Transpose[{xval,nxproj}];

plxmax=ListPlot[xplmax,Frame->True,	PlotLabel->Style["Projected Probability",{"Helvetica-Bold",12}],FrameLabel->{Style["x axis",{"Helvetica-Bold",12}],
		Style["Projected PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compute and plot marginal probability for x

To obtain the marginal probability of x, we integrate the joint probability function in the y coordinate.

xmarg=(∫_0^1)pdf\[DifferentialD]y

Check the marginal is a normalized probability distribution

xint=(∫_0^1)xmarg\[DifferentialD]x

Evaluate the marginal at the same xvalues used for the projected probability with the following command.

projx=xmarg/.x->xval

Create a list of {x,prob} pairs for plotting.

xmargprb=Transpose[{xval,projx}];

Plot both projected and marginal probabilities on the same plot.

ListPlot[{xplmax,xmargprb},Frame->True,
PlotStyle->{{Green},{Blue}},PlotLegend->{"projected","marginal"},
	LegendPosition->{-0.3,-0.3},LegendSpacing->0,
	LegendTextSpace->1.5,LegendBorderSpace->0,
	LegendSize->{0.5,0.15},
	LegendShadow->{0.02,-0.02},
	PlotLabel->Style["Marginal and Projected Probability",{"Helvetica-Bold",12}],FrameLabel->{Style["x axis",{"Helvetica-Bold",12}],
		Style["Probability density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Show contour plot of joint prob. dist. and  marginal probability for x

Show[GraphicsGrid[{{plcont, plfin}},Spacings->{Scaled[-0.15],Scaled[-0.0]}]]

Plot projection of  joint probability distribution along the y axis

Define the numerical value of each  x  value

yval=Table[(i-1) dy,{i,1,ny}];

For each value of  x we want to find the maximum value of the joint probability distribution along the y-axis.
We will make a table of the maximum values but first we need to Transpose pdftab distribution so the columns become rows.

yproj=Table[Max[pdftab[[i]]],{i,1,nx}];

Normalize to convert xproj to a probability scale, by dividing by (dx * the sum of the xproj values)

nyproj=yproj/(dy Plus@@yproj);

Creat a paired list of {y,prob} values to ListPlot

yplmax=Transpose[{yval,nyproj}];

plymax=ListPlot[yplmax,Frame->True,	PlotLabel->Style["Projected Probability",{"Helvetica-Bold",12}],FrameLabel->{Style["y axis",{"Helvetica-Bold",12}],
		Style["Projected PDF",{"Helvetica-Bold",12}]},BaseStyle->{12,FontFamily->"Helvetica-Bold"},FrameStyle->Thickness[0.006]]

Compute and plot marginal probability for y

To obtain the marginal probability of y, we integrate the joint probability function in the x coordinate.

ymarg=(∫_0^1)pdf\[DifferentialD]x

Check the marginal is a normalized probability distribution

yint=(∫_0^1)ymarg\[DifferentialD]y

Evaluate the marginal at the same yvalues used for the projected probability with the following command.

projy=ymarg/.y->yval

Create a list of {y,prob} pairs for plotting.

ymargprb=Transpose[{yval,projy}];

Plot both projected and marginal probabilities on the same plot.

ListPlot[{yplmax,ymargprb},Frame->True,
PlotStyle->{{Green},{Blue}},PlotLegend->{"projected","marginal"},
	LegendPosition->{-0.3,-0.3},LegendSpacing->0,
	LegendTextSpace->1.5,LegendBorderSpace->0,
	LegendSize->{0.5,0.15},
	LegendShadow->{0.02,-0.02},
	PlotLabel->Style["Marginal and Projected Probability",{"Helvetica-Bold",12}],FrameLabel->{Style["y axis",{"Helvetica-Bold",12}],
		Style["Probability density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Ch. 3: Problem 2

CleanUp

To ensure that this notebook does not inherit variables etc from notebooks you may have executed previously , we execute the following command. It is good practice to incorporate
this line at the beginning of all program segments and programs which are to be protected from 
unwanted inheritance.

Clear["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Read in data (one pair of x y values per line) with the Import command. Plot data.

(*data=Import["c:/greg1/p509/spec2005.dat"]*)

data={{1.,0.25},{2.,-0.19},{3.,0.25},{4.,-0.56},{5.,-0.41},{6.,-0.94},{7.,0.84},{8.,-0.30},{9.,-2.06},{10.,-1.39},{11.,0.07},{12.,1.80},{13.,-1.02},{14.,-0.46},{15.,0.29},{16.,-0.36},{17.,-0.42},{18.,1.43},{19.,-1.33},{20.,0.06},{21.,0.82},{22.,0.42},{23.,3.76},{24.,1.10},{25.,1.38},{26.,1.86},{27.,0.32},{28.,-1.14},{29.,1.24},{30.,-0.28},{31.,0.02},{32.,-1.52},{33.,0.44},{34.,0.05},{35.,0.59},{36.,0.94},{37.,-0.10},{38.,0.57},{39.,0.40},{40.,-0.97},{41.,2.20},{42.,0.15},{43.,-0.37},{44.,-0.67},{45.,-0.05},{46.,-0.20},{47.,0.65},{48.,-1.24},{49.,-1.56},{50.,-0.64},{51.,0.48},{52.,1.79},{53.,0.07},{54.,1.30},{55.,0.29},{56.,-0.23},{57.,-0.50},{58.,0.93},{59.,-1.28},{60.,-1.98},{61.,1.85},{62.,0.89},{63.,0.65},{64.,0.28}};

data[[2]]

lendat=Length[data]

Transpose the data and extract a vector of channel frequency data (x-coord.) and a vector of spectrum voltages (y-coord.).

tarr=Transpose[data];

freqvec=tarr[[1]];

specvec=tarr[[2]];

noiseStdDev=StandardDeviation[specvec]

noiseRMS=(Sqrt[((specvec.specvec)/lendat)-(((((Plus@@specvec)/lendat)))^2)])

Plot the spectrum

ListPlot[data,Frame->True,Joined->True,PlotRange->{{-1,65},{-3,4}},PlotMarkers->{Automatic},PlotStyle->{Black,Dashed,Thin},PlotLabel->Style["Spectral line data",{"Helvetica-Bold",12}],
FrameLabel->{Style["Channel Number",{"Helvetica-Bold",12}],
		Style["Signal Strength {mK}",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Creating the spectral line model

Model of spectral line:

		Ampl = T *  exp(-(f-fo)^2/(2*sigl^2))

We define the model spectral line shape:

amp[f_]:=Exp[-((((f-f0))^2)/(2 (sigl^2)))]

Calculations based on assuming line frequency = channel 24

Compute the odds ratio for both Uniform and Jeffreys prior on signal strength

The odds ratio = the ratio of the probability of the spectral line being present to the probabability of no line. 
M1 stand for the model = line present;  M0 is the model that data is consistent with gaussian noise.
           odds = p(M1|D,I)/p(M0|D,I)

On the next line we insert the freqvec into the spectral line model and evaluate it for a center frequency f0 = channel 24
and a Gaussian line width sigl = 2.0.

fi=N[amp[freqvec]]/.{f0->24,sigl->2.0}

sumfifi=fi.fi

sumdifi=specvec.fi

Tmax=100.0;
Tmin=0.1;
sigma=1;

Compute Odds numerically

Odds2 = Uniform prior for T
Odds3 = Jeffrey's prior for T

aa[T_]:=Exp[(((2.0 T sumdifi-(T^2) sumfifi) )/(2.0  (sigma^2)))]

odds2=((NIntegrate[aa[T],{T,Tmin,Tmax}])/Tmax)

probM1U=(1/(1+(1/odds2)))

odds3=((NIntegrate[((aa[T])/T),{T,Tmin,Tmax}] 1.0)/(Log[(Tmax/Tmin)]))

probM1J=(1/(1+(1/odds3)))

Reason for preferring the Jeffreys prior in this problem.

In this problem the prior uncertainty in the line strength ranges from 0.1 to 100 mK. In this case
the uniform prior implies  (see text Equ. 3.34) that the line strength is 100 times more probable to 
be in the top decade of the predicted range than the bottom, i.e., it is much more probable that T is
strong than weak. Usually, expressing great uncertainty in some quantity corresponds more closely 
to a statement of scale invariance or equal probability per decade. In this situation, we recommend 
using a Jeffreys prior which is scale invariant.

Compute posterior probability density function (PDF) of line strength

valu=NIntegrate[aa[T],{T,0,8}]

Normalize the PDF for signal strength by dividing by the line integral.

strM1U[T_]:=((aa[T])/valu)

Posterior probability for line strength assuming model M1 correct
and uniform prior.

pl5=Plot[strM1U[T],{T,0,8},PlotRange->All,Frame->True,FrameLabel->{Signal Strength,PDF},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

FindMaximum[strM1U[T],{T,1.9}]

You may run into problems with FindMaximum if your guess is too far from the peak. 
Try Maximize, it appears to be more robust.

Maximize[{strM1U[T],T>1&&T<3},{T}]

Assuming Jeffreys prior for line strength

valj=NIntegrate[((aa[T])/T),{T,Tmin,8}]

strM1J[T_]:=((aa[T])/(T*valj))

Posterior probability for line strength assuming model M1 correct
assuming Jeffreys prior.

pl6=Plot[strM1J[T],{T,Tmin,8},PlotRange->All,Frame->True,FrameLabel->{Signal Strength,PDF},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

FindMaximum[strM1J[T],{T,2.0}]

Comparison of Posterior Probability Densities for Jeffrey's and Uniform

Plot[{strM1J[T],strM1U[T]},{T,Tmin,5},
	PlotStyle->{{Black,Thick},{Thick}},
	PlotLegend->{Style["Jeffreys",
				{"Helvetica-Bold",12}],Style["Uniform",
				{"Helvetica-Bold",12}]},
	LegendPosition->{.3,0.25},LegendSize->{0.5,0.25}, 
	LegendTextSpace->4,LegendSpacing->1,
	LegendShadow->{0.015,-0.015},
	PlotRange->All,Frame->True,
	FrameLabel->{Style["Line Strength T",
				{"Helvetica-Bold",12}],
		Style["p(T|D,(Subscript[M, 1]),I)",{"Helvetica-Bold",12}]},
	FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compute the peak and upper and lower bounds of the 95%
credible region for uniform prior case.

Create a table of probability and T values for uniform case.

tabTmax=10;dT=0.01;

pu=Table[{strM1U[T],T},{T,0.1,tabTmax,dT}];

n=Length[pu]

Total[pu*dT]

Sort the table according to the first column in ascending order
 (i.e. according to increasing probability).

pus=Sort[pu];

mode=pus[[n,2]]

Set initial values for the lower and upper bound of the credible region.

tminU=pus[[n,2]];tmaxU=pus[[n,2]];

area=dT pus[[n,1]]

While[area≤0.95,area=area+dT*pus[[n-1,1]];If[pus[[n-1,2]]>tmaxU,tmaxU=pus[[n-1,2]],Null];If[pus[[n-1,2]]<tminU,tminU=pus[[n-1,2]],Null];n=n-1];area

l1={{"Peak","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max"," "," "}};

l2={{mode,tminU,tmaxU,mode-tminU,tmaxU-mode}};

smj=MatrixForm[Join[l1,l2]]

Compute the peak and upper and lower bounds of the 95%
credible region for Jeffreys prior.

Create a table of probability and T values for Jeffreys case.

tabTmax=10;dT=0.01;

pj=Table[{strM1J[T],T},{T,0.1,tabTmax,dT}];

n=Length[pj]

Sort the table according to the first column in ascending order
 (i.e. according to increasing probability).

pjs=Sort[pj];

mode=pjs[[n,2]]

Set initial values for the lower and upper bound of the credible region.

tminJ=pjs[[n,2]];tmaxJ=pjs[[n,2]];

area=dT pjs[[n,1]]

While[area≤0.95,area=area+dT pjs[[n-1,1]];If[pjs[[n-1,2]]>tmaxJ,tmaxJ=pjs[[n-1,2]],Null];If[pjs[[n-1,2]]<tminJ,tminJ=pjs[[n-1,2]],Null];n=n-1]

l3={{"Peak","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max"," "," "}};

l4={{mode,tminJ,tmaxJ,mode-tminJ,tmaxJ-mode}};

smj=MatrixForm[Join[l3,l4]]

Calculations assuming line frequency unknown
(assumes uniform prior on line frequency)

Evaluating the odds ratio for both Uniform and Jeffreys prior on signal strength

Theory section

Consider the modification to p(D|(Subscript[M, 1]),I) when the line frequency is also unknown.
     p(D|(Subscript[M, 1]),I) = ∫d(Subscript[ν, 0]) p((Subscript[ν, 0])|(Subscript[M, 1]),I) ∫dT p(T|(Subscript[M, 1]),I)× p(D|(Subscript[M, 1]),(Subscript[ν, 0]),T,I) 

We can approximate the integral over (Subscript[ν, 0]) by a summation
    p(D|(Subscript[M, 1]),I) = (∑_(i=1)^nl)p((Subscript[ν, 0i])|(Subscript[M, 1]),I) × Δ(Subscript[ν, 0i])×∫dT p(T|(Subscript[M, 1]),I)× p(D|(Subscript[M, 1]),(Subscript[ν, 0i]),T,I) ,
where the prior uncertainty in (Subscript[ν, 0]) spans nl channels.

Let Δ(Subscript[ν, 0i]) = 1 and nl = 50 channels
then p((Subscript[ν, 0i])|(Subscript[M, 1]),I) = 1/nl = 1/50 and 

    p(D|(Subscript[M, 1]),I) = (∑_(i=1)^nl) (1/nl)×∫dT p(T|(Subscript[M, 1]),I)× p(D|(Subscript[M, 1]),(Subscript[ν, 0i]),T,I)

How does the odds ratio change when the line frequency is unknown?
Again assuming  p((Subscript[M, 1])|I) = p((Subscript[M, 2])|I), 

odds = ((p(D|(Subscript[M, 1]),I))/(p(D|(Subscript[M, 2]),I)))
         = (∑_(i=1)^nl) (1/nl)×((∫dT p(T|(Subscript[M, 1]),I)×p(D|(Subscript[M, 1]),(Subscript[ν, 0i]),T,I))/(p(D|(Subscript[M, 2]),I)))
         = (∑_(i=1)^nl) (1/nl)× odds((Subscript[ν, 0i]))

where odds((Subscript[ν, 0i])) is the odds computed assuming a particular value for (Subscript[ν, 0i]) 
in the prior range of nl channels.

Let Tmax and Tmin = the prior upper and lower bounds on line strength in Kelvin,  sigl = the line width (Gaussian sigma) and flo = the low end of prior range for line
center frequency. The prior range for line center frequency = nl channels.

n=lendat;

Tmax=100.0;Tmin=0.1;sigma=1.0;

(*sigl=2.0;flo=1;nl=44;*)

sigl=2.0;flo=1;nl=50;

Set up a table to contain the value of the odds for each of nl choices of the line center frequency 
in the prior range for the center frequency. Later we will marginalize over this prior range by summing
the entries in the table and dividing by nl (assumes uniform prior for line center frequency).

oddsunif=Table[1,{i,1,nl}];

oddsJeff=Table[1,{i,1,nl}];

Alternate fast method of computing the ODDS with NIntegrate
using Method->Trapezoidal and PrecisionGoal->3 
(took 140 sec on my 650 MHz Pentium 3)

With AccuracyGoal-a and PrecisionGoal->p Mathematica attempts to make the numerical error in a result of sizexbe less than(10^(-a))+|x|(10^(-p)).

(*fi=amp[freqvec];fifi=fi fi;difi=specvec fi;sumfifi=Plus@@fifi;
	sumdifi=Plus@@difi;aa=Exp[((2.0 Sig sumdifi-(Sig^2) sumfifi)/2.0)];
	oddsunifTR=(1/Tmax)NIntegrate[aa,{Sig,Tmin,Tmax},{f0,1,50},Method->Trapezoidal,PrecisionGoal->3];*)

(*oddsunifTR/nl*)

Compute the odds for uniform (oddsunif) & Jeffreys (oddsJeff) priors for signal strength and for nl choices line center frequency
in the prior range.

Do[fx=flo-1+i;Plamp[f_]:=amp[f]/.{f0->fx};fi=N[Plamp[freqvec]];
	sumfifi=fi.fi;sumdifi=specvec.fi;aa[Sig_]:=Exp[((2.0 Sig sumdifi-(Sig^2) sumfifi)/2.0)];
	oddsunif[[i]]=((NIntegrate[aa[Sig],{Sig,Tmin,Tmax}])/Tmax);
	oddsJeff[[i]]=((NIntegrate[((aa[Sig])/Sig),{Sig,Tmin,Tmax}] 1.0)/(Log[(Tmax/Tmin)])),{i,nl}]

We could have used the faster Table command to compute these quantities.

(*oddsuniftab=Table[fx=flo-1+i;Plamp[f_]:=amp[f]/.{f0->fx};fi=N[Plamp[freqvec]];
	sumfifi=fi.fi;sumdifi=specvec.fi;aa[Sig_]:=Exp[((2.0 Sig sumdifi-(Sig^2) sumfifi)/2.0)];
	((NIntegrate[aa[Sig],{Sig,Tmin,Tmax}])/Tmax),{i,nl}]*)

maxoddsunif=Max[oddsunif]

oddsJeff

maxoddsJeff=Max[oddsJeff]

probM1U=(1/(1+(1/oddsunif)))

probM1J=(1/(1+(1/oddsJeff)))

Now marginalize over the prior range for the center frequency.

moddsunif=Total[oddsunif/nl]

moddsJeff=Total[oddsJeff/nl]

margprobM1U=(1/(1+(1/moddsunif)))

margprobM1J=(1/(1+(1/moddsJeff)))

Compute posterior PDF of center frequency & line strength
(assuming uniform prior for line frequency, uniform prior for signal strength)

nt=100;delT=0.1;flo=1;nl=50;

Compute two dimensional probability distribution in line freq. and line strength 
assuming uniform prior for line frequency, uniform prior for signal strength

par2=Table[fx=flo-1+i;Plamp[f_]:=amp[f]/.{f0->fx};
		fi=N[Plamp[freqvec]];
	sumfifi=fi.fi;sumdifi=specvec.fi;Exp[((2.0 (j delT)  sumdifi-(((j delT))^2) sumfifi)/2.0)],
			{i,1,nl},{j,1,nt}];

Note par2[[1]] = a column of 100 probabilities in the variable line strength for the first of 50 choices of line freq.

Marginalize over line strength and plot the marginal PDF of the line frequency.

upf=Plus@@Table[Plus@@par2[[i]],{i,1,nl}];

prbf=Table[{(flo-1+i),Plus@@par2[[i]]/upf},{i,1,nl}];

plfa=ListPlot[prbf,PlotRange->All,Frame->True,PlotJoined->True,PlotMarkers-> {●, 7},PlotStyle->{Black,Dashing[{0.01,0.01}]},PlotLabel->Style["Uniform priors for Line Freq. & Strength",{"Helvetica-Bold",12}],FrameLabel->{Style["Channel Number",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Marginalize over line frequency and plot the marginal PDF of the line strength.

Note Transpose[par2][[1]] = a column of 50 probabilities for possible line freq. for the first of 100 choices of line strength.

Length[Transpose[par2][[1]]]

upt=Plus@@Table[Plus@@Transpose[par2][[j]],{j,1,nt}];

prbt=Table[{(j delT),Plus@@Transpose[par2][[j]]/(upt*delT)},{j,1,nt}];

plta=ListPlot[prbt,PlotRange->All,Frame->True,PlotStyle->PointSize[0.012],PlotLabel->Style["Uniform priors for Line Freq. & Strength",{"Helvetica-Bold",12}],FrameLabel->{Style["Line Strength (mK)",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Extra: compare with PDF of the line strength if the line frequency is known to be ch 24

upt24=Total[par2[[24]]]

lineT=Table[j delT,{j,1,100}];

par2[[24]];

prbt24=Transpose[{lineT,par2[[24]]/(upt24*delT)}];

plta24=ListPlot[prbt24,PlotRange->All,Frame->True,PlotStyle->PointSize[0.012],PlotLabel->Style["Uniform priors for Line Freq. & Strength",{"Helvetica-Bold",12}],FrameLabel->{Style["Line Strength (mK)",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ListPlot[{prbt,prbt24},PlotLegend->{"Unknown center freq.","Center freq. ch. 24"},LegendPosition->{0.35,0.3},LegendSpacing->0.2,
	LegendTextSpace->5,
	LegendSize->{0.8,0.25},
	LegendShadow->{0.02,-0.02},PlotJoined->True,Frame->True,PlotRange->{{0,4},All},PlotStyle->{{Thickness[0.005],Dashing[{0.007,0.02}]},{Thickness[0.005],GrayLevel[0]}},FrameLabel->{"Line Strength (mK)","PDF","",""},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compute posterior PDF of center frequency & line strength
(assuming uniform prior for line frequency, Jeffreys prior for signal strength)

Compute two dimensional probability distribution in line freq. and line strength 
assuming uniform prior for line frequency, Jeffreys' prior for signal strength

par3=Table[fi=flo-1+i;Plamp[f_]:=amp[f]/.{f0->fi};fi=N[Plamp[freqvec]];
	fifi=fi fi;difi=specvec fi;sumfifi=Plus@@fifi;
	sumdifi=Plus@@difi;(1/((j delT)))Exp[((2.0 (j delT)  sumdifi-(((j delT))^2) sumfifi)/2.0)],
			{i,1,nl},{j,1,nt}];

Note par3[[1]] = a column of 100 probabilities in the variable line strength for the first of 50 choices of line freq.

Marginalize over line strength and plot the marginal PDF of the line frequency.

upfj=Plus@@Table[Plus@@par3[[i]],{i,1,nl}];

prbfj=Table[{(flo-1+i),Plus@@par3[[i]]/upfj},{i,1,nl}];

plfja=ListPlot[prbfj,PlotRange->All,Frame->True,PlotJoined->True,PlotMarkers->{★,15},PlotStyle->{Black,Dashing[{0.01,0.01}]},FrameLabel->{Style["Channel Number",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Marginalize over line frequency and plot the marginal PDF of the line strength.

Note par2[[1]] = a column of 100 probabilities in the variable line strength for the first of 50 choices of line freq.

uptj=Total[Table[Plus@@Transpose[par3][[j]],{j,1,nt}]];

prbtj=Table[{(j delT),Plus@@Transpose[par3][[j]]/(uptj*delT)},{j,1,nt}];

pltaj=ListPlot[prbtj,PlotRange->All,Frame->True,PlotStyle->PointSize[0.01],PlotLabel->Style["Line Freq. (uniform prior ) & Line Strength (Jeffreys)",{"Helvetica-Bold",12}],FrameLabel->{Style["Line Strength (mK)",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Extra: Compare with PDF of the line strength if the line frequency was known to be ch 24

uptj24=Total[par3[[24]]]

prbtj24=Transpose[{lineT,par3[[24]]/(uptj24*delT)}];

pltaj24=ListPlot[prbtj24,PlotRange->All,Frame->True,PlotStyle->PointSize[0.01],PlotLabel->Style["Line Freq. (uniform prior ) & Line Strength (Jeffreys)",{"Helvetica-Bold",12}],FrameLabel->{Style["Line Strength (mK)",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ListPlot[{prbtj,prbtj24},PlotLegend->{"Unknown center freq.","Center freq. ch. 24"},LegendPosition->{0.2,0.2},LegendSpacing->0.2,
	LegendTextSpace->5,LegendBorderSpace->0,
	LegendSize->{0.8,0.25},
	LegendShadow->{0.02,-0.02},PlotJoined->True,Frame->True,PlotRange->{{0,4},All},SymbolShape->{PlotSymbol[Star,0.05],PlotSymbol[Box,.05]},PlotStyle->{{Thickness[0.005],Dashing[{0.007,0.02}]},{Thickness[0.005],GrayLevel[0]}},FrameLabel->{"Line Strength (mK)","PDF","",""},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Comparison of Posterior Probability Densities for Jeffrey's and Uniform 
(assuming unknown line frequency)

ListPlot[{prbtj,prbt},PlotLegend->{"Jeffreys","Uniform"},LegendPosition->{0.3,0.2},LegendSpacing->0,
	LegendTextSpace->1.5,LegendBorderSpace->0,
	LegendSize->{0.5,0.25},
	LegendShadow->{0.02,-0.02},PlotJoined->True,Frame->True,PlotRange->{{0,4},All},PlotStyle->{{Thickness[0.005],Dashing[{0.007,0.02}]},{Thickness[0.005],GrayLevel[0]}},FrameLabel->{"Line Strength (mK)","PDF","",""},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compute the upper and lower bounds of the 95%
credible region for uniform prior for T and freq = ch. 1-50.

Create a table of probability and T values for uniform case.

tempu=Transpose[prbt][[1]];

probu=Transpose[prbt][[2]];

Total[probu]

pu=Transpose[{probu,tempu}];

tabTmax=10;dT=0.1;

n=Length[pu]

Sort the table according to the first column in ascending order
 (i.e. according to increasing probability).

pus=Sort[pu];

mode=pus[[n,2]]

Set initial values for the lower and upper bound of the credible region.

tminU=10;tmaxU=0.1;

n

area=pus[[n,1]]

j=0;While[area≤0.95,If[pus[[n,2]]<tminU,tminU=pus[[n,2]]];
area=area+ pus[[n-1,1]];
If[pus[[n-1,2]]>tmaxU,tmaxU=pus[[n-1,2]],Null];
If[pus[[n-1,2]]<tminU,tminU=pus[[n-1,2]],Null];n=n-1];area

l5={{"Peak","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max"," "," "}};

l6={{mode,tminU,tmaxU,mode-tminU,tmaxU-mode}};

smj=MatrixForm[Join[l5,l6]]

Compute the upper and lower bounds of the 95%
credible region for Jeffreys prior for T and freq = ch. 1-50.

Create a table of probability and T values for Jeffreys case.

tempJu=Transpose[prbtj][[1]];

probJu=Transpose[prbtj][[2]];

Total[probJu]

pu=Transpose[{probJu,tempJu}];

tabTmax=10;dT=0.1;

n=Length[pu]

Sort the table according to the first column in ascending order
 (i.e. according to increasing probability).

pus=Sort[pu];

mode=pus[[n,2]]

Set initial values for the lower and upper bound of the credible region.

tminJu=10;tmaxJu=0.1;

n

area=pus[[n,1]]

j=0;While[area≤0.95,If[pus[[n,2]]<tminJu,tminJu=pus[[n,2]]];area=area+ pus[[n-1,1]];
If[pus[[n-1,2]]>tmaxJu,tmaxJu=pus[[n-1,2]],Null];
If[pus[[n-1,2]]<tminJu,tminJu=pus[[n-1,2]],Null];n=n-1];area

l7={{"Peak","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max"," "," "}};

l8={{mode,tminJ,tmaxJ,mode-tminJ,tmaxJ-mode}};

smj=MatrixForm[Join[l7,l8]]

How to compute extra Occam penalty due to unknown freq. channel (Subscript[ν, 0])

global likelihood = max. likelihood  x  Occam factor ( (Subscript[Ω, □]))
Below I abbreviate max. likelihood by max like.

A) Unknown T

      oddsA = ((glob likeA(Subscript[M, 1]))/(glob like(Subscript[M, 2])))= ((max likeA× (Subscript[Ω, T]))/(glob like(Subscript[M, 2])))

B) Unknown T, (Subscript[ν, 0])

     oddsB = ((glob likeB(Subscript[M, 1]))/(glob like(Subscript[M, 2])))= ((max likeB× (Subscript[Ω, T]) × (Subscript[Ω, (Subscript[ν, 0])]))/(glob like(Subscript[M, 2])))

     (Subscript[Ω, (Subscript[ν, 0])]) = (oddsB/oddsA)= ((max likeB× (Subscript[Ω, T]) × (Subscript[Ω, (Subscript[ν, 0])]))/(max likeA× (Subscript[Ω, T])))   

        (since max likeB = max likeA in this case. i.e., channel 24 is the location of max like)

Some assumed  (Subscript[Ω, (Subscript[ν, 0])]) =  ((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))  (let's see why not)

p((Subscript[M, 1])|D,(Subscript[I, A]))  =  ((p((Subscript[M, 1])| (Subscript[I, A]))  p(D| (Subscript[M, 1]), (Subscript[I, A]))  )/( p(D| (Subscript[I, A]))  )) 

                     =  ((p((Subscript[M, 1])| (Subscript[I, A]))  max likeA × (Subscript[Ω, T])  )/( p(D| (Subscript[I, A]))  )) 

p((Subscript[M, 1])|D,(Subscript[I, B]))  =  ((p((Subscript[M, 1])| (Subscript[I, B]))  p(D| (Subscript[M, 1]), (Subscript[I, B]))  )/( p(D| (Subscript[I, B]))  )) 

                     =  ((p((Subscript[M, 1])| (Subscript[I, B]))  max likeB × (Subscript[Ω, T]) × (Subscript[Ω, (Subscript[ν, 0])]) )/( p(D| (Subscript[I, B]))  )) 

((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))= ((p((Subscript[M, 1])| (Subscript[I, B]))  max likeB × (Subscript[Ω, T]) × (Subscript[Ω, (Subscript[ν, 0])]) )/(p((Subscript[M, 1])| (Subscript[I, A]))  max likeA × (Subscript[Ω, T]) ))((p(D| (Subscript[I, A])))/(p(D| (Subscript[I, B]))))

                   = (( (Subscript[Ω, (Subscript[ν, 0])]) )/(1  ))((p(D| (Subscript[I, A])))/(p(D| (Subscript[I, B]))))

but (Subscript[I, B])  ((Subscript[M, 1]) with unknown T and unknown (Subscript[ν, 0])) ≠  (Subscript[I, A]) ((Subscript[M, 1]) with unknown T)

(Subscript[Ω, (Subscript[ν, 0])]) = ((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))((p(D| (Subscript[I, B])))/(p(D| (Subscript[I, A]))))

(Subscript[Ω, (Subscript[ν, 0])]) = ((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))((p(D| (Subscript[I, B])))/(p(D| (Subscript[I, A]))))

        = ((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))(([p((Subscript[M, 1])| (Subscript[I, B])) p(D| (Subscript[M, 1]), (Subscript[I, B])) + p((Subscript[M, 2])| (Subscript[I, B]))p(D| (Subscript[M, 2]), (Subscript[I, B]))])/([p((Subscript[M, 1])| (Subscript[I, A]))p(D| (Subscript[M, 1]), (Subscript[I, A])) + p((Subscript[M, 2])| (Subscript[I, A]))p(D| (Subscript[M, 2]), (Subscript[I, A]))]))

but  p((Subscript[M, 1])| (Subscript[I, A])) = p((Subscript[M, 1])| (Subscript[I, B])) = p((Subscript[M, 2])| (Subscript[I, A])) = p((Subscript[M, 2])| (Subscript[I, B])) = 1/2

(Subscript[Ω, (Subscript[ν, 0])]) = ((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))(([p(D| (Subscript[M, 1]), (Subscript[I, B]))  + p(D| (Subscript[M, 2]), (Subscript[I, B]))])/([p(D| (Subscript[M, 1]), (Subscript[I, A])) + p(D| (Subscript[M, 2]), (Subscript[I, A]))]))

              = ((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))((p(D| (Subscript[M, 2]), (Subscript[I, B])) [((p(D| (Subscript[M, 1]), (Subscript[I, B])))/(p(D| (Subscript[M, 2]), (Subscript[I, B])))) + 1])/(p(D| (Subscript[M, 2]), (Subscript[I, A])) [((p(D| (Subscript[M, 1]), (Subscript[I, A])))/(p(D| (Subscript[M, 2]), (Subscript[I, A])))) + 1]))
                
              = ((p((Subscript[M, 1])|D, (Subscript[I, B])))/(p((Subscript[M, 1])|D, (Subscript[I, A]))))((oddsB + 1)/(oddsA + 1))
              
     (Subscript[Ω, (Subscript[ν, 0])])  = ((1/(1+(1/oddsB)))/(1/(1+(1/oddsA)))) ((oddsB + 1)/(oddsA + 1)) =  (oddsB/oddsA)

In the first case oddsA = odds2 which was calculated earlier assuming a uniform prior for T and (Subscript[ν, 0])= channel 24.

oddsA=odds2

occamU=(moddsunif/oddsA)

In the second case oddsA = odds3 which was calculated earlier assuming a Jeffreys prior for T and (Subscript[ν, 0])= channel 24.

oddsA=odds3

occamJ=(moddsJeff/oddsA)

Ch. 4: Problem 5

A lottery is used to pick 3 astronauts from a total of 5 (2 female + 3 male) for two capsules.
Capsule A holds one person and B holds 2. 

Let (Subscript[F, A]) ≡ "a female astronaut picked for capsule A."
Let (Subscript[F, B]) ≡ "at least one female astronaut picked for capsule B." 

We know that one of the 3 picks will decide 
which astronaut will board capsule A but we are not told which one.

Let (Subscript[L, i]) ≡ "the (i^th) pick decides who will board capsule A."
Let (Subscript[F, i]) ≡ "a female astronaut picked on the (i^th) draw."

Then  (Subscript[F, A])= (Subscript[F, 1]),(Subscript[L, 1])+ (Subscript[F, 2]),(Subscript[L, 2])+ (Subscript[F, 3]),(Subscript[L, 3])      (mutually exclusive)

p((Subscript[F, A])|(Subscript[F, B]),I) = (∑_(i=1)^3)p((Subscript[F, i]),(Subscript[L, i])|(Subscript[F, B]),I) = (∑_(i=1)^3)p((Subscript[L, i])|(Subscript[F, B]),I)p((Subscript[F, i])|(Subscript[F, B]),(Subscript[L, i]),I)

Now  p((Subscript[L, i])|(Subscript[F, B]),I) = p((Subscript[L, i])|I) = 1/3

From Bayes' theorem

p((Subscript[F, i])|(Subscript[F, B]),(Subscript[L, i]),I) = ((p((Subscript[F, i])|(Subscript[L, i]),I) p((Subscript[F, B])|(Subscript[F, i]),(Subscript[L, i]),I))/(p((Subscript[F, B])|(Subscript[L, i]),I)))

Let (Subscript[L, i]) = (Subscript[L, 1]) , the decision made on the first draw.

p((Subscript[F, 1])|(Subscript[F, B]),(Subscript[L, 1]),I) = ((p((Subscript[F, 1])|(Subscript[L, 1]),I) p((Subscript[F, B])|(Subscript[F, 1]),(Subscript[L, 1]),I))/(p((Subscript[F, B])|(Subscript[L, 1]),I)))

In this case  (Subscript[F, B]) = (Subscript[F, 2]) + (Subscript[F, 3]),           where  (Subscript[F, 2]) ≡ "a female astronaut picked on the (2^nd) draw."

p((Subscript[F, B])|(Subscript[F, 1]),(Subscript[L, 1]),I) = 1 - p((OverBar[(Subscript[F, B])])|(Subscript[F, 1]),(Subscript[L, 1]),I) = 1 - p((OverBar[(Subscript[F, 2])]),(OverBar[(Subscript[F, 3])])|(Subscript[F, 1]),(Subscript[L, 1]),I)

But  (OverBar[(Subscript[F, 2])]),(OverBar[(Subscript[F, 3])]) = (Subscript[M, 2]), (Subscript[M, 3])

p((Subscript[F, B])|(Subscript[F, 1]),(Subscript[L, 1]),I) = 1 - p( (Subscript[M, 2]),(Subscript[M, 3])|(Subscript[F, 1]),(Subscript[L, 1]),I) = 1 - p( (Subscript[M, 2])|(Subscript[F, 1]),(Subscript[L, 1]),I) p( (Subscript[M, 3])|(Subscript[M, 2]),(Subscript[F, 1]),(Subscript[L, 1]),I)
                             = 1 - ((3/4)) ((2/3)) = (1/2) 
                             
 p((Subscript[F, B])|(Subscript[L, 1]),I) = 1 - p( (Subscript[M, 2]),(Subscript[M, 3])|(Subscript[L, 1]),I)  
 
 By exchangeability    p( (Subscript[M, 2]),(Subscript[M, 3])|(Subscript[L, 1]),I) = p( (Subscript[M, 1]),(Subscript[M, 2])|(Subscript[L, 1]),I)    
 
  p((Subscript[F, B])|(Subscript[L, 1]),I) = 1 - p( (Subscript[M, 1]),(Subscript[M, 2])|(Subscript[L, 1]),I) =  1 - p( (Subscript[M, 1])|(Subscript[L, 1]),I) p( (Subscript[M, 2])|(Subscript[M, 1]),(Subscript[L, 1]),I) 
                                                                 =  1 -   ((3/5)) ((2/4)) = (7/10)    
 
 and       p((Subscript[F, 1])|(Subscript[L, 1]),I) = (2/5)     
 
 Therefore   p((Subscript[F, 1])|(Subscript[F, B]),(Subscript[L, 1]),I) = (((2/5) ×(1/2))/(7/10)) = (2/7)                   
 
 Let (Subscript[L, i]) = (Subscript[L, 2]) , the decision made on the (2^nd) draw.

p((Subscript[F, 2])|(Subscript[F, B]),(Subscript[L, 2]),I) = ((p((Subscript[F, 2])|(Subscript[L, 2]),I) p((Subscript[F, B])|(Subscript[F, 2]),(Subscript[L, 2]),I))/(p((Subscript[F, B])|(Subscript[L, 2]),I)))

In this case  (Subscript[F, B]) = (Subscript[F, 1]) + (Subscript[F, 3]),           where  (Subscript[F, 3]) ≡ "a female astronaut picked on the (3^rd) draw."

p((Subscript[F, B])|(Subscript[F, 2]),(Subscript[L, 2]),I) = 1 - p((OverBar[(Subscript[F, B])])|(Subscript[F, 2]),(Subscript[L, 2]),I) = 1 - p((OverBar[(Subscript[F, 1])]),(OverBar[(Subscript[F, 3])])|(Subscript[F, 2]),(Subscript[L, 2]),I)

But  (OverBar[(Subscript[F, 1])]),(OverBar[(Subscript[F, 3])]) = (Subscript[M, 1]), (Subscript[M, 3])

p((Subscript[F, B])|(Subscript[F, 2]),(Subscript[L, 2]),I) = 1 - p( (Subscript[M, 1]),(Subscript[M, 3])|(Subscript[F, 2]),(Subscript[L, 2]),I) = 1 - p( (Subscript[M, 1])|(Subscript[F, 2]),(Subscript[L, 2]),I) p( (Subscript[M, 3])|(Subscript[M, 1]),(Subscript[F, 2]),(Subscript[L, 2]),I)
                             = 1 - ((3/4)) ((2/3)) = (1/2) 
                             
 p((Subscript[F, B])|(Subscript[L, 2]),I) = 1 - p( (Subscript[M, 1]),(Subscript[M, 3])|(Subscript[L, 2]),I)  
 
 By exchangeability    p( (Subscript[M, 1]),(Subscript[M, 3])|(Subscript[L, 2]),I) = p( (Subscript[M, 1]),(Subscript[M, 2])|(Subscript[L, 2]),I)    
 
  p((Subscript[F, B])|(Subscript[L, 2]),I) = 1 - p( (Subscript[M, 1]),(Subscript[M, 2])|(Subscript[L, 2]),I) =  1 - p( (Subscript[M, 1])|(Subscript[L, 1]),I) p( (Subscript[M, 2])|(Subscript[M, 1]),(Subscript[L, 2]),I) 
                                                                 =  1 -   ((3/5)) ((2/4)) = (7/10)    
 
 and       p((Subscript[F, 2])|(Subscript[L, 2]),I) = (2/5)     
 
 Therefore   p((Subscript[F, 2])|(Subscript[F, B]),(Subscript[L, 2]),I) = (((2/5) ×(1/2))/(7/10)) = (2/7)    
 
 Similarly we can show that if  (Subscript[L, i]) = (Subscript[L, 3]) , the decision made on the (3^rd) draw,
 
 that     p((Subscript[F, 3])|(Subscript[F, B]),(Subscript[L, 3]),I) = (2/7).                                         
 
 Therefore  p((Subscript[F, A])|(Subscript[F, B]),I) = (∑_(i=1)^3)p((Subscript[L, i])|(Subscript[F, B]),I)p((Subscript[F, i])|(Subscript[F, B]),(Subscript[L, i]),I)  = (1/3)  ×  (∑_(i=1)^3)  (2/7) =  (2/7).

Ch. 5: Problem 4

Random number generation

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["HypothesisTesting`"]

Make a table of 10000 random numbers with a BetaDistribution[2,4]

dist=BetaDistribution[2,4];

ran=Table[Random[dist],{10000}];

rantot=Plus@@ran

binIncrement=0.05;ybin=BinCounts[ran,{0,1,binIncrement}]

xbin=Table[N[(i/20)-(1/40)],{i,1,20}];

ranpl=Transpose[{xbin,(ybin/(binIncrement*Total[ybin]))}];

pla=ListPlot[ranpl,Frame->True,PlotJoined->True,PlotStyle->{Thick},FrameLabel->{Style["x",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compare distribution of random numbers to BetaDistribution[2,4]

plBeta=Plot[PDF[dist,x],{x,0,1},Frame->True,PlotRange->All,PlotStyle->{Black,Dashing[{0.01,0.01}],Thick},FrameLabel->{Style["x",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Show[plBeta,pla]

Ch. 5: Problem 5

Demonstration of Central Limit Theorem

According to the Central Limit Theorem the probability distribution of the average of m independent measurements of some quantity tends to a gaussian as m increases regardless of the probability distribution of individual measurements of the quantity, provided it has a finite variance. We will use an FFT implementation of convolution to compute the PDF of an average of m samples, following the example given in the text in chapter 5.

In this notebook we will assume the probability distribution of the individual measurements is
a BetaDistribution[2,4].

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["HypothesisTesting`"]

Needs["PlotLegends`"]

Create a zero padded BetaDistribution for convolving

Create pr1 = a PDF in the interval 0 to 1 for a BetaDistribution[6,2].
Represent the distribution by n points with the Table command.

dist=BetaDistribution[2,4];

n=64;

d1=Table[N[PDF[dist,(((x-1))/64.0)]],{x,n}];

Need zero  padding for Fourier convolution (use ntot=512 points for m up to 8)

ntot=512;

f[x_]:=Which[x≥1&&x≤ntot-n,0.0000000];

d2=Table[N[f[x]],{x,ntot-n}];

Concatenate the two tables

pr1=Join[d1,d2];

ListPlot[pr1]

Set up a list of x values for the probability distribution

dx1=1.0/n;

xdata1=Table[(i-1)*dx1,{i,ntot}];

data1=Transpose[{xdata1,pr1}];

The area under the PDF pr1 is obtained by summing pr1 and multiplying by dx1.

area1=Plus@@pr1*dx1

The mean of the probability distribution is equal to the sum of the product of the 
x values and the corresponding probability times the increment dx1.

mean1=Plus@@(xdata1*pr1)*dx1

var1=Plus@@((((xdata1-mean1))^2)*pr1)*dx1

sigma1=(Sqrt[var1])

Now create a label for the x axis for plotting purposes.

xlabel=
StyleForm[StringForm["``",
StyleForm["x",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->18]

Plot the PDF.

pl1=ListPlot[data1,PlotRange->{{0,1.},Automatic},Frame->True,Axes->{True,False},FrameLabel->{Style[xlabel,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",16}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Evaluate convolution for m = 3 case

conv3=InverseFourier[Fourier[pr1]*Fourier[pr1]*Fourier[pr1]];

Set up a list of x values for the new probability distribution

m=3;

dx3=1.0/(m*n);

xdata3=Table[(i-1)*dx3,{i,ntot}];

Compute the normalization constant k3 to convert conv3 to a a normalized PDF pr3.
It insures the area under pr3 = 1.

k3=1.0/(Plus@@Re[conv3]*dx3)

pr3=k3*Re[conv3];

ave3=Transpose[{xdata3,pr3}];

area3= Plus@@pr3*dx3

mean3=Plus@@(xdata3*pr3)*dx3

var3=Plus@@((((xdata3-mean3))^2)*pr3)*dx3

sigma3=(Sqrt[var3])

Plot the probability distribution of the average of two points

pl3=ListPlot[ave3,PlotRange->{{0,1.},All},Frame->True,Axes->{True,False},FrameLabel->{Style[xlabel,{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",16}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Evaluate convolution for m = 5 case

conv5=InverseFourier[Fourier[pr1]*Fourier[pr1]*Fourier[pr1]*Fourier[pr1]*Fourier[pr1]];

Set up a list of x values for the new probability distribution

m=5;

dx5=1.0/(m*n);

xdata5=Table[(i-1)*dx5,{i,ntot}];

Compute the normalization constant k5 to convert conv5 to a a normalized PDF pr5.
It insures the area under pr5 = 1.

k5=1.0/(Plus@@Re[conv5]*dx5)

pr5=k5*Re[conv5];

ave5=Transpose[{xdata5,pr5}];

area5= Plus@@pr5*dx5

mean5=Plus@@(xdata5*pr5)*dx5

var5=Plus@@((((xdata5-mean5))^2)*pr5)*dx5

sigma5=(Sqrt[var5])

Plot the probability distribution of the average of four points

pl5=ListPlot[ave5,PlotRange->{{0,1.},All},Frame->True,Axes->{True,False},FrameLabel->{Style[xlabel,{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",16}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Evaluate convolution for m = 6 case

conv6=InverseFourier[Fourier[pr1]*Fourier[pr1]*Fourier[pr1]*Fourier[pr1]*Fourier[pr1]*Fourier[pr1]];

Set up a list of x values for the new probability distribution

m=6;

dx6=1.0/(m*n);

xdata6=Table[(i-1)*dx6,{i,ntot}];

Compute the normalization constant k6 to convert conv6 to a a normalized PDF pr6.
It insures the area under pr6 = 1.

k6=1.0/(Plus@@Re[conv6]*dx6)

pr6=k6*Re[conv6];

ave6=Transpose[{xdata6,pr6}];

area6= Plus@@pr6*dx6

mean6=Plus@@(xdata6*pr6)*dx6

var6=Plus@@((((xdata6-mean6))^2)*pr6)*dx6

sigma6=(Sqrt[var6])

Plot the probability distribution of the average of six points

pl6=ListPlot[ave6,PlotRange->{{0,1.},All},Frame->True,Axes->{True,False},PlotJoined->True,FrameLabel->{Style[xlabel,{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",16}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Evaluate convolution for m = 8 case

conv8=InverseFourier[Fourier[pr1]*Fourier[pr1]*Fourier[pr1]*Fourier[pr1]*Fourier[pr1] *Fourier[pr1]*Fourier[pr1]*Fourier[pr1]];

Set up a list of x values for the new probability distribution

m=8;

dx8=1.0/(m*n);

xdata8=Table[(i-1)*dx8,{i,ntot}];

Compute the normalization constant k8 to convert conv8 to a a normalized PDF pr8.
It insures the area under pr8 = 1.

k8=1.0/(Plus@@Re[conv8]*dx8)

pr8=k8*Re[conv8];

ave8=Transpose[{xdata8,pr8}];

area8= Plus@@pr8*dx8

mean8=Plus@@(xdata8*pr8)*dx8

var8=Plus@@((((xdata8-mean8))^2)*pr8)*dx8

sigma8=(Sqrt[var8])

Plot the probability distribution of the average of six points

pl8=ListPlot[ave8,PlotRange->{{0,1.},All},Frame->True,Axes->{True,False},PlotJoined->True,FrameLabel->{Style[xlabel,{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",16}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plall=Show[pl8,pl5,pl3,pl1,Graphics[{Text[StyleForm["n=1",FontSize->11,FontWeight->"Bold"],{0.75,2.7}],Arrow[{0.68,2.45},{0.55,1.1},HeadLength->0.03],Text[StyleForm["n=3",FontSize->11,FontWeight->"Bold"],{0.55,3.8}],Arrow[{0.48,3.9},{0.34,3.75},HeadLength->0.03],Text[StyleForm["n=5",FontSize->11,FontWeight->"Bold"],{0.55,5.}],Arrow[{0.48,5.},{0.33,5.},HeadLength->0.03],Text[StyleForm["n=8",FontSize->11,FontWeight->"Bold"],{0.55,6.0}],Arrow[{0.48,6.0},{0.34,6.3},HeadLength->0.03]}],FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

For each m, compare mean, variance and σ of the PDF.

l0={{"m","mean","variance","σ"},{"","",""," "}};

l1={{1,mean1,var1,sigma1}};

l3={{3,mean3,var3,sigma3}};

l5={{5,mean5,var5,sigma5}};

l8={{8,mean8,var8,sigma8}};

smj=MatrixForm[Join[l0,l1,l3,l5,l8]]

Compare m=5 case to Gaussian with same mean and var.

Compute the variance of convolved distribution for comparison
with a gaussian of same mean and standard deviation.  m = 5 case

m=5;

plgauss5=Plot[PDF[NormalDistribution[mean5,sigma5],x],{x,0,1},PlotStyle->{Black,Dashing[{0.015,0.015}],Thick},PlotRange->{{0,1.0},All}]

Show[pl5,plgauss5,PlotRange->{{0,1.},All},Frame->True,Axes->False,FrameLabel->{Style[xlabel,{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compare m=8 case to Gaussian with same mean and var.

Compute the variance of convolved distribution for comparison
with a gaussian of same mean and standard deviation.  m=8 case

plgauss8=Plot[PDF[NormalDistribution[mean8,sigma8],x],{x,0,1},PlotStyle->{Thickness[0.005],Dashing[{0.015,0.015}]},PlotRange->{{0,1.0},All}]

plcompare=Show[plgauss8,pl8,PlotRange->{{0,1.},All},Frame->True,Axes->False,FrameLabel->{Style[xlabel,{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plboth=Show[GraphicsArray[{{plall,plcompare}},GraphicsSpacing->{-0.1,0}],DisplayFunction->$DisplayFunction]

Ch. 7: Problem 1

Comparing two data sets using frequentist methods

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["HypothesisTesting`"]

Data

d1  is  location 1 toxin level data  and  d2  is location 2 data.

d1={13.2,13.8,8.7,9.0,8.6,9.9,14.2,9.7,10.7,8.3,8.5,9.2};

d2={8.9,9.1,8.3,6.0,7.7,9.9,9.9,8.9};

We use a two-sided hypothesis test because we would reject the null hypothesis that the population variances are equal if the variance at location 1 is greater or less than the variance at location 2.

VarianceRatioTest[d1,d2,1.0,TwoSided->True,FullReport->True]

Since the P-value = 0.168915 is greater than 0.05, we fail to reject the hypothesis that the the population variances at the two locations are equal at the 95% confidence level.

Ch. 7: Problem 2

Comparing two data sets using frequentist methods

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["HypothesisTesting`"]

Data

d1  is  location 1 toxin level data  and  d2  is location 2 data.

d1={17.1,11.1,12.6,12.1,5.9,7.7,10.5,15.3,10.5,10.5};

d2={7.0,12.0,6.8,9.3,8.9,9.4,9.6,7.6};

n1=Length[d1];n2=Length[d2];

N[Variance[d1]]

N[Variance[d2]]

Find the 95% confidence limits for the means and variances of the two data sets.

MeanCI[d1,ConfidenceLevel->0.95]
MeanCI[d2,ConfidenceLevel->0.95]
VarianceCI[d1,ConfidenceLevel->0.95]
VarianceCI[d2,ConfidenceLevel->0.95]

Do a two-sided hypothesis test to decide whether both samples are from 
populations with the same variance.

fratio=N[Variance[d1]/Variance[d2]]

FRatioPValue[fratio,n1-1,n2-1,TwoSided->True]

Alternate to FRatioTest is VarianceRatioTest

VarianceRatioTest[d1,d2,1,TwoSided->True,FullReport->True]

Conclusion: we can't reject the probability that the two populations have different variances.

Do a two-sided hypothesis test to decide at what confidence level you can reject the null hypothesis that the two samples are from populations with the same mean.

a) Assuming equal but unknown population variances

MeanDifferenceTest[d1,d2,0,EqualVariances->True,TwoSided->True,
FullReport->True]

b) Assuming different population variances

MeanDifferenceTest[d1,d2,0,EqualVariances->False,TwoSided->True,
FullReport->True]

Alternatively compute answer with

sp=N[(Sqrt[Variance[d1]/n1+Variance[d2]/n2])]

def=N[((((Variance[d1]/n1+Variance[d2]/n2))^2)/(((((Variance[d1]/n1))^2)/(n1-1))+((((Variance[d2]/n2))^2)/(n2-1))))]

n2

tstat=((Mean[d1]-Mean[d2])/sp)

StudentTPValue[tstat,def,TwoSided->True]

Ch. 7: problem 4

(χ^2) Test of Random Numbers:  are they uniformily distributed?

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["HypothesisTesting`"]

Generate the random numbers

no=50000

ran=Table[Random[ ],{no}];

Bin the numbers and compute the Pearson goodness-of-fit statistic
and confidence in rejecting null hypothesis.

n=500;cnts=BinCounts[ran,{0,1,1/n}];

Specify the predicted count in each bin for the assumed uniform distribution.

predcnts=N[no/n]

Compute the Pearson (χ^2) test statistic.

chi2terms=(((((cnts-predcnts))^2)/predcnts));

chi2=Plus@@chi2terms

Confidence in rejecting the null hypothesis (use a one-tailed test because the alternate hypothesis
is that the distribution is nonuniform which would lead to higher values of (χ^2)) is given by:

conf=1-GammaRegularized[((n-1)/2),(chi2/2)]

Compare with confidence in rejecting the null hypothesis using the ChiSquarePValue command.
Recall this command has a maximum value of  0.5 before measuring the area in the opposite tail.

1-ChiSquarePValue[chi2,n-1][[2]]

Ch. 8: Problem 3

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["HypothesisTesting`"]

The form of the MaxEnt probability distribution  with ⟨Cos[y]⟩ = 0.6 constraint

From equ. 8.41 of Section 8.7.3, it is clear that the MaxEnt form of  p(y|I) = m(y) (e^(-(Subscript[λ, 0]) )) (e^(-λ Cos[y] )) . 

We take as given m(y) = constant between 0 & 2 π and 0 outside this range, therefore m(y) = (1/(2 π)) 

Therefore    p(y|I) =((e^(-(Subscript[λ, 0]) ))/(2 π)) (e^(-λ  Cos[y]))dy

Make use of first constraint (∫_0^(2 π))p(y)dy = 1, to evaluate (e^(-(Subscript[λ, 0]) ))

∫p(y|I)dy  =((e^(-(Subscript[λ, 0]) ))/(2 π))(∫_0^(2 π)) (e^(-λ  Cos[y]))dy = 1

int1=(∫_0^(2 π)) (E^(-λ  Cos[y]))\[DifferentialD]y

Therefore ((e^(-(Subscript[λ, 0]) ))/(2 π))2 π BesselI[0,λ] = 1   or  (e^(-(Subscript[λ, 0]) ))= 1/ BesselI[0,λ]

Now we can write    p(y|I) = (1/(2 π BesselI[0,λ]))(e^(-λ Cos[y] )) .

Make use of second constraint  (∫_0^(2 π))Cos[y] p(y)dy = 0.6

(∫_0^(2 π))Cos[y] p(y)dy = (∫_0^(2 π))Cos[y]  ((1^( ))/(2 π BesselI[0,λ]))(e^(-λ Cos[y] ))dy

int2= (∫_0^(2 π))Cos[y] (E^(-λ  Cos[y]))\[DifferentialD]y

Therefore (∫_0^(2 π))Cos[y] p(y)dy = (∫_0^(2 π))Cos[y]  ((1^( ))/(2 π BesselI[0,λ]))(e^(-λ Cos[y] ))dy  =(( -2 π BesselI[1,λ])/(2 π BesselI[0,λ]))=  0.6

Graphical solution for λ based on -BesselI[1,λ]/ BesselI[0,λ] == 0.6
or BesselI[1,λ]/ BesselI[0,λ] == -0.6.

p1=Plot[BesselI[1,λ]/BesselI[0,λ],{λ,-5,5},Frame->True,	FrameLabel->{Style["λ",{"Helvetica-Bold",12}],
		Style["",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Now plot the line y = -0.6.

p2=Graphics[{Thickness[0.001],Line[{{-5,-0.6},{5.,-0.6}}]}]

Show[p1,p2]

From the graph the intersection of the two curves is close to λ = -1.5.

Find λ using FindRoot command

lambda=FindRoot[-BesselI[1,λ]/ BesselI[0,λ]==0.6,{λ,-1.5}]

lambda[[1,2]]

py=((E^(-lambda[[1,2]] Cos[y] ))/(2π BesselI[0,lambda[[1,2]]]))

Plot the solution for p(y)

pl1=Plot[py,{y,0,2 π},PlotRange->{{0,2 π},{0,0.5}},Frame->True,	FrameLabel->{Style["y",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Ch. 9: Problem 3

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["HypothesisTesting`"]

Read in Data

Program assumes there are two data files with the same prefix followed by .1  or .2  . To use the commands below to read them in you need to remove the (*   *) braces on the two commands on lines 3 and 4 below. For now we include lines 6 and 7 which define two samples.

fileprefix="riverB";

(*d1=Flatten[ReadList[directory<>fileprefix<>".1",Number,RecordLists->True]]*)

(*d2=Flatten[ReadList[directory<>fileprefix<>".2",Number,RecordLists->True]]*)

d1={17.1,11.1,12.6,12.1,5.9,7.7,10.5,15.3,10.5,10.5};

d2={7.0,12.0,6.8,9.3,8.9,9.4,9.6,7.6};

n1=Length[d1]

n2=Length[d2]

n=n1+n2

Compute the average of the 1st data set

d1bar=Plus@@d1/n1

Compute the average of the 2nd data set

d2bar=Plus@@d2/n2

Compute the average of the combined data set

dbar=(Plus@@d1+Plus@@d2)/n

Compute the mean square average of the 1st data set

d1squbar=Plus@@(d1 d1)/n1

Compute the mean square average of the 2nd data set

d2squbar=Plus@@(d2 d2)/n2

Compute the mean square average of the combined data set

dsqubar=(Plus@@(d1 d1)+Plus@@(d2 d2))/n

Neater way of computing the above using a vector dot product

(d1.d1+d2.d2)/n

Compute the standard deviation of the 1st data set

d1std=StandardDeviation[d1]

Compute the standard deviation of the 2nd data set

d2std=StandardDeviation[d2]

Compute the standard deviation of the combined data set

dstd=StandardDeviation[Join[d1,d2]]

Input priors and no. of steps in evaluation of p(r|(Subscript[D, 1]),(Subscript[D, 2]),I) & p(δ|(Subscript[D, 1]),(Subscript[D, 2]),I)

nδ=100;nr=100;

nδ = number of steps in δ parameter
nr = number of steps in r parameter

Set prior limits (assumed the same for each data set) on mean  (low,high), and 
 prior limits  (assumed the same for each data set) on the standard deviation  (σlow, σhigh).

high=18;low=1;Ra=high-low;

σhigh=12;σlow=0.1;Rσ=σhigh/σlow;

Setup convenient abbreviations

We are interested in computing the 4 fundamental probabilities  
    p(C,S|(Subscript[D, 1]),(Subscript[D, 2]),I)
    p(C,(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)
    p((OverBar[C]),S|(Subscript[D, 1]),(Subscript[D, 2]),I)
    p((OverBar[C]),(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)

Expressions for these are given in Appendix C of the text, in particular equations C.9, C.18, C.20, & C.25. 
All these equations contain a common factor  K=1/p((Subscript[D, 1]),(Subscript[D, 2])|I). 
It is convenient to eliminate K so we define
    pCSK = p(C,S|(Subscript[D, 1]),(Subscript[D, 2]),I)/K = p(C,S|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I) 
    pCSbarK =p(C,(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)/K = p(C,(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)
    pCbarSK =p((OverBar[C]),S|(Subscript[D, 1]),(Subscript[D, 2]),I)/K = p((OverBar[C]),S|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)
    pCbarSbarK =p((OverBar[C]),(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)/K = p((OverBar[C]),(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

Compute  pCSK =  p(C,S|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

According to the formulas given in text (see Appendix C  entitled: "Difference in Two Samples").

z=n (dsqubar-(((dbar))^2))

uH=(Sqrt[(n/2)])(high-dbar)

uL=(Sqrt[(n/2)])(low-dbar)

sign=-Sign[(uH/uL)]

fnc1[σ1_]:=(( (((2 π))^(-n/2)) (Sqrt[(π/(2 n))]))/(4 Ra Log[Rσ]))((σ1)^(-n))(E^(-(z/(2 ((σ1)^2))))) (Erf[(uH/(σ1))] - Erf[(uL/(σ1))])

pCSK=NIntegrate[fnc1[σ1],{σ1,σlow,σhigh}]

Compute  pCSbarK = p(C,(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

u1A=(n1/2)(d1squbar-2 A d1bar +(A^2))

u2A=(n2/2)(d2squbar-2 A d2bar +(A^2))

fnc2[A_]:=(( (((2 π))^(-n/2))Gamma[(n1/2)] Gamma[(n2/2)] )/(16 Ra (((Log[Rσ]))^2)))(u1A^(-(n1/2)))(u2A^(-(n2/2)))(GammaRegularized[(n1/2),(u1A/((σhigh)^2))]- GammaRegularized[(n1/2),(u1A/((σlow)^2))])(GammaRegularized[(n2/2),(u2A/((σhigh)^2))]- GammaRegularized[(n2/2),(u2A/((σlow)^2))])

pCSbarK=NIntegrate[fnc2[A],{A,low,high}]

Compute  pCbarSK = p((OverBar[C]),S|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

z1=n1 (d1squbar-(((d1bar))^2))

u1H=(Sqrt[(n1/2)])(high-d1bar)

u1L=(Sqrt[(n1/2)])(low-d1bar)

z2=n2 (d2squbar-(((d2bar))^2))

u2H=(Sqrt[(n2/2)])(high-d2bar)

u2L=(Sqrt[(n2/2)])(low-d2bar)

sign1=-Sign[(u1H/( u1L))]

sign2=-Sign[(u2H/( u2L))]

fnc3[σ1_]:=(( (((2 π))^(-n/2))π)/(8 (((Ra))^2) Log[Rσ] (Sqrt[n1 n2])))((σ1)^(-n+1))(E^(-(((z1+z2))/(2 ((σ1)^2)))))(Erf[(u1H/(σ1))] - Erf[(u1L/(σ1))])(Erf[(u2H/(σ1))] - Erf[(u2L/(σ1))])

pCbarSK=NIntegrate[fnc3[σ1],{σ1,σlow,σhigh}]

Compute  pCbarSbarK = p((OverBar[C]),(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

sign1=-Sign[(u1H/( u1L))]

sign2=-Sign[(u2H/( u2L))]

fnc4A[σ1_]:=((σ1)^(-n1)) (E^(-(z1/(2 ((σ1)^2)))))(Erf[(u1H/(σ1))] - Erf[(u1L/(σ1))])

pCbarSbarKA=NIntegrate[fnc4A[σ1],{σ1,σlow,σhigh}]

fnc4B[σ2_]:=((σ2)^(-n2)) (E^(-(z2/(2 ((σ2)^2)))))(Erf[(u2H/(σ2))] - Erf[(u2L/(σ2))])

pCbarSbarKB=NIntegrate[fnc4B[σ2],{σ2,σlow,σhigh}]

pCbarSbarK=(( (((2 π))^(-n/2))π ×pCbarSbarKA ×pCbarSbarKB)/(8 (((Ra))^2) (((Log[Rσ]))^2)  (Sqrt[n1 n2])))

Compute p((Subscript[D, 1]),(Subscript[D, 2])|I) and the normalized probabilities

tot = pCSK+pCSbarK+pCbarSK+pCbarSbarK = (([p((Subscript[D, 1]),(Subscript[D, 2])|I)])^2)

tot=pCSK+pCSbarK+pCbarSK+pCbarSbarK

pCS = probability that the means &  standard  deviations are the same

pCS=pCSK/tot

pCSbar = probability that the means are the same &  standard  deviations are different

pCSbar=pCSbarK/tot

pCbarS = probability that the means are different &  standard  deviations are the same

pCbarS=pCbarSK/tot

pCbarSbar = probability that the means  &  standard  deviations are different

pCbarSbar=pCbarSbarK/tot

pC = probability that the means are the same independent of whether the standard deviations are the same or different

pC=pCS+pCSbar

psbar = probability that the means are different  independent of whether the standard deviations are the same or different

pCbar=pCbarS+pCbarSbar

Odds in favor of different means

oddsbars=pCbar/pC

pS = probability that the standard deviations are the same  independent of whether the means are the same or different

pS=pCS+pCbarS

pSbar = probability that the standard deviations are different  independent of whether the means are the same or different

pSbar=pCSbar+pCbarSbar

Odds in favor of different standard deviations

oddvbarv=pSbar/pS

Odds in favor of different means and/or standard deviations

odddiff=(1-pCS)/pCS

l1a={{""," Data Summary","",""},{"","","",""},{" No.","Standard Deviation"," Mean","Data set"},{"_____","__________________","_______","_________"},{n1,d1std,d1bar,fileprefix<>".1"},{n2,d2std,d2bar,fileprefix<>".2"},{n1+n2,dstd,dbar,"combined"}};

TableForm[l1a]

l1b={{"          Numerical Example","Value"},{"__________________________________________","___________"},{"Prior mean lower bound",low},{"prior mean upper bound",high},{"Prior standard deviation lower bound",σlow},{"Prior standard deviation upper bound",σhigh},{"",""},{"Number of steps for plotting p(δ|(Subscript[D, 1]),(Subscript[D, 2]),I)",nδ},{"Number of steps for plotting p(r|(Subscript[D, 1]),(Subscript[D, 2]),I)",nr},{"",""},{"                 Model","Probability"},{"__________________________________________","___________"},{"Same mean, same standard deviation",pCS},{"Different means, same standard deviation",pCbarS},{"Same mean, different standard deviation",pCSbar},{"Different means, different standard deviations",pCbarSbar},{"",""},{"Means are the same",pC},
{"Means are the different",pCbar},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[oddsbars*100]/100]]},{"",""},{"Standard deviations are the same",pS},{"Standard deviations are different",pSbar},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[oddvbarv*100]/100]]},{"",""},{"Same means and standard deviations",pCS},{"One or both are different",1-pCS},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[odddiff*100]/100]]}};

TableForm[l1b]

The difference in the means  ( δ)

p(δ|S,D1,D2,I)  problem

This section computes and plots the posterior probability density for the difference in the two means assuming the standard deviations are the same.

δlow=low-high;δhi=high-low;δdelta=(δhi-δlow)/(nδ-1);βlo=2 low;βhi=2 high;Δ=((n1-n2)/n);b=((n1 d1bar - n2 d2bar)/(2 n));V=(n/2) (dsqubar-2 δ b - β dbar +((β^2)/4)+((δ^2)/4)+((δ β Δ)/2));fndbV=((Gamma[n/2])/(8 (((Ra))^2) Log[Rσ]))*(V^(-n/2)) (GammaRegularized[n/2,V/((σhigh)^2)]-GammaRegularized[n/2,V/((σlow)^2)]);pdel=Table[NIntegrate[fndbV,{β,βlo,βhi}],{δ,δlow,δhi,δdelta}];pdelA=pdel/(δdelta*Plus@@pdel);xdel=Table[δ,{δ,δlow,δhi,δdelta}];xdA=Transpose[{xdel,pdelA}];
ListPlot[xdA,PlotJoined->True,Frame->True,Axes->False,PlotRange->All,PlotStyle->Black,FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["p(δ | v,(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(δ | (Overscript[S, -]),D1,D2,I)  problem

This section computes and plots the posterior probability density for the difference in the two means assuming the standard deviations are different.

δlow=low-high;δhi=high-low;δdelta=(δhi-δlow)/(nδ-1);βlo=2 low;βhi=2 high;w1=(n1/2) (d1squbar-(β+δ) d1bar+((((β+δ))^2)/4) );w2=(n2/2) (d2squbar-(β-δ) d2bar+((((β-δ))^2)/4) );fndbVbar=((Gamma[n1/2]Gamma[n2/2])/(16 (((Ra))^2) (((Log[Rσ]))^2)))*(w1^(-n1/2))  (w2^(-n2/2)) (GammaRegularized[n1/2,w1/((σhigh)^2)]-GammaRegularized[n1/2,w1/((σlow)^2)]) (GammaRegularized[n2/2,w2/((σhigh)^2)]-GammaRegularized[n2/2,w2/((σlow)^2)]);pdel=Table[NIntegrate[fndbVbar,{β,βlo,βhi}],{δ,δlow,δhi,δdelta}];pdelB=pdel/(δdelta*Plus@@pdel);xdel=Table[δ,{δ,δlow,δhi,δdelta}];xdB=Transpose[{xdel,pdelB}];ListPlot[xdB,PlotJoined->True,Frame->True,Axes->False,PlotRange->All,FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["p(δ | (Overscript[S, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(δ | D1,D2,I)

This section computes and plots the posterior probability density for the difference in the two means 
independent of whether the standard deviations are the same. It is a weighted average of  p(δ|S,D1,D2,I) and 
p(δ | (Overscript[S, -]),D1,D2,I) where the weights are pS and pSbar, the probability that the standard deviations are the same or different, respectively.

The code also computes the 95% credible region and the 99.5% credible region. The latter is used to choose suitable boundaries for plotting purposes so only the region with significant probability is displayed.

pdelave=(pS*pdelA+pSbar*pdelB);pdelave=pdelave/Plus@@pdelave;rxd=Transpose[{pdelave,xdel}];δpeak=Sort[rxd][[nδ,2]];δmean=pdelave.xdel;sortrxd=Sort[rxd];δmin=δhi;δmax=δlow;area=0.0;j=0;nδi=nδ;While[area≤0.95,
area=area+ sortrxd[[nδi,1]];
If[sortrxd[[nδi,2]]>δmax,δmax=sortrxd[[nδi,2]],Null];
If[sortrxd[[nδi,2]]<δmin,δmin=sortrxd[[nδi,2]],Null];nδi=nδi-1];δbmin=δmin;δbmax=δmax;While[area≤0.995&&nδi>0,
area=area+ sortrxd[[nδi,1]];
If[sortrxd[[nδi,2]]>δbmax,δbmax=sortrxd[[nδi,2]],Null];
If[sortrxd[[nδi,2]]<δbmin,δbmin=sortrxd[[nδi,2]],Null];nδi=nδi-1];pdelwta=Sort[RotateLeft[Take[sortrxd,{nδi+1,nδ}],{0,1}]];tr=Transpose[pdelwta];pdelwt=Transpose[{tr[[1]],tr[[2]]/δdelta}];pdelx=tr[[1]];xdAsub={};Do[If[Length[Intersection[{xdA[[i,1]]},pdelx]]>0,xdAsub=Append[xdAsub,xdA[[i]]],Null],{i,1,nδ}];xdBsub={};Do[If[Length[Intersection[{xdB[[i,1]]},pdelx]]>0,xdBsub=Append[xdBsub,xdB[[i]]],Null],{i,1,nδ}];
nδ
nδi
area
δpeak
δmean
δmin
δmax

Here we plot  p(δ | v,D1,D2,I),  p(δ | (Overscript[v, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak δ, average δ and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

plδ=ListPlot[{pdelwt,xdAsub,xdBsub},Joined->True,Frame->True,PlotMarker->{Automatic},Axes->False,PlotStyle->{Red,Green,Black},	PlotLegend->{"average","p(δ|S,(Subscript[D, 1]),(Subscript[D, 2]),I)","p(δ|(Overscript[S, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)"},
	LegendPosition->{-0.3,-0.35},LegendSpacing->0,
	LegendTextSpace->2,LegendBorderSpace->0.1,
	LegendSize->{0.6,0.25},
	LegendShadow->{0.02,-0.02},PlotLabel->Style["Peak δ ="<>ToString[N[Round[δpeak*100]/100]]<>" ; Mean δ ="<> ToString[N[Round[δmean*100]/100]]<>" ; 95% lower δ="<>ToString[N[Round[δmin*100]/100]]<>" ; 95% upper δ="<>ToString[N[Round[δmax*100]/100]],{"Helvetica-Bold",11}],FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

The ratio of the standard deviations   (r)

p(r|C,D1,D2,I) problem

This section computes and plots the posterior probability density for the ratio of the standard deviations 
assuming the means are the same. Change scaleL and/or scaleH to adjust lower and upper ends of the plot along the x axis.

scaleL =20;scaleH=4;rlow=d1std/(scaleL*d2std);rhi=scaleH*d1std/d2std;rdelta=(rhi-rlow)/(nr-1);AL=low;AH=high;u=((n1 d1squbar)/(r^2))+n2 d2squbar;v=((n1 d1bar)/(r^2))+n2 d2bar;w=(n1/(r^2))+n2;z=u-((v^2)/w);XH=(Sqrt[(w/(2 (σ^2)))])(AH-v/w);XL=(Sqrt[(w/(2 (σ^2)))])(AL-v/w);fnrS=(((((2 π))^(-n/2))(Sqrt[π/(8 w)]))/(Ra (((Log[Rσ]))^2)))*(r^(-(n1+1) ))(σ^(-n))  Exp[-(z/(2 (σ^2)))]  (Erf[XH]-Erf[XL]);pr=Table[NIntegrate[fnrS,{σ,σlow,σhigh}],{r,rlow,rhi,rdelta}];prA=pr/(rdelta*Plus@@pr);xr=Table[r,{r,rlow,rhi,rdelta}];xrA=Transpose[{xr,prA}];ListPlot[xrA,Joined->True,Frame->True,Axes->False,PlotRange->All,FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["p(r | C,(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(r|(Overscript[C, -]),D1,D2,I) problem

This section computes and plots the posterior probability density for the ratio of the standard deviations 
assuming the means are the different. Change scaleL and/or scaleH to adjust lower and upper ends of the plot along the x axis.

scaleL =20;scaleH=4;rlow=d1std/(scaleL*d2std);rhi=scaleH*d1std/d2std;rdelta=(rhi-rlow)/(nr-1);AL=low;AH=high;z1=n1(d1squbar-(d1bar^2));z2=n2(d2squbar-(d2bar^2));X1H=(Sqrt[(n1/(2 (r^2) (σ^2)))])(AH-d1bar);X1L=(Sqrt[(n1/(2 (r^2) (σ^2)))])(AL-d1bar);X2H=(Sqrt[(n2/(2 (σ^2)))])(AH-d2bar);X2L=(Sqrt[(n2/(2 (σ^2)))])(AL-d2bar);fnrSb=(((((2 π))^(-n/2)) π)/(4(((Ra))^2) (((Log[Rσ]))^2) (Sqrt[n1 n2])))*(r^(-n1 ))(σ^(1-n))  Exp[-(z1/(2 (r^2) (σ^2)))-(z2/(2 (σ^2)))]  (Erf[X1H]-Erf[X1L]) (Erf[X2H]-Erf[X2L]);pr=Table[NIntegrate[fnrSb,{σ,σlow,σhigh}],{r,rlow,rhi,rdelta}];prB=pr/(rdelta*Plus@@pr);xr=Table[r,{r,rlow,rhi,rdelta}];xrB=Transpose[{xr,prB}];ListPlot[xrB,PlotJoined->True,Frame->True,Axes->False,PlotRange->All,FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["p(r|(Overscript[C, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(r | D1,D2,I)

This section computes and plots the posterior probability density for the ratio of the standard deviations 
independent of whether the means are the same. It is a weighted average of  p(r | C,D1,D2,I) and 
p(r  | (Overscript[C, -]),D1,D2,I) where the weights are pC and pCbar, the probability that the means are the same or different, respectively.

The code computes the 95% credible region. It also computes the 99.9% credible region for choosing a range to plot. The latter is used to choose suitable boundaries for plotting purposes so only the region with significant probability is displayed.

prave=(pC*prA+pCbar*prB);prave=prave/Plus@@prave;rxr=Transpose[{prave,xr}];rpeak=Sort[rxr][[nr,2]];rmean=prave.xr;sortrxr=Sort[rxr];rmin=rhi;rmax=rlow;area=0.0;j=0;nri=nr;While[area≤0.95,
area=area+ sortrxr[[nri,1]];
If[sortrxr[[nri,2]]>rmax,rmax=sortrxr[[nri,2]],Null];
If[sortrxr[[nri,2]]<rmin,rmin=sortrxr[[nri,2]],Null];nri=nri-1];rbmin=rmin;rbmax=rmax;While[area≤0.999&&nri>0,
area=area+ sortrxr[[nri,1]];
If[sortrxr[[nri,2]]>rbmax,rbmax=sortrxr[[nri,2]],Null];
If[sortrxr[[nri,2]]<rbmin,rbmin=sortrxr[[nri,2]],Null];nri=nri-1];prwta=Sort[RotateLeft[Take[sortrxr,{nri+1,nr}],{0,1}]];tr=Transpose[prwta];prwt=Transpose[{tr[[1]],tr[[2]]/rdelta}];prx=tr[[1]];xrAsub={};Do[If[Length[Intersection[{xrA[[i,1]]},prx]]>0,xrAsub=Append[xrAsub,xrA[[i]]],Null],{i,1,nr}];xrBsub={};Do[If[Length[Intersection[{xrB[[i,1]]},prx]]>0,xrBsub=Append[xrBsub,xrB[[i]]],Null],{i,1,nr}];
nr
nri
area
rpeak
rmean
rmin
rmax

Here we plot  p(r | C,D1,D2,I),  p(r | (Overscript[C, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak r, average r and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

plr=ListPlot[{prwt,xrAsub,xrBsub},Joined->True,Frame->True,Axes->False,PlotStyle->{Red,Green,Black},	PlotLegend->{"average","p(r|C,(Subscript[D, 1]),(Subscript[D, 2]),I)","p(r|(Overscript[C, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)"},
	LegendPosition->{0.0,0.25},LegendSpacing->0,
	LegendTextSpace->2,LegendBorderSpace->0.1,
	LegendSize->{0.6,0.25},
	LegendShadow->{0.02,-0.02},PlotLabel->Style["Peak r ="<>ToString[N[Round[rpeak*100]/100]]<>" ; Mean  r ="<> ToString[N[Round[rmean*100]/100]]<>" ; 95% lower  r="<>ToString[N[Round[rmin*100]/100]]<>" ; 95% upper  r="<>ToString[N[Round[rmax*100]/100]],{"Helvetica-Bold",11}],FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Summary

Here we give a table summarizing the data

TableForm[l1a]

Next we give a table summarizing the priors and posterior probabilities.

TableForm[l1b]

Here we plot  p(δ | S,D1,D2,I),  p(δ | (Overscript[S, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak δ, average δ and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

δplots=Show[plδ]

Here we plot  p(r | C,D1,D2,I),  p(r | (Overscript[C, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak r, average r and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

rplots=Show[plr]

Following command will output the above graph as an EPS files with Mathematica fonts included.  (Note you need to remove the outer (*  *) braces to make the command active.

(*Export["c:/greg1/book/fig_rplots.eps", rplots,ImageSize->72*6]*)

Part 2

Input priors and no. of steps in evaluation of p(r|(Subscript[D, 1]),(Subscript[D, 2]),I) & p(δ|(Subscript[D, 1]),(Subscript[D, 2]),I)

nδ=100;nr=100;

nδ = number of steps in δ parameter
nr = number of steps in r parameter

Set prior limits (assumed the same for each data set) on mean  (low,high), and 
 prior limits  (assumed the same for each data set) on the standard deviation  (σlow, σhigh).

high=13;low=7;Ra=high-low;

σhigh=4;σlow=1;Rσ=σhigh/σlow;

Compute  pCSK =  p(C,S|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

According to the formulas given in text (see Appendix C  entitled: "Difference in Two Samples").

z=n (dsqubar-(((dbar))^2))

uH=(Sqrt[(n/2)])(high-dbar)

uL=(Sqrt[(n/2)])(low-dbar)

sign=-Sign[(uH/uL)]

fnc1[σ1_]:=(( (((2 π))^(-n/2)) (Sqrt[(π/(2 n))]))/(4 Ra Log[Rσ]))((σ1)^(-n))(E^(-(z/(2 ((σ1)^2))))) (Erf[(uH/(σ1))] - Erf[(uL/(σ1))])

pCSK=NIntegrate[fnc1[σ1],{σ1,σlow,σhigh}]

Compute  pCSbarK = p(C,(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

u1A=(n1/2)(d1squbar-2 A d1bar +(A^2))

u2A=(n2/2)(d2squbar-2 A d2bar +(A^2))

fnc2[A_]:=(( (((2 π))^(-n/2))Gamma[(n1/2)] Gamma[(n2/2)] )/(16 Ra (((Log[Rσ]))^2)))(u1A^(-(n1/2)))(u2A^(-(n2/2)))(GammaRegularized[(n1/2),(u1A/((σhigh)^2))]- GammaRegularized[(n1/2),(u1A/((σlow)^2))])(GammaRegularized[(n2/2),(u2A/((σhigh)^2))]- GammaRegularized[(n2/2),(u2A/((σlow)^2))])

pCSbarK=NIntegrate[fnc2[A],{A,low,high}]

Compute  pCbarSK = p((OverBar[C]),S|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

z1=n1 (d1squbar-(((d1bar))^2))

u1H=(Sqrt[(n1/2)])(high-d1bar)

u1L=(Sqrt[(n1/2)])(low-d1bar)

z2=n2 (d2squbar-(((d2bar))^2))

u2H=(Sqrt[(n2/2)])(high-d2bar)

u2L=(Sqrt[(n2/2)])(low-d2bar)

sign1=-Sign[(u1H/( u1L))]

sign2=-Sign[(u2H/( u2L))]

fnc3[σ1_]:=(( (((2 π))^(-n/2))π)/(8 (((Ra))^2) Log[Rσ] (Sqrt[n1 n2])))((σ1)^(-n+1))(E^(-(((z1+z2))/(2 ((σ1)^2)))))(Erf[(u1H/(σ1))] - Erf[(u1L/(σ1))])(Erf[(u2H/(σ1))] - Erf[(u2L/(σ1))])

pCbarSK=NIntegrate[fnc3[σ1],{σ1,σlow,σhigh}]

Compute  pCbarSbarK = p((OverBar[C]),(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)×p((Subscript[D, 1]),(Subscript[D, 2])|I)

sign1=-Sign[(u1H/( u1L))]

sign2=-Sign[(u2H/( u2L))]

fnc4A[σ1_]:=((σ1)^(-n1)) (E^(-(z1/(2 ((σ1)^2)))))(Erf[(u1H/(σ1))] - Erf[(u1L/(σ1))])

pCbarSbarKA=NIntegrate[fnc4A[σ1],{σ1,σlow,σhigh}]

fnc4B[σ2_]:=((σ2)^(-n2)) (E^(-(z2/(2 ((σ2)^2)))))(Erf[(u2H/(σ2))] - Erf[(u2L/(σ2))])

pCbarSbarKB=NIntegrate[fnc4B[σ2],{σ2,σlow,σhigh}]

pCbarSbarK=(( (((2 π))^(-n/2))π ×pCbarSbarKA ×pCbarSbarKB)/(8 (((Ra))^2) (((Log[Rσ]))^2)  (Sqrt[n1 n2])))

Compute p((Subscript[D, 1]),(Subscript[D, 2])|I) and the normalized probabilities

tot = pCSK+pCSbarK+pCbarSK+pCbarSbarK = (([p((Subscript[D, 1]),(Subscript[D, 2])|I)])^2)

tot=pCSK+pCSbarK+pCbarSK+pCbarSbarK

pCS = probability that the means &  standard  deviations are the same

pCS=pCSK/tot

pCSbar = probability that the means are the same &  standard  deviations are different

pCSbar=pCSbarK/tot

pCbarS = probability that the means are different &  standard  deviations are the same

pCbarS=pCbarSK/tot

pCbarSbar = probability that the means  &  standard  deviations are different

pCbarSbar=pCbarSbarK/tot

pC = probability that the means are the same independent of whether the standard deviations are the same or different

pC=pCS+pCSbar

psbar = probability that the means are different  independent of whether the standard deviations are the same or different

pCbar=pCbarS+pCbarSbar

Odds in favor of different means

oddsbars=pCbar/pC

pS = probability that the standard deviations are the same  independent of whether the means are the same or different

pS=pCS+pCbarS

pSbar = probability that the standard deviations are different  independent of whether the means are the same or different

pSbar=pCSbar+pCbarSbar

Odds in favor of different standard deviations

oddvbarv=pSbar/pS

Odds in favor of different means and/or standard deviations

odddiff=(1-pCS)/pCS

l1a={{""," Data Summary","",""},{"","","",""},{" No.","Standard Deviation"," Mean","Data set"},{"_____","__________________","_______","_________"},{n1,d1std,d1bar,fileprefix<>".1"},{n2,d2std,d2bar,fileprefix<>".2"},{n1+n2,dstd,dbar,"combined"}};

TableForm[l1a]

l1b={{"          Numerical Example","Value"},{"__________________________________________","___________"},{"Prior mean lower bound",low},{"prior mean upper bound",high},{"Prior standard deviation lower bound",σlow},{"Prior standard deviation upper bound",σhigh},{"",""},{"Number of steps for plotting p(δ|(Subscript[D, 1]),(Subscript[D, 2]),I)",nδ},{"Number of steps for plotting p(r|(Subscript[D, 1]),(Subscript[D, 2]),I)",nr},{"",""},{"                 Model","Probability"},{"__________________________________________","___________"},{"Same mean, same standard deviation",pCS},{"Different means, same standard deviation",pCbarS},{"Same mean, different standard deviation",pCSbar},{"Different means, different standard deviations",pCbarSbar},{"",""},{"Means are the same",pC},
{"Means are the different",pCbar},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[oddsbars*100]/100]]},{"",""},{"Standard deviations are the same",pS},{"Standard deviations are different",pSbar},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[oddvbarv*100]/100]]},{"",""},{"Same means and standard deviations",pCS},{"One or both are different",1-pCS},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[odddiff*100]/100]]}};

TableForm[l1b]

The difference in the means  ( δ)

p(δ|S,D1,D2,I)  problem

This section computes and plots the posterior probability density for the difference in the two means assuming the standard deviations are the same.

δlow=low-high;δhi=high-low;δdelta=(δhi-δlow)/(nδ-1);βlo=2 low;βhi=2 high;Δ=((n1-n2)/n);b=((n1 d1bar - n2 d2bar)/(2 n));V=(n/2) (dsqubar-2 δ b - β dbar +((β^2)/4)+((δ^2)/4)+((δ β Δ)/2));fndbV=((Gamma[n/2])/(8 (((Ra))^2) Log[Rσ]))*(V^(-n/2)) (GammaRegularized[n/2,V/((σhigh)^2)]-GammaRegularized[n/2,V/((σlow)^2)]);pdel=Table[NIntegrate[fndbV,{β,βlo,βhi}],{δ,δlow,δhi,δdelta}];pdelA=pdel/(δdelta*Plus@@pdel);xdel=Table[δ,{δ,δlow,δhi,δdelta}];xdA=Transpose[{xdel,pdelA}];
ListPlot[xdA,PlotJoined->True,Frame->True,Axes->False,PlotRange->All,PlotStyle->Black,FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["p(δ | v,(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(δ | (Overscript[S, -]),D1,D2,I)  problem

This section computes and plots the posterior probability density for the difference in the two means assuming the standard deviations are different.

δlow=low-high;δhi=high-low;δdelta=(δhi-δlow)/(nδ-1);βlo=2 low;βhi=2 high;w1=(n1/2) (d1squbar-(β+δ) d1bar+((((β+δ))^2)/4) );w2=(n2/2) (d2squbar-(β-δ) d2bar+((((β-δ))^2)/4) );fndbVbar=((Gamma[n1/2]Gamma[n2/2])/(16 (((Ra))^2) (((Log[Rσ]))^2)))*(w1^(-n1/2))  (w2^(-n2/2)) (GammaRegularized[n1/2,w1/((σhigh)^2)]-GammaRegularized[n1/2,w1/((σlow)^2)]) (GammaRegularized[n2/2,w2/((σhigh)^2)]-GammaRegularized[n2/2,w2/((σlow)^2)]);pdel=Table[NIntegrate[fndbVbar,{β,βlo,βhi}],{δ,δlow,δhi,δdelta}];pdelB=pdel/(δdelta*Plus@@pdel);xdel=Table[δ,{δ,δlow,δhi,δdelta}];xdB=Transpose[{xdel,pdelB}];ListPlot[xdB,PlotJoined->True,Frame->True,Axes->False,PlotRange->All,FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["p(δ | (Overscript[S, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(δ | D1,D2,I)

This section computes and plots the posterior probability density for the difference in the two means 
independent of whether the standard deviations are the same. It is a weighted average of  p(δ|S,D1,D2,I) and 
p(δ | (Overscript[S, -]),D1,D2,I) where the weights are pS and pSbar, the probability that the standard deviations are the same or different, respectively.

The code also computes the 95% credible region and the 99.5% credible region. The latter is used to choose suitable boundaries for plotting purposes so only the region with significant probability is displayed.

pdelave=(pS*pdelA+pSbar*pdelB);pdelave=pdelave/Plus@@pdelave;rxd=Transpose[{pdelave,xdel}];δpeak=Sort[rxd][[nδ,2]];δmean=pdelave.xdel;sortrxd=Sort[rxd];δmin=δhi;δmax=δlow;area=0.0;j=0;nδi=nδ;While[area≤0.95,
area=area+ sortrxd[[nδi,1]];
If[sortrxd[[nδi,2]]>δmax,δmax=sortrxd[[nδi,2]],Null];
If[sortrxd[[nδi,2]]<δmin,δmin=sortrxd[[nδi,2]],Null];nδi=nδi-1];δbmin=δmin;δbmax=δmax;While[area≤0.995&&nδi>0,
area=area+ sortrxd[[nδi,1]];
If[sortrxd[[nδi,2]]>δbmax,δbmax=sortrxd[[nδi,2]],Null];
If[sortrxd[[nδi,2]]<δbmin,δbmin=sortrxd[[nδi,2]],Null];nδi=nδi-1];pdelwta=Sort[RotateLeft[Take[sortrxd,{nδi+1,nδ}],{0,1}]];tr=Transpose[pdelwta];pdelwt=Transpose[{tr[[1]],tr[[2]]/δdelta}];pdelx=tr[[1]];xdAsub={};Do[If[Length[Intersection[{xdA[[i,1]]},pdelx]]>0,xdAsub=Append[xdAsub,xdA[[i]]],Null],{i,1,nδ}];xdBsub={};Do[If[Length[Intersection[{xdB[[i,1]]},pdelx]]>0,xdBsub=Append[xdBsub,xdB[[i]]],Null],{i,1,nδ}];
nδ
nδi
area
δpeak
δmean
δmin
δmax

Here we plot  p(δ | v,D1,D2,I),  p(δ | (Overscript[v, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak δ, average δ and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

plδ=ListPlot[{pdelwt,xdAsub,xdBsub},Joined->True,Frame->True,PlotMarker->{Automatic},Axes->False,PlotStyle->{Red,Green,Black},	PlotLegend->{"average","p(δ|S,(Subscript[D, 1]),(Subscript[D, 2]),I)","p(δ|(Overscript[S, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)"},
	LegendPosition->{-0.3,-0.35},LegendSpacing->0,
	LegendTextSpace->2,LegendBorderSpace->0.1,
	LegendSize->{0.6,0.25},
	LegendShadow->{0.02,-0.02},PlotLabel->Style["Peak δ ="<>ToString[N[Round[δpeak*100]/100]]<>" ; Mean δ ="<> ToString[N[Round[δmean*100]/100]]<>" ; 95% lower δ="<>ToString[N[Round[δmin*100]/100]]<>" ; 95% upper δ="<>ToString[N[Round[δmax*100]/100]],{"Helvetica-Bold",11}],FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

The ratio of the standard deviations   (r)

p(r|C,D1,D2,I) problem

This section computes and plots the posterior probability density for the ratio of the standard deviations 
assuming the means are the same. Change scaleL and/or scaleH to adjust lower and upper ends of the plot along the x axis.

scaleL =20;scaleH=4;rlow=d1std/(scaleL*d2std);rhi=scaleH*d1std/d2std;rdelta=(rhi-rlow)/(nr-1);AL=low;AH=high;u=((n1 d1squbar)/(r^2))+n2 d2squbar;v=((n1 d1bar)/(r^2))+n2 d2bar;w=(n1/(r^2))+n2;z=u-((v^2)/w);XH=(Sqrt[(w/(2 (σ^2)))])(AH-v/w);XL=(Sqrt[(w/(2 (σ^2)))])(AL-v/w);fnrS=(((((2 π))^(-n/2))(Sqrt[π/(8 w)]))/(Ra (((Log[Rσ]))^2)))*(r^(-(n1+1) ))(σ^(-n))  Exp[-(z/(2 (σ^2)))]  (Erf[XH]-Erf[XL]);pr=Table[NIntegrate[fnrS,{σ,σlow,σhigh}],{r,rlow,rhi,rdelta}];prA=pr/(rdelta*Plus@@pr);xr=Table[r,{r,rlow,rhi,rdelta}];xrA=Transpose[{xr,prA}];ListPlot[xrA,Joined->True,Frame->True,Axes->False,PlotRange->All,FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["p(r | C,(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(r|(Overscript[C, -]),D1,D2,I) problem

This section computes and plots the posterior probability density for the ratio of the standard deviations 
assuming the means are the different. Change scaleL and/or scaleH to adjust lower and upper ends of the plot along the x axis.

scaleL =20;scaleH=4;rlow=d1std/(scaleL*d2std);rhi=scaleH*d1std/d2std;rdelta=(rhi-rlow)/(nr-1);AL=low;AH=high;z1=n1(d1squbar-(d1bar^2));z2=n2(d2squbar-(d2bar^2));X1H=(Sqrt[(n1/(2 (r^2) (σ^2)))])(AH-d1bar);X1L=(Sqrt[(n1/(2 (r^2) (σ^2)))])(AL-d1bar);X2H=(Sqrt[(n2/(2 (σ^2)))])(AH-d2bar);X2L=(Sqrt[(n2/(2 (σ^2)))])(AL-d2bar);fnrSb=(((((2 π))^(-n/2)) π)/(4(((Ra))^2) (((Log[Rσ]))^2) (Sqrt[n1 n2])))*(r^(-n1 ))(σ^(1-n))  Exp[-(z1/(2 (r^2) (σ^2)))-(z2/(2 (σ^2)))]  (Erf[X1H]-Erf[X1L]) (Erf[X2H]-Erf[X2L]);pr=Table[NIntegrate[fnrSb,{σ,σlow,σhigh}],{r,rlow,rhi,rdelta}];prB=pr/(rdelta*Plus@@pr);xr=Table[r,{r,rlow,rhi,rdelta}];xrB=Transpose[{xr,prB}];ListPlot[xrB,PlotJoined->True,Frame->True,Axes->False,PlotRange->All,FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["p(r|(Overscript[C, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

p(r | D1,D2,I)

This section computes and plots the posterior probability density for the ratio of the standard deviations 
independent of whether the means are the same. It is a weighted average of  p(r | C,D1,D2,I) and 
p(r  | (Overscript[C, -]),D1,D2,I) where the weights are pC and pCbar, the probability that the means are the same or different, respectively.

The code computes the 95% credible region. It also computes the 99.9% credible region for choosing a range to plot. The latter is used to choose suitable boundaries for plotting purposes so only the region with significant probability is displayed.

prave=(pC*prA+pCbar*prB);prave=prave/Plus@@prave;rxr=Transpose[{prave,xr}];rpeak=Sort[rxr][[nr,2]];rmean=prave.xr;sortrxr=Sort[rxr];rmin=rhi;rmax=rlow;area=0.0;j=0;nri=nr;While[area≤0.95,
area=area+ sortrxr[[nri,1]];
If[sortrxr[[nri,2]]>rmax,rmax=sortrxr[[nri,2]],Null];
If[sortrxr[[nri,2]]<rmin,rmin=sortrxr[[nri,2]],Null];nri=nri-1];rbmin=rmin;rbmax=rmax;While[area≤0.999&&nri>0,
area=area+ sortrxr[[nri,1]];
If[sortrxr[[nri,2]]>rbmax,rbmax=sortrxr[[nri,2]],Null];
If[sortrxr[[nri,2]]<rbmin,rbmin=sortrxr[[nri,2]],Null];nri=nri-1];prwta=Sort[RotateLeft[Take[sortrxr,{nri+1,nr}],{0,1}]];tr=Transpose[prwta];prwt=Transpose[{tr[[1]],tr[[2]]/rdelta}];prx=tr[[1]];xrAsub={};Do[If[Length[Intersection[{xrA[[i,1]]},prx]]>0,xrAsub=Append[xrAsub,xrA[[i]]],Null],{i,1,nr}];xrBsub={};Do[If[Length[Intersection[{xrB[[i,1]]},prx]]>0,xrBsub=Append[xrBsub,xrB[[i]]],Null],{i,1,nr}];
nr
nri
area
rpeak
rmean
rmin
rmax

Here we plot  p(r | C,D1,D2,I),  p(r | (Overscript[C, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak r, average r and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

plr=ListPlot[{prwt,xrAsub,xrBsub},Joined->True,Frame->True,Axes->False,PlotStyle->{Red,Green,Black},	PlotLegend->{"average","p(r|C,(Subscript[D, 1]),(Subscript[D, 2]),I)","p(r|(Overscript[C, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)"},
	LegendPosition->{0.0,0.25},LegendSpacing->0,
	LegendTextSpace->2,LegendBorderSpace->0.1,
	LegendSize->{0.6,0.25},
	LegendShadow->{0.02,-0.02},PlotLabel->Style["Peak r ="<>ToString[N[Round[rpeak*100]/100]]<>" ; Mean  r ="<> ToString[N[Round[rmean*100]/100]]<>" ; 95% lower  r="<>ToString[N[Round[rmin*100]/100]]<>" ; 95% upper  r="<>ToString[N[Round[rmax*100]/100]],{"Helvetica-Bold",11}],FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Summary

Here we give a table summarizing the data

TableForm[l1a]

Next we give a table summarizing the priors and posterior probabilities.

TableForm[l1b]

Here we plot  p(δ | S,D1,D2,I),  p(δ | (Overscript[S, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak δ, average δ and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

δplots=Show[plδ]

Here we plot  p(r | C,D1,D2,I),  p(r | (Overscript[C, -]),D1,D2,I) and the weighted average of the two. See plot legend for details.The peak r, average r and upper and lower boundaries of the 95% credible region are displayed along the top of the plot.

rplots=Show[plr]

Following command will output the above graph as an EPS files with Mathematica fonts included.  (Note you need to remove the outer (*  *) braces to make the command active.

(*Export["c:/greg1/book/fig_rplots.eps", rplots,ImageSize->72*6]*)

Effect of different choice of priors on model probabilities

In Part 1, using a relatively large prior range for the mean and standard deviation the odds ratio for the two data sets being different = 3.07. The most probable model was (OverBar[C]),S (different means, same std. deviation) had a probability = 0.293. For comparison the simplest model C,S had a probability = 0.24, not that different. 

In Part 2, using a much smaller prior range for the mean and standard deviation the odds ratio for the two data sets being different increases to 12.4. Now the most probable model is (OverBar[C]),(OverBar[S]) (different means and std. deviations) had a probability = 0.55. For comparison the simplest model C,S has a probability = 0.07.

The difference is qualitatively as expected because with smaller prior ranges the Occam penalty which penalizes more complicated models is smaller in Part 2. Therefore, we see the probabilty of the most complicated model (OverBar[s]),(OverBar[v]) increase significantly. As an example, for a uniform prior the Occam factor is ∝ 1/(prior range). Since  model (OverBar[s]),(OverBar[v])  assumes the two means are different the Occam factor occurs twice (compared to models assuming s) and is ∝ 1/(prior range)2. Of course the Occam factor also depends directly on the width of the maximum likelihood dependence on s which can be smaller in principle for a more complicated model. For a Jeffreys prior (appropriate for the std. deviation parameter) the dependence of the Occam factor on prior range is ∝ 1/ln[((Subscript[v, max])/(Subscript[v, min]))], not as strong a dependence as for a uniform prior. Since  model (OverBar[s]),(OverBar[v])  assumes the two std. deviations are different the Occam factor occurs twice and is ∝ 1/(ln[((Subscript[v, max])/(Subscript[v, min]))])2.

Ch. 10: Problem 2

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

Needs["HypothesisTesting`"]

Data

(Subscript[X, i])                (Subscript[Yave, i])                (Subscript[n, i])
                          ________________________________

                                   10                  0.387              14
                                   20                  5.045                3
                                   30                  7.299              25
                                   40                  6.870                2
                                   50                 16.659               3 
                                   60                 13.951             22
                                   70                 16.781               5
                                   80                 20.323               2

Straight-line fit with X values measured from the midrange.

The model basis functions are 1 and x. Let GrawT be an array with first row containing
 the value of the first basis function at each point and similarly for row 2.

GrawT={{1,1,1,1,1,1,1,1},{10,20,30,40,50,60,70,80}};

Graw=Transpose[GrawT]

It turns out to be advantageous to determine the slope with reference to the weighted average X coord.
The weighted average x coordinate xmean= (((∑_(i=1)^(Subscript[N, i]))(Subscript[w, i]) (Subscript[x, i]))/((∑_(i=1)^(Subscript[N, i]))(Subscript[w, i]))), where (Subscript[w, i])= ((Subscript[N, i])/(Subscript[σ, i]^2))
xmean=Total[GT[[2]].EINV]/Total[Plus@@EINV]

The advantageous of this is that it has the effect of making the two basis functions 
more orthogonal. This results in smaller zero off diagonal elements in the covariance matrix
of the paramters (i.e. reduced correlation coefficient between the parameters).

Diagonal elements of EINV are # of data in the ith data average, with each datum in ave. having the same std dev. sig.

sig=4.0;

(*sig=(Sqrt[8.1]);*)

EINV=(1/(sig^2)){{14,0,0,0,0,0,0,0},
		{0,3,0,0,0,0,0,0},
		{0,0,25,0,0,0,0,0},
		{0,0,0,2,0,0,0,0},
		{0,0,0,0,3,0,0,0},
		{0,0,0,0,0,22,0,0},
		{0,0,0,0,0,0,5,0},
		{0,0,0,0,0,0,0,2}};

EE=Inverse[EINV]

xmean=Total[GrawT[[2]].EINV]/Total[Plus@@EINV]

xshift=GrawT[[2]]-xmean

GT={GrawT[[1]],xshift}

G=Transpose[GT];

ψ=GT.EINV.G

Parameter covariance matrix follows.

V=Inverse[ψ]

data={{0.387},{5.045},{7.299},{6.870},{16.659},{13.951},{16.781},{20.323}};

AMPL=Inverse[ψ].GT.EINV.data

Error on intercept

Interr=(Sqrt[V[[1,1]]])

Error on slope

sloperr=(Sqrt[V[[2,2]]])

Correlation coefficient

cor=((V[[1,2]])/(Sqrt[V[[1,1]] V[[2,2]]]))

lnchisq = Chi^2 residuals for linear fit

chisq=(∑_(i=1)^8)((((data[[i]]-(∑_(j=1)^2)AMPL[[j]] GT[[j,i]]))^2)/(EE[[i,i]]))

conflnf= confidence in rejecting linear model

conflnf=1-GammaRegularized[((8-2)/2),(chisq/2)]

ft=Transpose[Table[(∑_(j=1)^2)AMPL[[j]] GT[[j,i]],{i,1,8}]];

ftlst=Table[{GT[[2,i]],ft[[1,i]]},{i,1,8}];

pltft=ListPlot[ftlst,PlotJoined->True,Frame->True]

Now plot the data and error bars on the new x scale

tdata=Transpose[data]

dpltb=Table[{GT[[2,i]],tdata[[1,i]],(Sqrt[EE[[i,i]]])},{i,1,8}];

pltbdat=ErrorListPlot[dpltb,Frame->True]

Show[pltbdat,pltft]

Joint credible region contours for a straight line fit.

Below we give the ψ = (G^T).(E^(-1)). G  matrix obtained from fitting a straight line model to some sample data (see section 10.2.2 of the text).

ψ

AMPL=V.(G^T).(E^(-1))  gives the solution for the slope and intercept of the fit.

AMPL

With this information we can plot the 68% and 95% credible region contours with the code that follows.

Refer to Table 10.2 in text to determine the value of Δ((Subscript[χ, crit]^2)^(  ))that corresponds to the desired probability. We use the variable label dchisq to represent Δ((Subscript[χ, crit]^2)^(  ))in the code given below.

dchisq1=2.3;dchisq2=6.17;

polAmp[r_,θ_]:= {{r Cos[θ]},{r Sin[θ]}};polAmpT[r_,θ_]:=Transpose[polAmp[r,θ]];Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]];locus68rθa=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq1,r][[2]][[1,2]],θ},{θ,0,2 π,2 π/180}];locus68rθb=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq1,r][[2]][[1,2]],θ},{θ,0, π/50,2 π/3600}];locus68rθc=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq1,r][[2]][[1,2]],θ},{θ,π (2-1/50),2 π,2 π/3600}];locus68rθd=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq1,r][[2]][[1,2]],θ},{θ,98*π/100, 102*π/100,2 π/3600}];locus68rθ=RotateRight[Sort[RotateLeft[Join[locus68rθa,locus68rθb,locus68rθc,locus68rθd],{0,1}]],{0,1}];
tlocus68r=Transpose[locus68rθ][[1]];
tlocus68θ=Transpose[locus68rθ][[2]];xlocus=tlocus68r*Cos[tlocus68θ]+AMPL[[1,1]];ylocus=tlocus68r*Sin[tlocus68θ]+AMPL[[2,1]];locus68xy=Transpose[{xlocus,ylocus}];locus95rθa=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq2,r][[2]][[1,2]],θ},{θ,0,2 π,2 π/180}];locus95rθb=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq2,r][[2]][[1,2]],θ},{θ,0, π/50,2 π/3600}];locus95rθc=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq2,r][[2]][[1,2]],θ},{θ,π (2-1/50),2 π,2 π/3600}];locus95rθd=Table[{NSolve[Flatten[polAmpT[r,θ].ψ.polAmp[r,θ]][[1]]==dchisq2,r][[2]][[1,2]],θ},{θ,98*π/100, 102*π/100,2 π/3600}];locus95rθ=RotateRight[Sort[RotateLeft[Join[locus95rθa,locus95rθb,locus95rθc,locus95rθd],{0,1}]],{0,1}];
tlocus95r=Transpose[locus95rθ][[1]];
tlocus95θ=Transpose[locus95rθ][[2]];
xlocus=tlocus95r*Cos[tlocus95θ]+AMPL[[1,1]];
ylocus=tlocus95r*Sin[tlocus95θ]+AMPL[[2,1]];
locus95xy=Transpose[{xlocus,ylocus}];
pl2=ListPlot[{locus68xy,locus95xy},PlotRange->All,Joined->True,Frame->True,PlotStyle->{{Black,Thick},{Black,Dashed,Thick}},Axes->False,FrameLabel->{Style["Intercept",{"Helvetica-Bold",12}],
		Style["Slope",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

pl2line=Graphics[{{Text[StyleForm["((Δχ)^2)=2.3",FontSize->10,FontWeight->"Bold"],{7.3,0.24},{-1,0},{1,0}]},{Text[StyleForm["((Δχ)^2)=6.17",FontSize->10,FontWeight->"Bold"],{7.3,0.31},{-1,0},{1,0}]},{Arrow[{{7.7,0.245},{ 8.5,0.26}}]},{Arrow[{{7.7,0.3},{ 8.1,0.28}}]}}];plsh1=Show[pl2,pl2line,DisplayFunction->$DisplayFunction]

Ch. 10: Problem 4

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

Needs["HypothesisTesting`"]

Data manipulation

(*data=ReadList["c:/greg1/math/p509/ozone.dat",Real,RecordLists->True];*)

data={{-7.`,53.8`},{-7.`,53.3`},{-7.`,54.8`},{-7.`,54.6`},{-7.`,53.7`},{-7.`,55.2`},{-7.`,55.7`},{-7.`,54.1`},{-6.`,63.8`},{-6.`,64.2`},{-6.`,66.9`},{-6.`,67.2`},{-6.`,65.4`},{-6.`,67.3`},{-5.`,71.8`},{-5.`,73.2`},{-5.`,75.6`},{-5.`,76.2`},{-5.`,72.7`},{-4.`,79.4`},{-4.`,81.1`},{-4.`,85.2`},{-4.`,83.`},{-4.`,84.1`},{-4.`,82.8`},{-3.`,90.3`},{-3.`,84.2`},{-3.`,88.3`},{-3.`,86.`},{-2.`,93.2`},{-2.`,97.4`},{-2.`,98.3`},{-1.`,102.8`},{-1.`,96.9`},{-1.`,98.2`},{0.`,98.9`},{0.`,96.1`},{0.`,99.6`},{0.`,91.4`},{1.`,101.1`},{1.`,94.6`},{1.`,95.9`},{2.`,92.3`},{2.`,96.6`},{2.`,98.5`},{3.`,93.6`},{3.`,86.2`},{3.`,87.9`},{3.`,89.5`},{4.`,74.8`},{4.`,82.3`},{4.`,76.9`},{4.`,81.2`},{5.`,73.6`},{5.`,65.4`},{5.`,67.1`},{6.`,60.2`},{6.`,54.9`},{6.`,50.8`},{7.`,44.7`},{7.`,38.5`}};

Length[data]

MatrixForm[data];

Construct a list of consecutive samples to be grouped and averaged, e.g., to achieve a minimum of 5 samples in an average (CLT).

My binning of the data

(*nave={8,6,5,6,4,6,4,6,6,5,5};*)

Student binning

(*nave={8,6,5,6,7,7,6,8,8};*)

Keeping the raw grouping of the data

nave={8,6,5,6,4,3,3,4,3,3,4,4,3,3,2};

nd=Length[nave]

Make a list, m, of beginning and end sample numbers to be
grouped together for averaging.

i1=0;

m=Table[{i1+1,i1=i1+nave[[i]]},{i,1,nd}];

Make a new grouped data set, ndata

ndata=Table[Take[data,m[[i]]],{i,1,nd}];

Compute mean ozone layer number and mean measurement

nndat=Table[((Plus@@ndata[[i]])/(nave[[i]])),{i,1,nd}];

xdata=Transpose[nndat][[1]]

ydata=Transpose[nndat][[2]]

Compute the std. dev. of the mean, sigmean, for each group.
For sigmean we want the second element of the Transpose of sigma.

sigmean=Table[StandardDeviation[Transpose[ndata[[i]]][[2]]]/(Sqrt[nave[[i]]]),{i,1,nd}]

Model 1, quadratic polynomial and (χ^2)  P-value

The model basis functions are 1 and x and x^2. Let GT be an array with first row containing the value of the first basis function at each point and similarly for row 2.

GT={Table[1,{i,1,nd}],xdata,(xdata^2)};

G=Transpose[GT];

Create a data covariance matrix.

dcov=(sigmean^2) IdentityMatrix[nd]

Idcov=Inverse[dcov];

psi=GT.Idcov.G;

Vq=Inverse[psi]

Solve for quadratic model amplitudes

AMPL=Vq.GT.Idcov.ydata

Errors

err=(Sqrt[{Vq[[1,1]],Vq[[2,2]],Vq[[3,3]]}])

chisqq = (χ^2) residuals for quadratic fit

((((ydata[[1]]-(∑_(j=1)^3)AMPL[[j]] GT[[j,1]]))^2)/(dcov[[1,1]]))

chisqq=(∑_(i=1)^nd)((((ydata[[i]]-(∑_(j=1)^3)AMPL[[j]] GT[[j,i]]))^2)/(dcov[[i,i]]))

conflf= confidence in rejecting quadratic model (from frequentist statistics)

Note the maximum value of ChiSquarePValue is 0.5 
whereas GammaRegularized max =1

conf=1-ChiSquarePValue[chisqq,nd-3][[2]]

conflf=1-GammaRegularized[((nd-3)/2),(chisqq/2)]

A value this large would seem to warrant rejecting model. Be careful a large value 
of chi^2 can result from underestimating the errors.

dplt= list of {(Subscript[x, i]),(Subscript[y, (Subscript[ave, i])]), (Subscript[error, i])} values for plotting

dplt=Table[{GT[[2,i]],ydata[[i]],(Sqrt[dcov[[i,i]]])},{i,1,nd}];

Plot of data plus errors

pltdat=ErrorListPlot[dplt,Frame->True,PlotStyle->Black]

Best fit model predictions of data

lft=Table[(∑_(j=1)^3)AMPL[[j]] GT[[j,i]],{i,1,nd}];

Table of model x,y values for plotting

lftlst=Table[{GT[[2,i]],lft[[i]]},{i,1,nd}];

Plot of best fit model of partial pressure vs ozone layer

pltlf=ListPlot[lftlst,PlotJoined->True,PlotStyle->Dashing[{0.01,0.01}],Frame->True]

Plot of best fit model plus data

Show[pltdat,pltlf]

Model 2, cubic polynomial and (χ^2)  P-value

The model basis functions are 1 and x and x^2. Let GT be an array with first row containing
 the value of the first basis function at each point and similarly for row 2.

cGT={Table[1,{i,1,nd}],xdata,(xdata^2),(xdata^3)};

cG=Transpose[cGT];

Create a data varaince covariance matrix.

psic=cGT.Idcov.cG;

Vc=Inverse[psic]

Solve for model amplitudes

AMPLc=Vc.cGT.Idcov.ydata

Errors

errc=(Sqrt[{Vc[[1,1]],Vc[[2,2]],Vc[[3,3]],Vc[[4,4]]}])

lchisqc = (χ^2) residuals for cubic fit

chisqc=(∑_(i=1)^nd)((((ydata[[i]]-(∑_(j=1)^4)AMPLc[[j]] cGT[[j,i]]))^2)/(dcov[[i,i]]))

conflf= confidence in rejecting cubic model (from frequentist statistics)

conflfc=1-GammaRegularized[((nd-4)/2),(chisqc/2)]

A value this large would not seem to warrant rejecting model. Be careful a large value 
of chi^2 can result from underestimating the errors.

cor12=((Vc[[1,2]])/(Sqrt[Vc[[1,1]] Vc[[2,2]]]))

cor23=((Vc[[2,3]])/(Sqrt[Vc[[2,2]] Vc[[3,3]]]))

cor34=((Vc[[3,4]])/(Sqrt[Vc[[3,3]] Vc[[4,4]]]))

Best fit model predictions of data

lftc=Table[(∑_(j=1)^4)AMPLc[[j]] cGT[[j,i]],{i,1,nd}];

Table of model x,y values for plotting

lftclst=Table[{cGT[[2,i]],lftc[[i]]},{i,1,nd}];

Plot of best fit model

pltlfc=ListPlot[lftclst,PlotJoined->True,Frame->True]

Comparison of two models

Plot of best fit model plus data (quadratic fit shown by dashed line).

Show[pltdat,pltlf,pltlfc]

Compute odds of cubic model over quadratic model

deltaA= prior uncertainty for extra quadratic parameter

deltA=1.0

Ocq=(((E^((chisqq-chisqc)/2)) N[(((2 π))^((4-3)/2))] (Sqrt[((Det[Vc])/(Det[Vq]))]))/deltA)

probcubicModel=(1/(1+(1/Ocq)))

probquadModel=1-probcubicModel

Ch. 11: Problem

Nonlinear Model Fitting. Includes a calculation of the Lapacian approximation to the Global Likelihood (now more commonly referred to as the Marginal Likelihood) for use in computing the Bayesian Odds Ratio for comparing models of different complexity.

Clean up

Remove["Global`*"]

Off[General::"spell"];Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

Input data and plot.

data={{1.`,0.874306`},{1.18`,0.998132`},{1.36`,0.533335`},{1.54`,0.827465`},{1.72`,1.476216`},{1.9`,1.181253`},{2.08`,1.287244`},{2.26`,1.35795`},{2.44`,0.523707`},{2.62`,1.062476`},{2.8`,1.024384`},{2.98`,1.544074`},{3.16`,1.623569`},{3.34`,1.290548`},{3.52`,1.58593`},{3.7`,2.141774`},{3.88`,2.28047`},{4.06`,2.777337`},{4.24`,3.000513`},{4.42`,4.083662`},{4.6`,4.838485`},{4.78`,4.461056`},{4.96`,5.320244`},{5.14`,5.048011`},{5.32`,6.035729`},{5.5`,6.384887`},{5.68`,5.576636`},{5.86`,5.959995`},{6.04`,5.465587`},{6.22`,4.785814`},{6.4`,4.654824`},{6.58`,3.553078`},{6.76`,3.88979`},{6.94`,3.403476`},{7.12`,2.881303`},{7.3`,1.779117`},{7.48`,1.903956`},{7.66`,1.909748`},{7.84`,2.158314`},{8.02`,1.957183`},{8.2`,1.977496`},{8.38`,2.74111`},{8.56`,2.68445`},{8.74`,2.385319`},{8.92`,3.53247`},{9.1`,2.41652`},{9.28`,2.780344`},{9.46`,3.232633`},{9.64`,2.704366`},{9.82`,2.847899`},{10.`,2.928985`},{10.18`,3.266361`},{10.36`,4.059317`},{10.54`,3.979717`},{10.72`,4.762072`},{10.9`,5.085152`},{11.08`,5.169173`},{11.26`,4.868291`},{11.44`,4.762306`},{11.62`,4.933535`},{11.8`,5.341957`},{11.98`,4.841552`},{12.16`,4.034773`},{12.34`,3.948958`},{12.52`,3.971291`},{12.7`,4.382299`},{12.88`,3.253825`},{13.06`,3.351365`},{13.24`,2.806787`},{13.42`,2.917352`},{13.6`,3.320938`},{13.78`,2.104567`},{13.96`,2.741008`},{14.14`,2.187061`},{14.32`,1.730899`},{14.5`,1.758127`},{14.68`,1.781037`},{14.86`,1.499114`},{15.04`,1.489122`},{15.22`,1.580747`},{15.4`,1.463544`},{15.58`,1.151953`},{15.76`,1.457694`},{15.94`,1.289739`},{16.12`,1.132981`},{16.3`,0.954391`},{16.48`,0.796418`},{16.66`,1.289895`},{16.84`,1.321293`},{17.02`,0.742822`},{17.2`,0.617609`},{17.38`,0.856651`},{17.56`,1.02056`},{17.74`,1.115464`},{17.92`,1.293023`},{18.1`,1.492653`},{18.28`,1.295247`},{18.46`,1.031297`},{18.64`,0.965182`},{18.82`,1.327506`}};

Good idea to look at data to see the structure of the data list. To do that remove the ";" from end of above line. You should see a list of xy pairs.

n=Length[data]

Plot the data.

pl0=ListPlot[data]

Create list of data errors if they are not constant. If constant set errfun = value of this constant. For this data sigma = 1.0

errfun[x_]:= N[0.3]

err=Array[errfun,n];

Convert the data errors to a weight (wt) which is equal to 1/(err)^2.

wt= err^(-2);

Fit a 3 parameter model, a baseline and 1 Gaussian.

Specify the model to be fit in terms of the model parameters

varL=1;

model[x_]:=a0+a1*Exp[((-(((x-c1))^2))/(2*varL))];

Here is where the nonlinearfit is executed

lpar={{a0, 1.},{a1,6},{c1, 5.5}};result=NonlinearModelFit[data,
 model[x],lpar,x,Weights->wt];

To obtain the best fit funtional form.

Normal[result]

The best fit parameters.

result["BestFitParameters"]

The next statement gives the parameter standard errors or more accurately the asymptotic standard errors. The use of these errors is based on the assumption that in the vicinity of the mode, the joint posterior probability distribution is a good approximation to a multivariate Gaussian

result["ParameterErrors"]

Tabulate best fit parameters, standard errors and confidence intervals.

result["ParameterConfidenceIntervalTable"]

The asymptotic standard error for each parameter is equal to the square root of  of the corresponding diagonal element of the asymptotic covariance matrix which is given below

covmatrix=result["CovarianceMatrix"]

List fit residuals (model values - data values)

result["FitResiduals"]

Compute the value of the best fit(χ^2) statistic designated by chisq.

chisq1=Total[(((result["FitResiduals"]))^2)*wt]

First specify the number of fitted parameters (m).

m = 3;

Reduced (χ^2) equals (χ^2) divided by number of degrees of freedom (= no. data points - no. of fitted paramters) Should be around the value 1 for a good model.

reducedchisq=chisq1/(n-m)

Note on the meaning of the asymptotic SE (standard error). In computing this Mathematica assumes that the measurement error associated with (i^th)  datum = k (Subscript[σ, i]), and computes k in the following way. If the model is valid the expected value of (χ^2)at the solution minimum, (Subscript[χ, expect]^2), is equal to the number of degrees of freedom = n-m where n = the number of data points = 100, and m = the number of fitted parameters = 3. 
(Subscript[χ, expect]^2)= (∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/((k^2) (Subscript[σ, i]^2)))) = (1/(k^2))(∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/( (Subscript[σ, i]^2)))) = ((Subscript[χ, meas]^2)/(k^2))= n-m = 97
Therefore (k^2) = ((Subscript[χ, meas]^2)/97), where (Subscript[χ, meas]^2) is the measured value based on given data errors. Including a factor k is a good thing to do since often nature is more complicated than than either the model or known data measurement errors can account for. Increasing all the data errors by k corresponds to increasing the terms in the parameter covariance matrix by (k^2) or the parameter standard errors by k.

k1=(Sqrt[(chisq1/(n-m))])

Now compute the frequents confidence in rejecting the fitted model. If confidence (conflf) is = 0.95 then we can say we are rejecting the model at the 95% confidence level.

conflf=1-GammaRegularized[((n-m)/2), chisq1/2]

Create a list called time which is the first part of each entry in the data list. Good idea to type data to see the structure of the data list. You should see a list of xy pairs.

time=Transpose[data][[1]];

Note above line could also be accomplished with "time=Map[#[[1]]&,data];"

Now create a list of the y values of the data.

yval=Transpose[data][[2]];

Combine the time, yval, err for plotting data with error bars.

datapluserror=Transpose[{time,yval,err}];

Plot the data plus errors

pl3=ErrorListPlot[datapluserror,PlotStyle->Black]

Anotherway of extracting the model parameters

result[[1,2]]

To obtain the best fit model function

fitfun[x_]=model[x]/. result[[1,2]]

fitfun[1.2]

xup=Max[Transpose[data][[1]]]

xdown=Min[Transpose[data][[1]]]

pl1=Plot[fitfun[x],{x,xdown,xup},PlotRange->All,Axes->False,Frame->True]

Show[pl1,pl3]

Show the best fit overlayed on data with errors

resids=result["FitResiduals"]

diff=Transpose[{time,resids,err}];

pl1r=ErrorListPlot[diff,PlotStyle->Black]

Compute mean, variance and reduced chi^2 of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the global likelihood of the model for use in comparing different models.

The result assumes your prior information about each amplitude parameter is uniform over a range of ± a factor of f = 3 from your initial guess of the parameter. Also assumes your prior information about each line center parameter is uniform between 1 and 17. As a first step we specify the prior ranges for the parameters.

f=3;

ra0=f*lpar[[1,2]]-lpar[[1,2]]/f;ra1=f*lpar[[2,2]]-lpar[[2,2]]/f;rc1=17;

(*ra0=f*lpar[[1,2]];ra1=f*lpar[[2,2]];rc1=f*lpar[[3,2]]*)

globlike1=(((ra0*ra1*rc1))^(-1))(((2 π))^(-(((n-m))/2))) Times@@(Sqrt[wt])  Exp[-(chisq1/2)] (((Det[covmatrix/(k1^2)]))^(1/2))

Fit a 5 parameter model, a baseline and 2 Gaussians.

Specify the model to be fit in terms of the model parameters

varL=1;

model[x_]:=a0+a1*Exp[((-(((x-c1))^2))/(2*varL))]+a2*Exp[((-(((x-c2))^2))/(2*varL))];

Here is where the nonlinearfit is executed

lpar={{a0, 1.},{a1,6},{c1, 5.5},{a2,5. },{c2, 11}};result=NonlinearModelFit[data,
 model[x],lpar,x,Weights->wt];

To obtain the best fit funtional form.

Normal[result]

The best fit parameters.

parval=result["BestFitParameters"]

The next statement gives the parameter standard errors or more accurately the asymptotic standard errors. The use of these errors is based on the assumption that in the vicinity of the mode, the joint posterior probability distribution is a good approximation to a multivariate Gaussian

parerror=result["ParameterErrors"]

Tabulate best fit parameters, standard errors and confidence intervals.

result["ParameterConfidenceIntervalTable"]

The asymptotic standard error for each parameter is equal to the square root of  of the corresponding diagonal element of the asymptotic covariance matrix which is given below

covmatrix=result["CovarianceMatrix"]

List fit residuals (model values - data values)

result["FitResiduals"]

Compute the value of the best fit(χ^2) statistic designated by chisq.

chisq2=Total[(((result["FitResiduals"]))^2)*wt]

First specify the number of fitted parameters (m).

m = 5;

Reduced (χ^2) equals (χ^2) divided by number of degrees of freedom (= no. data points - no. of fitted paramters) Should be around the value 1 for a good model.

reducedchisq=chisq2/(n-m)

Note on the meaning of the asymptotic SE (standard error). In computing this Mathematica assumes that the measurement error associated with (i^th)  datum = k (Subscript[σ, i]), and computes k in the following way. If the model is valid the expected value of (χ^2)at the solution minimum, (Subscript[χ, expect]^2), is equal to the number of degrees of freedom = n-m where n = the number of data points = 100, and m = the number of fitted parameters = 4. 
(Subscript[χ, expect]^2)= (∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/((k^2) (Subscript[σ, i]^2)))) = (1/(k^2))(∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/( (Subscript[σ, i]^2)))) = ((Subscript[χ, meas]^2)/(k^2))= n-m = 96
Therefore (k^2) = ((Subscript[χ, meas]^2)/96), where (Subscript[χ, meas]^2) is the measured value based on given data errors. Including a factor k is a good thing to do since often nature is more complicated than than either the model or known data measurement errors can account for. Increasing all the data errors by k corresponds to increasing the terms in the parameter covariance matrix by (k^2) or the parameter standard errors by k.

k2=(Sqrt[(chisq2/(n-m))])

Now compute the frequents confidence in rejecting the fitted model. If confidence (conflf) is = 0.95 then we can say we are rejecting the model at the 95% confidence level.

conflf=1-GammaRegularized[((n-m)/2), chisq2/2]

Create a list called time which is the first part of each entry in the data list. Good idea to type data to see the structure of the data list. You should see a list of xy pairs.

time=Transpose[data][[1]];

Note above line could also be accomplished with "time=Map[#[[1]]&,data];"

Now create a list of the y values of the data.

yval=Transpose[data][[2]];

Combine the time, yval, err for plotting data with error bars.

datapluserror=Transpose[{time,yval,err}];

Plot the data plus errors

pl3=ErrorListPlot[datapluserror,PlotStyle->Black]

Anotherway of extracting the model parameters

result[[1,2]]

To obtain the best fit model function

fitfun[x_]=model[x]/. result[[1,2]]

fitfun[1.2]

xup=Max[Transpose[data][[1]]]

xdown=Min[Transpose[data][[1]]]

pl1=Plot[fitfun[x],{x,xdown,xup},PlotRange->All,Axes->False,Frame->True]

Show[pl1,pl3]

Show the best fit overlayed on data with errors

resids=result["FitResiduals"]

diff=Transpose[{time,resids,err}];

pl1r=ErrorListPlot[diff,PlotStyle->Black]

Compute mean, variance and reduced chi^2 of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the global likelihood of the model for use in comparing different models.

The result assumes your prior information about each amplitude parameter is uniform over a range of ± a factor of f = 3 from your initial guess of the parameter. Also assumes your prior information about each line center parameter is uniform between 1 and 17. As a first step we specify the prior ranges for the parameters.

f=3;

ra0=f*lpar[[1,2]]-lpar[[1,2]]/f;ra1=f*lpar[[2,2]]-lpar[[2,2]]/f;ra2=f*lpar[[4,2]]-lpar[[4,2]]/f;rc1=17;rc2=17;

(*ra0=f*lpar[[1,2]];ra1=f*lpar[[2,2]];rc1=f*lpar[[3,2]];ra2=f*lpar[[4,2]];rc2=f*lpar[[5,2]];*)

globlike2=(((ra0*ra1*rc1*ra2*rc2))^(-1))(((2 π))^(-(((n-m))/2))) Times@@(Sqrt[wt])  Exp[-(chisq2/2)] (((Det[covmatrix/(k2^2)]))^(1/2))

(Subscript[ODDS, 21])=globlike2/globlike1

Fit a 7 parameter model, a baseline and 3 Gaussians.

varL=1;

model[x_]:=a0+a1*Exp[((-(((x-c1))^2))/(2*varL))]+a2*Exp[((-(((x-c2))^2))/(2*varL))]+a3*Exp[((-(((x-c3))^2))/(2*varL))];

Here is where the nonlinearfit is executed

lpar={{a0, 1.},{a1,6},{c1, 5.5},{a2,5. },{c2, 11},{a3,1.5 },{c3, 8}};result=NonlinearModelFit[data,
 model[x],lpar,x,Weights->wt];

To obtain the best fit funtional form.

Normal[result]

The best fit parameters.

parval=result["BestFitParameters"]

The next statement gives the parameter standard errors or more accurately the asymptotic standard errors. The use of these errors is based on the assumption that in the vicinity of the mode, the joint posterior probability distribution is a good approximation to a multivariate Gaussian

parerror=result["ParameterErrors"]

Tabulate best fit parameters, standard errors and confidence intervals.

result["ParameterConfidenceIntervalTable"]

The asymptotic standard error for each parameter is equal to the square root of  of the corresponding diagonal element of the asymptotic covariance matrix which is given below

covmatrix=result["CovarianceMatrix"]

List fit residuals (model values - data values)

result["FitResiduals"]

Compute the value of the best fit(χ^2) statistic designated by chisq.

chisq3=Total[(((result["FitResiduals"]))^2)*wt]

First specify the number of fitted parameters (m).

m = 7;

Reduced (χ^2) equals (χ^2) divided by number of degrees of freedom (= no. data points - no. of fitted paramters) Should be around the value 1 for a good model.

reducedchisq=chisq3/(n-m)

Note on the meaning of the asymptotic SE (standard error). In computing this Mathematica assumes that the measurement error associated with (i^th)  datum = k (Subscript[σ, i]), and computes k in the following way. If the model is valid the expected value of (χ^2)at the solution minimum, (Subscript[χ, expect]^2), is equal to the number of degrees of freedom = n-m where n = the number of data points = 100, and m = the number of fitted parameters = 4. 
(Subscript[χ, expect]^2)= (∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/((k^2) (Subscript[σ, i]^2)))) = (1/(k^2))(∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/( (Subscript[σ, i]^2)))) = ((Subscript[χ, meas]^2)/(k^2))= n-m = 96
Therefore (k^2) = ((Subscript[χ, meas]^2)/96), where (Subscript[χ, meas]^2) is the measured value based on given data errors. Including a factor k is a good thing to do since often nature is more complicated than than either the model or known data measurement errors can account for. Increasing all the data errors by k corresponds to increasing the terms in the parameter covariance matrix by (k^2) or the parameter standard errors by k.

k3=(Sqrt[(chisq3/(n-m))])

Now compute the frequents confidence in rejecting the fitted model. If confidence (conflf) is = 0.95 then we can say we are rejecting the model at the 95% confidence level.

conflf=1-GammaRegularized[((n-m)/2), chisq3/2]

Create a list called time which is the first part of each entry in the data list. Good idea to type data to see the structure of the data list. You should see a list of xy pairs.

time=Transpose[data][[1]];

Note above line could also be accomplished with "time=Map[#[[1]]&,data];"

Now create a list of the y values of the data.

yval=Transpose[data][[2]];

Combine the time, yval, err for plotting data with error bars.

datapluserror=Transpose[{time,yval,err}];

Plot the data plus errors

pl3=ErrorListPlot[datapluserror,PlotStyle->Black]

Anotherway of extracting the model parameters

result[[1,2]]

To obtain the best fit model function

fitfun[x_]=model[x]/. result[[1,2]]

fitfun[1.2]

xup=Max[Transpose[data][[1]]]

xdown=Min[Transpose[data][[1]]]

pl1=Plot[fitfun[x],{x,xdown,xup},PlotRange->All,Axes->False,Frame->True]

Show[pl1,pl3]

Show the best fit overlayed on data with errors

resids=result["FitResiduals"]

diff=Transpose[{time,resids,err}];

pl1r=ErrorListPlot[diff,PlotStyle->Black]

Compute mean, variance and reduced chi^2 of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the global likelihood of the model for use in comparing different models.

The result assumes your prior information about each amplitude parameter is uniform over a range of ± a factor of f = 3 from your initial guess of the parameter. Also assumes your prior information about each line center parameter is uniform between 1 and 17. As a first step we specify the prior ranges for the parameters.

f=3;

ra0=f*lpar[[1,2]]-lpar[[1,2]]/f;ra1=f*lpar[[2,2]]-lpar[[2,2]]/f;ra2=f*lpar[[4,2]]-lpar[[4,2]]/f;ra3=f*lpar[[6,2]]-lpar[[4,2]]/f;rc1=17;rc2=17;rc3=17;

globlike3=(((ra0*ra1*rc1*ra2*rc2*ra3*rc3))^(-1))(((2 π))^(-(((n-m))/2))) Times@@(Sqrt[wt])  Exp[-(chisq3/2)] (((Det[covmatrix/(k3^2)]))^(1/2))

(Subscript[ODDS, 32])=globlike3/globlike2

Fit a 9 parameter model, a baseline and 4 Gaussians.

varL=1;

model[x_]:=a0+a1 Exp[((-(((x-c1))^2))/(2 varL))]+a2 Exp[((-(((x-c2))^2))/(2 varL))]+a3 Exp[((-(((x-c3))^2))/(2 varL))]+
a4 Exp[((-(((x-c4))^2))/(2 varL))];

Here is where the nonlinearfit is executed

lpar={{a0, 1.},{a1,6},{c1, 5.5},{a2,5. },{c2, 11},{a3,1.5 },{c3, 8},{a4,0.8 },{c4, 12.5}};result=NonlinearModelFit[data,
 model[x],lpar,x,Weights->wt];

To obtain the best fit funtional form.

Normal[result]

The best fit parameters.

parval=result["BestFitParameters"]

The next statement gives the parameter standard errors or more accurately the asymptotic standard errors. The use of these errors is based on the assumption that in the vicinity of the mode, the joint posterior probability distribution is a good approximation to a multivariate Gaussian

parerror=result["ParameterErrors"]

Tabulate best fit parameters, standard errors and confidence intervals.

result["ParameterConfidenceIntervalTable"]

The asymptotic standard error for each parameter is equal to the square root of  of the corresponding diagonal element of the asymptotic covariance matrix which is given below

covmatrix=result["CovarianceMatrix"]

List fit residuals (model values - data values)

result["FitResiduals"]

Compute the value of the best fit(χ^2) statistic designated by chisq.

chisq4=Total[(((result["FitResiduals"]))^2)*wt]

First specify the number of fitted parameters (m).

m = 9;

Reduced (χ^2) equals (χ^2) divided by number of degrees of freedom (= no. data points - no. of fitted paramters) Should be around the value 1 for a good model.

reducedchisq=chisq4/(n-m)

Note on the meaning of the asymptotic SE (standard error). In computing this Mathematica assumes that the measurement error associated with (i^th)  datum = k (Subscript[σ, i]), and computes k in the following way. If the model is valid the expected value of (χ^2)at the solution minimum, (Subscript[χ, expect]^2), is equal to the number of degrees of freedom = n-m where n = the number of data points = 100, and m = the number of fitted parameters = 4. 
(Subscript[χ, expect]^2)= (∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/((k^2) (Subscript[σ, i]^2)))) = (1/(k^2))(∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/( (Subscript[σ, i]^2)))) = ((Subscript[χ, meas]^2)/(k^2))= n-m = 96
Therefore (k^2) = ((Subscript[χ, meas]^2)/96), where (Subscript[χ, meas]^2) is the measured value based on given data errors. Including a factor k is a good thing to do since often nature is more complicated than than either the model or known data measurement errors can account for. Increasing all the data errors by k corresponds to increasing the terms in the parameter covariance matrix by (k^2) or the parameter standard errors by k.

k4=(Sqrt[(chisq4/(n-m))])

Now compute the frequents confidence in rejecting the fitted model. If confidence (conflf) is = 0.95 then we can say we are rejecting the model at the 95% confidence level.

conflf=1-GammaRegularized[((n-m)/2), chisq4/2]

Create a list called time which is the first part of each entry in the data list. Good idea to type data to see the structure of the data list. You should see a list of xy pairs.

time=Transpose[data][[1]];

Note above line could also be accomplished with "time=Map[#[[1]]&,data];"

Now create a list of the y values of the data.

yval=Transpose[data][[2]];

Combine the time, yval, err for plotting data with error bars.

datapluserror=Transpose[{time,yval,err}];

Plot the data plus errors

pl3=ErrorListPlot[datapluserror,PlotStyle->Black]

Anotherway of extracting the model parameters

result[[1,2]]

To obtain the best fit model function

fitfun[x_]=model[x]/. result[[1,2]]

fitfun[1.2]

xup=Max[Transpose[data][[1]]]

xdown=Min[Transpose[data][[1]]]

pl1=Plot[fitfun[x],{x,xdown,xup},PlotRange->All,Axes->False,Frame->True]

Show[pl1,pl3]

Show the best fit overlayed on data with errors

resids=result["FitResiduals"]

diff=Transpose[{time,resids,err}];

pl1r=ErrorListPlot[diff,PlotStyle->Black]

Compute mean, variance and reduced chi^2 of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the global likelihood of the model for use in comparing different models.

The result assumes your prior information about each amplitude parameter is uniform over a range of ± a factor of f = 3 from your initial guess of the parameter. Also assumes your prior information about each line center parameter is uniform between 1 and 17. As a first step we specify the prior ranges for the parameters.

f=3;

ra0=f*lpar[[1,2]]-lpar[[1,2]]/f;ra1=f*lpar[[2,2]]-lpar[[2,2]]/f;ra2=f*lpar[[4,2]]-lpar[[4,2]]/f;ra3=f*lpar[[6,2]]-lpar[[4,2]]/f;ra4=f*lpar[[8,2]]-lpar[[8,2]]/f;rc1=17;rc2=17;rc3=17;rc4=17;

globlike4=(((ra0*ra1*rc1*ra2*rc2*ra3*rc3*ra4*rc4))^(-1))(((2 π))^(-(((n-m))/2))) Times@@(Sqrt[wt])  Exp[-(chisq4/2)] (((Det[covmatrix/(k4^2)]))^(1/2))

(Subscript[ODDS, 43])=globlike4/globlike3

Compute projected probability density and Laplacian marginal density for the amplitude a3 .

First modify the name of the variable of interest (in this case a3) by appending an x to the name, i.e. a3x. 
Give the model a new name

model1[x_]:=a0+a1*Exp[((-(((x-c1))^2))/(2 varL))]+a2*Exp[((-(((x-c2))^2))/(2 varL))]+a3x*Exp[((-(((x-c3))^2))/(2 varL))]+
a4*Exp[((-(((x-c4))^2))/(2 varL))];

Further steps are outlined below:
(1) define a3mode = best fit a3.
(2) define a3error = asymptotic standard error.
(3) define resolution = resolution of a3 axis of the final marginal probability density plot, 
e.g., a3error/resolution = a3error/3, so resolution parameter = 3.
(4) number of discrete points on a3 axis = 2*nstep+1 (symetrical about a0mode).
(5) If the k value for the best set of model parameters, is greater than one, this indicates that the data errors may have been underestimated. Implement the approximate way of correcting for this discussed in the section entitled, ``Marginal and Projected Distributions,'' in the chapter on Nonlinear Model Fitting. 
(6) output table called tautab contains the following columns (a3x, chisqi, facti, probi, probi*facti), where a3x is the parameter variable of interest,  chisqi =  the  (Subscript[χ, min]^2) for this choice of fixed a3x allowing all the other parameters to vary, probi = the projected probability for this choice of a3x which is ∝ (e^(Subscript[χ, min]^2)), facti = Laplacian factor needed to multiply probi to convert to the marginal density,    probi*facti = Laplacian approximation to marginal probability density for tau.
(7) Timing[  ] outputs the time taken for this computation. You might want to set nstep = 1 to start with, and check the execution time before setting nstep larger. On a 650 MHz Pentium III runing Mathematica version 4.1, the execution time was 2.1 sec for nstep = 12.

npar=9;vartable=Table[{parval[[i,1]],parval[[i,2]],
parerror[[i]]},{i,npar}]

j=6;l1v=Take[vartable,{j}];lv=Complement[vartable,l1v];tlv=Transpose[lv];lvar=Transpose[{tlv[[1]],tlv[[2]]}]

Timing[a3mode=parval[[6,2]];a3error=parerror[[6]];If[k4>1,k4squ=(k4^2),k4squ=1];resolution=6;inca3=a3error/resolution;nstep=15;a3tab={};Do[a3x=a3mode+(i-nstep-1)*inca3;
resulti=NonlinearModelFit[data,model1[x],lvar,x,Weights->wt];
residi=resulti["FitResiduals"];chisqi=residi.(wt*residi);ksqu=(chisqi/(n-(m-1)));probi=(E^(-chisqi/(2*k4squ)));facti=(((Det[k4squ*resulti["CovarianceMatrix"]/ksqu]))^(1/2));a3tab=Append[a3tab,{a3x,chisqi,facti,probi,probi*facti,(Sqrt[ksqu])}],{i,1,2 nstep+1}
]
]

Now plot the projected and marginal probability densities by extracting the relevant columns from the output table, tautab, and then using MultipleListPlot. For this to work correctly you must not alter the items or order of the options specified in the regression report in the step above.

(* Need to edit the xaxis and table names in the next two lines*) 
xaxis=a3;(* name of x axis variable on plot*)
table="a3tab";(* name of output table above*)
prb=Transpose[ToExpression[table]][[4]]/Plus@@Transpose[ToExpression[table]][[4]];mxprb=Max[prb];d1=Transpose[{Transpose[ToExpression[table]][[1]],prb}];margprb=Transpose[ToExpression[table]][[5]]/Plus@@Transpose[ToExpression[table]][[5]];d2=Transpose[{Transpose[ToExpression[table]][[1]],margprb}];ListPlot[{d1,d2},PlotRange->All,Joined->True,Frame->True,Axes->False,PlotStyle->{{Black,Thick},{Black,Dashed,Thick}},
	PlotLegend->{"projected","marginal"},
	LegendPosition->{-0.2,-0.35},LegendSpacing->0,
	LegendTextSpace->1.5,LegendBorderSpace->0.2,
	LegendSize->{0.5,0.25},
	LegendShadow->{0.02,-0.02},FrameLabel->{Style[ToString[xaxis]<>" amplitude",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compute projected probability density and Laplacian marginal density for the parameter a0 .
(not a required part of the problem)

model1[x_]:=a0x+a1*Exp[((-(((x-c1))^2))/(2*varL))]+a2*Exp[((-(((x-c2))^2))/(2*varL))]+a3*Exp[((-(((x-c3))^2))/(2*varL))]+
a4*Exp[((-(((x-c4))^2))/(2*varL))];

npar=9;vartable=Table[{parval[[i,1]],parval[[i,2]],
parerror[[i]]},{i,npar}]

j=1;l1v=Take[vartable,{j}];lv=Complement[vartable,l1v];tlv=Transpose[lv];lvar=Transpose[{tlv[[1]],tlv[[2]]}]

Timing[a0mode=parval[[1,2]];;a0error=parerror[[1]];If[k4>1,k4squ=(k4^2),k4squ=1];resolution=6;inca0=a0error/resolution;nstep=15;a0tab={};Do[a0x=a0mode+(i-nstep-1) inca0;resulti=NonlinearModelFit[data,model1[x],lvar,x,Weights->wt];
residi=resulti["FitResiduals"];chisqi=residi.(wt residi);ksqu=(chisqi/(n-(m-1)));probi=(E^(-chisqi/(2*k4squ)));facti=(((Det[k4squ*resulti["CovarianceMatrix"]/ksqu]))^(1/2));a0tab=Append[a0tab,{a0x,chisqi,facti,probi,probi facti,(Sqrt[ksqu])}],{i,1,2 nstep+1}]]

Now plot the projected and marginal probability densities by extracting the relevant columns from the output table, tautab, and then using MultipleListPlot. For this to work correctly you must not alter the items or order of the options specified in the regression report in the step above.

(* Need to edit the xaxis and table names in the next two lines*) 
xaxis=a0;(* name of x axis variable on plot*)
table="a0tab";(* name of output table above*)
prb=Transpose[ToExpression[table]][[4]]/Plus@@Transpose[ToExpression[table]][[4]];mxprb=Max[prb];d1=Transpose[{Transpose[ToExpression[table]][[1]],prb}];margprb=Transpose[ToExpression[table]][[5]]/Plus@@Transpose[ToExpression[table]][[5]];d2=Transpose[{Transpose[ToExpression[table]][[1]],margprb}];ListPlot[{d1,d2},PlotRange->All,Joined->True,Frame->True,Axes->False,PlotStyle->{{Black,Thick},{Black,Dashed,Thick}},
	PlotLegend->{"projected","marginal"},
	LegendPosition->{-0.2,-0.35},LegendSpacing->0,
	LegendTextSpace->1.5,LegendBorderSpace->0.2,
	LegendSize->{0.5,0.25},
	LegendShadow->{0.02,-0.02},FrameLabel->{Style[ToString[xaxis]<>" amplitude",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Fit a 11 parameter model, a baseline and 5 Gaussians.
(not a required part of the problem)

varL=1;

model[x_]:=a0+a1*Exp[((-(((x-c1))^2))/(2*varL))]+a2*Exp[((-(((x-c2))^2))/(2*varL))]+a3*Exp[((-(((x-c3))^2))/(2*varL))]+
a4*Exp[((-(((x-c4))^2))/(2*varL))]+a5*Exp[((-(((x-c5))^2))/(2*varL))];

Here is where the nonlinearfit is executed

lpar={{a0, 1.},{a1,6},{c1, 5.5},{a2,5. },{c2, 11},{a3,1.5 },{c3, 8},{a4,0.8 },{c4, 12.5},{a5,0.7 },{c5, 8.5}};result=NonlinearModelFit[data,
 model[x],lpar,x,Weights->wt];

To obtain the best fit funtional form.

Normal[result]

The best fit parameters.

parval=result["BestFitParameters"]

The next statement gives the parameter standard errors or more accurately the asymptotic standard errors. The use of these errors is based on the assumption that in the vicinity of the mode, the joint posterior probability distribution is a good approximation to a multivariate Gaussian

parerror=result["ParameterErrors"]

Tabulate best fit parameters, standard errors and confidence intervals.

result["ParameterConfidenceIntervalTable"]

The asymptotic standard error for each parameter is equal to the square root of  of the corresponding diagonal element of the asymptotic covariance matrix which is given below

covmatrix=result["CovarianceMatrix"]

List fit residuals (model values - data values)

result["FitResiduals"]

Compute the value of the best fit(χ^2) statistic designated by chisq.

chisq5=Total[(((result["FitResiduals"]))^2)*wt]

First specify the number of fitted parameters (m).

m = 11;

Reduced (χ^2) equals (χ^2) divided by number of degrees of freedom (= no. data points - no. of fitted paramters) Should be around the value 1 for a good model.

reducedchisq=chisq5/(n-m)

Note on the meaning of the asymptotic SE (standard error). In computing this Mathematica assumes that the measurement error associated with (i^th)  datum = k (Subscript[σ, i]), and computes k in the following way. If the model is valid the expected value of (χ^2)at the solution minimum, (Subscript[χ, expect]^2), is equal to the number of degrees of freedom = n-m where n = the number of data points = 100, and m = the number of fitted parameters = 4. 
(Subscript[χ, expect]^2)= (∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/((k^2) (Subscript[σ, i]^2)))) = (1/(k^2))(∑_(i=1)^n)((((((Subscript[d, i ])-(Subscript[f, i ])))^2)/( (Subscript[σ, i]^2)))) = ((Subscript[χ, meas]^2)/(k^2))= n-m = 96
Therefore (k^2) = ((Subscript[χ, meas]^2)/96), where (Subscript[χ, meas]^2) is the measured value based on given data errors. Including a factor k is a good thing to do since often nature is more complicated than than either the model or known data measurement errors can account for. Increasing all the data errors by k corresponds to increasing the terms in the parameter covariance matrix by (k^2) or the parameter standard errors by k.

k5=(Sqrt[(chisq5/(n-m))])

Now compute the frequents confidence in rejecting the fitted model. If confidence (conflf) is = 0.95 then we can say we are rejecting the model at the 95% confidence level.

conflf=1-GammaRegularized[((n-m)/2), chisq5/2]

Create a list called time which is the first part of each entry in the data list. Good idea to type data to see the structure of the data list. You should see a list of xy pairs.

time=Transpose[data][[1]];

Note above line could also be accomplished with "time=Map[#[[1]]&,data];"

Now create a list of the y values of the data.

yval=Transpose[data][[2]];

Combine the time, yval, err for plotting data with error bars.

datapluserror=Transpose[{time,yval,err}];

Plot the data plus errors

pl3=ErrorListPlot[datapluserror,PlotStyle->Black]

Anotherway of extracting the model parameters

result[[1,2]]

To obtain the best fit model function

fitfun[x_]=model[x]/. result[[1,2]]

fitfun[1.2]

xup=Max[Transpose[data][[1]]]

xdown=Min[Transpose[data][[1]]]

pl1=Plot[fitfun[x],{x,xdown,xup},PlotRange->All,Axes->False,Frame->True]

Show[pl1,pl3]

Show the best fit overlayed on data with errors

resids=result["FitResiduals"]

diff=Transpose[{time,resids,err}];

pl1r=ErrorListPlot[diff,PlotStyle->Black]

Compute mean, variance and reduced chi^2 of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the global likelihood of the model for use in comparing different models.

The result assumes your prior information about each amplitude parameter is uniform over a range of ± a factor of f = 3 from your initial guess of the parameter. Also assumes your prior information about each line center parameter is uniform between 1 and 17. As a first step we specify the prior ranges for the parameters.

f=3;

ra0=f*lpar[[1,2]]-lpar[[1,2]]/f;ra1=f*lpar[[2,2]]-lpar[[2,2]]/f;ra2=f*lpar[[4,2]]-lpar[[4,2]]/f;ra3=f*lpar[[6,2]]-lpar[[4,2]]/f;ra4=f*lpar[[8,2]]-lpar[[8,2]]/f;ra5=f*lpar[[10,2]]-lpar[[10,2]]/f;rc1=17;rc2=17;rc3=17;rc4=17;rc5=17;

globlike5=(((ra0*ra1*rc1*ra2*rc2*ra3*rc3*ra4*rc4*ra5*rc5))^(-1))(((2 π))^(-(((n-m))/2))) Times@@(Sqrt[wt])  Exp[-(chisq5/2)] (((Det[covmatrix/(k5^2)]))^(1/2))

(Subscript[ODDS, 54])=globlike5/globlike4

Ch. 12: Problem 1  (1 MCMC chain)

Introduction

This notebook employs a semi-automatic parallel tempering (Section 12.8) version of Markov Chain Monte Carlo to analyze the spectral line data of chapter 3. In this version of the problem the line frequency (f), line temperature (T), and line width are unknown within given prior limits. See Section 12.6 for more details. The program can easily be modified for another nonlinear model fitting problem.

16 MCMC chains are run in parallel each with a different tempering parameter β. At random intervals, proposals to swap the parameter values of a random pair of chains is considered. This prevents the MCMC from becoming trapped in one probability peak region. The program automates the selection of Gaussian proposal σ's, one for each parameter. 
The best approach is to choose a set of proposal distribution {σ} that are about 1/10th the prior range of each parameter, then let the control system automatically home in on improved proposal σ's. Useful parameter iterations are obtained after the control system terminates. 

The Bayes factor, used in model selection, is computed in two different ways at the end of this program.

The spectral line model equations

Let f0 stand for the line frequency,T  for the line temperature, and σl  for the line width .

Model of spectral line  = temperature * Exp[-((((f-f0))^2)/(2 ((σl)^2)))]

The set of  f values in the measured spectrum is given by  fvec.

Let model[T_,f0_] stand for the set of measurements predicted by 
the model.
model[temperature_,f0_]:=temperature* Exp[-((((fvec-f0))^2)/(2 ((σl)^2)))]

According to the model we can write for the (i^th) data value
                            di = mi + ei,
where  mi   is the  model  prediction for the (i^th) data value and  ei   is an independent
Gaussian error term.

The likelihood is given by
     p(D|M,X,I) = (((2 π))^(-nd/2))(σ^(-nd))Exp[-(((∑_(i=1)^n)(((di- mi))^2))/(2 (σ^2)))]
                       = (((2 π))^(-nd/2))(σ^(-nd))Exp[-(((∑_(i=1)^n)(di^2))/(2 (σ^2)))] Exp[-((2(∑_(i=1)^n)di mi)/(2 (σ^2)))]Exp[-(((∑_(i=1)^n)(mi^2))/(2 (σ^2)))]

Let  dvec stand for the vector of n data value 
Let  mvec stand for the vector of n model predictions
then (∑_(i=1)^n)(di^2) = dvec.dvec ;    (∑_(i=1)^n)(mi^2) = mvec.mvec  ;  (∑_(i=1)^n)di mi = dvec.mvec

Alternate calulation used in actual program allows for a different error for each data point:
                y=(dvec-mvec)/errvec
     p(D|M,X,I) = (((2 π))^(-nd/2)){Times@@(((errvec))^(-1))}Exp[-0.5*y.y]

Equations needed for model selection

For model comparison need to compute  odds = Exp[logpM1-logpM2]  (see Section 12.7)

logpM1 = log[p(D|M1,I)] = ∫ (Subscript[⟨ log[p(D|M1,f,T,I)] ⟩, β])  dβ

(Subscript[⟨ log[p(D|M1,f,T,I)] ⟩, β]) = expectation value of  log[p(D|M1,f,T,I)]  for  given  β
                                              = (1/n)(∑_(t=1)^n)  log[p(D|M1,(Subscript[f, t,β ]),(Subscript[T, t,β]) ,I)] 
                                                      where n = number of  MCMC iterations
                                              = abbreviate by    expect[[nb]],
    - where nb goes from 1 to nβ ,
    - and  the list of  β values is given by  βlis = Table[β0+dβ (i-1),{i,1,nβ}],     
    - and p(D|M1,(Subscript[f, t,β ]),(Subscript[T, t,β]) ,I) is the likelihood of each set of parameter choices 
      accepted for the given value of β.  
      
(see section on spectral line model above and Chapter 3 for discussion of the models)      
p(D|M1,f,T,I) = abbreviated   like1 = (((2 π))^(-nd/2)){Times@@(((errvec))^(-1))}Exp[-0.5*y.y]
     - where  mvec = model[T,f];    
     - and   model[temperature_,f0_]:=temperature * Exp[-((((fvec-f0))^2)/(2*((σl)^2)))];   
prior1 = =(c/T) ;  where c =1/{(fmax-fmin)*Log[(Tmax/Tmin)]};      
and   pdfβ1= prior1*(((like1))^β);
  
finally  logpM2 = log[p(D|M2,I)] = Log[(((2 π))^(-nd/2)) {Times@@(((errvec))^(-1)) } Exp[- 0.5*y.y]] 
                                                        = global probability of model M2;    
  - recall model M2 has no parameters

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

Needs["Graphics`Common`GraphicsCommon`"]

List and plot the the spectral line data

The data, named dat, consists of (f,T), frequency channel number and temperature pairs.

dat1= {{1.`,0.82`},{2.`,-2.07`},{3.`,0.38`},{4.`,0.99`},{5.`,-0.12`},{6.`,-1.35`},{7.`,-0.2`},{8.`,0.36`},{9.`,0.78`},{10.`,1.01`},{11.`,0.44`},{12.`,0.34`},{13.`,1.58`},{14.`,0.08`},{15.`,0.38`},{16.`,-0.71`},{17.`,-0.9`},{18.`,0.33`},{19.`,0.8`},{20.`,-1.42`},{21.`,0.28`},{22.`,-0.42`},{23.`,0.12`},{24.`,0.14`},{25.`,-0.63`},{26.`,-1.77`},{27.`,-0.67`},{28.`,0.55`},{29.`,1.98`},{30.`,-0.08`},{31.`,1.16`},{32.`,0.48`},{33.`,-0.03`},{34.`,1.47`},{35.`,1.7`},{36.`,1.89`},{37.`,4.55`},{38.`,3.59`},{39.`,2.02`},{40.`,0.21`},{41.`,0.05`},{42.`,0.54`},{43.`,-0.09`},{44.`,-0.61`},{45.`,2.49`},{46.`,0.07`},{47.`,-1.45`},{48.`,0.56`},{49.`,-0.72`},{50.`,0.38`},{51.`,0.02`},{52.`,-1.26`},{53.`,1.35`},{54.`,-0.04`},{55.`,-1.45`},{56.`,1.48`},{57.`,-1.16`},{58.`,-0.4`},{59.`,0.01`},{60.`,0.29`},{61.`,-1.35`},{62.`,-0.21`},{63.`,-1.67`},{64.`,0.7`}};

Details concerning data manipulation and statistics.

tarr1=Transpose[dat1];

lendat=Length[dat1];nd=lendat

fvec1=N[tarr1[[1]]];

fvecmin=First[fvec1];

fvecmax=Last[fvec1];

dvec1=N[tarr1[[2]]];

σnoise=1.0;(* data noise sigma *)

errvec1=Table[σnoise,{nd}];

aveDerror=Mean[errvec1];

dat=Transpose[{fvec1,dvec1,errvec1}];

tarr=Transpose[dat];

fvec=N[tarr[[1]]];

dvec=N[tarr[[2]]];

ppeak=Max[dvec]-Min[dvec]

errvec=N[tarr[[3]]]

data=Transpose[{fvec,dvec}];

Plot the data

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,PlotStyle->Black,FrameLabel->{Style["Channel  number",{"Helvetica-Bold",12}],Style["Temperature",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.005],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp1r=Show[plshp1,Graphics[{Text["(a)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Parallel Tempering program

INITIALIZE PROGRAM VALUES

nthin=1; (* store MCMC iterations at a thinning interval of nthin. Since successive
iterations are partially correlated using an nthin ≈ 10 reduces the correlation
and reduces the memory requirements for long iterations *)

n=50000*nthin; (* number of MCMC iterations *)

nβ=1;(* number of choices of tempering parameter *)(* Note:the product nβ\[Cross]ns/(swap rate) should be approximately ≃ 150 *)

βlis={1.0};(* tempering parameter values *)

(*βlis={0.0001,0.001,0.01,0.025,0.1,0.2,0.3,0.45,0.6,0.75,1.0};*)(* tempering parameter values *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains *)

ns=5; (* ns is mean number of iterations between swap proposals *)

np=2; (* np= number of free parameters computational explored *)

ncs=np; (* only the first ncs parameter proposal σ's adjusted by the control system *)

nl=np+4;(* item in output list containing prior1*(((like1))^β) (don't change this) *)

n2l=np+3;(* item in output list containing Log[like] (don't change this) *)

swb=0; (* swb=1 if extra noise parameter s included, swb = 0 otherwise *)

STARTING PARAMETER VALUES

avst=Table[0,{np}]; (* initialize table of start parameter values *)
avmin=Table[0,{np}];(* initialize table of parameter lower bounds *)
avMax=Table[0,{np}];(* initialize table of parameter upper bounds *)
bfmin=Table[0,{np}];(* Bayes factor parameter lower bounds *)
bfMax=Table[0,{np}];(* Bayes factor parameter upper bounds *)

avst[[1]]= 30.0; (* line center freq. start value *)

a1name= "f"; a1unit="  (channel #)";(* name of parameter 1 and units *)

avst[[2]]=5.0; (* line temperature start value *)

a2name= "T"; a2unit="  (mK)";(* name of parameter 2 and units *)

PRIOR SEARCH RANGES

avmin[[1]]=1.0;avMax[[1]]=44;(* search bounds on line center freq *)

avmin[[2]]=0.1;avMax[[2]]=ppeak;(* search bounds on line temperature *)

type={0,0}; (* If type = -1, parameter is a period but search carried out in frequency *)
(* type = 1, angular parameter, wrap around at 0 and 1 *)
(* type = 2, angular parameter, wrap around at 0 and 2π *)
(* type = 3, angular parameter, wrap around at 0 and 4π *)
(* type = 4, angular parameter, wrap around at -2π and 2π *)
(* type = 5, parameter is first radial velocity amplitude (Subscript[K, 1 ])*)
(* type = 6, parameter is second radial velocity amplitude (Subscript[K, 2 ])in multiple planet fit *)
(* type = 7, parameter is second radial velocity amplitude (Subscript[K, 3 ])in multiple planet fit *)
(* type = 0, all other parameters *)

PRIOR RANGE FOR BAYES FACTOR CALCULATION

bfmin[[1]]=1.0;bfMax[[1]]=44.;(* search bounds on line center freq *)
bfmin[[2]]=0.1;bfMax[[2]]=100.;(* search bounds on line temperature *)
(* search bounds on line width *)

STARTING SIGMAS AND MINIMUM SIGMAS

σst=Table[0,{i,1,ncs}];(* initialize table of parameter proposal σ's *)

minσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ's *)

swminσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ switches  *)

Typically set start sigma to approximately 10 to 20% of the parameter search range.

σst[[1]]=0.2*(avMax[[1]]-avmin[[1]]); (* sigma for a1 proposal random Gaussian step *)

σst[[2]]=0.2*ppeak; (* sigma for a2 proposal random Gaussian step *)

Set minimum proposal sigmas.

sigTonoise=0.5*ppeak/Mean[errvec];

minσ[[1]]=0.1;(* min sigma for proposal random Gaussian step *)

minσ[[2]]=Mean[errvec]/(Sqrt[nd]); (* min sigma for proposal random Gaussian step *)

CONTROL SYSTEM PARAMETERS  (user don't change this)

minCS=3000; (* minimum number of iterations before Control System turned off *)

maxCS=7000; (* maximum number of iterations before 1st stage Control System turned off *)

deltaN=5000; (* intervals in i used to decide on whether to rerun 2nd stage CS *)

sw1=0;(* =0 when control system is on and =1 when turned off.*)

sw5=1;(* =0 never do 2nd stage CS, =1 execute 2nd stage CS *)

n0=1000; (* initial search with no control system active *)

λ=0.25; (* target acceptance ratio *)

n1=1000; (* number of iterations between changes in σ's *)

n2=200; (* number of iterations per parameter per minor cycle *)

nt1=λ*n1; (* target no. of acceptances per n1 iterations *)

nt=λ*n2; (* target no. of acceptances per n2 iterations *)

tol1=0; (* error tolerance 1 in annealing *)

(*tol1=1.5*(Sqrt[nt1]);*) (* error tolerance 1 in annealing *)

tol2=1.5*(Sqrt[nt1]); (* error tolerance each β chain must satisfy before CS turned off *)

(*tol2=0;*) (* error tolerance each β chain must satisfy before CS turned off *)

scmax=0.1; (* max factor to reduce/increase σ in control sys minor cycles *)

gain=Table[0.7,{i,1,nβ}];
(*gain={0.25,0.45,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6};*)
(*gain=Table[0.7-(nβ-i)*0.1/(nβ-1),{i,1,nβ}];*)(* gain x scmax = max factor to reduce/increase proposal σ's *)

γ=1.6; (* damping exponent in annealing process *)

alfm=0.806096-1.12051*(10^(-2))*ncs+3.1233*(10^(-4))*(ncs^2)-3.03567*(10^(-6))*(ncs^3);(* Scaling exponent for calulation of accept rate for individual parameters 2nd stage CS *)

kalf=0.98; (* Empirical factor for scaling exponent, typical value 0.87 *)

accept=Table[(((λ))^(1/(ncs^(kalf*alfm)))),{kn,1,nβ},{kj,1,ncs}]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS

Define the constant portion of the joint prior for model M1.

c=-Log[(bfMax[[1]]-bfmin[[1]])*Log[((bfMax[[2]])/(bfmin[[2]]))]](* normalization constants for prior *)

Define the constant portion of the joint prior for model M1 
(assumes a modified Jeffreys prior for T).

(*c=-Log[(bfMax[[1]]-bfmin[[1]])*Log[((mJlim+bfMax[[2]])/mJlim)]];*)(* normalization constants for prior *)

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (depends on model)

Version below does not include extra noise parameter s.

Specify terms needed in calculation of model M1 likelihood

σline=2.0;

logfact=((-nd)/2.0)*Log[2*π];(*portion of likelihood that does not depend on f,T,σl *) model[temperature_,f0_]:=temperature*Exp[-((((fvec-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T *)

Specify a module for calculating the basic work ≡  logposterior = logprior + loglikelihood 
for model M1. 
It is convenient to work with Log quantities because this avoids the need for Mathematica to use extended precision calculations (much slower than machine precision calculations) when the likelihoods are very small, often the case.
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

work:=Module[{f,T,y},f=av[[1]];T=av[[2]];
mvec=model[T,f]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T] ; (* the prior for parameters f & T *) 
y=(dvec-mvec)/errvec;
loglike=logfact-Plus@@Log[errvec]-0.5*y.y;(* likelihood fn for particular f,T *)  
pvec={f,T}]

MODULE THAT PROPOSES THE NEW PARAMETER SET (depends on model)

Propose new parameter values. Uses Switch command and parameter type[[ii]] to handle different parameter types. 
For type[[1]],  proposed update in Period = av[[1]] is the reciprocal of a proposed change in frequency.
Check if proposed values lie outside prior borders, if so reflect parameter or wrap angular parameters.

propose:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,av[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,av[[ii]]=Mod[2*avMaxt-av0,(avMaxt-avmint),avmint]],
-1,
If[smp>0&&i>ncsys&&RandomReal[]<0.25,avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],2*σall[[k,ii]]]];av[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,av[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,av[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σall[[k,ii]]]];av[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,av[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,av[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
1,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],1],
2,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],2π],
3,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],4π],
4,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av5<avmint,av[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,av[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av6<avmint,av[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,av[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av7<avmint,av[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,av[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]]
];
]

STEP TO EXECUTE MCMC CALCULATION (user don't change this)

AbsoluteTiming[
logpdfβi=.;  (* remove any existing definition of output file *)
logpdf=.;  (* remove any existing definition of file *)
num=ToString[rnum];  (* run number for specifying unique output plots *)
nnt=n/nthin;  (* no. of thinned iterations, n needs to be integer divisible by nthin *)
logpdf=Table[0,{i,1,2},{j,1,nβ}]; (* initialize storage *) 
logpdf2=Table[0,{i,1,2},{j,1,nβ}]; (* initialize storage *)
logpdfβi=Table[0,{i,1,nnt},{j,1,nβ}]; (* initialize storage *)
accept1=Table[0,{i,1,nβ},{j,1,ncs}]; (* initialize storage for param. acceptance rates *)
accept2=Table[0,{i,1,nβ},{j,1,ncs}]; 
accept3=Table[0,{i,1,nβ},{j,1,ncs}]; 
maxlogpdfβi=Table[0,{j,1,nβ}]; (* initialize storage *) 
na=Table[0,{nβ}];  (* initialize acceptance array *)
nb=Table[0,{k,1,nβ},{ncs}];  (* initialize array to store #accepted proposals in minor cycle *)(* for each parameter proposal σ *)
smp=0;(* smp=0 or 1, smp=1 better multiple peak detection, reduced acceptance rate*)
diag={};  (* initialize diagnostic array {sw,er,i,parameter #} *)
swap={};  (* initialize diagnostic array for swaps *)
(*α0=1/ns;*) (* if uniform random deviate is less than α0 then swap *)
nas=0; (* initiate an integer used in computing actual swap rate *)
nbmin=Table[0.0,{nβ}]; (* inintialize control system array *)
nbmax=Table[0.0,{nβ}]; (* inintialize control system array *)
dnb=Table[0.0,{nβ}]; (* inintialize control system array *)
err=Table[0.0,{nβ}]; (* inintialize control system err array *)
erl={}; (* array used to determine when err in all chains < tol2 *)
κ=Table[1.0,{k,1,nβ},{ncs}];(* weak logarithmic restoring force array*)
diagarray=Table[0,{k,1,nβ},{6}]; 
av=Table[0.0,{np}]; (* inintialize parameter array *)
σall1=Table[0,{np}];  
Do[σall1[[i]]=σst[[i]],{i,1,np}];(*initialize σall1 array*)
σall=Table[σst[[i]],{k,1,nβ},{i,1,np}];  
(* initialize σall array *)
σallold={};(* record previous best σall *)
logpdftemp2old={};(* record previous best logpdftemp2 in β=1 chain in 2nd stage CS *)
maxlogpdfAllold={};(* record previous values of maxlogpdfAll *)
σmonitor={{1,σall}};  (* initialize monitor of parameter proposal σ's  *)(* specify some constants & switches used in the control system *) 
nc1=1;(* maj/minor cycle counter initially set to 1 *)
nc2=Table[0,{nβ}];(* # of prop. acceptances in each subcycle *)
nc4=0;(* = 0 in major cycle and = 1,2,--,ncs in minor cycles *)
sw=Table[0,{nβ}];(* =0 in major cycles and in minor cycles 
=+1 if er[[k]]<0 and =-1 if er[[k]]>0 *)
sw3=0;(* =0 in major cycles and =1 in minor cycles.*)
sw4=0;(* =0 skip over 2nd stage CS, =1 execute 2nd stage CS *)
gain0=gain;(* initial control system gain.*)
(* Control system turned off as soon as er< tol2. *)
ncsys=n; (* otherwise ncsys=iteration # when control system turned off *)
ncsysold={}; (* records previous values of ncsys=iteration # *)
it=0;(* initialize counter for thinned iteration number *)
logfact=-(nd/2.0)*Log[2.0*π] ;
(* Evaluate the probability for the i=0 sample for each tempering level*)
Do[(* iteration over β *) β=βlis[[k]];av=avst;
 (* initiate parameter values *)
(* ******************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdf1= loglike;
pdfβ1= logprior+β*loglike; (* factor needed to decide on tempering swap *)
logpdf[[1,k]]=Join[{β},pvec,{0,pdf1,pdfβ1}],{k,1,nβ} 
];  (* close first Do loop iterating over β *)
maxlogpdfβi=logpdf[[1]];
maxlogpdfAll=logpdf[[1,nβ]];
Do[ (* start calculation for ith iteration beginning at i = 1 *)
If[i>n0,nc1=nc1+1];If[nc1<2&&i>n0,logpdftemp=logpdfinow,logpdftemp=logpdf[[1]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk = logpdftemp[[k]]; values = Take[logpdftempk, {2, np + 1}];
(* recover previous parameter values*)
(*************** propose new parameter set ******************) 
Do[propose,{ii,1,np}];
(* ****************** Basic working *********************** *)
work;
(* ******************************************************** *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf[[2,k]]=Join[{β},pvec,{i,pdfi,pdfβi}];If[pdfβi>Last[maxlogpdfβi[[k]]],maxlogpdfβi[[k]]=logpdf[[2,k]]];
If[i>n0,nc2[[k]]=nc2[[k]]+1;If[nc4<1,na[[k]]=na[[k]]+1]],logpdf[[2,k]]=logpdftempk;logpdf[[2,k,n2l-1]]=i
], (* complete If statement *)
{k,1,nβ} 
];(* complete Do loop over β *)
(* Consider a swap between 2 tempering levels if i an integer multiple of ns *)
If[nc4>0||nβ<2,Goto[anneal]];
If[IntegerQ[i/ns],(* next pick the 2 levels k1 & k2 to swap *)
(* following command chooses k1 from 1 to nβ-1 and sets k2=k1-1 *)
k1=RandomInteger[{1,(nβ-1)}];
k2=k1+1;
(* evaluate swap acceptance rule*)
loglike1=logpdf[[2,k1,n2l]];
loglike2=logpdf[[2,k2,n2l]];
β1=logpdf[[2,k1,1]];β2=logpdf[[2,k2,1]];
logprior1=logpdf[[2,k1,nl]]-β1*loglike1;
logprior2=logpdf[[2,k2,nl]]-β2*loglike2;
p12=logprior1+β2*loglike1;
p21=logprior2+β1*loglike2;
r=Exp[(β2-β1)*(loglike1-loglike2)];  
u2=RandomReal[];
If[u2≤r (* if uniform random ≤ r then accept swap *),nas=nas+1;swap=Append[swap,{k1+k2,1,i}];
temp=logpdf[[2,k1]];
Do[logpdf[[2,k1,ji]]=logpdf[[2,k2,ji]],{ji,2,np+1}];
logpdf[[2,k1,n2l]]=loglike2;logpdf[[2,k1,nl]]=p21;
Do[logpdf[[2,k2,ji]]=temp[[ji]],{ji,2,np+1}];
logpdf[[2,k2,n2l]]=loglike1;logpdf[[2,k2,nl]]=p12,
swap=Append[swap,{k1+k2,0,i}]]  (* complete accept If swap statement *)
] ; (* complete first If swap statement *)
(* start of annealing control system *)
Label[anneal];
If[sw1>0||i<n0,Goto[next],(* sw1=1 means want control system turned off *)
If[nc4>0,Goto[cycle],
If[nc1<n1,Goto[next],nc1=0;er=Table[nc2[[k]]-nt1,{k,1,nβ}];nc2=Table[0,{nβ}];
If[i>minCS&&Abs[er[[nβ]]]<tol2,sw1=1;nc4=0;na=Table[0,{nβ}];ncsys=i;ncsys1=ncsys+deltaN;If[sw5>0,sw4=1];Goto[next]];
If[Max[Abs[er]]<tol1,Goto[next],
logpdfinow=logpdf[[2]];scexp1=(((Abs[er]/nt1))^γ);scexp=Table[Min[1,scexp1[[jj]]],{jj,1,nβ}];sc=(scmax^scexp);scplus=gain*(1-sc);scminus=gain/sc;
Do[If[er[[k]]<0,sw[[k]]=1;nc4=1,sw[[k]]=-1;nc4=1],{k,1,nβ}]
];(* sw=1 for cooling parameter & sw=-1 for heating parameter *) 
If[nc4>0,Do[σall[[k,nc4]]=sc[[k]]^sw[[k]]*σall[[k,nc4]],{k,1,nβ}]];
Goto[next]
]
]
];
Label[cycle];
If[nc1<n2,Goto[next],Do[nb[[k,nc4]]=nc2[[k]];σall[[k,nc4]]=sc[[k]]^(-sw[[k]])*σall[[k,nc4]],{k,1,nβ}]
];
nc4=nc4+1;nc2=Table[0,{nβ}];nc1=0;If[nc4>ncs,Goto[list],Do[σall[[k,nc4]]=sc[[k]]^sw[[k]]*σall[[k,nc4]],{k,1,nβ}];Goto[next]
];
Label[list];
Do[nbmax[[k]]=Max[nb[[k]]];nbmin[[k]]=Min[nb[[k]]];dnb[[k]]=nbmax[[k]]-nbmin[[k]];nc3=Flatten[Position[nb[[k]],nbmax[[k]]]];lnc3=Length[nc3];nc5=Flatten[Position[nb[[k]],nbmin[[k]]]];lnc5=Length[nc5];
If[sw[[k]]>0,
If[nbmin[[k]]<nbmax[[k]],
Do[σallprop=(1-scplus[[k]])*σall[[k,nc3[[ik]]]]; If[σallprop<minσ[[ik]],σall[[k,nc3[[ik]]]]=minσ[[ik]];If[k==nβ,swminσ[[ik]]=1],σall[[k,nc3[[ik]]]]=σallprop],{ik,1,lnc3}],
Do[σallprop=sc[[k]]*σall[[k,ik]];If[σallprop<minσ[[ik]],σall[[k,nc3[[ik]]]]=minσ[[ik]];If[k==nβ,swminσ[[ik]]=1],σall[[k,nc3[[ik]]]]=σallprop],{ik,1,ncs}]
];
err[[k]]=nbmax[[k]]-nt;
diagarray[[k]]={sw[[k]],er[[k]],err[[k]],sc[[k]],i,dnb[[k]]};sw[[k]]=0,If[nbmin[[k]]<nbmax[[k]],
Do[σall[[k,nc5[[ik]]]]=scminus[[k]]*σall[[k,nc5[[ik]]]]; If[k==nβ&&(nbmax[[k]]-nc5)>0,swminσ[[ik]]=0],{ik,1,lnc5}],
Do[σall[[k,ik]]=σall[[k,ik]]*scminus[[k]];If[k==nβ,swminσ[[ik]]=0],{ik,1,ncs}]
];
err[[k]]=nbmin[[k]]-nt;
diagarray[[k]]={sw[[k]],er[[k]],err[[k]],sc[[k]],i,dnb[[k]]};sw[[k]]=0
],{k,1,nβ}
];
If[Product[swminσ[[i]],{i,ncs}]>0,sw1=1;nc4=0;na=Table[0,{nβ}];ncsys=i];
σmonitor=Append[σmonitor,{i,σall}];diag=Append[diag,diagarray];nc4=0;
If[i>maxCS&&sw1==0,sw1=1;sw4=1;ncsys=maxCS];
Label[next];
If[sw4<1,(* If sw4==0 skip 2nd stage control system *)
If[IntegerQ[i/nthin],it=it+1;logpdfβi[[it]]=logpdf[[2]]];logpdf[[1]]=logpdf[[2]],
(************************************************************************)
(*** Control system 2nd stage, acceptance for individual parameters ***)
(************************************************************************)
If[IntegerQ[i/nthin],it=it+1;logpdfβi[[it]]=logpdf[[2]]];(* ***************** Find best chain values ***************** *)
bestvec=Take[RotateLeft[maxlogpdfAll,1],np];
Do[(* iteration over β *) β=βlis[[k]];av=bestvec;
 (* initiate parameter values *)
(* ******************** Basic working ********************** *)
work;
(* ********************************************************* *)
pdfj= loglike;
pdfβj= logprior+β*loglike; 
If[pdfβj>Last[maxlogpdfβi[[k]]],
maxlogpdfβi[[k]]=Join[{β},pvec,{1,pdfj,pdfβj}]],
{k,1,nβ} 
];  (* close first Do loop iterating over β *)
(* *********************************************************** *)
logpdf[[1]]=maxlogpdfβi;
logpdfinow2=maxlogpdfβi;
nβlow=nβ-n2β+1;
k2vals=Table[iip,{iip,nβlow,nβ}];
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,nβlow,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept1[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
σold1=σall;
Do[σall[[k]]=σall[[k]]*(Sqrt[((N[accept1[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept1[[k]]/n1]+0.01)))]),{k,nβlow,nβ}];
(**************************************************************)
(* Control upper limit of σall to be ≤ parameter search range *)
Do[(* iteration over parameters *)
Do[Switch[type[[ip2]],
0,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
-1,If[σall[[k,ip2]]>(1./avmin[[ip2]]-1./avMax[[ip2]]),σall[[k,ip2]]=(1./avmin[[ip2]]-1./avMax[[ip2]])],
1,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
3,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
4,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
5,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
6,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
7,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]]
],{k,nβlow,nβ}
],(* complete β Do loop *)
{ip2,1,ncs}
];(* complete parameter Do loop *)
(**************************************************************)
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,nβlow,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept2[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
σold2=σall;
Do[σall[[k]]=σall[[k]]*(Sqrt[((N[accept2[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept2[[k]]/n1]+0.01)))]),{k,nβlow,nβ}];
(**************************************************************)
(* Control upper limit of σall to be ≤ parameter search range *)
Do[(* iteration over parameters *)
Do[Switch[type[[ip2]],
0,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
-1,If[σall[[k,ip2]]>(1./avmin[[ip2]]-1./avMax[[ip2]]),σall[[k,ip2]]=(1./avmin[[ip2]]-1./avMax[[ip2]])],
1,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
3,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
4,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
5,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
6,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
7,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]]
],{k,nβlow,nβ}
],(* complete β Do loop *)
{ip2,1,ncs}
];(* complete parameter Do loop *)
(**************************************************************)
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,1,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept3[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
sw4=0
]; (* complete If statement *)
If[i>ncsys&&IntegerQ[(i-ncsys)/deltaN]&&(Last[maxlogpdfAll]-Last[logpdftemp2[[nβ]]])>3.0,sw4=1;ncsysold=Append[ncsysold,ncsys];σallold=Append[σallold,σall];logpdftemp2old=Append[logpdftemp2old,logpdftemp2];na=Table[0,{nβ}];ncsys=i,
];(* complete If statement *)
,{i,1,n} (* complete iteration Do loop *)
];
acceptratio=If[ncsys<n,N[na/(n-ncsys)],N[na/n]]  (* evaluate acceptance ratio *)
]

The line above gives the execution time and average acceptance rate for each chain after the control system was turned off. The control system switched off at an iteration number specified by ncsys (given below).

The MCMC iteration number (unthinned) at which control system was turned off for the last time.

ncsys

The line below lists the most probable parameter set found in the MCMC.

Take[maxlogpdfAll,{2,np+1}]

A number of specialized items only of use to the code designer.

ncsysold

swminσ

maxlogpdfAll

Length[maxlogpdfAllold]

maxlogpdfAllold

maxlogpdfβi

logpdfinow2

MemoryInUse[]

n2c2

na

MCMC performance diagnostics & parameter proposal σ's

The next command gives the acceptance rate for each chain (tempering level).

acceptratio

The output from the next command gives the swap acceptance rate between adjacent tempering levels. First item is the swap rate between the two with lowest β tempering levels, etc.

If[nβ>1&&n>ncsys,swaplen={};swaprate={};nsw0=1;swaps=Sort[swap];spl=Split[Transpose[swaps][[1]]];Do[nswi=Length[spl[[i]]];swlst=Take[swaps,{nsw0,nswi+nsw0-1}];swpr=N[(Plus@@(Transpose[swlst][[2]]))/nswi];swaprate=Append[swaprate,swpr];swaplen=Append[swaplen,nswi];nsw0=nsw0+nswi,{i,1,nβ-1}];swaprate,]

The MCMC iteration number (unthinned) at which control system was turned off for the last time.

ncsys

The line below lists the most probable parameter set found in the MCMC.

Take[maxlogpdfAll,{2,np+1}]

The following is a matrix of Gaussian parameter proposal σ's chossen by the control system. There should be nβ lines, one for each tempering level. The top row corresponds to β0 and the bottom to β = 1. The columns give the proposal σ's for the parameters. 
They should all be greater than the corresponding value in minσ given on the next line.

minσ

MatrixForm[σall]

A number of specialized diagnostic, only of use to designer.

ncsysold

swminσ

maxlogpdfAll

Length[maxlogpdfAllold]

maxlogpdfAllold

maxlogpdfβi

logpdfinow2

MemoryInUse[]

n2c2

na

MatrixForm[σold1]

MatrixForm[σold2]

MatrixForm[N[accept1/n1]]

Times@@(accept1[[nβ]]/N[n1])

MatrixForm[N[accept2/n1]]

Times@@(accept2[[nβ]]/N[n1])

MatrixForm[N[accept3/n1]]

Times@@(accept3[[nβ]]/N[n1])

Plotting results of MCMC

Setup some graph axes labels

tlabel=
StyleForm[StringForm["``",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

tmklabel=
StyleForm[StringForm["``  (mK)",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

flabel=
StyleForm[StringForm["``  (channel #)",
StyleForm["f",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

tACFlabel=
StyleForm[StringForm["``  ACF",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

fACFlabel=
StyleForm[StringForm["``  ACF",
StyleForm["f",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

Extracting model parameter samples for the β = 1 MCMC chain

All the results are stored by the variable logpdfβi. (example format for 3 parameters f,T,σl)
First let's look at an example of the first row of the output given by logpdfβi[[1]].
{{0.01`,30.`,5.`,0.7`,-118.00310275500061`,0.0000591119911561849`},{0.2575`,30.`,5.`,0.7`,-118.00310275500061`,1.2239727134969812`*^-17},{0.505`,30.`,5.`,0.7`,-118.00310275500061`,2.5343575374188987`*^-30},{0.7525`,30.`,5.`,0.7`,-118.00310275500061`,5.247639965045567`*^-43},{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55}}
Here is MatrixForm[logpdfβi[[1]]];
(({{0.01`, 30.`, 5.`, 0.7`, -118.00310275500061`, 0.0000591119911561849`}, {0.2575`, 30.`, 5.`, 0.7`, -118.00310275500061`, 1.2239727134969812`*^-17}, {0.505`, 30.`, 5.`, 0.7`, -118.00310275500061`, 2.5343575374188987`*^-30}, {0.7525`, 30.`, 5.`, 0.7`, -118.00310275500061`, 5.247639965045567`*^-43}, {1.`, 30.`, 5.`, 0.7`, -118.00310275500061`, 1.0865761754668881`*^-55}}))
The first row contains the result for β = 0.01 and the last row is for β = nβ = 1.0.
We want to extract the β = 1.0 values. Do this with tr = Transpose[logpdfβi][[nβ]];
Now look at the first 5 rows with the command Take[tr,5].
{{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55},
{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55},{1.`,31.395819229020145`,4.463705555454431`,0.6292479467731473`,-112.7790133460596`,2.260100997434301`*^-53},{1.`,31.395819229020145`,4.463705555454431`,0.6292479467731473`,-112.7790133460596`,2.260100997434301`*^-53},{1.`,31.064587671869017`,2.339148265037844`,0.6509533931515838`,-107.75817884100877`,6.535613421513293`*^-51}}
The first item in each row is the value of β, 
The next two items are the current values of the two parameters f,T,σl.
The next item is the Log of the likelihood, that is used in computing the global likelihood of the model for the Bayes factor calculation.
The final item is the value of   prior*(((like))^β) for the particular set of parameter values.
To obtain columns of each quantity use trn = Transpose[tr];
Finally we obtain the complete list of  f & T parameter iterations with  fgood=trn[[2]]; Tgood=trn[[3]]; 
Now putting this all together we write

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];fgood=trn[[2]];Tgood=trn[[3]];σlgood=trn[[4]];ng=Length[trn[[1]]]

Examine parameter iterations for the β = 1 (k = nβ) MCMC chain

Sart by choosing some display parameters.

niter=100;(* with niter = 100, plot only every 100th point *)

nburn1=5000;(* skip first nburn1 iterations for 2nd (upper right) plot *)

(*pl=Table[0,{i,np+2+nplan}];*)(* initiate table of graphs to be plotted *)

pl=Table[0,{i,np+2}];(* initiate table of graphs to be plotted *)

fn=Table[i,{i,1,ng}];(* initiate a variable representing the iteration number *)

Here is where we create the plots for the np parameters

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];
pl[[i+2]]=ListPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},AspectRatio->0.5,
PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration",{"Helvetica-Bold",12}],Style[label,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}
],{i,1,np}
];

Next create a plot of (Subscript[Log, 10]) (Prior × Likelihood) vs iteration.

conv=Log[10,Exp[1.0]];pl[[1]]=ListPlot[Take[Transpose[{fn,conv*trn[[nl]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration  chain  (β = "<>ToString[βlis[[k]]]<>")",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10]) (Prior × Like)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];

Now create a plot of (Subscript[Log, 10]) (Prior × Likelihood) dropping first nburn1 iterations.

pl[[2]]=ListPlot[Take[Take[Transpose[{fn,conv*trn[[nl]]}],-(ng-nburn1)],{1,ng-nburn1,niter}],PlotRange->All,Joined->False,Frame->True,PlotStyle->{Black,PointSize[0.008]},Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration  chain  (β = "<>ToString[βlis[[k]]]<>")",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10]) (Prior × Like)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];

Next line shows the final plots.

plIter=Show[GraphicsGrid[If[EvenQ[np+2],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,np+2,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(np+2)/2]*2,2}],{{pl[[IntegerPart[(np+2)/2]*2+1]]}}]],Spacings->{Scaled[-0.15],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Notes on burn-in period and tests for convergence:

1) One scheme is to examine plots of the MCMC iterations for each parameter as is shown below.

2) A better test of convergence (not shown here) is to run m repeated simulations with different 
    starting points and compute the Gelman-rubin statistic for each parameter from the repeated runs 
    as described below.
         Let θ represent one of the model parameters.
         Let (Subscript[θ, j]^i) represent the (i^th) iteration of the (j^th) chain.
         Extract the last η post burn-in iterations for each simulation.

Mean within chain variance  W=(1/(m(η-1)))(∑_(j=1)^m)(∑_(i=1)^η)((((Subscript[θ, j]^i)-(OverBar[(Subscript[θ, j])])))^2)
               Between chain variance  B=(η/(m-1))(∑_(j=1)^m)((((OverBar[(Subscript[θ, j])])-(OverBar[θ])))^2)
               Estimated variance   (OverHat[V])(θ)=(1-(1/η))W+(1/η)B
               Gelman-Rubin statistic =(Sqrt[(((OverHat[V])(θ))/W)])
                       The Gelman-Rubin statistic should be close to 1.0  (e.g. <1.05)  for all paramaters for convergence.
          Ref:Gelman,A.and D.B.Rubin (1992)'Inference from iterative simulations    
                      using multiple sequences (with discussion)',Statistical Science 7, pp. 457-511.

Set the burn-in value nburn.

The burn - in period is the greater of : (a) no. of iterations at which all the parameter distributions
 have converged, and (b) the point at which the control system is turned off.

ncsys is the iteration number at which the control system achieved its goal of automatically 
finding a good set of parameter proposal distribution σ's, and was turned off. 
Note: since only 1 out of every nthin iterations is kept the effective iteration at which the 
         control system cuts off is Ceiling[N[ncsys]/nthin].

ncsys

minimumBurnin=Ceiling[ncsys/nthin]

Examine the parameter iterations (traces) above to see it is safe to set nburn = minimumBurnin = Ceiling[ncsys/nthin],
the iteration number at which the proposal σ control system is turned off.

nburn =minimumBurnin (* Default choice of burn-in = minimumBurnin *)

Plot marginal  distribution for model parameters

Extract parameter iterations beyond burn-in for plotting. Specify the tempering level, normally k = nβ.

k=nβ;tr=Take[Transpose[logpdfβi][[k]],-(nnt-nburn)];trn=Transpose[tr];trnn=Drop[trn,{1}];ng=Length[trnn[[1]]]

Plot histograms of all the parameter iterations.

plh=Table[1,{i,np}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==50,pdotk=Max[Abs[trnn[[i]]]];trnnx=trnn[[i]]*(10^(-RealDigits[pdotk][[2]]));label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]<>"  (×"<>ToString[(10^(1.0*RealDigits[pdotk][[2]]))]<>")"];
plh[[i]]=Histogram[trnn[[i]],PlotRange->{{0.995*Min[trnnx[[i]]],1.0005*Max[trnnx[[i]]]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],
plh[[i]]=Histogram[trnn[[i]],PlotRange->{{0.995*Min[trnn[[i]]],1.0005*Max[trnn[[i]]]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]],{i,1,np}
];
plhis=Show[GraphicsGrid[If[EvenQ[np],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,np,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(np)/2]*2,2}],{{plh[[IntegerPart[(np)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Plot 2 dimensional parameter distribution.

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];ng=Length[trn[[1]]]

Suppose the two parameters of interest are f,T the first and second. Set ip = 1 and jp = 2

ip=1;jp=2;

ninterval=30;fT=Take[Transpose[{trn[[ip+1]],trn[[jp+1]]}],-(ng-nburn)];fTpl=Take[fT,{1,ng-nburn,ninterval}];tfT=Transpose[fTpl];fmin=Min[tfT[[1]]];fmax=Max[tfT[[1]]];plscata=ListPlot[fTpl,Frame->True,Axes->False,PlotRange->{{fmin,fmax},Automatic},PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[flabel,{"Helvetica-Bold",12}],
		Style[tlabel,{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

plscat=Show[plscata,Graphics[{Text["",{3,3.7}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5];

Plot binned marginal  distribution for model parameters.
It also computes quantities needed for 68% credible regions used in next section.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];trn=Transpose[tr];Length[trn[[1]]]

Details behind generating the marginal distributions.

Specify the number of points nai to bin the continuous parameters and set up some tables we will need for some parameter distribution statistics.

nai=50;plp=Table[1,{i,np}];meanai=Table[0,{j,1,np}];medianai=Table[0,{j,1,np}];modeai=Table[0,{j,1,np}];minai=Table[0,{j,1,np}];maxai=Table[0,{j,1,np}];areai=Table[0,{j,1,np}];

Next block computes the marginal PDF for the continuous parameters.

Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=trn[[i+1]];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[10000000*Min[aimarg]]/10000000;hi=Round[10000000*Max[aimarg]]/10000000;dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Plus@@aibin;yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2,#1}]&];modeai[[i]]=pbin[[1,2]];minai[[i]]=1000000000;maxai[[i]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[i]],minai[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[i]],maxai[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],PlotJoined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],{i,1,np}];N[areai]

minai

maxai

If[ncsys<n>0,plmarg1all=Show[GraphicsGrid[If[EvenQ[np],Table[{plp[[ii]],plp[[ii+1]]},{ii,1,np,2}],Join[Table[{plp[[ii]],plp[[ii+1]]},{ii,1,IntegerPart[(np)/2]*2,2}],{{plp[[IntegerPart[(np)/2]*2+1]]}}]],Spacings->{Scaled[-0.1],Scaled[0.05]}]]]

Find most probable set of parameters & 68.3% marginal credible regions.

tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(ng-nburn)];tr5s=RotateLeft[Sort[RotateRight[tr5,{0,1}],OrderedQ[{#2,#1}]&],{0,1}];

tr5s[[1]]

The output list from the above command contains the most probable set of parameters (f,T,σl).
The next command extracts these peak parameter values.

peakai=Table[0,{i,1,ncs}];Do[probMax=tr5s[[1,nl]];peakai[[i]]=tr5s[[1,i+1]],{i,1,ncs}];If[swb>0,peakb=tr5s[[1,np+1]],];peakai

probMax

Summary table of parameter values and 68% credible regions.

l1={{"Item","Peak","Mean","Median","Mode"},{"","","","",""}};

l2=Table[{ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"],peakai[[i]],meanai[[i]],medianai[[i]],modeai[[i]]},{i,np}];

l4={{"","","","",""},{"Item","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max","68%","68%"}};

l5=Table[{ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"],minai[[i]],maxai[[i]],peakai[[i]]-minai[[i]],maxai[[i]]-peakai[[i]]},{i,np}];

smj=MatrixForm[Join[l1,l2,l4,l5]]

Plot data with overlaid mean MCMC fit and fit residuals.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];nsel=Length[tr]

Create spectrum model for a list of frequencies flist (at higher resolution than measurements).

model1[temperature_,f0_]:=temperature*Exp[-((((flist-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

interval=100;flist=Table[f,{f,fvecmin,fvecmax,(fvecmax-fvecmin)/200}];spec={};
Do[str=Take[tr[[i]],{2,np+1}];
spec=Append[spec,model1[str[[2]],str[[1]]]],{i,1,nsel,interval}
]

Compute the mean of these spectra.

meanspec=Mean[spec];

Compute the standard deviation of these spectra.

stdspec=StandardDeviation[spec];

Plot the mean of these spectra with the data.

modlist=Transpose[{flist,meanspec}];plfitmean=ListPlot[modlist,PlotJoined->True,PlotRange->All,PlotStyle->{Black,Thickness[0.004]}];
plfitdatamean=Show[plshp1,plfitmean]

Plot another of these with a different aspect ratio and index letter for later display with other plots.

plmapfitmeanb=Show[plfitdatamean,Graphics[{Text["(b)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

modlist1=Transpose[{flist,(meanspec+stdspec)}];modlist2=Transpose[{flist,(meanspec-stdspec)}];plfitmeanr=ListPlot[{modlist1,modlist2},PlotJoined->True,PlotRange->All,PlotStyle->{{Thickness[0.006],Red},{Thickness[0.006],Green}}];
plfitdatameanr=Show[plshp1,plfitmeanr]

plmapfitmeanrb=Show[plfitdatameanr,Graphics[{Text["(d)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Create spectrum model for the measured list of frequencies fvec.

model[temperature_,f0_]:=temperature*Exp[-((((fvec-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

interval=100;mspec={};
Do[str=Take[tr[[i]],{2,np+1}];
mspec=Append[mspec,model[str[[2]],str[[1]]]],{i,1,nsel,interval}
]

Compute the mean of these spectra.

meanmspec=Mean[mspec];

Compute the standard deviation of these spectra.

stdmspec=StandardDeviation[mspec];

Compute the reduced (χ^2) of the mean fit.

y=(meanmspec-dvec)/errvec;

reducedchi2=y.y/(nd-4)

Compute the RMS residual of the fit.

yy=(meanmspec-dvec);

rmsresid=(Sqrt[((yy.yy)/nd)])

Construct the residual for plotting.

resid=Transpose[{fvec,dvec-Mean[mspec]}];

respk=StandardDeviation[resid]

resid

residerr=Table[{resid[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp2mean=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",12}],Style["Residuals  (mK)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{"Helvetica-Bold",12}]

plshp2meanb=Show[plshp2mean,Graphics[{Text["(c)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

plboth=Show[GraphicsGrid[{{plshp1r,plmapfitmeanb},{plshp2meanb,plmapfitmeanrb}},Spacings->{Scaled[-0.1],Scaled[-0.02]}]]

(*Export["c:/temp/Ch12Problem2SolutionM6AmeanFit.eps", plboth,ImageSize->72*7]*)

Compare data points to best fit model (MAP solution).

Create spectrum model for a list of frequencies flist (at higher resolution than measurements).

model1[temperature_,f0_]:=temperature*Exp[-((((flist-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

flist=Table[f,{f,fvecmin,fvecmax,(fvecmax-fvecmin)/200}];modspec=model1[peakai[[2]],peakai[[1]]];modfit=Transpose[{flist,modspec}];plfit=ListPlot[modfit,PlotJoined->True,Frame->True,PlotRange->All,PlotStyle->{Black,Thickness[0.004]},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",14}],Style["Temperatue  (mK}",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.004]];
plfitdat=Show[plfit,plshp1,DisplayFunction->$DisplayFunction]

plfitdatpk=Show[plfitdat,Graphics[{Text["(a)",{10,-2.1}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Compute and display residuals

resid=Transpose[{fvec,(dvec-model[peakai[[2]],peakai[[1]]])}];

residerr=Table[{resid[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",14}],Style["Residuals  (mK)",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.004]]

plshp2b=Show[plshp2,Graphics[{Text["(b)",{10,-2.4}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plboth=Show[GraphicsGrid[{{plfitdatpk},{plshp2b}},Spacings->{Scaled[-0.2],Scaled[0]}]]

Compute the Bayes factor from parallel tempering results

Compares model M2 to model M1 (rejecting the first nburn samples). 
((NOTE: THIS SECTION WON'T EVALUATE IF nβ <10.))
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 15) of β levels are used spanning the range β = 0 to 1. 
Otherwise use the Quasi Monte Carlo Bayes factor calculation in the next section.

Compute p(D|M1,I), the global likelihood for spectral line model

Here we compute  the log of the global likelihood of the model, which is designated by  logpM1
                logpM1=log[p(D|(Subscript[M, 1]),I)]=∫ (Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T ,I)] ⟩, β])  dβ
(Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T ,I)] ⟩, β]) =expectation value oflog[p(D|(Subscript[M, 1]),f,T ,I)]  for given β
                                              =(1/n)(∑_(t=1)^n)  log[p(D|(Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,I)] where n=number of MCMC iterations
                                              =abbreviate by   expect[[nb]]

Recall all the results are stored by the variable logpdfβi.
    Look at a typical row 8000of the output given by logpdfβi[[8000]].

{{1., 36.838, 3.60494, 8000, -86.6526, -93.6287}}

The quantity  log[p(D| (Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,I)] is the penultimate item  in each row. The different rows correspond to different values of the tempering parameter β, which is the first item in each row.

First check that you are happy with the burn -in value, nburn.

nburn

If[nβ>10,nused=ng-nburn;tr=Transpose[Take[logpdfβi,-nused]];expect=Table[0.0,{i,1,nβ}];Do[trnb=Transpose[tr[[nb]]];tb1Num=trnb[[n2l]];logpdfβ=Total[tb1Num]/nused;expect[[nb]]=logpdfβ,{nb,1,nβ}],];

If[nβ>10,expect,]

If[nβ>10,βlis,]

If[nβ>10,pl1=ListPlot[Transpose[{Log[10,βlis],expect}],Frame->True,PlotStyle->PointSize[0.02],PlotRange->All,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨p(D| (Subscript[M, 1]),\!\(\*SubscriptBox[\(f\), \(\(β\)\(\\ \)\)]\),(Subscript[T, β]),(Subscript[σl, β]),(Subscript[s, β]),I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

Generate an interpolating function for a LogLinearPlot

If[nβ>10,spline1 = Interpolation[Transpose[{Log[10,βlis],expect}], Method -> "Spline"]]

Specify the x range for cubic spline interpolation in the line below by {x, Min[Log[10, βlis ]], 0.0, 0.01}.

If[nβ>10,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect],]

If[nβ>10,pl4=ListPlot[newexpect,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D| (Subscript[M, 1]),\!\(\*SubscriptBox[\(f\), \(\(β\)\(\\ \)\)]\),(Subscript[T, β]),(Subscript[σl, β]),(Subscript[s, β]),I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

If[nβ>10,plBayesFactor=Show[pl1,pl4,PlotRange->All],]

Now we want to convert to a table with linear coordinates.

If[nβ>10,tnewexpext=Transpose[newexpect];newexpect1=Transpose[{(10^(tnewexpext[[1]])),tnewexpext[[2]]}],];

Next we approximate the integral by a sum of the table of interpolation values. Call it logpM1.

If[nβ>10,logpM1=Total[Table[0.5*(newexpect1[[i]][[2]]+newexpect1[[i+1]][[2]])*(newexpect1[[i+1]][[1]]-newexpect1[[i]][[1]]),{i,1,Length[newexpect1]-1}]],]

If[nβ>10,Exp[logpM1],]

Suppose we drop the first nn  β levels and redo the calculation of the log of the global likelihood for M1.

nn=1;

If[nβ⩾(10+nn),spline2 = Interpolation[Transpose[{Log[10,Drop[βlis,nn]],Drop[expect,nn]}], Method -> "Spline"]]

Specify the x range for cubic spline interpolation in the line below by {x, Min[Log[10,Drop[βlis,nn]]], 0.0, 0.01}.

If[nβ⩾(10+nn),newexpect2=Table[{x,spline2[x]},{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2],]

If[nβ⩾(10+nn),tnewexpext=Transpose[newexpect2];newexpect3=Transpose[{(10^(tnewexpext[[1]])),tnewexpext[[2]]}],];

Next we approximate the integral by a sum of the table of interpolation values. Call it logpM1A.

If[nβ⩾(10+nn),logpM1A=Total[Table[0.5*(newexpect3[[i]][[2]]+newexpect3[[i+1]][[2]])*(newexpect3[[i+1]][[1]]-newexpect3[[i]][[1]]),{i,1,Length[newexpect3]-1}]],]

If[nβ⩾(10+nn),Exp[logpM1A],]

Compute p(D|M2,I), the global likelihood for no line model

logfact=-(nd/2.0)*Log[2.0*π] ;

yy=dvec/errvec;logpM2=logfact -Plus@@Log[errvec]- 0.5*yy.yy

Exp[logpM2]

Compute Bayes factor

If[nβ>10,odds=Exp[logpM1-logpM2],]

If[nβ⩾(10+nn),odds=Exp[logpM1A-logpM2],]

Compute the Bayes factor using quasi Monte Carlo integration

Compares model M1 to model M2 (rejecting the first nburn samples). 
Quasi Monte Carlo (QMC) Bayes factor calculation is efficient even for models with 
a large number of parameter, provided one uses the MCMC marginals to constrain 
the parameter ranges (in this case we use the 99% credible region boundaries) to 
regions where the posterior has significant probability.

Computes 99% credible region for each parameter from the binned marginal  distribution.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];trn=Transpose[tr];Length[trn[[1]]]

Details behind generating the marginal distributions.

Specify the number of points nai to bin the continuous parameters and set up some tables we will need for some parameter distribution statistics.

nai=50;plp=Table[1,{i,np}];meanai=Table[0,{j,1,np}];medianai=Table[0,{j,1,np}];modeai=Table[0,{j,1,np}];minai99=Table[0,{j,1,np}];maxai99=Table[0,{j,1,np}];areai=Table[0,{j,1,np}];

Next block computes the marginal PDF for the continuous parameters.

Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=trn[[i+1]];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[10000000*Min[aimarg]]/10000000;hi=Round[10000000*Max[aimarg]]/10000000;dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Plus@@aibin;yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2,#1}]&];modeai[[i]]=pbin[[1,2]];minai99[[i]]=1000000000;maxai99[[i]]=-1000000000;area=0;j=1;
While[area≤0.99,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai99[[i]],minai99[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai99[[i]],maxai99[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],PlotJoined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],{i,1,np}];N[areai]

minai99

maxai99

Compute p(D|M1,I), the global likelihood for spectral line model

Now specify the procedure to compute the logprior and loglikelihood for use in the QuasiMonteCarlo integration. The integration is performed over a volume in parameter space defined by the 99% credible region. You need to modify this code for any additional model parameters.

logfact=-(nd/2.0)*Log[2.0*π] ;

Now, we find or specify the upper and lower parameter boundaries for the MC interation based on the 99% credible region of the MCMC marginal parameter distributions which defines the region in parameter space where the joint posterior has significant probability. If there are multiple regions then the MC integration should be performed separately.

low=Table[minai99[[i]],{i,1,np}]

hi=Table[maxai99[[i]],{i,1,np}]

The next step performs the QuasiMonteCarlo integration for the model parameters using {parf,parT,parσl,parσl} to represent {f,T,σl,s}. By default the range of the model parameters used for integration is set equal to the prior search range, e.g., avmin[[i]], avMax[[i]]. When dealing with large number of parameters these ranges should be reduced to values where the posterior has a significant probability as indicated by the MCMC marginal distribution for each parameter. You need to modify this for any additional model parameters.

work1:=Module[{},f=parf;T=parT;mvec=model[T,f]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T] ; (* the prior for parameters f & T *) 
y=(dvec-mvec)/errvec;
loglike=logfact-Plus@@Log[errvec]-0.5*y.y  
]

logpM1B=Log[NIntegrate[work1;Exp[logprior+loglike],{parf,low[[1]],hi[[1]]},{parT,low[[2]],hi[[2]]},Method->"QuasiMonteCarlo",AccuracyGoal->12]]

Exp[logpM1B]

Compute p(D|M2,I), the global likelihood for no line model

yy=dvec/errvec;

logpM2=logfact- Plus@@Log[errvec]- 0.5*yy.yy

Exp[logpM2]

Compute Bayes factor

odds=Exp[logpM1B-logpM2]

Ch. 12: Problem 2  (1 MCMC chain)

Introduction

This notebook employs a semi-automatic parallel tempering (Section 12.8) version of Markov Chain Monte Carlo to analyze the spectral line data of chapter 3. In this version of the problem the line frequency (f), line temperature (T), and line width (σl) are unknown within given prior limits. See Section 12.6 for more details. The program can easily be modified for another nonlinear model fitting problem.

Nine MCMC chains are run in parallel each with a different tempering parameter β. At random intervals, proposals to swap the parameter values of a random pair of chains is considered. This prevents the MCMC from becoming trapped in one probability peak region. The program automates the selection of Gaussian proposal σ's, one for each parameter. 
The best approach is to choose a set of proposal distribution {σ} that are about 1/10th the prior range of each parameter, then let the control system automatically home in on improved proposal σ's. Useful parameter iterations are obtained after the control system terminates. 

The Bayes factor, used in model selection, is computed in two different ways at the end of this program.

The spectral line model equations

Let f0 stand for the line frequency,T  for the line temperature, and σl  for the line width .

Model of spectral line  = temperature * Exp[-((((f-f0))^2)/(2 ((σl)^2)))]

The set of  f values in the measured spectrum is given by  fvec.

Let model[T_,f0_,σl_] stand for the set of measurements predicted by 
the model.
model[temperature_,f0_,σl_]:=temperature* Exp[-((((fvec-f0))^2)/(2 ((σl)^2)))]

According to the model we can write for the (i^th) data value
                            di = mi + ei,
where  mi   is the  model  prediction for the (i^th) data value and  ei   is an independent
Gaussian error term.

The likelihood is given by
     p(D|M,X,I) = (((2 π))^(-nd/2))(σ^(-nd))Exp[-(((∑_(i=1)^n)(((di- mi))^2))/(2 (σ^2)))]
                       = (((2 π))^(-nd/2))(σ^(-nd))Exp[-(((∑_(i=1)^n)(di^2))/(2 (σ^2)))] Exp[-((2(∑_(i=1)^n)di mi)/(2 (σ^2)))]Exp[-(((∑_(i=1)^n)(mi^2))/(2 (σ^2)))]

Let  dvec stand for the vector of n data value 
Let  mvec stand for the vector of n model predictions
then (∑_(i=1)^n)(di^2) = dvec.dvec ;    (∑_(i=1)^n)(mi^2) = mvec.mvec  ;  (∑_(i=1)^n)di mi = dvec.mvec

Alternate calulation used in actual program allows for a different error for each data point:
                y=(dvec-mvec)/errvec
     p(D|M,X,I) = (((2 π))^(-nd/2)){Times@@(((errvec))^(-1))}Exp[-0.5*y.y]

Equations needed for model selection

For model comparison need to compute  odds = Exp[logpM1-logpM2]  (see Section 12.7)

logpM1 = log[p(D|M1,I)] = ∫ (Subscript[⟨ log[p(D|M1,f,T,σl,I)] ⟩, β])  dβ

(Subscript[⟨ log[p(D|M1,f,T,σl,I)] ⟩, β]) = expectation value of  log[p(D|M1,f,T,σl,I)]  for  given  β
                                              = (1/n)(∑_(t=1)^n)  log[p(D|M1,(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I)] 
                                                      where n = number of  MCMC iterations
                                              = abbreviate by    expect[[nb]],
    - where nb goes from 1 to nβ ,
    - and  the list of  β values is given by  βlis = Table[β0+dβ (i-1),{i,1,nβ}],     
    - and p(D|M1,(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I) is the likelihood of each set of parameter choices 
      accepted for the given value of β.  
      
(see section on spectral line model above and Chapter 3 for discussion of the models)      
p(D|M1,f,T,I) = abbreviated   like1 = (((2 π))^(-nd/2)){Times@@(((errvec))^(-1))}Exp[-0.5*y.y]
     - where  mvec = model[T,f];    
     - and   model[temperature_,f0_]:=temperature * Exp[-((((fvec-f0))^2)/(2*((σl)^2)))];   
prior1 = =(c/T) ;  where c =1/{(fmax-fmin)*Log[(Tmax/Tmin)]*(σlmax-σlmin)};      
and   pdfβ1= prior1*(((like1))^β);
  
finally  logpM2 = log[p(D|M2,I)] = Log[(((2 π))^(-nd/2)) {Times@@(((errvec))^(-1)) } Exp[- 0.5*y.y]] 
                                                        = global probability of model M2;    
  - recall model M2 has no parameters

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

Needs["Graphics`Common`GraphicsCommon`"]

List and plot the the spectral line data

The data, named dat, consists of (f,T), frequency channel number and temperature pairs.

dat1= {{1.`,0.82`},{2.`,-2.07`},{3.`,0.38`},{4.`,0.99`},{5.`,-0.12`},{6.`,-1.35`},{7.`,-0.2`},{8.`,0.36`},{9.`,0.78`},{10.`,1.01`},{11.`,0.44`},{12.`,0.34`},{13.`,1.58`},{14.`,0.08`},{15.`,0.38`},{16.`,-0.71`},{17.`,-0.9`},{18.`,0.33`},{19.`,0.8`},{20.`,-1.42`},{21.`,0.28`},{22.`,-0.42`},{23.`,0.12`},{24.`,0.14`},{25.`,-0.63`},{26.`,-1.77`},{27.`,-0.67`},{28.`,0.55`},{29.`,1.98`},{30.`,-0.08`},{31.`,1.16`},{32.`,0.48`},{33.`,-0.03`},{34.`,1.47`},{35.`,1.7`},{36.`,1.89`},{37.`,4.55`},{38.`,3.59`},{39.`,2.02`},{40.`,0.21`},{41.`,0.05`},{42.`,0.54`},{43.`,-0.09`},{44.`,-0.61`},{45.`,2.49`},{46.`,0.07`},{47.`,-1.45`},{48.`,0.56`},{49.`,-0.72`},{50.`,0.38`},{51.`,0.02`},{52.`,-1.26`},{53.`,1.35`},{54.`,-0.04`},{55.`,-1.45`},{56.`,1.48`},{57.`,-1.16`},{58.`,-0.4`},{59.`,0.01`},{60.`,0.29`},{61.`,-1.35`},{62.`,-0.21`},{63.`,-1.67`},{64.`,0.7`}};

Details concerning data manipulation and statistics.

tarr1=Transpose[dat1];

lendat=Length[dat1];nd=lendat

fvec1=N[tarr1[[1]]];

fvecmin=First[fvec1];

fvecmax=Last[fvec1];

dvec1=N[tarr1[[2]]];

σnoise=1.0;(* data noise sigma *)

errvec1=Table[σnoise,{nd}];

aveDerror=Mean[errvec1];

dat=Transpose[{fvec1,dvec1,errvec1}];

tarr=Transpose[dat];

fvec=N[tarr[[1]]];

dvec=N[tarr[[2]]];

ppeak=Max[dvec]-Min[dvec]

errvec=N[tarr[[3]]]

data=Transpose[{fvec,dvec}];

Plot the data

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,PlotStyle->Black,FrameLabel->{Style["Channel  number",{"Helvetica-Bold",12}],Style["Temperature",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.005],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp1r=Show[plshp1,Graphics[{Text["(a)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Parallel Tempering program

INITIALIZE PROGRAM VALUES

nthin=1; (* store MCMC iterations at a thinning interval of nthin. Since successive
iterations are partially correlated using an nthin ≈ 10 reduces the correlation
and reduces the memory requirements for long iterations *)

n=50000*nthin; (* number of MCMC iterations *)

nβ=1;(* number of choices of tempering parameter *)(* Note:the product nβ\[Cross]ns/(swap rate) should be approximately ≃ 150 *)

βlis={1.0} ;(* tempering parameter values *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains *)

ns=5; (* ns is mean number of iterations between swap proposals *)

np=3; (* np= number of free parameters computational explored *)

ncs=np; (* only the first ncs parameter proposal σ's adjusted by the control system *)

nl=np+4;(* item in output list containing prior1*(((like1))^β) (don't change this) *)

n2l=np+3;(* item in output list containing Log[like] (don't change this) *)

swb=0; (* swb=1 if extra noise parameter s included, swb = 0 otherwise *)

STARTING PARAMETER VALUES

avst=Table[0,{np}]; (* initialize table of start parameter values *)
avmin=Table[0,{np}];(* initialize table of parameter lower bounds *)
avMax=Table[0,{np}];(* initialize table of parameter upper bounds *)
bfmin=Table[0,{np}];(* Bayes factor parameter lower bounds *)
bfMax=Table[0,{np}];(* Bayes factor parameter upper bounds *)

avst[[1]]= 30.0; (* line center freq. start value *)

a1name= "f"; a1unit="  (channel #)";(* name of parameter 1 and units *)

avst[[2]]=5.0; (* line temperature start value *)

a2name= "T"; a2unit="  (mK)";(* name of parameter 2 and units *)

avst[[3]]=0.7;(* line width start value *)

a3name= "σl"; a3unit="  (channels)"; (* name of parameter 3 and units *)

PRIOR SEARCH RANGES

avmin[[1]]=1.0;avMax[[1]]=44;(* search bounds on line center freq *)

avmin[[2]]=0.1;avMax[[2]]=ppeak;(* search bounds on line temperature *)

avmin[[3]]=0.5;avMax[[3]]=4.0;(* search bounds on line width *)

type={0,0,0}; (* If type = -1, parameter is a period but search carried out in frequency *)
(* type = 1, angular parameter, wrap around at 0 and 1 *)
(* type = 2, angular parameter, wrap around at 0 and 2π *)
(* type = 3, angular parameter, wrap around at 0 and 4π *)
(* type = 4, angular parameter, wrap around at -2π and 2π *)
(* type = 5, parameter is first radial velocity amplitude (Subscript[K, 1 ])*)
(* type = 6, parameter is second radial velocity amplitude (Subscript[K, 2 ])in multiple planet fit *)
(* type = 7, parameter is second radial velocity amplitude (Subscript[K, 3 ])in multiple planet fit *)
(* type = 0, all other parameters *)

PRIOR RANGE FOR BAYES FACTOR CALCULATION

bfmin[[1]]=1.0;bfMax[[1]]=44.;(* search bounds on line center freq *)

bfmin[[2]]=0.1;bfMax[[2]]=100.;(* search bounds on line temperature *)

bfmin[[3]]=0.5;bfMax[[3]]=4.0;(* prior bounds on line width *)

STARTING SIGMAS AND MINIMUM SIGMAS

σst=Table[0,{i,1,ncs}];(* initialize table of parameter proposal σ's *)

minσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ's *)

swminσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ switches  *)

Typically set start sigma to approximately 10 to 20% of the parameter search range.

σst[[1]]=0.2*(avMax[[1]]-avmin[[1]]); (* sigma for a1 proposal random Gaussian step *)

σst[[2]]=0.2*ppeak; (* sigma for a2 proposal random Gaussian step *)

σst[[3]]=0.5; (* sigma for a3 proposal random Gaussian step *)

Set minimum proposal sigmas.

sigTonoise=0.5*ppeak/Mean[errvec];

minσ[[1]]=0.1;(* min sigma for proposal random Gaussian step *)

minσ[[2]]=Mean[errvec]/(Sqrt[nd]); (* min sigma for proposal random Gaussian step *)

minσ[[3]]=0.1; (* min sigma for proposal random Gaussian step *)

CONTROL SYSTEM PARAMETERS  (user don't change this)

minCS=5000; (* minimum number of iterations before Control System turned off *)

maxCS=10000; (* maximum number of iterations before 1st stage Control System turned off *)

deltaN=5000; (* intervals in i used to decide on whether to rerun 2nd stage CS *)

sw1=0;(* =0 when control system is on and =1 when turned off.*)

sw5=1;(* =0 never do 2nd stage CS, =1 execute 2nd stage CS *)

n0=1000; (* initial search with no control system active *)

λ=0.25; (* target acceptance ratio *)

n1=1000; (* number of iterations between changes in σ's *)

n2=200; (* number of iterations per parameter per minor cycle *)

nt1=λ*n1; (* target no. of acceptances per n1 iterations *)

nt=λ*n2; (* target no. of acceptances per n2 iterations *)

tol1=0; (* error tolerance 1 in annealing *)

(*tol1=1.5*(Sqrt[nt1]);*) (* error tolerance 1 in annealing *)

tol2=1.5*(Sqrt[nt1]); (* error tolerance each β chain must satisfy before CS turned off *)

(*tol2=0;*) (* error tolerance each β chain must satisfy before CS turned off *)

scmax=0.1; (* max factor to reduce/increase σ in control sys minor cycles *)

(*gain=Table[0.7,{i,1,nβ}];*)
(*gain={0.25,0.45,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6};*)
gain=Table[0.7-(nβ-i)*0.1/(nβ-1),{i,1,nβ}];(* gain x scmax = max factor to reduce/increase proposal σ's *)

γ=1.6; (* damping exponent in annealing process *)

alfm=0.806096-1.12051*(10^(-2))*ncs+3.1233*(10^(-4))*(ncs^2)-3.03567*(10^(-6))*(ncs^3);(* Scaling exponent for calulation of accept rate for individual parameters 2nd stage CS *)

kalf=0.87; (* Empirical factor for scaling exponent, typical value 0.87 *)

accept=Table[(((λ))^(1/(ncs^((kalf^((βlis[[kn]])^(-1.0)))*alfm)))),{kn,1,nβ},{kj,1,ncs}]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS

Define the constant portion of the joint prior for model M1.

c=-Log[(bfMax[[1]]-bfmin[[1]])*Log[((bfMax[[2]])/(bfmin[[2]]))]*(bfMax[[3]]-bfmin[[3]])](* normalization constants for prior *)

Define the constant portion of the joint prior for model M1 
(assumes a modified Jeffreys prior for T not used in this example).

(*mJlim=0.1;*)(* for modified Jeffreys prior for T *)

(*c=-Log[(bfMax[[1]]-bfmin[[1]])*Log[((mJlim+bfMax[[2]])/mJlim)]];*)(* normalization constants for prior *)

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (depends on model)

Version below does not include extra noise parameter s.

Specify terms needed in calculation of model M1 likelihood

logfact=((-nd)/2.0)*Log[2*π];(* part of likelihood independent of f,T,σl *)

model[temperature_,f0_,σline_]:=temperature*Exp[-((((fvec-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Specify a module for calculating the basic work ≡  logposterior = logprior + loglikelihood 
for model M1. 
It is convenient to work with Log quantities because this avoids the need for Mathematica to use extended precision calculations (much slower than machine precision calculations) when the likelihoods are very small, often the case.
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

work:=Module[{f,T,σl,y},f=av[[1]];T=av[[2]];σl=av[[3]];
mvec=model[T,f,σl]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T] ; (* the prior for parameters f & T *) 
y=(dvec-mvec)/errvec;
loglike=logfact-Plus@@Log[errvec]-0.5*y.y;(* likelihood fn for particular f,T, σl *)  
pvec={f,T,σl}]

MODULE THAT PROPOSES THE NEW PARAMETER SET (depends on model)

Propose new parameter values. Uses Switch command and parameter type[[ii]] to handle different parameter types. 
For type[[1]],  proposed update in Period = av[[1]] is the reciprocal of a proposed change in frequency.
Check if proposed values lie outside prior borders, if so reflect parameter or wrap angular parameters.

propose:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,av[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,av[[ii]]=Mod[2*avMaxt-av0,(avMaxt-avmint),avmint]],
-1,
If[smp>0&&i>ncsys&&RandomReal[]<0.25,avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],2*σall[[k,ii]]]];av[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,av[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,av[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σall[[k,ii]]]];av[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,av[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,av[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
1,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],1],
2,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],2π],
3,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],4π],
4,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av5<avmint,av[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,av[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av6<avmint,av[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,av[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av7<avmint,av[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,av[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]]
];
]

STEP TO EXECUTE MCMC CALCULATION (user don't change this)

AbsoluteTiming[
logpdfβi=.;  (* remove any existing definition of output file *)
logpdf=.;  (* remove any existing definition of file *)
num=ToString[rnum];  (* run number for specifying unique output plots *)
nnt=n/nthin;  (* no. of thinned iterations, n needs to be integer divisible by nthin *)
logpdf=Table[0,{i,1,2},{j,1,nβ}]; (* initialize storage *) 
logpdf2=Table[0,{i,1,2},{j,1,nβ}]; (* initialize storage *)
logpdfβi=Table[0,{i,1,nnt},{j,1,nβ}]; (* initialize storage *)
accept1=Table[0,{i,1,nβ},{j,1,ncs}]; (* initialize storage for param. acceptance rates *)
accept2=Table[0,{i,1,nβ},{j,1,ncs}]; 
accept3=Table[0,{i,1,nβ},{j,1,ncs}]; 
maxlogpdfβi=Table[0,{j,1,nβ}]; (* initialize storage *) 
na=Table[0,{nβ}];  (* initialize acceptance array *)
nb=Table[0,{k,1,nβ},{ncs}];  (* initialize array to store #accepted proposals in minor cycle *)(* for each parameter proposal σ *)
smp=0;(* smp=0 or 1, smp=1 better multiple peak detection, reduced acceptance rate*)
diag={};  (* initialize diagnostic array {sw,er,i,parameter #} *)
swap={};  (* initialize diagnostic array for swaps *)
(*α0=1/ns;*) (* if uniform random deviate is less than α0 then swap *)
nas=0; (* initiate an integer used in computing actual swap rate *)
nbmin=Table[0.0,{nβ}]; (* inintialize control system array *)
nbmax=Table[0.0,{nβ}]; (* inintialize control system array *)
dnb=Table[0.0,{nβ}]; (* inintialize control system array *)
err=Table[0.0,{nβ}]; (* inintialize control system err array *)
erl={}; (* array used to determine when err in all chains < tol2 *)
κ=Table[1.0,{k,1,nβ},{ncs}];(* weak logarithmic restoring force array*)
diagarray=Table[0,{k,1,nβ},{6}]; 
av=Table[0.0,{np}]; (* inintialize parameter array *)
σall1=Table[0,{np}];  
Do[σall1[[i]]=σst[[i]],{i,1,np}];(*initialize σall1 array*)
σall=Table[σst[[i]],{k,1,nβ},{i,1,np}];  
(* initialize σall array *)
σallold={};(* record previous best σall *)
logpdftemp2old={};(* record previous best logpdftemp2 in β=1 chain in 2nd stage CS *)
maxlogpdfAllold={};(* record previous values of maxlogpdfAll *)
σmonitor={{1,σall}};  (* initialize monitor of parameter proposal σ's  *)(* specify some constants & switches used in the control system *) 
nc1=1;(* maj/minor cycle counter initially set to 1 *)
nc2=Table[0,{nβ}];(* # of prop. acceptances in each subcycle *)
nc4=0;(* = 0 in major cycle and = 1,2,--,ncs in minor cycles *)
sw=Table[0,{nβ}];(* =0 in major cycles and in minor cycles 
=+1 if er[[k]]<0 and =-1 if er[[k]]>0 *)
sw3=0;(* =0 in major cycles and =1 in minor cycles.*)
sw4=0;(* =0 skip over 2nd stage CS, =1 execute 2nd stage CS *)
gain0=gain;(* initial control system gain.*)
(* Control system turned off as soon as er< tol2. *)
ncsys=n; (* otherwise ncsys=iteration # when control system turned off *)
ncsysold={}; (* records previous values of ncsys=iteration # *)
it=0;(* initialize counter for thinned iteration number *)
logfact=-(nd/2.0)*Log[2.0*π] ;
(* Evaluate the probability for the i=0 sample for each tempering level*)
Do[(* iteration over β *) β=βlis[[k]];av=avst;
 (* initiate parameter values *)
(* ******************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdf1= loglike;
pdfβ1= logprior+β*loglike; (* factor needed to decide on tempering swap *)
logpdf[[1,k]]=Join[{β},pvec,{0,pdf1,pdfβ1}],{k,1,nβ} 
];  (* close first Do loop iterating over β *)
maxlogpdfβi=logpdf[[1]];
maxlogpdfAll=logpdf[[1,nβ]];
Do[ (* start calculation for ith iteration beginning at i = 1 *)
If[i>n0,nc1=nc1+1];If[nc1<2&&i>n0,logpdftemp=logpdfinow,logpdftemp=logpdf[[1]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk = logpdftemp[[k]]; values = Take[logpdftempk, {2, np + 1}];
(* recover previous parameter values*)
(*************** propose new parameter set ******************) 
Do[propose,{ii,1,np}];
(* ****************** Basic working *********************** *)
work;
(* ******************************************************** *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf[[2,k]]=Join[{β},pvec,{i,pdfi,pdfβi}];If[pdfβi>Last[maxlogpdfβi[[k]]],maxlogpdfβi[[k]]=logpdf[[2,k]]];
If[i>n0,nc2[[k]]=nc2[[k]]+1;If[nc4<1,na[[k]]=na[[k]]+1]],logpdf[[2,k]]=logpdftempk;logpdf[[2,k,n2l-1]]=i
], (* complete If statement *)
{k,1,nβ} 
];(* complete Do loop over β *)
(* Consider a swap between 2 tempering levels if i an integer multiple of ns *)
If[nc4>0||nβ<2,Goto[anneal]];
If[IntegerQ[i/ns],(* next pick the 2 levels k1 & k2 to swap *)
(* following command chooses k1 from 1 to nβ-1 and sets k2=k1-1 *)
k1=RandomInteger[{1,(nβ-1)}];
k2=k1+1;
(* evaluate swap acceptance rule*)
loglike1=logpdf[[2,k1,n2l]];
loglike2=logpdf[[2,k2,n2l]];
β1=logpdf[[2,k1,1]];β2=logpdf[[2,k2,1]];
logprior1=logpdf[[2,k1,nl]]-β1*loglike1;
logprior2=logpdf[[2,k2,nl]]-β2*loglike2;
p12=logprior1+β2*loglike1;
p21=logprior2+β1*loglike2;
r=Exp[(β2-β1)*(loglike1-loglike2)];  
u2=RandomReal[];
If[u2≤r (* if uniform random ≤ r then accept swap *),nas=nas+1;swap=Append[swap,{k1+k2,1,i}];
temp=logpdf[[2,k1]];
Do[logpdf[[2,k1,ji]]=logpdf[[2,k2,ji]],{ji,2,np+1}];
logpdf[[2,k1,n2l]]=loglike2;logpdf[[2,k1,nl]]=p21;
Do[logpdf[[2,k2,ji]]=temp[[ji]],{ji,2,np+1}];
logpdf[[2,k2,n2l]]=loglike1;logpdf[[2,k2,nl]]=p12,
swap=Append[swap,{k1+k2,0,i}]]  (* complete accept If swap statement *)
] ; (* complete first If swap statement *)
(* start of annealing control system *)
Label[anneal];
If[sw1>0||i<n0,Goto[next],(* sw1=1 means want control system turned off *)
If[nc4>0,Goto[cycle],
If[nc1<n1,Goto[next],nc1=0;er=Table[nc2[[k]]-nt1,{k,1,nβ}];nc2=Table[0,{nβ}];
If[i>minCS&&Abs[er[[nβ]]]<tol2,sw1=1;nc4=0;na=Table[0,{nβ}];ncsys=i;ncsys1=ncsys+deltaN;If[sw5>0,sw4=1];Goto[next]];
If[Max[Abs[er]]<tol1,Goto[next],
logpdfinow=logpdf[[2]];scexp1=(((Abs[er]/nt1))^γ);scexp=Table[Min[1,scexp1[[jj]]],{jj,1,nβ}];sc=(scmax^scexp);scplus=gain*(1-sc);scminus=gain/sc;
Do[If[er[[k]]<0,sw[[k]]=1;nc4=1,sw[[k]]=-1;nc4=1],{k,1,nβ}]
];(* sw=1 for cooling parameter & sw=-1 for heating parameter *) 
If[nc4>0,Do[σall[[k,nc4]]=sc[[k]]^sw[[k]]*σall[[k,nc4]],{k,1,nβ}]];
Goto[next]
]
]
];
Label[cycle];
If[nc1<n2,Goto[next],Do[nb[[k,nc4]]=nc2[[k]];σall[[k,nc4]]=sc[[k]]^(-sw[[k]])*σall[[k,nc4]],{k,1,nβ}]
];
nc4=nc4+1;nc2=Table[0,{nβ}];nc1=0;If[nc4>ncs,Goto[list],Do[σall[[k,nc4]]=sc[[k]]^sw[[k]]*σall[[k,nc4]],{k,1,nβ}];Goto[next]
];
Label[list];
Do[nbmax[[k]]=Max[nb[[k]]];nbmin[[k]]=Min[nb[[k]]];dnb[[k]]=nbmax[[k]]-nbmin[[k]];nc3=Flatten[Position[nb[[k]],nbmax[[k]]]];lnc3=Length[nc3];nc5=Flatten[Position[nb[[k]],nbmin[[k]]]];lnc5=Length[nc5];
If[sw[[k]]>0,
If[nbmin[[k]]<nbmax[[k]],
Do[σallprop=(1-scplus[[k]])*σall[[k,nc3[[ik]]]]; If[σallprop<minσ[[ik]],σall[[k,nc3[[ik]]]]=minσ[[ik]];If[k==nβ,swminσ[[ik]]=1],σall[[k,nc3[[ik]]]]=σallprop],{ik,1,lnc3}],
Do[σallprop=sc[[k]]*σall[[k,ik]];If[σallprop<minσ[[ik]],σall[[k,nc3[[ik]]]]=minσ[[ik]];If[k==nβ,swminσ[[ik]]=1],σall[[k,nc3[[ik]]]]=σallprop],{ik,1,ncs}]
];
err[[k]]=nbmax[[k]]-nt;
diagarray[[k]]={sw[[k]],er[[k]],err[[k]],sc[[k]],i,dnb[[k]]};sw[[k]]=0,If[nbmin[[k]]<nbmax[[k]],
Do[σall[[k,nc5[[ik]]]]=scminus[[k]]*σall[[k,nc5[[ik]]]]; If[k==nβ&&(nbmax[[k]]-nc5)>0,swminσ[[ik]]=0],{ik,1,lnc5}],
Do[σall[[k,ik]]=σall[[k,ik]]*scminus[[k]];If[k==nβ,swminσ[[ik]]=0],{ik,1,ncs}]
];
err[[k]]=nbmin[[k]]-nt;
diagarray[[k]]={sw[[k]],er[[k]],err[[k]],sc[[k]],i,dnb[[k]]};sw[[k]]=0
],{k,1,nβ}
];
If[Product[swminσ[[i]],{i,ncs}]>0,sw1=1;nc4=0;na=Table[0,{nβ}];ncsys=i];
σmonitor=Append[σmonitor,{i,σall}];diag=Append[diag,diagarray];nc4=0;
If[i>maxCS&&sw1==0,sw1=1;sw4=1;ncsys=maxCS];
Label[next];
If[sw4<1,(* If sw4==0 skip 2nd stage control system *)
If[IntegerQ[i/nthin],it=it+1;logpdfβi[[it]]=logpdf[[2]]];logpdf[[1]]=logpdf[[2]],
(************************************************************************)
(*** Control system 2nd stage, acceptance for individual parameters ***)
(************************************************************************)
If[IntegerQ[i/nthin],it=it+1;logpdfβi[[it]]=logpdf[[2]]];(* ***************** Find best chain values ***************** *)
bestvec=Take[RotateLeft[maxlogpdfAll,1],np];
Do[(* iteration over β *) β=βlis[[k]];av=bestvec;
 (* initiate parameter values *)
(* ******************** Basic working ********************** *)
work;
(* ********************************************************* *)
pdfj= loglike;
pdfβj= logprior+β*loglike; 
If[pdfβj>Last[maxlogpdfβi[[k]]],
maxlogpdfβi[[k]]=Join[{β},pvec,{1,pdfj,pdfβj}]],
{k,1,nβ} 
];  (* close first Do loop iterating over β *)
(* *********************************************************** *)
logpdf[[1]]=maxlogpdfβi;
logpdfinow2=maxlogpdfβi;
nβlow=nβ-n2β+1;
k2vals=Table[iip,{iip,nβlow,nβ}];
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,nβlow,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept1[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
σold1=σall;
Do[σall[[k]]=σall[[k]]*(Sqrt[((N[accept1[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept1[[k]]/n1]+0.01)))]),{k,nβlow,nβ}];
(**************************************************************)
(* Control upper limit of σall to be ≤ parameter search range *)
Do[(* iteration over parameters *)
Do[Switch[type[[ip2]],
0,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
-1,If[σall[[k,ip2]]>(1./avmin[[ip2]]-1./avMax[[ip2]]),σall[[k,ip2]]=(1./avmin[[ip2]]-1./avMax[[ip2]])],
1,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
3,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
4,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
5,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
6,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
7,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]]
],{k,nβlow,nβ}
],(* complete β Do loop *)
{ip2,1,ncs}
];(* complete parameter Do loop *)
(**************************************************************)
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,nβlow,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept2[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
σold2=σall;
Do[σall[[k]]=σall[[k]]*(Sqrt[((N[accept2[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept2[[k]]/n1]+0.01)))]),{k,nβlow,nβ}];
(**************************************************************)
(* Control upper limit of σall to be ≤ parameter search range *)
Do[(* iteration over parameters *)
Do[Switch[type[[ip2]],
0,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
-1,If[σall[[k,ip2]]>(1./avmin[[ip2]]-1./avMax[[ip2]]),σall[[k,ip2]]=(1./avmin[[ip2]]-1./avMax[[ip2]])],
1,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
3,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
4,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
5,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
6,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
7,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]]
],{k,nβlow,nβ}
],(* complete β Do loop *)
{ip2,1,ncs}
];(* complete parameter Do loop *)
(**************************************************************)
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,1,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept3[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
sw4=0
]; (* complete If statement *)
If[i>ncsys&&IntegerQ[(i-ncsys)/deltaN]&&(Last[maxlogpdfAll]-Last[logpdftemp2[[nβ]]])>3.0,sw4=1;ncsysold=Append[ncsysold,ncsys];σallold=Append[σallold,σall];logpdftemp2old=Append[logpdftemp2old,logpdftemp2];na=Table[0,{nβ}];ncsys=i,
];(* complete If statement *)
,{i,1,n} (* complete iteration Do loop *)
];
acceptratio=If[ncsys<n,N[na/(n-ncsys)],N[na/n]]  (* evaluate acceptance ratio *)
]

The line above gives the execution time and average acceptance rate for each chain after the control system was turned off. The control system switched off at an iteration number specified by ncsys (given below).

The MCMC iteration number (unthinned) at which control system was turned off for the last time.

ncsys

The line below lists the most probable parameter set found in the MCMC.

Take[maxlogpdfAll,{2,np+1}]

A number of specialized items only of use to the code designer.

ncsysold

swminσ

maxlogpdfAll

Length[maxlogpdfAllold]

maxlogpdfAllold

maxlogpdfβi

logpdfinow2

MemoryInUse[]

n2c2

na

MCMC performance diagnostics & parameter proposal σ's

The next command gives the acceptance rate for each chain (tempering level).

acceptratio

The output from the next command gives the swap acceptance rate between adjacent tempering levels. First item is the swap rate between the two with lowest β tempering levels, etc.

If[nβ>1&&n>ncsys,swaplen={};swaprate={};nsw0=1;swaps=Sort[swap];spl=Split[Transpose[swaps][[1]]];Do[nswi=Length[spl[[i]]];swlst=Take[swaps,{nsw0,nswi+nsw0-1}];swpr=N[(Plus@@(Transpose[swlst][[2]]))/nswi];swaprate=Append[swaprate,swpr];swaplen=Append[swaplen,nswi];nsw0=nsw0+nswi,{i,1,nβ-1}];swaprate,]

The MCMC iteration number (unthinned) at which control system was turned off for the last time.

ncsys

The line below lists the most probable parameter set found in the MCMC.

Take[maxlogpdfAll,{2,np+1}]

The following is a matrix of Gaussian parameter proposal σ's chossen by the control system. There should be nβ lines, one for each tempering level. The top row corresponds to β0 and the bottom to β = 1. The columns give the proposal σ's for the parameters. 
They should all be greater than the corresponding value in minσ given on the next line.

minσ

MatrixForm[σall]

A number of specialized diagnostic, only of use to designer.

ncsysold

swminσ

maxlogpdfAll

Length[maxlogpdfAllold]

maxlogpdfAllold

maxlogpdfβi

logpdfinow2

MemoryInUse[]

n2c2

na

MatrixForm[σold1]

MatrixForm[σold2]

MatrixForm[N[accept1/n1]]

Times@@(accept1[[nβ]]/N[n1])

MatrixForm[N[accept2/n1]]

Times@@(accept2[[nβ]]/N[n1])

MatrixForm[N[accept3/n1]]

Times@@(accept3[[nβ]]/N[n1])

Plotting results of MCMC

Setup some graph axes labels

tlabel=
StyleForm[StringForm["``",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

tmklabel=
StyleForm[StringForm["``  (mK)",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

flabel=
StyleForm[StringForm["``  (channel #)",
StyleForm["f",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

tACFlabel=
StyleForm[StringForm["``  ACF",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

fACFlabel=
StyleForm[StringForm["``  ACF",
StyleForm["f",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

Extracting model parameter samples for the β = 1 MCMC chain

All the results are stored by the variable logpdfβi. (example format for 3 parameters f,T,σl)
First let's look at an example of the first row of the output given by logpdfβi[[1]].
{{0.01`,30.`,5.`,0.7`,-118.00310275500061`,0.0000591119911561849`},{0.2575`,30.`,5.`,0.7`,-118.00310275500061`,1.2239727134969812`*^-17},{0.505`,30.`,5.`,0.7`,-118.00310275500061`,2.5343575374188987`*^-30},{0.7525`,30.`,5.`,0.7`,-118.00310275500061`,5.247639965045567`*^-43},{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55}}
Here is MatrixForm[logpdfβi[[1]]];
(({{0.01`, 30.`, 5.`, 0.7`, -118.00310275500061`, 0.0000591119911561849`}, {0.2575`, 30.`, 5.`, 0.7`, -118.00310275500061`, 1.2239727134969812`*^-17}, {0.505`, 30.`, 5.`, 0.7`, -118.00310275500061`, 2.5343575374188987`*^-30}, {0.7525`, 30.`, 5.`, 0.7`, -118.00310275500061`, 5.247639965045567`*^-43}, {1.`, 30.`, 5.`, 0.7`, -118.00310275500061`, 1.0865761754668881`*^-55}}))
The first row contains the result for β = 0.01 and the last row is for β = nβ = 1.0.
We want to extract the β = 1.0 values. Do this with tr = Transpose[logpdfβi][[nβ]];
Now look at the first 5 rows with the command Take[tr,5].
{{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55},
{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55},{1.`,31.395819229020145`,4.463705555454431`,0.6292479467731473`,-112.7790133460596`,2.260100997434301`*^-53},{1.`,31.395819229020145`,4.463705555454431`,0.6292479467731473`,-112.7790133460596`,2.260100997434301`*^-53},{1.`,31.064587671869017`,2.339148265037844`,0.6509533931515838`,-107.75817884100877`,6.535613421513293`*^-51}}
The first item in each row is the value of β, 
The next two items are the current values of the two parameters f,T,σl.
The next item is the Log of the likelihood, that is used in computing the global likelihood of the model for the Bayes factor calculation.
The final item is the value of   prior*(((like))^β) for the particular set of parameter values.
To obtain columns of each quantity use trn = Transpose[tr];
Finally we obtain the complete list of  f & T parameter iterations with  fgood=trn[[2]]; Tgood=trn[[3]]; 
Now putting this all together we write

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];fgood=trn[[2]];Tgood=trn[[3]];σlgood=trn[[4]];ng=Length[trn[[1]]]

Examine parameter iterations for the β = 1 (k = nβ) MCMC chain

Sart by choosing some display parameters.

niter=100;(* with niter = 100, plot only every 100th point *)

nburn1=5000;(* skip first nburn1 iterations for 2nd (upper right) plot *)

(*pl=Table[0,{i,np+2+nplan}];*)(* initiate table of graphs to be plotted *)

pl=Table[0,{i,np+2}];(* initiate table of graphs to be plotted *)

fn=Table[i,{i,1,ng}];(* initiate a variable representing the iteration number *)

Here is where we create the plots for the np parameters

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];
pl[[i+2]]=ListPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},AspectRatio->0.5,
PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration",{"Helvetica-Bold",12}],Style[label,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}
],{i,1,np}
];

Next create a plot of (Subscript[Log, 10]) (Prior × Likelihood) vs iteration.

conv=Log[10,Exp[1.0]];pl[[1]]=ListPlot[Take[Transpose[{fn,conv*trn[[nl]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration  chain  (β = "<>ToString[βlis[[k]]]<>")",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10]) (Prior × Like)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];

Now create a plot of (Subscript[Log, 10]) (Prior × Likelihood) dropping first nburn1 iterations.

pl[[2]]=ListPlot[Take[Take[Transpose[{fn,conv*trn[[nl]]}],-(ng-nburn1)],{1,ng-nburn1,niter}],PlotRange->All,Joined->False,Frame->True,PlotStyle->{Black,PointSize[0.008]},Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration  chain  (β = "<>ToString[βlis[[k]]]<>")",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10]) (Prior × Like)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];

Next line shows the final plots.

plIter=Show[GraphicsGrid[If[EvenQ[np+2],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,np+2,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(np+2)/2]*2,2}],{{pl[[IntegerPart[(np+2)/2]*2+1]]}}]],Spacings->{Scaled[-0.15],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Notes on burn-in period and tests for convergence:

1) One scheme is to examine plots of the MCMC iterations for each parameter as is shown below.

2) A better test of convergence (not shown here) is to run m repeated simulations with different 
    starting points and compute the Gelman-rubin statistic for each parameter from the repeated runs 
    as described below.
         Let θ represent one of the model parameters.
         Let (Subscript[θ, j]^i) represent the (i^th) iteration of the (j^th) chain.
         Extract the last η post burn-in iterations for each simulation.

Mean within chain variance  W=(1/(m(η-1)))(∑_(j=1)^m)(∑_(i=1)^η)((((Subscript[θ, j]^i)-(OverBar[(Subscript[θ, j])])))^2)
               Between chain variance  B=(η/(m-1))(∑_(j=1)^m)((((OverBar[(Subscript[θ, j])])-(OverBar[θ])))^2)
               Estimated variance   (OverHat[V])(θ)=(1-(1/η))W+(1/η)B
               Gelman-Rubin statistic =(Sqrt[(((OverHat[V])(θ))/W)])
                       The Gelman-Rubin statistic should be close to 1.0  (e.g. <1.05)  for all paramaters for convergence.
          Ref:Gelman,A.and D.B.Rubin (1992)'Inference from iterative simulations    
                      using multiple sequences (with discussion)',Statistical Science 7, pp. 457-511.

Set the burn-in value nburn.

The burn - in period is the greater of : (a) no. of iterations at which all the parameter distributions
 have converged, and (b) the point at which the control system is turned off.

ncsys is the iteration number at which the control system achieved its goal of automatically 
finding a good set of parameter proposal distribution σ's, and was turned off. 
Note: since only 1 out of every nthin iterations is kept the effective iteration at which the 
         control system cuts off is Ceiling[N[ncsys]/nthin].

ncsys

minimumBurnin=Ceiling[ncsys/nthin]

Examine the parameter iterations (traces) above to see it is safe to set nburn = minimumBurnin = Ceiling[ncsys/nthin],
the iteration number at which the proposal σ control system is turned off.

nburn =minimumBurnin (* Default choice of burn-in = minimumBurnin *)

Plot marginal  distribution for model parameters

Extract parameter iterations beyond burn-in for plotting. Specify the tempering level, normally k = nβ.

k=nβ;tr=Take[Transpose[logpdfβi][[k]],-(nnt-nburn)];trn=Transpose[tr];trnn=Drop[trn,{1}];ng=Length[trnn[[1]]]

trnn[[1,1]]

Plot histograms of all the parameter iterations.

plh=Table[1,{i,np}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==50,pdotk=Max[Abs[trnn[[i]]]];trnnx=trnn[[i]]*(10^(-RealDigits[pdotk][[2]]));label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]<>"  (×"<>ToString[(10^(1.0*RealDigits[pdotk][[2]]))]<>")"];
plh[[i]]=Histogram[trnn[[i]],PlotRange->{{0.995*Min[trnnx[[i]]],1.0005*Max[trnnx[[i]]]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],
plh[[i]]=Histogram[trnn[[i]],PlotRange->{{0.995*Min[trnn[[i]]],1.0005*Max[trnn[[i]]]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]],{i,1,np}
];
plhis=Show[GraphicsGrid[If[EvenQ[np],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,np,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(np)/2]*2,2}],{{plh[[IntegerPart[(np)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Plot 2 dimensional parameter distribution.

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];ng=Length[trn[[1]]]

Suppose the two parameters of interest are f,T the first and second. Set ip = 1 and jp = 2

ip=1;jp=2;

ninterval=30;fT=Take[Transpose[{trn[[ip+1]],trn[[jp+1]]}],-(ng-nburn)];fTpl=Take[fT,{1,ng-nburn,ninterval}];tfT=Transpose[fTpl];fmin=Min[tfT[[1]]];fmax=Max[tfT[[1]]];plscata=ListPlot[fTpl,Frame->True,Axes->False,PlotRange->{{fmin,fmax},Automatic},PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[flabel,{"Helvetica-Bold",12}],
		Style[tlabel,{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

plscat=Show[plscata,Graphics[{Text["",{3,3.7}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5];

Plot binned marginal  distribution for model parameters.
It also computes quantities needed for 68% credible regions used in next section.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];trn=Transpose[tr];Length[trn[[1]]]

Details behind generating the marginal distributions.

Specify the number of points nai to bin the continuous parameters and set up some tables we will need for some parameter distribution statistics.

nai=50;plp=Table[1,{i,np}];meanai=Table[0,{j,1,np}];medianai=Table[0,{j,1,np}];modeai=Table[0,{j,1,np}];minai=Table[0,{j,1,np}];maxai=Table[0,{j,1,np}];areai=Table[0,{j,1,np}];

Next block computes the marginal PDF for the continuous parameters.

Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=trn[[i+1]];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[10000000*Min[aimarg]]/10000000;hi=Round[10000000*Max[aimarg]]/10000000;dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Plus@@aibin;yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2,#1}]&];modeai[[i]]=pbin[[1,2]];minai[[i]]=1000000000;maxai[[i]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[i]],minai[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[i]],maxai[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],PlotJoined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],{i,1,np}];N[areai]

minai

maxai

If[ncsys<n>0,plmarg1all=Show[GraphicsGrid[If[EvenQ[np],Table[{plp[[ii]],plp[[ii+1]]},{ii,1,np,2}],Join[Table[{plp[[ii]],plp[[ii+1]]},{ii,1,IntegerPart[(np)/2]*2,2}],{{plp[[IntegerPart[(np)/2]*2+1]]}}]],Spacings->{Scaled[-0.1],Scaled[0.05]}]]]

Find most probable set of parameters & 68.3% marginal credible regions.

tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(ng-nburn)];tr5s=RotateLeft[Sort[RotateRight[tr5,{0,1}],OrderedQ[{#2,#1}]&],{0,1}];

tr5s[[1]]

The output list from the above command contains the most probable set of parameters (f,T,σl).
The next command extracts these peak parameter values.

peakai=Table[0,{i,1,ncs}];Do[probMax=tr5s[[1,nl]];peakai[[i]]=tr5s[[1,i+1]],{i,1,ncs}];If[swb>0,peakb=tr5s[[1,np+1]],];peakai

probMax

Summary table of parameter values and 68% credible regions.

l1={{"Item","Peak","Mean","Median","Mode"},{"","","","",""}};

l2=Table[{ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"],peakai[[i]],meanai[[i]],medianai[[i]],modeai[[i]]},{i,np}];

l4={{"","","","",""},{"Item","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max","68%","68%"}};

l5=Table[{ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"],minai[[i]],maxai[[i]],peakai[[i]]-minai[[i]],maxai[[i]]-peakai[[i]]},{i,np}];

smj=MatrixForm[Join[l1,l2,l4,l5]]

Plot data with overlaid mean MCMC fit and fit residuals.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];nsel=Length[tr]

Create spectrum model for a list of frequencies flist (at higher resolution than measurements).

model1[temperature_,f0_,σline_]:=temperature*Exp[-((((flist-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

interval=100;flist=Table[f,{f,fvecmin,fvecmax,(fvecmax-fvecmin)/200}];spec={};
Do[str=Take[tr[[i]],{2,np+1}];
spec=Append[spec,model1[str[[2]],str[[1]],str[[3]]]],{i,1,nsel,interval}
]

Compute the mean of these spectra.

meanspec=Mean[spec];

Compute the standard deviation of these spectra.

stdspec=StandardDeviation[spec];

Plot the mean of these spectra with the data.

modlist=Transpose[{flist,meanspec}];plfitmean=ListPlot[modlist,PlotJoined->True,PlotRange->All,PlotStyle->{Black,Thickness[0.004]}];
plfitdatamean=Show[plshp1,plfitmean]

Plot another of these with a different aspect ratio and index letter for later display with other plots.

plmapfitmeanb=Show[plfitdatamean,Graphics[{Text["(c)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

modlist1=Transpose[{flist,(meanspec+stdspec)}];modlist2=Transpose[{flist,(meanspec-stdspec)}];plfitmeanr=ListPlot[{modlist1,modlist2},PlotJoined->True,PlotRange->All,PlotStyle->{{Thickness[0.006],Red},{Thickness[0.006],Green}}];
plfitdatameanr=Show[plshp1,plfitmeanr]

plmapfitmeanrb=Show[plfitdatameanr,Graphics[{Text["(d)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Create spectrum model for the measured list of frequencies fvec.

model[temperature_,f0_,σline_]:=temperature*Exp[-((((fvec-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

interval=100;mspec={};
Do[str=Take[tr[[i]],{2,np+1}];
mspec=Append[mspec,model[str[[2]],str[[1]],str[[3]]]],{i,1,nsel,interval}
]

Compute the mean of these spectra.

meanmspec=Mean[mspec];

Compute the standard deviation of these spectra.

stdmspec=StandardDeviation[mspec];

Compute the reduced (χ^2) of the mean fit.

y=(meanmspec-dvec)/errvec;

reducedchi2=y.y/(nd-4)

Compute the RMS residual of the fit.

yy=(meanmspec-dvec);

(Sqrt[((yy.yy)/nd)])

rmsresid=(Sqrt[((yy.yy)/nd)])

Construct the residual for plotting.

resid=Transpose[{fvec,dvec-Mean[mspec]}];

respk=StandardDeviation[resid]

resid

residerr=Table[{resid[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp2mean=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",12}],Style["Residuals  (mK)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{"Helvetica-Bold",12}]

plshp2meanb=Show[plshp2mean,Graphics[{Text["(b)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

plboth=Show[GraphicsGrid[{{plshp1r,plmapfitmeanb},{plshp2meanb,plmapfitmeanrb}},Spacings->{Scaled[-0.1],Scaled[-0.02]}]]

(*Export["c:/temp/Ch12Problem2SolutionM6AmeanFit.eps", plboth,ImageSize->72*7]*)

Compare data points to best fit model (MAP solution).

Create spectrum model for a list of frequencies flist (at higher resolution than measurements).

model1[temperature_,f0_,σline_]:=temperature*Exp[-((((flist-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

flist=Table[f,{f,fvecmin,fvecmax,(fvecmax-fvecmin)/200}];modspec=model1[peakai[[2]],peakai[[1]],peakai[[3]]];modfit=Transpose[{flist,modspec}];plfit=ListPlot[modfit,PlotJoined->True,Frame->True,PlotRange->All,PlotStyle->{Black,Thickness[0.004]},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",14}],Style["Temperatue  (mK}",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.004]];
plfitdat=Show[plfit,plshp1,DisplayFunction->$DisplayFunction]

plfitdatpk=Show[plfitdat,Graphics[{Text["(a)",{10,-2.1}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Compute and display residuals

resid=Transpose[{fvec,(dvec-model[peakai[[2]],peakai[[1]],peakai[[3]]])}];

residerr=Table[{resid[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",14}],Style["Residuals  (mK)",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.004]]

plshp2b=Show[plshp2,Graphics[{Text["(b)",{10,-2.4}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plboth=Show[GraphicsGrid[{{plfitdatpk},{plshp2b}},Spacings->{Scaled[-0.2],Scaled[0]}]]

Compute the Bayes factor from parallel tempering results

Compares model M2 to model M1 (rejecting the first nburn samples). 
((NOTE: THIS SECTION WON'T EVALUATE IF nβ <10.))
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 15) of β levels are used spanning the range β = 0 to 1. 
Otherwise use the Quasi Monte Carlo Bayes factor calculation in the next section.

Compute p(D|M1,I), the global likelihood for spectral line model

Here we compute  the log of the global likelihood of the model, which is designated by  logpM1
                logpM1=log[p(D|(Subscript[M, 1]),I)]=∫ (Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T ,σl,I)] ⟩, β])  dβ
(Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T ,σl,I)] ⟩, β]) =expectation value oflog[p(D|(Subscript[M, 1]),f,T ,σl,I)]  for given β
                                              =(1/n)(∑_(t=1)^n)  log[p(D|(Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I)] where n=number of MCMC iterations
                                              =abbreviate by   expect[[nb]]

Recall all the results are stored by the variable logpdfβi.
    Look at a typical row 8000of the output given by logpdfβi[[8000]].

The quantity  log[p(D| (Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I)] is the penultimate item  in each row. The different rows correspond to different values of the tempering parameter β, which is the first item in each row.

First check that you are happy with the burn -in value, nburn.

nburn

If[nβ>10,nused=ng-nburn;tr=Transpose[Take[logpdfβi,-nused]];expect=Table[0.0,{i,1,nβ}];Do[trnb=Transpose[tr[[nb]]];tb1Num=trnb[[n2l]];logpdfβ=Total[tb1Num]/nused;expect[[nb]]=logpdfβ,{nb,1,nβ}],];

If[nβ>10,expect,]

If[nβ>10,βlis,]

If[nβ>10,pl1=ListPlot[Transpose[{Log[10,βlis],expect}],Frame->True,PlotStyle->PointSize[0.02],PlotRange->All,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨p(D| (Subscript[M, 1]),\!\(\*SubscriptBox[\(f\), \(\(β\)\(\\ \)\)]\),(Subscript[T, β]),(Subscript[σl, β]),(Subscript[s, β]),I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

Generate an interpolating function for a LogLinearPlot

If[nβ>10,spline1 = Interpolation[Transpose[{Log[10,βlis],expect}], Method -> "Spline"]]

Specify the x range for cubic spline interpolation in the line below by {x, Min[Log[10, βlis ]], 0.0, 0.01}.

If[nβ>10,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect],]

If[nβ>10,pl4=ListPlot[newexpect,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D| (Subscript[M, 1]),\!\(\*SubscriptBox[\(f\), \(\(β\)\(\\ \)\)]\),(Subscript[T, β]),(Subscript[σl, β]),(Subscript[s, β]),I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

If[nβ>10,plBayesFactor=Show[pl1,pl4,PlotRange->All],]

Now we want to convert to a table with linear coordinates.

If[nβ>10,tnewexpext=Transpose[newexpect];newexpect1=Transpose[{(10^(tnewexpext[[1]])),tnewexpext[[2]]}],];

Next we approximate the integral by a sum of the table of interpolation values. Call it logpM1.

If[nβ>10,logpM1=Total[Table[0.5*(newexpect1[[i]][[2]]+newexpect1[[i+1]][[2]])*(newexpect1[[i+1]][[1]]-newexpect1[[i]][[1]]),{i,1,Length[newexpect1]-1}]],]

If[nβ>10,Exp[logpM1],]

Suppose we drop the first nn  β levels and redo the calculation of the log of the global likelihood for M1.

nn=1;

If[nβ⩾(10+nn),spline2 = Interpolation[Transpose[{Log[10,Drop[βlis,nn]],Drop[expect,nn]}], Method -> "Spline"]]

Specify the x range for cubic spline interpolation in the line below by {x, Min[Log[10,Drop[βlis,nn]]], 0.0, 0.01}.

If[nβ⩾(10+nn),newexpect2=Table[{x,spline2[x]},{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2],]

If[nβ⩾(10+nn),tnewexpext=Transpose[newexpect2];newexpect3=Transpose[{(10^(tnewexpext[[1]])),tnewexpext[[2]]}],];

Next we approximate the integral by a sum of the table of interpolation values. Call it logpM1A.

If[nβ⩾(10+nn),logpM1A=Total[Table[0.5*(newexpect3[[i]][[2]]+newexpect3[[i+1]][[2]])*(newexpect3[[i+1]][[1]]-newexpect3[[i]][[1]]),{i,1,Length[newexpect3]-1}]],]

If[nβ⩾(10+nn),Exp[logpM1A],]

Compute p(D|M2,I), the global likelihood for no line model

logfact=-(nd/2.0)*Log[2.0*π] ;

yy=dvec/errvec;logpM2=logfact -Plus@@Log[errvec]- 0.5*yy.yy

Exp[logpM2]

Compute Bayes factor

If[nβ>10,odds=Exp[logpM1-logpM2],]

If[nβ⩾(10+nn),odds=Exp[logpM1A-logpM2],]

Compute the Bayes factor using quasi Monte Carlo integration

Compares model M1 to model M2 (rejecting the first nburn samples). 
Quasi Monte Carlo (QMC) Bayes factor calculation is efficient even for models with 
a large number of parameter, provided one uses the MCMC marginals to constrain 
the parameter ranges (in this case we use the 99% credible region boundaries) to 
regions where the posterior has significant probability.

Computes 99% credible region for each parameter from the binned marginal  distribution.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];trn=Transpose[tr];Length[trn[[1]]]

Details behind generating the marginal distributions.

Specify the number of points nai to bin the continuous parameters and set up some tables we will need for some parameter distribution statistics.

nai=50;plp=Table[1,{i,np}];meanai=Table[0,{j,1,np}];medianai=Table[0,{j,1,np}];modeai=Table[0,{j,1,np}];minai99=Table[0,{j,1,np}];maxai99=Table[0,{j,1,np}];areai=Table[0,{j,1,np}];

Next block computes the marginal PDF for the continuous parameters.

Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=trn[[i+1]];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[10000000*Min[aimarg]]/10000000;hi=Round[10000000*Max[aimarg]]/10000000;dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Plus@@aibin;yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2,#1}]&];modeai[[i]]=pbin[[1,2]];minai99[[i]]=1000000000;maxai99[[i]]=-1000000000;area=0;j=1;
While[area≤0.99,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai99[[i]],minai99[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai99[[i]],maxai99[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],PlotJoined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],{i,1,np}];N[areai]

minai99

maxai99

Compute p(D|M1,I), the global likelihood for spectral line model

Now specify the procedure to compute the logprior and loglikelihood for use in the QuasiMonteCarlo integration. The integration is performed over a volume in parameter space defined by the 99% credible region. You need to modify this code for any additional model parameters.

logfact=-(nd/2.0)*Log[2.0*π] ;

Now, we find or specify the upper and lower parameter boundaries for the MC interation based on the 99% credible region of the MCMC marginal parameter distributions which defines the region in parameter space where the joint posterior has significant probability. If there are multiple regions then the MC integration should be performed separately.

low=Table[minai99[[i]],{i,1,np}]

hi=Table[maxai99[[i]],{i,1,np}]

The next step performs the QuasiMonteCarlo integration for the model parameters using {parf,parT,parσl,parσl} to represent {f,T,σl,s}. By default the range of the model parameters used for integration is set equal to the prior search range, e.g., avmin[[i]], avMax[[i]]. When dealing with large number of parameters these ranges should be reduced to values where the posterior has a significant probability as indicated by the MCMC marginal distribution for each parameter. You need to modify this for any additional model parameters.

work1:=Module[{},f=parf;T=parT;σl=parσl;mvec=model[T,f,σl]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T] ; (* the prior for parameters f & T *) 
y=(dvec-mvec)/errvec;
loglike=logfact-Plus@@Log[errvec]-0.5*y.y  
]

logpM1B=Log[NIntegrate[work1;Exp[logprior+loglike],{parf,low[[1]],hi[[1]]},{parT,low[[2]],hi[[2]]},{parσl,low[[3]],hi[[3]]},Method->"QuasiMonteCarlo",AccuracyGoal->12]]

Exp[logpM1B]

Compute p(D|M2,I), the global likelihood for no line model

yy=dvec/errvec;

logpM2=logfact- Plus@@Log[errvec]- 0.5*yy.yy

Exp[logpM2]

Compute Bayes factor

odds=Exp[logpM1B-logpM2]

Ch. 12: Problem 2  (11 MCMC chains)

Introduction

This notebook employs a semi-automatic parallel tempering (Section 12.8) version of Markov Chain Monte Carlo to analyze the spectral line data of chapter 3. In this version of the problem the line frequency (f), line temperature (T), and line width (σl) are unknown within given prior limits. See Section 12.6 for more details. The program can easily be modified for another nonlinear model fitting problem.

Nine MCMC chains are run in parallel each with a different tempering parameter β. At random intervals, proposals to swap the parameter values of a random pair of chains is considered. This prevents the MCMC from becoming trapped in one probability peak region. The program automates the selection of Gaussian proposal σ's, one for each parameter. 
The best approach is to choose a set of proposal distribution {σ} that are about 1/10th the prior range of each parameter, then let the control system automatically home in on improved proposal σ's. Useful parameter iterations are obtained after the control system terminates. 

The Bayes factor, used in model selection, is computed in two different ways at the end of this program.

The spectral line model equations

Let f0 stand for the line frequency,T  for the line temperature, and σl  for the line width .

Model of spectral line  = temperature * Exp[-((((f-f0))^2)/(2 ((σl)^2)))]

The set of  f values in the measured spectrum is given by  fvec.

Let model[T_,f0_,σl_] stand for the set of measurements predicted by 
the model.
model[temperature_,f0_,σl_]:=temperature* Exp[-((((fvec-f0))^2)/(2 ((σl)^2)))]

According to the model we can write for the (i^th) data value
                            di = mi + ei,
where  mi   is the  model  prediction for the (i^th) data value and  ei   is an independent
Gaussian error term.

The likelihood is given by
     p(D|M,X,I) = (((2 π))^(-nd/2))(σ^(-nd))Exp[-(((∑_(i=1)^n)(((di- mi))^2))/(2 (σ^2)))]
                       = (((2 π))^(-nd/2))(σ^(-nd))Exp[-(((∑_(i=1)^n)(di^2))/(2 (σ^2)))] Exp[-((2(∑_(i=1)^n)di mi)/(2 (σ^2)))]Exp[-(((∑_(i=1)^n)(mi^2))/(2 (σ^2)))]

Let  dvec stand for the vector of n data value 
Let  mvec stand for the vector of n model predictions
then (∑_(i=1)^n)(di^2) = dvec.dvec ;    (∑_(i=1)^n)(mi^2) = mvec.mvec  ;  (∑_(i=1)^n)di mi = dvec.mvec

Alternate calulation used in actual program allows for a different error for each data point:
                y=(dvec-mvec)/errvec
     p(D|M,X,I) = (((2 π))^(-nd/2)){Times@@(((errvec))^(-1))}Exp[-0.5*y.y]

Equations needed for model selection

For model comparison need to compute  odds = Exp[logpM1-logpM2]  (see Section 12.7)

logpM1 = log[p(D|M1,I)] = ∫ (Subscript[⟨ log[p(D|M1,f,T,σl,I)] ⟩, β])  dβ

(Subscript[⟨ log[p(D|M1,f,T,σl,I)] ⟩, β]) = expectation value of  log[p(D|M1,f,T,σl,I)]  for  given  β
                                              = (1/n)(∑_(t=1)^n)  log[p(D|M1,(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I)] 
                                                      where n = number of  MCMC iterations
                                              = abbreviate by    expect[[nb]],
    - where nb goes from 1 to nβ ,
    - and  the list of  β values is given by  βlis = Table[β0+dβ (i-1),{i,1,nβ}],     
    - and p(D|M1,(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I) is the likelihood of each set of parameter choices 
      accepted for the given value of β.  
      
(see section on spectral line model above and Chapter 3 for discussion of the models)      
p(D|M1,f,T,I) = abbreviated   like1 = (((2 π))^(-nd/2)){Times@@(((errvec))^(-1))}Exp[-0.5*y.y]
     - where  mvec = model[T,f];    
     - and   model[temperature_,f0_]:=temperature * Exp[-((((fvec-f0))^2)/(2*((σl)^2)))];   
prior1 = =(c/T) ;  where c =1/{(fmax-fmin)*Log[(Tmax/Tmin)]*(σlmax-σlmin)};      
and   pdfβ1= prior1*(((like1))^β);
  
finally  logpM2 = log[p(D|M2,I)] = Log[(((2 π))^(-nd/2)) {Times@@(((errvec))^(-1)) } Exp[- 0.5*y.y]] 
                                                        = global probability of model M2;    
  - recall model M2 has no parameters

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

Needs["Graphics`Common`GraphicsCommon`"]

List and plot the the spectral line data

The data, named dat, consists of (f,T), frequency channel number and temperature pairs.

dat1= {{1.`,0.82`},{2.`,-2.07`},{3.`,0.38`},{4.`,0.99`},{5.`,-0.12`},{6.`,-1.35`},{7.`,-0.2`},{8.`,0.36`},{9.`,0.78`},{10.`,1.01`},{11.`,0.44`},{12.`,0.34`},{13.`,1.58`},{14.`,0.08`},{15.`,0.38`},{16.`,-0.71`},{17.`,-0.9`},{18.`,0.33`},{19.`,0.8`},{20.`,-1.42`},{21.`,0.28`},{22.`,-0.42`},{23.`,0.12`},{24.`,0.14`},{25.`,-0.63`},{26.`,-1.77`},{27.`,-0.67`},{28.`,0.55`},{29.`,1.98`},{30.`,-0.08`},{31.`,1.16`},{32.`,0.48`},{33.`,-0.03`},{34.`,1.47`},{35.`,1.7`},{36.`,1.89`},{37.`,4.55`},{38.`,3.59`},{39.`,2.02`},{40.`,0.21`},{41.`,0.05`},{42.`,0.54`},{43.`,-0.09`},{44.`,-0.61`},{45.`,2.49`},{46.`,0.07`},{47.`,-1.45`},{48.`,0.56`},{49.`,-0.72`},{50.`,0.38`},{51.`,0.02`},{52.`,-1.26`},{53.`,1.35`},{54.`,-0.04`},{55.`,-1.45`},{56.`,1.48`},{57.`,-1.16`},{58.`,-0.4`},{59.`,0.01`},{60.`,0.29`},{61.`,-1.35`},{62.`,-0.21`},{63.`,-1.67`},{64.`,0.7`}};

Details concerning data manipulation and statistics.

tarr1=Transpose[dat1];

lendat=Length[dat1];nd=lendat

fvec1=N[tarr1[[1]]];

fvecmin=First[fvec1];

fvecmax=Last[fvec1];

dvec1=N[tarr1[[2]]];

σnoise=1.0;(* data noise sigma *)

errvec1=Table[σnoise,{nd}];

aveDerror=Mean[errvec1];

dat=Transpose[{fvec1,dvec1,errvec1}];

tarr=Transpose[dat];

fvec=N[tarr[[1]]];

dvec=N[tarr[[2]]];

ppeak=Max[dvec]-Min[dvec]

errvec=N[tarr[[3]]]

data=Transpose[{fvec,dvec}];

Plot the data

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,PlotStyle->Black,FrameLabel->{Style["Channel  number",{"Helvetica-Bold",12}],Style["Temperature",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.005],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp1r=Show[plshp1,Graphics[{Text["(a)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Parallel Tempering program

INITIALIZE PROGRAM VALUES

nthin=1; (* store MCMC iterations at a thinning interval of nthin. Since successive
iterations are partially correlated using an nthin ≈ 10 reduces the correlation
and reduces the memory requirements for long iterations *)

n=20000*nthin; (* number of MCMC iterations *)

nβ=11;(* number of choices of tempering parameter *)(* Note:the product nβ\[Cross]ns/(swap rate) should be approximately ≃ 150 *)

βlis={0.0001,0.001,0.01,0.025,0.1,0.2,0.3,0.45,0.6,0.75,1.0} ;(* tempering parameter values *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains *)

ns=5; (* ns is mean number of iterations between swap proposals *)

np=3; (* np= number of free parameters computational explored *)

ncs=np; (* only the first ncs parameter proposal σ's adjusted by the control system *)

nl=np+4;(* item in output list containing prior1*(((like1))^β) (don't change this) *)

n2l=np+3;(* item in output list containing Log[like] (don't change this) *)

swb=0; (* swb=1 if extra noise parameter s included, swb = 0 otherwise *)

STARTING PARAMETER VALUES

avst=Table[0,{np}]; (* initialize table of start parameter values *)
avmin=Table[0,{np}];(* initialize table of parameter lower bounds *)
avMax=Table[0,{np}];(* initialize table of parameter upper bounds *)
bfmin=Table[0,{np}];(* Bayes factor parameter lower bounds *)
bfMax=Table[0,{np}];(* Bayes factor parameter upper bounds *)

avst[[1]]= 30.0; (* line center freq. start value *)

a1name= "f"; a1unit="  (channel #)";(* name of parameter 1 and units *)

avst[[2]]=5.0; (* line temperature start value *)

a2name= "T"; a2unit="  (mK)";(* name of parameter 2 and units *)

avst[[3]]=0.7;(* line width start value *)

a3name= "σl"; a3unit="  (channels)"; (* name of parameter 3 and units *)

PRIOR SEARCH RANGES

avmin[[1]]=1.0;avMax[[1]]=44;(* search bounds on line center freq *)

avmin[[2]]=0.1;avMax[[2]]=ppeak;(* search bounds on line temperature *)

avmin[[3]]=0.5;avMax[[3]]=4.0;(* search bounds on line width *)

type={0,0,0}; (* If type = -1, parameter is a period but search carried out in frequency *)
(* type = 1, angular parameter, wrap around at 0 and 1 *)
(* type = 2, angular parameter, wrap around at 0 and 2π *)
(* type = 3, angular parameter, wrap around at 0 and 4π *)
(* type = 4, angular parameter, wrap around at -2π and 2π *)
(* type = 5, parameter is first radial velocity amplitude (Subscript[K, 1 ])*)
(* type = 6, parameter is second radial velocity amplitude (Subscript[K, 2 ])in multiple planet fit *)
(* type = 7, parameter is second radial velocity amplitude (Subscript[K, 3 ])in multiple planet fit *)
(* type = 0, all other parameters *)

PRIOR RANGE FOR BAYES FACTOR CALCULATION

bfmin[[1]]=1.0;bfMax[[1]]=44.;(* search bounds on line center freq *)

bfmin[[2]]=0.1;bfMax[[2]]=100.;(* search bounds on line temperature *)

bfmin[[3]]=0.5;bfMax[[3]]=4.0;(* prior bounds on line width *)

STARTING SIGMAS AND MINIMUM SIGMAS

σst=Table[0,{i,1,ncs}];(* initialize table of parameter proposal σ's *)

minσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ's *)

swminσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ switches  *)

Typically set start sigma to approximately 10 to 20% of the parameter search range.

σst[[1]]=0.2*(avMax[[1]]-avmin[[1]]); (* sigma for a1 proposal random Gaussian step *)

σst[[2]]=0.2*ppeak; (* sigma for a2 proposal random Gaussian step *)

σst[[3]]=0.5; (* sigma for a3 proposal random Gaussian step *)

Set minimum proposal sigmas.

sigTonoise=0.5*ppeak/Mean[errvec];

minσ[[1]]=0.1;(* min sigma for proposal random Gaussian step *)

minσ[[2]]=Mean[errvec]/(Sqrt[nd]); (* min sigma for proposal random Gaussian step *)

minσ[[3]]=0.1; (* min sigma for proposal random Gaussian step *)

CONTROL SYSTEM PARAMETERS  (user don't change this)

minCS=5000; (* minimum number of iterations before Control System turned off *)

maxCS=10000; (* maximum number of iterations before 1st stage Control System turned off *)

deltaN=5000; (* intervals in i used to decide on whether to rerun 2nd stage CS *)

sw1=0;(* =0 when control system is on and =1 when turned off.*)

sw5=1;(* =0 never do 2nd stage CS, =1 execute 2nd stage CS *)

n0=1000; (* initial search with no control system active *)

λ=0.25; (* target acceptance ratio *)

n1=1000; (* number of iterations between changes in σ's *)

n2=200; (* number of iterations per parameter per minor cycle *)

nt1=λ*n1; (* target no. of acceptances per n1 iterations *)

nt=λ*n2; (* target no. of acceptances per n2 iterations *)

tol1=0; (* error tolerance 1 in annealing *)

(*tol1=1.5*(Sqrt[nt1]);*) (* error tolerance 1 in annealing *)

tol2=1.5*(Sqrt[nt1]); (* error tolerance each β chain must satisfy before CS turned off *)

(*tol2=0;*) (* error tolerance each β chain must satisfy before CS turned off *)

scmax=0.1; (* max factor to reduce/increase σ in control sys minor cycles *)

(*gain=Table[0.7,{i,1,nβ}];*)
(*gain={0.25,0.45,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6,0.6};*)
gain=Table[0.7-(nβ-i)*0.1/(nβ-1),{i,1,nβ}];(* gain x scmax = max factor to reduce/increase proposal σ's *)

γ=1.6; (* damping exponent in annealing process *)

alfm=0.806096-1.12051*(10^(-2))*ncs+3.1233*(10^(-4))*(ncs^2)-3.03567*(10^(-6))*(ncs^3);(* Scaling exponent for calulation of accept rate for individual parameters 2nd stage CS *)

kalf=0.87; (* Empirical factor for scaling exponent, typical value 0.87 *)

accept=Table[(((λ))^(1/(ncs^((kalf^((βlis[[kn]])^(-1.0)))*alfm)))),{kn,1,nβ},{kj,1,ncs}]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS

Define the constant portion of the joint prior for model M1.

c=-Log[(bfMax[[1]]-bfmin[[1]])*Log[((bfMax[[2]])/(bfmin[[2]]))]*(bfMax[[3]]-bfmin[[3]])](* normalization constants for prior *)

Define the constant portion of the joint prior for model M1 
(assumes a modified Jeffreys prior for T not used in this example).

(*mJlim=0.1;*)(* for modified Jeffreys prior for T *)

(*c=-Log[(bfMax[[1]]-bfmin[[1]])*Log[((mJlim+bfMax[[2]])/mJlim)]];*)(* normalization constants for prior *)

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (depends on model)

Version below does not include extra noise parameter s.

Specify terms needed in calculation of model M1 likelihood

logfact=((-nd)/2.0)*Log[2*π];(* part of likelihood independent of f,T,σl *)

model[temperature_,f0_,σline_]:=temperature*Exp[-((((fvec-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Specify a module for calculating the basic work ≡  logposterior = logprior + loglikelihood 
for model M1. 
It is convenient to work with Log quantities because this avoids the need for Mathematica to use extended precision calculations (much slower than machine precision calculations) when the likelihoods are very small, often the case.
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

work:=Module[{f,T,σl,y},f=av[[1]];T=av[[2]];σl=av[[3]];
mvec=model[T,f,σl]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T] ; (* the prior for parameters f & T *) 
y=(dvec-mvec)/errvec;
loglike=logfact-Plus@@Log[errvec]-0.5*y.y;(* likelihood fn for particular f,T, σl *)  
pvec={f,T,σl}]

MODULE THAT PROPOSES THE NEW PARAMETER SET (depends on model)

Propose new parameter values. Uses Switch command and parameter type[[ii]] to handle different parameter types. 
For type[[1]],  proposed update in Period = av[[1]] is the reciprocal of a proposed change in frequency.
Check if proposed values lie outside prior borders, if so reflect parameter or wrap angular parameters.

propose:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,av[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,av[[ii]]=Mod[2*avMaxt-av0,(avMaxt-avmint),avmint]],
-1,
If[smp>0&&i>ncsys&&RandomReal[]<0.25,avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],2*σall[[k,ii]]]];av[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,av[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,av[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σall[[k,ii]]]];av[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,av[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,av[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
1,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],1],
2,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],2π],
3,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],4π],
4,
av[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av5<avmint,av[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,av[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av6<avmint,av[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,av[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]];
Which[av7<avmint,av[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,av[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]]
];
]

STEP TO EXECUTE MCMC CALCULATION (user don't change this)

AbsoluteTiming[
logpdfβi=.;  (* remove any existing definition of output file *)
logpdf=.;  (* remove any existing definition of file *)
num=ToString[rnum];  (* run number for specifying unique output plots *)
nnt=n/nthin;  (* no. of thinned iterations, n needs to be integer divisible by nthin *)
logpdf=Table[0,{i,1,2},{j,1,nβ}]; (* initialize storage *) 
logpdf2=Table[0,{i,1,2},{j,1,nβ}]; (* initialize storage *)
logpdfβi=Table[0,{i,1,nnt},{j,1,nβ}]; (* initialize storage *)
accept1=Table[0,{i,1,nβ},{j,1,ncs}]; (* initialize storage for param. acceptance rates *)
accept2=Table[0,{i,1,nβ},{j,1,ncs}]; 
accept3=Table[0,{i,1,nβ},{j,1,ncs}]; 
maxlogpdfβi=Table[0,{j,1,nβ}]; (* initialize storage *) 
na=Table[0,{nβ}];  (* initialize acceptance array *)
nb=Table[0,{k,1,nβ},{ncs}];  (* initialize array to store #accepted proposals in minor cycle *)(* for each parameter proposal σ *)
smp=0;(* smp=0 or 1, smp=1 better multiple peak detection, reduced acceptance rate*)
diag={};  (* initialize diagnostic array {sw,er,i,parameter #} *)
swap={};  (* initialize diagnostic array for swaps *)
(*α0=1/ns;*) (* if uniform random deviate is less than α0 then swap *)
nas=0; (* initiate an integer used in computing actual swap rate *)
nbmin=Table[0.0,{nβ}]; (* inintialize control system array *)
nbmax=Table[0.0,{nβ}]; (* inintialize control system array *)
dnb=Table[0.0,{nβ}]; (* inintialize control system array *)
err=Table[0.0,{nβ}]; (* inintialize control system err array *)
erl={}; (* array used to determine when err in all chains < tol2 *)
κ=Table[1.0,{k,1,nβ},{ncs}];(* weak logarithmic restoring force array*)
diagarray=Table[0,{k,1,nβ},{6}]; 
av=Table[0.0,{np}]; (* inintialize parameter array *)
σall1=Table[0,{np}];  
Do[σall1[[i]]=σst[[i]],{i,1,np}];(*initialize σall1 array*)
σall=Table[σst[[i]],{k,1,nβ},{i,1,np}];  
(* initialize σall array *)
σallold={};(* record previous best σall *)
logpdftemp2old={};(* record previous best logpdftemp2 in β=1 chain in 2nd stage CS *)
maxlogpdfAllold={};(* record previous values of maxlogpdfAll *)
σmonitor={{1,σall}};  (* initialize monitor of parameter proposal σ's  *)(* specify some constants & switches used in the control system *) 
nc1=1;(* maj/minor cycle counter initially set to 1 *)
nc2=Table[0,{nβ}];(* # of prop. acceptances in each subcycle *)
nc4=0;(* = 0 in major cycle and = 1,2,--,ncs in minor cycles *)
sw=Table[0,{nβ}];(* =0 in major cycles and in minor cycles 
=+1 if er[[k]]<0 and =-1 if er[[k]]>0 *)
sw3=0;(* =0 in major cycles and =1 in minor cycles.*)
sw4=0;(* =0 skip over 2nd stage CS, =1 execute 2nd stage CS *)
gain0=gain;(* initial control system gain.*)
(* Control system turned off as soon as er< tol2. *)
ncsys=n; (* otherwise ncsys=iteration # when control system turned off *)
ncsysold={}; (* records previous values of ncsys=iteration # *)
it=0;(* initialize counter for thinned iteration number *)
logfact=-(nd/2.0)*Log[2.0*π] ;
(* Evaluate the probability for the i=0 sample for each tempering level*)
Do[(* iteration over β *) β=βlis[[k]];av=avst;
 (* initiate parameter values *)
(* ******************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdf1= loglike;
pdfβ1= logprior+β*loglike; (* factor needed to decide on tempering swap *)
logpdf[[1,k]]=Join[{β},pvec,{0,pdf1,pdfβ1}],{k,1,nβ} 
];  (* close first Do loop iterating over β *)
maxlogpdfβi=logpdf[[1]];
maxlogpdfAll=logpdf[[1,nβ]];
Do[ (* start calculation for ith iteration beginning at i = 1 *)
If[i>n0,nc1=nc1+1];If[nc1<2&&i>n0,logpdftemp=logpdfinow,logpdftemp=logpdf[[1]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk = logpdftemp[[k]]; values = Take[logpdftempk, {2, np + 1}];
(* recover previous parameter values*)
(*************** propose new parameter set ******************) 
Do[propose,{ii,1,np}];
(* ****************** Basic working *********************** *)
work;
(* ******************************************************** *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf[[2,k]]=Join[{β},pvec,{i,pdfi,pdfβi}];If[pdfβi>Last[maxlogpdfβi[[k]]],maxlogpdfβi[[k]]=logpdf[[2,k]]];
If[i>n0,nc2[[k]]=nc2[[k]]+1;If[nc4<1,na[[k]]=na[[k]]+1]],logpdf[[2,k]]=logpdftempk;logpdf[[2,k,n2l-1]]=i
], (* complete If statement *)
{k,1,nβ} 
];(* complete Do loop over β *)
(* Consider a swap between 2 tempering levels if i an integer multiple of ns *)
If[nc4>0||nβ<2,Goto[anneal]];
If[IntegerQ[i/ns],(* next pick the 2 levels k1 & k2 to swap *)
(* following command chooses k1 from 1 to nβ-1 and sets k2=k1-1 *)
k1=RandomInteger[{1,(nβ-1)}];
k2=k1+1;
(* evaluate swap acceptance rule*)
loglike1=logpdf[[2,k1,n2l]];
loglike2=logpdf[[2,k2,n2l]];
β1=logpdf[[2,k1,1]];β2=logpdf[[2,k2,1]];
logprior1=logpdf[[2,k1,nl]]-β1*loglike1;
logprior2=logpdf[[2,k2,nl]]-β2*loglike2;
p12=logprior1+β2*loglike1;
p21=logprior2+β1*loglike2;
r=Exp[(β2-β1)*(loglike1-loglike2)];  
u2=RandomReal[];
If[u2≤r (* if uniform random ≤ r then accept swap *),nas=nas+1;swap=Append[swap,{k1+k2,1,i}];
temp=logpdf[[2,k1]];
Do[logpdf[[2,k1,ji]]=logpdf[[2,k2,ji]],{ji,2,np+1}];
logpdf[[2,k1,n2l]]=loglike2;logpdf[[2,k1,nl]]=p21;
Do[logpdf[[2,k2,ji]]=temp[[ji]],{ji,2,np+1}];
logpdf[[2,k2,n2l]]=loglike1;logpdf[[2,k2,nl]]=p12,
swap=Append[swap,{k1+k2,0,i}]]  (* complete accept If swap statement *)
] ; (* complete first If swap statement *)
(* start of annealing control system *)
Label[anneal];
If[sw1>0||i<n0,Goto[next],(* sw1=1 means want control system turned off *)
If[nc4>0,Goto[cycle],
If[nc1<n1,Goto[next],nc1=0;er=Table[nc2[[k]]-nt1,{k,1,nβ}];nc2=Table[0,{nβ}];
If[i>minCS&&Abs[er[[nβ]]]<tol2,sw1=1;nc4=0;na=Table[0,{nβ}];ncsys=i;ncsys1=ncsys+deltaN;If[sw5>0,sw4=1];Goto[next]];
If[Max[Abs[er]]<tol1,Goto[next],
logpdfinow=logpdf[[2]];scexp1=(((Abs[er]/nt1))^γ);scexp=Table[Min[1,scexp1[[jj]]],{jj,1,nβ}];sc=(scmax^scexp);scplus=gain*(1-sc);scminus=gain/sc;
Do[If[er[[k]]<0,sw[[k]]=1;nc4=1,sw[[k]]=-1;nc4=1],{k,1,nβ}]
];(* sw=1 for cooling parameter & sw=-1 for heating parameter *) 
If[nc4>0,Do[σall[[k,nc4]]=sc[[k]]^sw[[k]]*σall[[k,nc4]],{k,1,nβ}]];
Goto[next]
]
]
];
Label[cycle];
If[nc1<n2,Goto[next],Do[nb[[k,nc4]]=nc2[[k]];σall[[k,nc4]]=sc[[k]]^(-sw[[k]])*σall[[k,nc4]],{k,1,nβ}]
];
nc4=nc4+1;nc2=Table[0,{nβ}];nc1=0;If[nc4>ncs,Goto[list],Do[σall[[k,nc4]]=sc[[k]]^sw[[k]]*σall[[k,nc4]],{k,1,nβ}];Goto[next]
];
Label[list];
Do[nbmax[[k]]=Max[nb[[k]]];nbmin[[k]]=Min[nb[[k]]];dnb[[k]]=nbmax[[k]]-nbmin[[k]];nc3=Flatten[Position[nb[[k]],nbmax[[k]]]];lnc3=Length[nc3];nc5=Flatten[Position[nb[[k]],nbmin[[k]]]];lnc5=Length[nc5];
If[sw[[k]]>0,
If[nbmin[[k]]<nbmax[[k]],
Do[σallprop=(1-scplus[[k]])*σall[[k,nc3[[ik]]]]; If[σallprop<minσ[[ik]],σall[[k,nc3[[ik]]]]=minσ[[ik]];If[k==nβ,swminσ[[ik]]=1],σall[[k,nc3[[ik]]]]=σallprop],{ik,1,lnc3}],
Do[σallprop=sc[[k]]*σall[[k,ik]];If[σallprop<minσ[[ik]],σall[[k,nc3[[ik]]]]=minσ[[ik]];If[k==nβ,swminσ[[ik]]=1],σall[[k,nc3[[ik]]]]=σallprop],{ik,1,ncs}]
];
err[[k]]=nbmax[[k]]-nt;
diagarray[[k]]={sw[[k]],er[[k]],err[[k]],sc[[k]],i,dnb[[k]]};sw[[k]]=0,If[nbmin[[k]]<nbmax[[k]],
Do[σall[[k,nc5[[ik]]]]=scminus[[k]]*σall[[k,nc5[[ik]]]]; If[k==nβ&&(nbmax[[k]]-nc5)>0,swminσ[[ik]]=0],{ik,1,lnc5}],
Do[σall[[k,ik]]=σall[[k,ik]]*scminus[[k]];If[k==nβ,swminσ[[ik]]=0],{ik,1,ncs}]
];
err[[k]]=nbmin[[k]]-nt;
diagarray[[k]]={sw[[k]],er[[k]],err[[k]],sc[[k]],i,dnb[[k]]};sw[[k]]=0
],{k,1,nβ}
];
If[Product[swminσ[[i]],{i,ncs}]>0,sw1=1;nc4=0;na=Table[0,{nβ}];ncsys=i];
σmonitor=Append[σmonitor,{i,σall}];diag=Append[diag,diagarray];nc4=0;
If[i>maxCS&&sw1==0,sw1=1;sw4=1;ncsys=maxCS];
Label[next];
If[sw4<1,(* If sw4==0 skip 2nd stage control system *)
If[IntegerQ[i/nthin],it=it+1;logpdfβi[[it]]=logpdf[[2]]];logpdf[[1]]=logpdf[[2]],
(************************************************************************)
(*** Control system 2nd stage, acceptance for individual parameters ***)
(************************************************************************)
If[IntegerQ[i/nthin],it=it+1;logpdfβi[[it]]=logpdf[[2]]];(* ***************** Find best chain values ***************** *)
bestvec=Take[RotateLeft[maxlogpdfAll,1],np];
Do[(* iteration over β *) β=βlis[[k]];av=bestvec;
 (* initiate parameter values *)
(* ******************** Basic working ********************** *)
work;
(* ********************************************************* *)
pdfj= loglike;
pdfβj= logprior+β*loglike; 
If[pdfβj>Last[maxlogpdfβi[[k]]],
maxlogpdfβi[[k]]=Join[{β},pvec,{1,pdfj,pdfβj}]],
{k,1,nβ} 
];  (* close first Do loop iterating over β *)
(* *********************************************************** *)
logpdf[[1]]=maxlogpdfβi;
logpdfinow2=maxlogpdfβi;
nβlow=nβ-n2β+1;
k2vals=Table[iip,{iip,nβlow,nβ}];
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,nβlow,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept1[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
σold1=σall;
Do[σall[[k]]=σall[[k]]*(Sqrt[((N[accept1[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept1[[k]]/n1]+0.01)))]),{k,nβlow,nβ}];
(**************************************************************)
(* Control upper limit of σall to be ≤ parameter search range *)
Do[(* iteration over parameters *)
Do[Switch[type[[ip2]],
0,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
-1,If[σall[[k,ip2]]>(1./avmin[[ip2]]-1./avMax[[ip2]]),σall[[k,ip2]]=(1./avmin[[ip2]]-1./avMax[[ip2]])],
1,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
3,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
4,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
5,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
6,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
7,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]]
],{k,nβlow,nβ}
],(* complete β Do loop *)
{ip2,1,ncs}
];(* complete parameter Do loop *)
(**************************************************************)
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,nβlow,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept2[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
σold2=σall;
Do[σall[[k]]=σall[[k]]*(Sqrt[((N[accept2[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept2[[k]]/n1]+0.01)))]),{k,nβlow,nβ}];
(**************************************************************)
(* Control upper limit of σall to be ≤ parameter search range *)
Do[(* iteration over parameters *)
Do[Switch[type[[ip2]],
0,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
-1,If[σall[[k,ip2]]>(1./avmin[[ip2]]-1./avMax[[ip2]]),σall[[k,ip2]]=(1./avmin[[ip2]]-1./avMax[[ip2]])],
1,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
3,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
4,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
5,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
6,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
7,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]]
],{k,nβlow,nβ}
],(* complete β Do loop *)
{ip2,1,ncs}
];(* complete parameter Do loop *)
(**************************************************************)
Do[(* iteration over parameters *)
n2c1=0;n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
Do[ (* start calculation for ith iteration beginning at i2 = 1 *)
n2c1=n2c1+1;If[n2c1<2,logpdftemp2=logpdfinow2,logpdftemp2=logpdf2[[2]]];
Do[(* iteration over β *) β=βlis[[k]];logpdftempk2=logpdftemp2[[k]];values=Take[logpdftempk2,{2,np+1}];av=values;
(* recover previous parameter values*)
ii=ip2;
(*************** propose new parameter value ****************) 
propose;
(* ******************************************************** *)
(* ****************** Basic working *********************** *)
work;
(* ********************************************************* *)
pdfi= loglike;
pdfβi= logprior+β*loglike; (* factor needed to decide on tempering swap *)pdfβiA= logprior+loglike;
If[pdfβiA>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=Join[{β},pvec,{i,pdfi,pdfβiA}]];
r1=Exp[pdfβi-logpdftempk2[[nl]]];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,logpdf2[[2,k]]=Join[{β},pvec,{i2,pdfi,pdfβi}];n2c2[[k]]=n2c2[[k]]+1,logpdf2[[2,k]]=logpdftempk2;logpdf2[[2,k,n2l-1]]=i2
], (* complete If statement *)
{k,1,nβ} 
],(* complete Do loop over β *)
{i2,1,n1} (* complete iteration Do loop *)
];Do[accept3[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
sw4=0
]; (* complete If statement *)
If[i>ncsys&&IntegerQ[(i-ncsys)/deltaN]&&(Last[maxlogpdfAll]-Last[logpdftemp2[[nβ]]])>3.0,sw4=1;ncsysold=Append[ncsysold,ncsys];σallold=Append[σallold,σall];logpdftemp2old=Append[logpdftemp2old,logpdftemp2];na=Table[0,{nβ}];ncsys=i,
];(* complete If statement *)
,{i,1,n} (* complete iteration Do loop *)
];
acceptratio=If[ncsys<n,N[na/(n-ncsys)],N[na/n]]  (* evaluate acceptance ratio *)
]

The line above gives the execution time and average acceptance rate for each chain after the control system was turned off. The control system switched off at an iteration number specified by ncsys (given below).

The MCMC iteration number (unthinned) at which control system was turned off for the last time.

ncsys

The line below lists the most probable parameter set found in the MCMC.

Take[maxlogpdfAll,{2,np+1}]

A number of specialized items only of use to the code designer.

ncsysold

swminσ

maxlogpdfAll

Length[maxlogpdfAllold]

maxlogpdfAllold

maxlogpdfβi

logpdfinow2

MemoryInUse[]

n2c2

na

MCMC performance diagnostics & parameter proposal σ's

The next command gives the acceptance rate for each chain (tempering level).

acceptratio

The output from the next command gives the swap acceptance rate between adjacent tempering levels. First item is the swap rate between the two with lowest β tempering levels, etc.

If[nβ>1&&n>ncsys,swaplen={};swaprate={};nsw0=1;swaps=Sort[swap];spl=Split[Transpose[swaps][[1]]];Do[nswi=Length[spl[[i]]];swlst=Take[swaps,{nsw0,nswi+nsw0-1}];swpr=N[(Plus@@(Transpose[swlst][[2]]))/nswi];swaprate=Append[swaprate,swpr];swaplen=Append[swaplen,nswi];nsw0=nsw0+nswi,{i,1,nβ-1}];swaprate,]

The MCMC iteration number (unthinned) at which control system was turned off for the last time.

ncsys

The line below lists the most probable parameter set found in the MCMC.

Take[maxlogpdfAll,{2,np+1}]

The following is a matrix of Gaussian parameter proposal σ's chossen by the control system. There should be nβ lines, one for each tempering level. The top row corresponds to β0 and the bottom to β = 1. The columns give the proposal σ's for the parameters. 
They should all be greater than the corresponding value in minσ given on the next line.

minσ

MatrixForm[σall]

A number of specialized diagnostic, only of use to designer.

ncsysold

swminσ

maxlogpdfAll

Length[maxlogpdfAllold]

maxlogpdfAllold

maxlogpdfβi

logpdfinow2

MemoryInUse[]

n2c2

na

MatrixForm[σold1]

MatrixForm[σold2]

MatrixForm[N[accept1/n1]]

Times@@(accept1[[nβ]]/N[n1])

MatrixForm[N[accept2/n1]]

Times@@(accept2[[nβ]]/N[n1])

MatrixForm[N[accept3/n1]]

Times@@(accept3[[nβ]]/N[n1])

Plotting results of MCMC

Setup some graph axes labels

tlabel=
StyleForm[StringForm["``",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

tmklabel=
StyleForm[StringForm["``  (mK)",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

flabel=
StyleForm[StringForm["``  (channel #)",
StyleForm["f",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

tACFlabel=
StyleForm[StringForm["``  ACF",
StyleForm["T",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

fACFlabel=
StyleForm[StringForm["``  ACF",
StyleForm["f",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

Extracting model parameter samples for the β = 1 MCMC chain

All the results are stored by the variable logpdfβi. (example format for 3 parameters f,T,σl)
First let's look at an example of the first row of the output given by logpdfβi[[1]].
{{0.01`,30.`,5.`,0.7`,-118.00310275500061`,0.0000591119911561849`},{0.2575`,30.`,5.`,0.7`,-118.00310275500061`,1.2239727134969812`*^-17},{0.505`,30.`,5.`,0.7`,-118.00310275500061`,2.5343575374188987`*^-30},{0.7525`,30.`,5.`,0.7`,-118.00310275500061`,5.247639965045567`*^-43},{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55}}
Here is MatrixForm[logpdfβi[[1]]];
(({{0.01`, 30.`, 5.`, 0.7`, -118.00310275500061`, 0.0000591119911561849`}, {0.2575`, 30.`, 5.`, 0.7`, -118.00310275500061`, 1.2239727134969812`*^-17}, {0.505`, 30.`, 5.`, 0.7`, -118.00310275500061`, 2.5343575374188987`*^-30}, {0.7525`, 30.`, 5.`, 0.7`, -118.00310275500061`, 5.247639965045567`*^-43}, {1.`, 30.`, 5.`, 0.7`, -118.00310275500061`, 1.0865761754668881`*^-55}}))
The first row contains the result for β = 0.01 and the last row is for β = nβ = 1.0.
We want to extract the β = 1.0 values. Do this with tr = Transpose[logpdfβi][[nβ]];
Now look at the first 5 rows with the command Take[tr,5].
{{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55},
{1.`,30.`,5.`,0.7`,-118.00310275500061`,1.0865761754668881`*^-55},{1.`,31.395819229020145`,4.463705555454431`,0.6292479467731473`,-112.7790133460596`,2.260100997434301`*^-53},{1.`,31.395819229020145`,4.463705555454431`,0.6292479467731473`,-112.7790133460596`,2.260100997434301`*^-53},{1.`,31.064587671869017`,2.339148265037844`,0.6509533931515838`,-107.75817884100877`,6.535613421513293`*^-51}}
The first item in each row is the value of β, 
The next two items are the current values of the two parameters f,T,σl.
The next item is the Log of the likelihood, that is used in computing the global likelihood of the model for the Bayes factor calculation.
The final item is the value of   prior*(((like))^β) for the particular set of parameter values.
To obtain columns of each quantity use trn = Transpose[tr];
Finally we obtain the complete list of  f & T parameter iterations with  fgood=trn[[2]]; Tgood=trn[[3]]; 
Now putting this all together we write

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];fgood=trn[[2]];Tgood=trn[[3]];σlgood=trn[[4]];ng=Length[trn[[1]]]

Examine parameter iterations for the β = 1 (k = nβ) MCMC chain

Notes on burn-in period and tests for convergence:

1) One scheme is to examine plots of the MCMC iterations for each parameter as is shown below.
2) A better test of convergence (not shown here) is to divide the post burn-in iterations into two halves
    and plot one on top of the other using different colors.
3) A still better test of convergence (not shown here) is to run m repeated simulations with different 
    starting points and compute the Gelman-rubin statistic for each parameter from the repeated runs 
    as described below.
         Let θ represent one of the model parameters.
         Let (Subscript[θ, j]^i) represent the (i^th) iteration of the (j^th) chain.
         Extract the last η post burn-in iterations for each simulation.

Mean within chain variance  W=(1/(m(η-1)))(∑_(j=1)^m)(∑_(i=1)^η)((((Subscript[θ, j]^i)-(OverBar[(Subscript[θ, j])])))^2)
               Between chain variance  B=(η/(m-1))(∑_(j=1)^m)((((OverBar[(Subscript[θ, j])])-(OverBar[θ])))^2)
               Estimated variance   (OverHat[V])(θ)=(1-(1/η))W+(1/η)B
               Gelman-Rubin statistic =(Sqrt[(((OverHat[V])(θ))/W)])
                       The Gelman-Rubin statistic should be close to 1.0  (e.g. <1.05)  for all paramaters for convergence.
          Ref:Gelman,A.and D.B.Rubin (1992)'Inference from iterative simulations    
                      using multiple sequences (with discussion)',Statistical Science 7, pp. 457-511.

Sart by choosing some display parameters.

niter=100;(* with niter = 100, plot only every 100th point *)

nburn1=5000;(* skip first nburn1 iterations for 2nd (upper right) plot *)

(*pl=Table[0,{i,np+2+nplan}];*)(* initiate table of graphs to be plotted *)

pl=Table[0,{i,np+2}];(* initiate table of graphs to be plotted *)

fn=Table[i,{i,1,ng}];(* initiate a variable representing the iteration number *)

Here is where we create the plots for the np parameters

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];
pl[[i+2]]=ListPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},AspectRatio->0.5,
PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration",{"Helvetica-Bold",12}],Style[label,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}
],{i,1,np}
];

Next create a plot of (Subscript[Log, 10]) (Prior × Likelihood) vs iteration.

conv=Log[10,Exp[1.0]];pl[[1]]=ListPlot[Take[Transpose[{fn,conv*trn[[nl]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration  chain  (β = "<>ToString[βlis[[k]]]<>")",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10]) (Prior × Like)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];

Now create a plot of (Subscript[Log, 10]) (Prior × Likelihood) dropping first nburn1 iterations.

pl[[2]]=ListPlot[Take[Take[Transpose[{fn,conv*trn[[nl]]}],-(ng-nburn1)],{1,ng-nburn1,niter}],PlotRange->All,Joined->False,Frame->True,PlotStyle->{Black,PointSize[0.008]},Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Iteration  chain  (β = "<>ToString[βlis[[k]]]<>")",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10]) (Prior × Like)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];

Next line shows the final plots.

plIter=Show[GraphicsGrid[If[EvenQ[np+2],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,np+2,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(np+2)/2]*2,2}],{{pl[[IntegerPart[(np+2)/2]*2+1]]}}]],Spacings->{Scaled[-0.15],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Set the burn-in value nburn.

The burn - in period is the greater of : (a) no. of iterations at which all the parameter distributions
 have converged, and (b) the point at which the control system is turned off.

ncsys is the iteration number at which the control system achieved its goal of automatically 
finding a good set of parameter proposal distribution σ's, and was turned off. 
Note: since only 1 out of every nthin iterations is kept the effective iteration at which the 
         control system cuts off is Ceiling[N[ncsys]/nthin].

ncsys

minimumBurnin=Ceiling[ncsys/nthin]

Examine the parameter iterations (traces) above to see it is safe to set nburn = minimumBurnin = Ceiling[ncsys/nthin],
the iteration number at which the proposal σ control system is turned off.

nburn =minimumBurnin (* Default choice of burn-in = minimumBurnin *)

Plot marginal  distribution for model parameters

Extract parameter iterations beyond burn-in for plotting. Specify the tempering level, normally k = nβ.

k=nβ;tr=Take[Transpose[logpdfβi][[k]],-(nnt-nburn)];trn=Transpose[tr];trnn=Drop[trn,{1}];ng=Length[trnn[[1]]]

trnn[[1,1]]

Plot histograms of all the parameter iterations.

plh=Table[1,{i,np}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==50,pdotk=Max[Abs[trnn[[i]]]];trnnx=trnn[[i]]*(10^(-RealDigits[pdotk][[2]]));label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]<>"  (×"<>ToString[(10^(1.0*RealDigits[pdotk][[2]]))]<>")"];
plh[[i]]=Histogram[trnn[[i]],PlotRange->{{0.995*Min[trnnx[[i]]],1.0005*Max[trnnx[[i]]]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],
plh[[i]]=Histogram[trnn[[i]],PlotRange->{{0.995*Min[trnn[[i]]],1.0005*Max[trnn[[i]]]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]],{i,1,np}
];
plhis=Show[GraphicsGrid[If[EvenQ[np],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,np,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(np)/2]*2,2}],{{plh[[IntegerPart[(np)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Plot 2 dimensional parameter distribution.

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];ng=Length[trn[[1]]]

Suppose the two parameters of interest are f,T the first and second. Set ip = 1 and jp = 2

ip=1;jp=2;

ninterval=30;fT=Take[Transpose[{trn[[ip+1]],trn[[jp+1]]}],-(ng-nburn)];fTpl=Take[fT,{1,ng-nburn,ninterval}];tfT=Transpose[fTpl];fmin=Min[tfT[[1]]];fmax=Max[tfT[[1]]];plscata=ListPlot[fTpl,Frame->True,Axes->False,PlotRange->{{fmin,fmax},Automatic},PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[flabel,{"Helvetica-Bold",12}],
		Style[tlabel,{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

plscat=Show[plscata,Graphics[{Text["",{3,3.7}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5];

Plot binned marginal  distribution for model parameters.
It also computes quantities needed for 68% credible regions used in next section.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];trn=Transpose[tr];Length[trn[[1]]]

Details behind generating the marginal distributions.

Specify the number of points nai to bin the continuous parameters and set up some tables we will need for some parameter distribution statistics.

nai=50;plp=Table[1,{i,np}];meanai=Table[0,{j,1,np}];medianai=Table[0,{j,1,np}];modeai=Table[0,{j,1,np}];minai=Table[0,{j,1,np}];maxai=Table[0,{j,1,np}];areai=Table[0,{j,1,np}];

Next block computes the marginal PDF for the continuous parameters.

Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=trn[[i+1]];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[10000000*Min[aimarg]]/10000000;hi=Round[10000000*Max[aimarg]]/10000000;dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Plus@@aibin;yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2,#1}]&];modeai[[i]]=pbin[[1,2]];minai[[i]]=1000000000;maxai[[i]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[i]],minai[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[i]],maxai[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],PlotJoined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],{i,1,np}];N[areai]

minai

maxai

If[ncsys<n>0,plmarg1all=Show[GraphicsGrid[If[EvenQ[np],Table[{plp[[ii]],plp[[ii+1]]},{ii,1,np,2}],Join[Table[{plp[[ii]],plp[[ii+1]]},{ii,1,IntegerPart[(np)/2]*2,2}],{{plp[[IntegerPart[(np)/2]*2+1]]}}]],Spacings->{Scaled[-0.1],Scaled[0.05]}]]]

Find most probable set of parameters & 68.3% marginal credible regions.

tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(ng-nburn)];tr5s=RotateLeft[Sort[RotateRight[tr5,{0,1}],OrderedQ[{#2,#1}]&],{0,1}];

tr5s[[1]]

The output list from the above command contains the most probable set of parameters (f,T,σl).
The next command extracts these peak parameter values.

peakai=Table[0,{i,1,ncs}];Do[probMax=tr5s[[1,nl]];peakai[[i]]=tr5s[[1,i+1]],{i,1,ncs}];If[swb>0,peakb=tr5s[[1,np+1]],];peakai

probMax

Summary table of parameter values and 68% credible regions.

l1={{"Item","Peak","Mean","Median","Mode"},{"","","","",""}};

l2=Table[{ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"],peakai[[i]],meanai[[i]],medianai[[i]],modeai[[i]]},{i,np}];

l4={{"","","","",""},{"Item","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max","68%","68%"}};

l5=Table[{ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"],minai[[i]],maxai[[i]],peakai[[i]]-minai[[i]],maxai[[i]]-peakai[[i]]},{i,np}];

smj=MatrixForm[Join[l1,l2,l4,l5]]

Plot data with overlaid mean MCMC fit, mean fit ± standard deviation and fit residuals.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];nsel=Length[tr]

Create spectrum model for a list of frequencies flist (at higher resolution than measurements).

model1[temperature_,f0_,σline_]:=temperature*Exp[-((((flist-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

interval=100;flist=Table[f,{f,fvecmin,fvecmax,(fvecmax-fvecmin)/200}];spec={};
Do[str=Take[tr[[i]],{2,np+1}];
spec=Append[spec,model1[str[[2]],str[[1]],str[[3]]]],{i,1,nsel,interval}
]

Compute the mean of these spectra.

meanspec=Mean[spec];

Compute the standard deviation of these spectra.

stdspec=StandardDeviation[spec];

Plot the mean of these spectra with the data.

modlist=Transpose[{flist,meanspec}];plfitmean=ListPlot[modlist,PlotJoined->True,PlotRange->All,PlotStyle->{Black,Thickness[0.004]}];
plfitdatamean=Show[plshp1,plfitmean]

Plot another of these with a different aspect ratio and index letter for later display with other plots.

plmapfitmeanb=Show[plfitdatamean,Graphics[{Text["(c)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

modlist1=Transpose[{flist,(meanspec+stdspec)}];modlist2=Transpose[{flist,(meanspec-stdspec)}];plfitmeanr=ListPlot[{modlist1,modlist2},PlotJoined->True,PlotRange->All,PlotStyle->{{Thickness[0.006],Red},{Thickness[0.006],Green}}];
plfitdatameanr=Show[plshp1,plfitmeanr]

plmapfitmeanrb=Show[plfitdatameanr,Graphics[{Text["(d)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Create spectrum model for the measured list of frequencies fvec.

model[temperature_,f0_,σline_]:=temperature*Exp[-((((fvec-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

interval=100;mspec={};
Do[str=Take[tr[[i]],{2,np+1}];
mspec=Append[mspec,model[str[[2]],str[[1]],str[[3]]]],{i,1,nsel,interval}
]

Compute the mean of these spectra.

meanmspec=Mean[mspec];

Compute the standard deviation of these spectra.

stdmspec=StandardDeviation[mspec];

Compute the reduced (χ^2) of the mean fit.

y=(meanmspec-dvec)/errvec;

reducedchi2=y.y/(nd-4)

Compute the RMS residual of the fit.

yy=(meanmspec-dvec);

(Sqrt[((yy.yy)/nd)])

rmsresid=(Sqrt[((yy.yy)/nd)])

Construct the residual for plotting.

resid=Transpose[{fvec,dvec-Mean[mspec]}];

respk=StandardDeviation[resid]

resid

residerr=Table[{resid[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp2mean=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",12}],Style["Residuals  (mK)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{"Helvetica-Bold",12}]

plshp2meanb=Show[plshp2mean,Graphics[{Text["(b)",{10,-2}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

plboth=Show[GraphicsGrid[{{plshp1r,plmapfitmeanb},{plshp2meanb,plmapfitmeanrb}},Spacings->{Scaled[-0.15],Scaled[-0.02]}]]

Compare data points to best fit model (MAP solution).

Create spectrum model for a list of frequencies flist (at higher resolution than measurements).

model1[temperature_,f0_,σline_]:=temperature*Exp[-((((flist-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T & σline *)

Compute a set of model spectra one for each post burn-in MCMC sample parameter values (thinned by an amount = interval).

flist=Table[f,{f,fvecmin,fvecmax,(fvecmax-fvecmin)/200}];modspec=model1[peakai[[2]],peakai[[1]],peakai[[3]]];modfit=Transpose[{flist,modspec}];plfit=ListPlot[modfit,PlotJoined->True,Frame->True,PlotRange->All,PlotStyle->{Black,Thickness[0.004]},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",14}],Style["Temperatue  (mK}",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.004]];
plfitdat=Show[plfit,plshp1,DisplayFunction->$DisplayFunction]

plfitdatpk=Show[plfitdat,Graphics[{Text["(a)",{10,-2.1}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Compute and display residuals

resid=Transpose[{fvec,(dvec-model[peakai[[2]],peakai[[1]],peakai[[3]]])}];

residerr=Table[{resid[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",14}],Style["Residuals  (mK)",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.004]]

plshp2b=Show[plshp2,Graphics[{Text["(b)",{10,-2.4}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plboth=Show[GraphicsGrid[{{plfitdatpk},{plshp2b}},Spacings->{Scaled[-0.2],Scaled[0]}]]

(*Export["c:/temp/Ch12Problem2SolutionM6AmeanFit.eps", plboth,ImageSize->72*7]*)

Compute the Bayes factor from parallel tempering results

Compares model M2 to model M1 (rejecting the first nburn samples). 
((NOTE: THIS SECTION WON'T EVALUATE IF nβ <10.))
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 15) of β levels are used spanning the range β = 0 to 1. 
Otherwise use the Quasi Monte Carlo Bayes factor calculation in the next section.

Compute p(D|M1,I), the global likelihood for spectral line model

Here we compute  the log of the global likelihood of the model, which is designated by  logpM1
                logpM1=log[p(D|(Subscript[M, 1]),I)]=∫ (Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T ,σl,I)] ⟩, β])  dβ
(Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T ,σl,I)] ⟩, β]) =expectation value oflog[p(D|(Subscript[M, 1]),f,T ,σl,I)]  for given β
                                              =(1/n)(∑_(t=1)^n)  log[p(D|(Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I)] where n=number of MCMC iterations
                                              =abbreviate by   expect[[nb]]

Recall all the results are stored by the variable logpdfβi.
    Look at a typical row 8000of the output given by logpdfβi[[8000]].

The quantity  log[p(D| (Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),I)] is the penultimate item  in each row. The different rows correspond to different values of the tempering parameter β, which is the first item in each row.

First check that you are happy with the burn -in value, nburn.

nburn

If[nβ>10,nused=ng-nburn;tr=Transpose[Take[logpdfβi,-nused]];expect=Table[0.0,{i,1,nβ}];Do[trnb=Transpose[tr[[nb]]];tb1Num=trnb[[n2l]];logpdfβ=Total[tb1Num]/nused;expect[[nb]]=logpdfβ,{nb,1,nβ}],];

If[nβ>10,expect,]

If[nβ>10,βlis,]

nβ=11;

If[nβ>10,pl1=ListPlot[Transpose[{Log[10,βlis],expect}],Frame->True,PlotStyle->PointSize[0.02],PlotRange->All,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨p(D| (Subscript[M, 1]),\!\(\*SubscriptBox[\(f\), \(\(β\)\(\\ \)\)]\),(Subscript[T, β]),(Subscript[σl, β]),(Subscript[s, β]),I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

Generate an interpolating function for a LogLinearPlot

Transpose[{Log[10,βlis],expect}]

If[nβ>10,spline1 = Interpolation[Transpose[{Log[10,βlis],expect}], Method -> "Spline"]]

Specify the x range for cubic spline interpolation in the line below by {x, Min[Log[10, βlis ]], 0.0, 0.01}.

If[nβ>10,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect],]

If[nβ>10,pl4=ListPlot[newexpect,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D| (Subscript[M, 1]),\!\(\*SubscriptBox[\(f\), \(\(β\)\(\\ \)\)]\),(Subscript[T, β]),(Subscript[σl, β]),(Subscript[s, β]),I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

If[nβ>10,plBayesFactor=Show[pl1,pl4,PlotRange->All],]

Now we want to convert to a table with linear coordinates.

If[nβ>10,tnewexpext=Transpose[newexpect];newexpect1=Transpose[{(10^(tnewexpext[[1]])),tnewexpext[[2]]}],];

Next we approximate the integral by a sum of the table of interpolation values. Call it logpM1.

If[nβ>10,logpM1=Total[Table[0.5*(newexpect1[[i]][[2]]+newexpect1[[i+1]][[2]])*(newexpect1[[i+1]][[1]]-newexpect1[[i]][[1]]),{i,1,Length[newexpect1]-1}]],]

If[nβ>10,Exp[logpM1],]

Suppose we drop the first nn  β levels and redo the calculation of the log of the global likelihood for M1.

nn=1;

Log[10,Drop[βlis,nn]]

Drop[expect,nn]

If[nβ⩾(10+nn),spline2 = Interpolation[Transpose[{Log[10,Drop[βlis,nn]],Drop[expect,nn]}], Method -> "Spline"]]

Specify the x range for cubic spline interpolation in the line below by {x, Min[Log[10,Drop[βlis,nn]]], 0.0, 0.01}.

If[nβ⩾(10+nn),newexpect2=Table[{x,spline2[x]},{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2],]

If[nβ⩾(10+nn),tnewexpext=Transpose[newexpect2];newexpect3=Transpose[{(10^(tnewexpext[[1]])),tnewexpext[[2]]}],];

Next we approximate the integral by a sum of the table of interpolation values. Call it logpM1A.

If[nβ⩾(10+nn),logpM1A=Total[Table[0.5*(newexpect3[[i]][[2]]+newexpect3[[i+1]][[2]])*(newexpect3[[i+1]][[1]]-newexpect3[[i]][[1]]),{i,1,Length[newexpect3]-1}]],]

If[nβ⩾(10+nn),Exp[logpM1A],]

Compute p(D|M2,I), the global likelihood for no line model

logfact=-(nd/2.0)*Log[2.0*π] ;

yy=dvec/errvec;logpM2=logfact -Plus@@Log[errvec]- 0.5*yy.yy

Exp[logpM2]

Compute Bayes factor

If[nβ>10,odds=Exp[logpM1-logpM2],]

If[nβ⩾(10+nn),odds=Exp[logpM1A-logpM2],]

Compute the Bayes factor using quasi Monte Carlo integration

Compares model M1 to model M2 (rejecting the first nburn samples). 
Quasi Monte Carlo (QMC) Bayes factor calculation is efficient even for models with 
a large number of parameter, provided one uses the MCMC marginals to constrain 
the parameter ranges (in this case we use the 99% credible region boundaries) to 
regions where the posterior has significant probability.

Computes 99% credible region for each parameter from the binned marginal  distribution.

Extract the data beyond burn-in.

tr=Take[Transpose[logpdfβi][[nβ]],-(ng-nburn)];trn=Transpose[tr];Length[trn[[1]]]

Details behind generating the marginal distributions.

Specify the number of points nai to bin the continuous parameters and set up some tables we will need for some parameter distribution statistics.

nai=50;plp=Table[1,{i,np}];meanai=Table[0,{j,1,np}];medianai=Table[0,{j,1,np}];modeai=Table[0,{j,1,np}];minai99=Table[0,{j,1,np}];maxai99=Table[0,{j,1,np}];areai=Table[0,{j,1,np}];

Next block computes the marginal PDF for the continuous parameters.

Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=trn[[i+1]];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[10000000*Min[aimarg]]/10000000;hi=Round[10000000*Max[aimarg]]/10000000;dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Plus@@aibin;yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2,#1}]&];modeai[[i]]=pbin[[1,2]];minai99[[i]]=1000000000;maxai99[[i]]=-1000000000;area=0;j=1;
While[area≤0.99,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai99[[i]],minai99[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai99[[i]],maxai99[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],PlotJoined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],{i,1,np}];N[areai]

minai99

maxai99

Compute p(D|M1,I), the global likelihood for spectral line model

Now specify the procedure to compute the logprior and loglikelihood for use in the QuasiMonteCarlo integration. The integration is performed over a volume in parameter space defined by the 99% credible region. You need to modify this code for any additional model parameters.

logfact=-(nd/2.0)*Log[2.0*π] ;

Now, we find or specify the upper and lower parameter boundaries for the MC interation based on the 99% credible region of the MCMC marginal parameter distributions which defines the region in parameter space where the joint posterior has significant probability. If there are multiple regions then the MC integration should be performed separately.

low=Table[minai99[[i]],{i,1,np}]

hi=Table[maxai99[[i]],{i,1,np}]

The next step performs the QuasiMonteCarlo integration for the model parameters using {parf,parT,parσl,parσl} to represent {f,T,σl,s}. By default the range of the model parameters used for integration is set equal to the prior search range, e.g., avmin[[i]], avMax[[i]]. When dealing with large number of parameters these ranges should be reduced to values where the posterior has a significant probability as indicated by the MCMC marginal distribution for each parameter. You need to modify this for any additional model parameters.

work1:=Module[{},f=parf;T=parT;σl=parσl;mvec=model[T,f,σl]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T] ; (* the prior for parameters f & T *) 
y=(dvec-mvec)/errvec;
loglike=logfact-Plus@@Log[errvec]-0.5*y.y  
]

logpM1B=Log[NIntegrate[work1;Exp[logprior+loglike],{parf,low[[1]],hi[[1]]},{parT,low[[2]],hi[[2]]},{parσl,low[[3]],hi[[3]]},Method->"QuasiMonteCarlo",AccuracyGoal->12]]

Exp[logpM1B]

Compute p(D|M2,I), the global likelihood for no line model

yy=dvec/errvec;

logpM2=logfact- Plus@@Log[errvec]- 0.5*yy.yy

Exp[logpM2]

Compute Bayes factor

odds=Exp[logpM1B-logpM2]

Ch. 13: Problem

CleanUp

Clear["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

List and plot the data.

(*data=ReadList["c:/greg1/math/p509/psd.dat",Number,
		RecordLists->True];*)

data={{1.`,0.474`},{2.`,0.281`},{3.`,1.227`},{4.`,-1.523`},{5.`,-0.831`},{6.`,-0.978`},{7.`,0.169`},{8.`,0.040`},{9.`,0.760`},{10.`,0.847`},{11.`,0.106`},{12.`,-1.814`},{13.`,-1.160`},{14.`,0.249`},{15.`,-1.054`},{16.`,-0.359`},{17.`,-0.865`},{18.`,0.206`},{19.`,-0.926`},{20.`,2.294`},{21.`,0.786`},{22.`,0.522`},{23.`,-1.040`},{24.`,-0.181`},{25.`,-1.470`},{26.`,-1.837`},{27.`,0.523`},{28.`,0.605`},{29.`,-1.595`},{30.`,-0.413`},{31.`,1.275`},{32.`,-1.644`},{33.`,-0.225`},{34.`,-1.017`},{35.`,0.817`},{36.`,-2.064`},{37.`,-0.103`},{38.`,1.878`},{39.`,0.625`},{40.`,1.418`},{41.`,0.464`},{42.`,-1.182`},{43.`,-1.319`},{44.`,1.354`},{45.`,-1.784`},{46.`,-0.989`},{47.`,-1.520`},{48.`,1.239`},{49.`,0.369`},{50.`,0.695`},{51.`,1.291`},{52.`,0.978`},{53.`,-0.592`},{54.`,-0.986`},{55.`,-1.005`},{56.`,-1.268`},{57.`,-0.571`},{58.`,1.128`},{59.`,0.640`},{60.`,0.144`},{61.`,-1.468`},{62.`,-0.710`},{63.`,-1.486`},{64.`,-0.129`}};

no=Length[data]

tarr=Transpose[data];

timvec=tarr[[1]];

datavec=tarr[[2]]-Mean[tarr[[2]]];

Specify Gaussian noise sigma in the data

sigma=1.0;

err=Table[sigma,{i,1,no}];

datapoints=Table[{{i,datavec[[i]]},ErrorBar[err[[i]]]},{i,1,no}];

plotdat=ErrorListPlot[datapoints,Frame->True,PlotRange->{{0,65},{-4,4}},PlotStyle->Black,	
		PlotLabel->Style["SIMULATED TIME SERIES  [sin 2πft + noise (σ = 1)]",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Time axis",{"Helvetica-Bold",12}],
		Style["Signal Strength",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

FFT of time series (no zero padding)

fftabs=(Sqrt[(no/no)]) Abs[Fourier[datavec]];

ListPlot[fftabs,PlotJoined->True,PlotRange->All,PlotStyle->Black,
	Frame->True]

psd2=fftabs fftabs;

Max[psd2]

f[i_]:=Which[i==1,psd2[[i]],i>1&&i≤(no/2),
		psd2[[i]]+psd2[[no+2-i]],i==(no/2)+1,psd2[[(no/2)+1]]]

Compute the one sided psd = P1side

P1side=Table[f[i],{i,1,(no/2)+1}];

Compute one half of the 2-sided psd = P2side, needed in computation of p(f|D I).

P2side=Take[psd2,(no/2)+1];

Now compute the frequency intervals. The Nyquist frequency fc=1/2 , assuming
one sec interval sampling. The frequency interval= 2*fc/nt.

freq=Table[((i-1)/no),{i,1,(no/2)+1}];

PSD1=Transpose[{freq,P1side}];

Plot the one sided PSD

pl3=ListPlot[PSD1,PlotJoined->True,Frame->True,
		PlotRange->{{0.0,0.5},{0.0,18.}},PlotStyle->Black,
		PlotLabel->Style["FOURIER POWER SPECTRAL DENSITY",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["Power Density",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

FFT of time series (with zero padding)

Need zero  padding for Fourier convolution (nz = total no. of points)

nz=4096;

zpad=Table[0.00001,{i,1,nz-no}];

data1=Join[datavec,zpad];

Note Mathematica defines the Fourier transform as
(Subscript[H, n]) = (1/(Sqrt[nz]))  (Underoverscript[ ∑, (k=0), (nt-1)])(Subscript[h, k])(e^(i 2π n k/nz)),
where no = number of data points, nz = total points including zero pads.
We want the Sqrt term to be (Sqrt[no]) not (Sqrt[nz]). 
Therefore need to multiply (Subscript[H, n]) by (Sqrt[(nz/no)]).

fftabs=(Sqrt[(nz/no)]) Abs[Fourier[data1]];

ListPlot[fftabs,PlotJoined->True,PlotRange->All,PlotStyle->Black,
	Frame->True]

psd2=fftabs fftabs;

Max[psd2]

f[i_]:=Which[i==1,psd2[[i]],i>1&&i≤(nz/2),
		psd2[[i]]+psd2[[nz+2-i]],i==(nz/2)+1,psd2[[(nz/2)+1]]]

Compute the one sided psd = P1side

P1side=Table[f[i],{i,1,(nz/2)+1}];

Compute one half of the 2-sided psd = P2side, needed in computation of p(f|D I).

P2side=Take[psd2,(nz/2)+1];

Now compute the frequency intervals. The Nyquist frequency fc=1/2 , assuming
one sec interval sampling. The frequency interval= 2*fc/nz.

freq=Table[((i-1)/nz),{i,1,(nz/2)+1}];

PSD1=Transpose[{freq,P1side}];

Plot the one sided PSD

pl3=ListPlot[PSD1,PlotJoined->True,Frame->True,
		PlotRange->{{0.0,0.5},{0.0,25.}},PlotStyle->Black,
		PlotLabel->Style["FOURIER POWER SPECTRAL DENSITY",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["Power Density",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

maxP1side=Max[P1side]

NP1side=(P1side/maxP1side);

NPSD1=Transpose[{freq,NP1side}];

pl4=ListPlot[NPSD1,PlotJoined->True,Frame->True,
		PlotRange->{{0.05,0.15},{0.,1.}},
		PlotStyle->{Black,Dashed},
			PlotLabel->Style["COMPARISON",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compute Bayesian posterior PDF after marginalizing over unknown noise sigma. 
This calculation uses P2side computed from the FFT.

dbar=((datavec.datavec)/no)

pstud=(((1-((2 P2side)/(no dbar))))^((2-no)/2));

sumpstud=Total[pstud]

Let fc =  Nyquist frequency = 0.5 for one sec sampling. The frequency resolution df =fc/(nz/2).

df=0.5/(nz/2)

freq=Table[(i-1)*df,{i,1,(nz/2)+1}];

normprobstud=Transpose[{freq,(pstud/((sumpstud*df)))}];

pl8a=ListPlot[normprobstud,PlotJoined->True,Frame->True,PlotRange->All,PlotStyle->Black]

pla=ErrorListPlot[datapoints,Frame->True,PlotRange->{{0,65},{-4,4.2}},AspectRatio->0.5,PlotStyle->Black,	
		PlotLabel->Style["SIMULATED TIME SERIES  [sin 2πft + noise (σ = 1)]",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Time axis",{"Helvetica-Bold",12}],
		Style["Signal Strength",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plb=ListPlot[PSD1,PlotJoined->True,Frame->True,AspectRatio->0.5,
		PlotRange->All,PlotStyle->Black,
		PlotLabel->Style["FOURIER POWER SPECTRAL DENSITY",
				{"Helvetica-Bold",11}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["Power Density",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plc=ListPlot[normprobstud,PlotJoined->True,Frame->True,AspectRatio->0.5,
		PlotRange->All,PlotStyle->Black,
		PlotLabel->Style["BAYESIAN PROBABILITY DENSITY",
				{"Helvetica-Bold",11}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

fig=Show[GraphicsArray[{{pla},{plb},{plc}}]]

Compare shape and and width at half height of highest peak in FFT PSD 
to Bayesian posterior PDF.

maxpstud=Max[pstud]

Npstud=(pstud/maxpstud);

pltpstud=Transpose[{freq,Npstud}];

pl8=ListPlot[pltpstud,PlotJoined->True,Frame->True,PlotStyle->Black,PlotRange->{{0.05,0.15},{0.0,1.0}}]

Show[pl4,pl8]

Full width at half-height of PSD = 0.014 frequency units

Full width at half-height of Bayesian PDF = 0.0045 frequency units

Compare Log[Bayesian PDF] to FFT PSD.

lognormprobstud=Transpose[{freq,Log[(pstud/((sumpstud*df)))]}];

pld=ListPlot[lognormprobstud,PlotJoined->True,Frame->True,AspectRatio->0.5,
		PlotRange->All,Axes->False,PlotStyle->Black,
		PlotLabel->Style["Log [BAYESIAN PROBABILITY DENSITY]",
				{"Helvetica-Bold",11}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["Log[PDF]",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

GraphicsGrid[{{plfitdatpk},{plshp2b}},Spacings->{Scaled[-0.2],Scaled[0]}]

fig=Show[GraphicsGrid[{{plb},{pld}}]]

Ch. 14: Problem 4

CleanUp

Clear["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

List and plot the data.

tser={1.44`,1.64`,2.55`,2.88`,2.9`,3.27`,4.39`,5.01`,5.08`,5.11`,5.33`,5.4`,5.45`,5.58`,5.79`,6.17`,7.84`,7.86`,8.8`,8.9`,11.71`,11.73`,11.78`,14.88`,14.96`,15.61`,18.95`,19.42`,20.11`,20.28`,21.46`,21.52`,23.62`,24.21`,24.38`,24.39`,25.76`,27.92`,28.92`,29.28`,29.74`,30.04`,31.34`,32.08`,34.62`,35.04`,35.38`,36.43`,36.94`,38.97`,40.66`,41.62`,42.69`,43.02`,43.36`,45.11`,47.38`,49.65`,50.52`,51.22`};

n=Length[tser]

ListPlot[tser,Frame->True,PlotRange->All,PlotStyle->PointSize[0.015],PlotStyle->Black,
		FrameLabel->{Style["Count number",{"Helvetica-Bold",12}],
		Style["Count  time",{"Helvetica-Bold",12}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

T=Last[tser]

Evaluate the marginal p((Subscript[r, 0])|D,I)

We will do the integration required for marginalization two ways. a) using NItegration, and b) by a summation operation.

Set up prior limits for the initial rate r0 and the half-life tau. To marginalize over tau construct a two dimensional table of probability values in r0 and tau and then marginalize over tau by summation.

nr0=150;r0L=0.0;r0H=5.0;dr0=(r0H-r0L)/nr0;

ntau=200;tauL=2.0;tauH=300.0;dtau=(tauH-tauL)/ntau;

(a) Integration over tau using NItegration, need to specify PrecisionGoal and 
      AccuracyGoal to avoid error message.

We can evaluate the joint posterior  p((Subscript[r, 0]),τ|D,I)  to within an unimportant constant of 
proportionality from equations (14.26) and (14.31). 
Ignore the ((Δt)^N) term as it is part of the constant of proportionality which cancels with 
the denominator of Bayes' theorem.

probr0tau[r_,t_]:=((r^n)/t)*(2^((-(1/t)Total[tser])))*Exp[-((r*t)/(Log[2.0]))*(1-(2^(-T/t)))]

pr0lis=Table[NIntegrate[probr0tau[r0,tau],{tau,10,300},PrecisionGoal->10,AccuracyGoal->30],{r0,r0L,r0H,dr0}];

sumpr0lis=Total[pr0lis]

prbr0=Table[{(r0L+(i-1)*dr0),pr0lis[[i]]/(dr0*sumpr0lis)},{i,1,nr0}];

plar0=ListPlot[prbr0,PlotRange->All,Frame->True,Joined->True,PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["(Subscript[r, 0])  ((s^(-1)))",{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

(b) Integration over tau by summing a two dimensional table of joint posterior values in r0,tau. 
      First make the two dimensional table.

pr0tau=Table[r0=0+(i-1)*dr0;tau=tauL+(j-1)*dtau;probr0tau[r0,tau],
			{i,1,nr0},{j,1,ntau}];

pr0tau is a list of lists {{----},{----},{----},----,{----}}. The inner lists correspond to the rows of a matrix. Each row corresponds to a particular value of r0 and each item in a row is the value of  p((Subscript[r, 0]),τ|D,I) (a two dimensional probability density distribution) for a particular value of tau.

If we ask for the length of pr0tau we get the number of rows = number of r0 values.

Length[pr0tau]

To normalize the marginal PDF  p(r|D,I) we need to obtain sumprob = the sum of the pr0tau values, 
and divide by (dr0*sumprob).

pr0=Table[Total[dtau*pr0tau[[i]]],{i,1,nr0}];

probr0=Table[{(r0L+(i-1)*dr0),pr0[[i]]/(dr0*Total[pr0])},{i,1,nr0}];

plr0=ListPlot[probr0,PlotRange->All,Frame->True,PlotJoined->True,PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["(Subscript[r, 0])  ((s^(-1)))",{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compare marginal PDF for two integration results.

Show[plar0,plr0]

Evaluate the marginal p(τ|D,I)  (not required for question)

ntau=200;tauL=2.0;tauH=300.0;dtau=(tauH-tauL)/ntau;

ptau=Table[NIntegrate[probr0tau[r0,tau],{r0,0,5}],{tau,tauL,tauH,dtau}];

sumtau=Total[ptau]

prbtau=ptau/sumtau;

probtau=Table[{(tauL+(i-1)*dtau),prbtau[[i]]},{i,1,ntau}];

pltau=ListPlot[probtau,PlotRange->All,Frame->True,PlotJoined->True,Axes->False,PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Half-life (s)",{"Helvetica-Bold",14}],
		Style["PDF",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Evaluate the joint posterior p((Subscript[r, 0]),τ|D,I)  (not required for question)

We can evaluate the joint posterior  p((Subscript[r, 0]),τ|D,I)  to within an unimportant constant of 
proportionality from equations (14.26) and (14.31). 
Ignore the ((Δt)^N) term as it is part of the constant of proportionality which cancels with 
the denominator of Bayes' theorem.

probr0tau[r_,t_]:=((r^n)/t)*(2^((-(1/t)Total[tser])))*Exp[-((r*t)/(Log[2.0]))*(1-(2^(-T/t)))]

pk=probr0tau[1.9,35]

pltwo1=ContourPlot[probr0tau[r0,tau]/pk,{tau,1,120},{r0,1.0,3.0},PlotRange->{0.001,2.0},PlotPoints->100,ContourShading->None,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["τ  (s)",{"Helvetica-Bold",16}],
		Style["(Subscript[r, 0])  ((s^(-1)))",{"Helvetica-Bold",16}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}, Background->White]