Mathematica 7 support material
to accompany the book
"Bayesian Logical Data Analysis for the Physical Sciences"
by
P. C. Gregory
University of British Columbia
Last revision Dec. 10, 2011
Published by Cambridge University Press (2005, 2010)

To start, double click on outer bracket on RHS of the notebook for the topic of interest. This open up the notebook items on that topic. Double clicking on that bracket again closes that topic. If all sections of the tutorial are executed it expands to about 26 MBytes in size and takes about 90 min.

Introduction

This support material is designed to empower the reader to explore Bayesian data analysis on their own. To do this, one needs an efficient computing environment for visualizing and manipulating the data. The majority of my students have found Mathematica to provide such an environment. The first part of this document is aimed at addressing the question, "How do I come up to speed in Mathematica for doing data analysis if I have no previous experience with this software." The latter sections, beginning with chapter numbers, illustrate real Bayesian solutions to problems or issues relevant to the chapters of my book.

Disclaimer

Disclaimer of Warranty
We make no warranties, express or implied, that this Mathematica tutorial software is free of error, or is consistent with any particular standard of merchantability, or that it will meet your requirements for any particular application.This software should not be relied on for solving a problem whose incorrect solution could result in injury to a person or loss of property. If you do use the software in such a manner, it is at your own risk. The author and publisher disclaim all liability for direct or consequential damages resulting from your use of this software.

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. The command is the bold faced line below.
To execute the command click on the the line and type shift enter.

Clear["Global`*"]

Even better than Clear["Global`*"] is  Remove["Global`*"] because it will allow you to re-evaluate a notebook if you are trying to recover from a simple mistake like calling a command before you have loaded the package containing the command. The first time you run a notebook containing Remove["Global`*"], it will produce the following error message which can safely be ignored.
Remove:: rmnsm: There are no symbols matching  "Global`*

To turn off annoying spelling warnings which appear if the spelling of a new symbol is similar (but different) to an old symbol

Off[General::"spell"]

Off[General::"spell1"]

Mathematica Basics

Numbers

Integer arithmetic

(2+2*3)/2

(2+2  3)/2

%^588

((%)^(1/588))

Sqrt[%]

x=(((a+b))^c)

a=2;b=4;c=2;

x

Real numbers and Arbitrary-precision

Integer arithmetic is done with infinite precision. We can convert to an approximate real number to as many decimal places as desired.

N[(3^(2011 ))]

N[(3^2011) ,50]

Now do the same calculation but change the rational number 3 to a real number 3.0.

N[(3.0^2011) ,50]

In this case we only get 16 digits of accuracy. For real numbers Mathematica uses the built-in floating-point arithmetic by default. For any specified machine the machine precision can be accessed by $MachinePrecision. Machine precision numbers typically correspond to double precision in FORTRAN or type double in a C program.

$MachinePrecision

Two other interesting numbers are the biggest and smallest ones.

{$MaxMachineNumber,$MinMachineNumber}

Arbitrary-Precision numbers

Note: Mathematica automatically performs accuracy checks during the calculation, and the accuracy of the calculation is stepped up to extended-precision if necessary. Over- and underflows are sensed and handled correctly. For example if the value in a calculation exceeds  $MaxMachineNumber then the calculation will switch to extended precision and an overflow will only occur if the value exceeds $MaxNumber. Check out the size of $MaxNumber.

{$MaxNumber,$MinNumber}

If needed it is possible to perform real number calculations with a particular precision using the SetPrecision[] command. Here I will create a list of real numbers with 32 digits of precision. We might want to perform some computation on these numbers in which roundoff errors become very important. For some members of the list the higher precision number are evident from the appended zeros. However, notice that the number 1.35 has non-zero digits in the last 16 digits which has to do with its binary machine number representation. This would be acceptable if after the computations we only required a MachinePrecision answer.

lis1={1.35,2.5,4.0};list=SetPrecision[lis1,32]

Alternatively we can create the number 1.35 with 32 digits of precision by typing it in as 32 digits.

num=1.3500000000000000000000000000000

Suppose we now add the list of numbers called list.

sum=Plus@@list

The answer is accurate to 32 digits.

Precision[sum]

The precision reverts to MachinePrecision if we multiply by the real number not previously declared to have a precision higher than  MachinePrecision.

Precision[3.2*sum]

Speed Issues

Arithmetic with high precision number is done in software, because the native floating point hardware cannot directly handle operations on numbers with so many significant figures. Consequently there is a performance penalty for the use of precision higher than the MachinePrecision.

To reduce the possibility of a performance penalty associated with extended precision calculations it is useful to work with the Log of the quantity of interest where this is possible. In model fitting problems where one is exploring a large range of model parameter space it is sometimes necesary to compute the Exp of a quantity that can yield a range of values well outside the MachinePrecision range. With the use of an offset we arrange for the largest values to be within the upper end of the MachinePrecision range. The values that fall below the lower end can frequently be clipped because they are too small to effect the conclusion.

In the following command the quantity being exponentiated is tested to see if it is smaller than -700. The fast relacement operation carries out the test and since it is true it replaces quantity by the value -700 before the exponential is executed. Exp[-700] is safely above the lower end of the MachinePrecision range.

quantity =-900;Exp[(quantity)/.a_/;a<-700.0->-700.0]

The replacement operation is demonstrated in more detail in the section entitled: 
Lists, data as a list,  replacing elements in a list, rotating lists, sorting.

Manipulating algebraic expressions

Clear["Global`*"]

y=((2-3 x+(x^3))/(9+3 x-5 (x^2)+(x^3)))

Factor[y]

Lists, data as a list,  replacing elements in a list, rotating lists, sorting

Remove["Global`*"]

Lists are a very important built-in data type in Mathematica. They are used for themselves and to represent vectors and matrices. As we have seen, lists are indicated by curly brackets.

{a, b, c}

A convenient way to construct a list whose elements are given by some mathematical formula is to use the Table command.

Table[Expand[(1 + x)^n], {n, 1, 8}]

The command TableForm will display this in a nicer format.

TableForm[%]

There are many operations that take lists as arguments; for instance:

Permutations[{a, b, c}]

Flatten[%]

List value replacement: Suppose we have some data represented by the list data1

data1={5.3,3,-2,8.1,2,-3.6,0,-2,4,3,6}

Now replace all occurences of the value -2 by 0 with the replacement operation /.

data1/.-2->0

Now replace all negative numbers in data1 by 0. The symbol x_  stands for any expression in the list like a number. The pattern x_ /; x < 0 represents an expression which must be negative. The following will find all negative values and replace them by 0.

data1/.x_/;x<0->0

Now replace all real numbers in data1 by the integer part

data1/.x_Real->IntegerPart[x]

Find all cases in data2 where the x value is 3 and the y value is > 3

data2={{1,2},{3,4},{3,3},{8,3},{3,7}};

Cases[data2,{x_/;x==3,y_/;y>3}]

Suppose we wanted to interchange the x and y values of each pair of data values. The list contains two levels of nesting. We can use the RotateLeft or RotateRight to rotate items at any particular level of nesting. The argument {0,1} indicates we will rotate by 0 at the first level of nesting and by 1 at the second level.

RotateRight[data2,{0,1}]

Sort the items in list data2 in ascending order according to the first item in each pair of data points.

Sort[data2]

Sort the items in list data2 in descending order according to the first item in each pair of data points.

Sort[data2,OrderedQ[{#2, #1}]&]

Sort the items in list data2 in descending order according to the SECOND item in each pair of data points. To do this we first use the RotateLeft command to rotate the 2nd item into the 1st position , then sort and then RotateRight to return the items to their original position.

RotateRight[Sort[RotateLeft[data2,{0,1}],OrderedQ[{#2, #1}]&],{0,1}]

Plotting functions and data (includes dynamic and animated graphs)

Define and plot a simple function

Clear["Global`*"]

Pi

To type π in traditional form use keystrokes: esc p esc

We can define a function of the variables t & f  in two ways. Here is one way,

r[t_,f_]:=Sin[2 π f t]+Cos[4 π f t]

To find it's value at t = 1 & f = 2,

r[1,2]

A simpler way to define the function r is shown below. Now every algebraic symbol not defined is considered a variable.

r=Sin[2 π f t]+Cos[4 π f t];

To find it's value at t = 1 we can set t = 1 and type the function name,

t =1;r

Now I will cancel the assignment for t by,

t=.

An alternatve way to evaluate the function r at a particular value of t is,

r/.t->1

This second way inserts a particular value of t into the equation only for this evaluation.

Now lets plot function r for a range of t with a particular choice of f inserted.

Plot[r/.f->4,{t,1,3}]

Add Plot features like a plot frame, label, axes labeling and dashed line

Plot[r/.f->4,{t,1,3},Frame->True,PlotStyle->{Black,Dashed},PlotLabel->Style["My Plot",Medium],FrameLabel->{"Time axis","Function Value"},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

The same plot with more options.

Plot[r/.f->4,{t,1,3},Frame->True,PlotStyle->{Blue,Dashing[{0.005,0.01}],Thick},PlotLabel->Style["My Plot",{"Helvetica-Bold",12}],FrameLabel->{Style["Time axis",{"Helvetica-Bold",12}],Style["Function Value",{"Helvetica-Bold",12}]},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

The same plot showing how to make a fancy plot label, with a variation in the PlotSyle, 
and added Filling.

Plot[r/.f->4,{t,1,3},Frame->True,PlotStyle->Dashing[Small],PlotLabel->Style[Framed[Cos[4 f π]+Sin[2 f π]],14,Blue,Background->Lighter[Yellow]],FrameLabel->{"Time axis","Function Value"},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"},Filling->Bottom]

Specify the values of the tick marks on the x-axis in previous plot

You can specify the tick marks to be used on one or more of the four sides of a plot frame with the option FrameTicks. In this example we will specify the tick marks for the lower frame border and allow the other border tick marks to be selected automatically. We accomplish this with
 FrameTicks->{{1,2,3},Automatic,Automatic,Automatic}.

Plot[r/.f->4,{t,1,3},Frame->True,FrameTicks->{{1,2,3},Automatic,Automatic,Automatic},PlotStyle->Dashing[Small],PlotLabel->Style[Framed[Cos[4 f π]+Sin[2 f π]],14,Blue,Background->Lighter[Yellow]],FrameLabel->{"Time axis","Function Value"},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Now plot two versions of the function on same graph & add legend

Now for a more complicated plot of the same function for two choices of frequency f and the addition of a plot legend. First we need to load "PlotLegends`".

<<"PlotLegends`"

Plot[{r/.f->3,r/.f->3.05},{t,1,3},Frame->True,PlotStyle->{{Red,Dashed},{Blue,Dashed}},PlotLegend->{"f = 3.0","f = 3.1"},LegendPosition->{0.8,0},LegendSpacing->0,LegendTextSpace->2.5,LegendBorderSpace->0.5,LegendSize->{0.4,0.25},LegendShadow->{0.02,-0.02},PlotLabel->Style[Framed[Cos[4 f π]+Sin[2 f π]],12,Blue,Background->Lighter[Yellow]],FrameLabel->{"Time axis","Function Value"},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Same again but specify color by Hue[ ] option and make one curve Thick.

Plot[{r/.f->3,r/.f->3.05},{t,1,3},Frame->True,PlotStyle->{{Hue[0.0],Dashed},{Hue[0.3],Dashed,Thick}},PlotLegend->{"f = 3.0","f = 3.1"},LegendPosition->{0.8,0},LegendSpacing->0,LegendTextSpace->2.5,LegendBorderSpace->0.5,LegendSize->{0.4,0.25},LegendShadow->{0.02,-0.02},PlotLabel->Style[Framed[Cos[4 f π]+Sin[2 f π]],12,Blue,Background->Lighter[Yellow]],FrameLabel->{"Time axis","Function Value"},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Define a function which has a different meaning in different ranges of x

Clear["Global`*"]

Here is a function definition which depends on what range the variable x is in.

fn:=0/;x<2
fn:=Exp[-((((x-3))^2)/3)]/;x≥2&&x≤4;
fn:=0/;x>4

Now lets plot function fn for the range x  = 0 to 7.

Plot[fn,{x,0,7}]

Create a data set & plot with ListPlot and specify PointSize and Frame labels

Now specify a data sets dat1. Double click the outer brace to see the two lists.

dat1={{0.45`,0.077`},{0.47`,0.098`},{0.49`,0.121`},{0.5`,0.146`},{0.52`,0.173`},{0.54`,0.201`},{0.56`,0.23`},{0.58`,0.26`},{0.6`,0.291`},{0.62`,0.322`},{0.63`,0.353`},{0.65`,0.385`},{0.67`,0.416`},{0.69`,0.446`},{0.71`,0.476`},{0.73`,0.506`},{0.74`,0.534`},{0.76`,0.561`},{0.78`,0.587`},{0.8`,0.612`},{0.82`,0.635`},{0.84`,0.657`},{0.86`,0.678`},{0.87`,0.697`},{0.89`,0.714`},{0.91`,0.73`},{0.93`,0.744`},{0.95`,0.756`},{0.97`,0.767`},{0.99`,0.777`},{1.`,0.784`},{1.02`,0.791`},{1.04`,0.796`},{1.06`,0.799`},{1.08`,0.801`},{1.1`,0.802`},{1.12`,0.801`},{1.13`,0.799`},{1.15`,0.796`},{1.17`,0.792`},{1.19`,0.787`},{1.21`,0.781`},{1.23`,0.774`},{1.25`,0.766`},{1.26`,0.758`},{1.28`,0.748`},{1.3`,0.739`},{1.32`,0.728`},{1.34`,0.717`},{1.36`,0.706`},{1.38`,0.694`},{1.39`,0.681`}};

Here is where we ListPlot the data and specify the PointSize.

ListPlot[dat1,PlotRange->{{0.4,1.45},{0,0.9}},Frame->True,PlotStyle->{Black,PointSize[0.015]},PlotLabel->Style["My Plot",{"Helvetica-Bold",12}],FrameLabel->{Style["Time axis",{"Helvetica-Bold",12}],Style["Function value",{"Helvetica-Bold",12}]},LabelStyle->Directive[Blue],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Here is another way of specifying the Frame labels for our graph.

xlabel=
StyleForm[StringForm["``",
StyleForm["Time axis",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->16]

ylabel=
StyleForm[StringForm["``",
StyleForm["Function Value",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->16]

Here is where we ListPlot the data and specify the PointSize.

ListPlot[dat1,PlotRange->{{0.4,1.45},{0,0.9}},Frame->True,PlotStyle->{Black,PointSize[0.015]},PlotLabel->Style["My Plot",{"Helvetica-Bold",12}],FrameLabel->{Style[xlabel,{"Helvetica-Bold",12}],Style[ylabel,{"Helvetica-Bold",12}]},LabelStyle->Directive[Blue],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Create a data set, plot with ListPlot and add text, lines and arrows,
and employ mixed fonts (normal and italic) in the axis labelling

Now specify a data sets dat1. Double click the outer brace to see the two lists.

dat1={{0.45`,0.077`},{0.47`,0.098`},{0.49`,0.121`},{0.5`,0.146`},{0.52`,0.173`},{0.54`,0.201`},{0.56`,0.23`},{0.58`,0.26`},{0.6`,0.291`},{0.62`,0.322`},{0.63`,0.353`},{0.65`,0.385`},{0.67`,0.416`},{0.69`,0.446`},{0.71`,0.476`},{0.73`,0.506`},{0.74`,0.534`},{0.76`,0.561`},{0.78`,0.587`},{0.8`,0.612`},{0.82`,0.635`},{0.84`,0.657`},{0.86`,0.678`},{0.87`,0.697`},{0.89`,0.714`},{0.91`,0.73`},{0.93`,0.744`},{0.95`,0.756`},{0.97`,0.767`},{0.99`,0.777`},{1.`,0.784`},{1.02`,0.791`},{1.04`,0.796`},{1.06`,0.799`},{1.08`,0.801`},{1.1`,0.802`},{1.12`,0.801`},{1.13`,0.799`},{1.15`,0.796`},{1.17`,0.792`},{1.19`,0.787`},{1.21`,0.781`},{1.23`,0.774`},{1.25`,0.766`},{1.26`,0.758`},{1.28`,0.748`},{1.3`,0.739`},{1.32`,0.728`},{1.34`,0.717`},{1.36`,0.706`},{1.38`,0.694`},{1.39`,0.681`}};

Here is where we ListPlot the data and specify the PointSize.

pl1=ListPlot[dat1,PlotRange->{{0.4,1.45},{0,.9}},Frame->True,PlotStyle->{PointSize[0.015],Blue},FrameLabel->{Style["Angle θ",{"Helvetica-Bold",12}],Style["Log |H(θ)+C((|)^2)",{"Helvetica-Bold",12}]},BaseStyle->{12,FontFamily->"Helvetica-Bold"},FrameStyle->Thickness[0.006]]

Now add a line, an arrow and some text to the figure. We need to load a package.

plgraphics=Graphics[{Line[{{0.45,0.14},{0.85,0.8}}],Text[Style["Raw data",FontSize->11,FontWeight->"Bold"],{1,0.3},{-1,0},{1,0}],Arrow[{{1.1,0.36},{0.8,0.6}}],Text[Style["Predicted  slope",FontSize->11,FontWeight->"Bold"],{0.8,0.2},{-1,0},{1,0}],Arrow[{{0.8,0.26},{0.62,0.4}}]},DisplayFunction->Identity];

Here we combine the figure with the graphics item above.

plboth=Show[pl1,plgraphics,DisplayFunction->$DisplayFunction]

Using mixed fonts (normal and italic) in a plot

Now suppose we want to mix font styles (normal and italic text, for example) in the labelling of the y-axis. We want the variables H and C to be in italic font. This requires a bit more work. We seperate the label generation from the plot command for clarity:

ylabel=
Style[StringForm["Log  |``(θ)+``((|)^2))",
StyleForm["H",FontSlant->Italic],
StyleForm["C",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->12]

Each italicized character is separately created with StyleForm, and then inserted into a string containing non-italic characters at the location of the `` mark. StyleForm is again applied to the entire structure to globally affect the font face and size. StringForm is used to insert the italic characters.

Now insert the ylabel in FrameLabel specification of the earlier ListPlot.

pl1=ListPlot[dat1,PlotRange->{{0.4,1.45},{0,.9}},Frame->True,PlotStyle->PointSize[0.015],FrameLabel->{Style["Angle θ",{"Helvetica-Bold",12}],Style[ylabel,{"Helvetica-Bold",12}]},BaseStyle->{12,FontFamily->"Helvetica-Bold"},FrameStyle->Thickness[0.006]]

Create two {x,y} data sets & plot with ListPlot, specify the point symbols and sizes with/without connecting lines.

Now specify the two data sets dat1 and dat2. Double click the outer brace to see the two lists.

dat1={{0.45`,0.077`},{0.47`,0.098`},{0.49`,0.121`},{0.5`,0.146`},{0.52`,0.173`},{0.54`,0.201`},{0.56`,0.23`},{0.58`,0.26`},{0.6`,0.291`},{0.62`,0.322`},{0.63`,0.353`},{0.65`,0.385`},{0.67`,0.416`},{0.69`,0.446`},{0.71`,0.476`},{0.73`,0.506`},{0.74`,0.534`},{0.76`,0.561`},{0.78`,0.587`},{0.8`,0.612`},{0.82`,0.635`},{0.84`,0.657`},{0.86`,0.678`},{0.87`,0.697`},{0.89`,0.714`},{0.91`,0.73`},{0.93`,0.744`},{0.95`,0.756`},{0.97`,0.767`},{0.99`,0.777`},{1.`,0.784`},{1.02`,0.791`},{1.04`,0.796`},{1.06`,0.799`},{1.08`,0.801`},{1.1`,0.802`},{1.12`,0.801`},{1.13`,0.799`},{1.15`,0.796`},{1.17`,0.792`},{1.19`,0.787`},{1.21`,0.781`},{1.23`,0.774`},{1.25`,0.766`},{1.26`,0.758`},{1.28`,0.748`},{1.3`,0.739`},{1.32`,0.728`},{1.34`,0.717`},{1.36`,0.706`},{1.38`,0.694`},{1.39`,0.681`},{1.41`,0.669`},{1.43`,0.656`},{1.45`,0.643`},{1.47`,0.63`},{1.49`,0.616`},{1.51`,0.603`},{1.52`,0.589`},{1.54`,0.575`},{1.56`,0.562`},{1.58`,0.548`},{1.6`,0.534`},{1.62`,0.521`},{1.64`,0.507`},{1.65`,0.494`},{1.67`,0.481`},{1.69`,0.468`},{1.71`,0.455`},{1.73`,0.442`},{1.75`,0.429`},{1.77`,0.417`},{1.78`,0.405`},{1.8`,0.393`},{1.82`,0.381`},{1.84`,0.37`},{1.86`,0.359`},{1.88`,0.348`},{1.9`,0.337`},{1.91`,0.326`},{1.93`,0.316`},{1.95`,0.306`},{1.97`,0.296`},{1.99`,0.287`},{2.01`,0.277`},{2.03`,0.268`},{2.04`,0.259`},{2.06`,0.251`},{2.08`,0.243`},{2.1`,0.235`},{2.12`,0.227`},{2.14`,0.219`},{2.15`,0.212`},{2.17`,0.204`},{2.19`,0.197`},{2.21`,0.191`},{2.23`,0.184`},{2.25`,0.178`},{2.27`,0.172`},{2.28`,0.166`},{2.3`,0.16`},{2.32`,0.154`},{2.34`,0.149`},{2.36`,0.144`},{2.38`,0.139`},{2.4`,0.134`},{2.41`,0.129`},{2.43`,0.125`},{2.45`,0.12`},{2.47`,0.116`},{2.49`,0.112`},{2.51`,0.108`},{2.53`,0.104`},{2.54`,0.1`},{2.56`,0.097`},{2.58`,0.093`},{2.6`,0.09`},{2.62`,0.087`},{2.64`,0.084`},{2.66`,0.081`},{2.67`,0.078`},{2.69`,0.075`},{2.71`,0.072`},{2.73`,0.07`},{2.75`,0.067`},{2.77`,0.065`},{2.79`,0.063`},{2.8`,0.06`},{2.82`,0.058`},{2.84`,0.056`},{2.86`,0.054`},{2.88`,0.052`},{2.9`,0.05`},{2.92`,0.049`},{2.93`,0.047`},{2.95`,0.045`},{2.97`,0.044`},{2.99`,0.042`},{3.01`,0.041`},{3.03`,0.039`},{3.05`,0.038`},{3.06`,0.036`},{3.08`,0.035`},{3.1`,0.034`},{3.12`,0.033`},{3.14`,0.032`},{3.16`,0.03`},{3.18`,0.029`},{3.19`,0.028`},{3.21`,0.027`},{3.23`,0.026`},{3.25`,0.025`},{3.27`,0.025`},{3.29`,0.024`},{3.31`,0.023`},{3.32`,0.022`},{3.34`,0.021`},{3.36`,0.021`},{3.38`,0.02`},{3.4`,0.019`},{3.42`,0.018`},{3.43`,0.018`},{3.45`,0.017`},{3.47`,0.017`},{3.49`,0.016`},{3.51`,0.015`},{3.53`,0.015`},{3.55`,0.014`},{3.56`,0.014`},{3.58`,0.013`},{3.6`,0.013`},{3.62`,0.013`},{3.64`,0.012`},{3.66`,0.012`},{3.68`,0.011`},{3.69`,0.011`},{3.71`,0.011`},{3.73`,0.01`},{3.75`,0.01`},{3.77`,0.009`},{3.79`,0.009`},{3.81`,0.009`},{3.82`,0.009`},{3.84`,0.008`},{3.86`,0.008`},{3.88`,0.008`},{3.9`,0.007`},{3.92`,0.007`},{3.94`,0.007`},{3.95`,0.007`},{3.97`,0.006`},{3.99`,0.006`}};

dat2={{0.45`,0.064`},{0.47`,0.082`},{0.49`,0.102`},{0.5`,0.125`},{0.52`,0.149`},{0.54`,0.175`},{0.56`,0.203`},{0.58`,0.233`},{0.6`,0.263`},{0.62`,0.295`},{0.63`,0.327`},{0.65`,0.36`},{0.67`,0.394`},{0.69`,0.428`},{0.71`,0.461`},{0.73`,0.495`},{0.74`,0.528`},{0.76`,0.56`},{0.78`,0.591`},{0.8`,0.621`},{0.82`,0.65`},{0.84`,0.678`},{0.86`,0.704`},{0.87`,0.728`},{0.89`,0.75`},{0.91`,0.771`},{0.93`,0.79`},{0.95`,0.806`},{0.97`,0.821`},{0.99`,0.834`},{1.`,0.845`},{1.02`,0.853`},{1.04`,0.86`},{1.06`,0.865`},{1.08`,0.868`},{1.1`,0.869`},{1.12`,0.869`},{1.13`,0.867`},{1.15`,0.863`},{1.17`,0.858`},{1.19`,0.852`},{1.21`,0.844`},{1.23`,0.835`},{1.25`,0.826`},{1.26`,0.815`},{1.28`,0.803`},{1.3`,0.79`},{1.32`,0.777`},{1.34`,0.763`},{1.36`,0.748`},{1.38`,0.733`},{1.39`,0.718`},{1.41`,0.702`},{1.43`,0.686`},{1.45`,0.67`},{1.47`,0.653`},{1.49`,0.637`},{1.51`,0.62`},{1.52`,0.604`},{1.54`,0.587`},{1.56`,0.571`},{1.58`,0.554`},{1.6`,0.538`},{1.62`,0.522`},{1.64`,0.506`},{1.65`,0.491`},{1.67`,0.476`},{1.69`,0.461`},{1.71`,0.446`},{1.73`,0.431`},{1.75`,0.417`},{1.77`,0.403`},{1.78`,0.39`},{1.8`,0.377`},{1.82`,0.364`},{1.84`,0.351`},{1.86`,0.339`},{1.88`,0.327`},{1.9`,0.316`},{1.91`,0.305`},{1.93`,0.294`},{1.95`,0.283`},{1.97`,0.273`},{1.99`,0.263`},{2.01`,0.254`},{2.03`,0.244`},{2.04`,0.235`},{2.06`,0.227`},{2.08`,0.218`},{2.1`,0.21`},{2.12`,0.203`},{2.14`,0.195`},{2.15`,0.188`},{2.17`,0.181`},{2.19`,0.174`},{2.21`,0.167`},{2.23`,0.161`},{2.25`,0.155`},{2.27`,0.149`},{2.28`,0.144`},{2.3`,0.138`},{2.32`,0.133`},{2.34`,0.128`},{2.36`,0.123`},{2.38`,0.118`},{2.4`,0.114`},{2.41`,0.109`},{2.43`,0.105`},{2.45`,0.101`},{2.47`,0.097`},{2.49`,0.094`},{2.51`,0.09`},{2.53`,0.087`},{2.54`,0.084`},{2.56`,0.08`},{2.58`,0.077`},{2.6`,0.074`},{2.62`,0.072`},{2.64`,0.069`},{2.66`,0.066`},{2.67`,0.064`},{2.69`,0.061`},{2.71`,0.059`},{2.73`,0.057`},{2.75`,0.055`},{2.77`,0.053`},{2.79`,0.051`},{2.8`,0.049`},{2.82`,0.047`},{2.84`,0.045`},{2.86`,0.043`},{2.88`,0.042`},{2.9`,0.04`},{2.92`,0.039`},{2.93`,0.037`},{2.95`,0.036`},{2.97`,0.035`},{2.99`,0.033`},{3.01`,0.032`},{3.03`,0.031`},{3.05`,0.03`},{3.06`,0.029`},{3.08`,0.028`},{3.1`,0.027`},{3.12`,0.026`},{3.14`,0.025`},{3.16`,0.024`},{3.18`,0.023`},{3.19`,0.022`},{3.21`,0.021`},{3.23`,0.021`},{3.25`,0.02`},{3.27`,0.019`},{3.29`,0.018`},{3.31`,0.018`},{3.32`,0.017`},{3.34`,0.016`},{3.36`,0.016`},{3.38`,0.015`},{3.4`,0.015`},{3.42`,0.014`},{3.43`,0.014`},{3.45`,0.013`},{3.47`,0.013`},{3.49`,0.012`},{3.51`,0.012`},{3.53`,0.011`},{3.55`,0.011`},{3.56`,0.011`},{3.58`,0.01`},{3.6`,0.01`},{3.62`,0.01`},{3.64`,0.009`},{3.66`,0.009`},{3.68`,0.009`},{3.69`,0.008`},{3.71`,0.008`},{3.73`,0.008`},{3.75`,0.007`},{3.77`,0.007`},{3.79`,0.007`},{3.81`,0.007`},{3.82`,0.006`},{3.84`,0.006`},{3.86`,0.006`},{3.88`,0.006`},{3.9`,0.006`},{3.92`,0.005`},{3.94`,0.005`},{3.95`,0.005`},{3.97`,0.005`},{3.99`,0.005`}};

Here is where we ListPlot the data. We will only plot every 3rd data point by employing the Take command.

data1=Take[dat1,{1,Length[dat1],3}];data2=Take[dat2,{1,Length[dat2],3}];

pl2=ListPlot[{data1,data2},PlotRange->{{0.0,4.0},{0,0.9}},Joined->False,Frame->True,PlotMarkers->{Automatic,10},PlotStyle->{Red,Blue} ,FrameLabel->{Style["Standard Deviation Ratio",{"Helvetica-Bold",12}],Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006`],BaseStyle->{"Helvetica-Bold",12}]

PlotMarkers->{Automatic,10} automatically selects different symbols for each data set and the second argument sets the size to 10. You can select custom symbols from the Special Charcters Palettes as we have done below with PlotMarkers -> {{■, 10}, {□, 10}}.

If you want all the points to appear black for low cost Journal publication then add the option PlotStyle->{Black} .

To join the points with connecting lines, change PlotJoined->False to PlotJoined->True.

pl2=ListPlot[{data1,data2},PlotRange->{{0.0,4.0},{0,0.9}},Joined->True,Frame->True,PlotMarkers->{{■,10},{□,10}},PlotStyle->{Black} ,FrameLabel->{Style["Standard Deviation Ratio",{"Helvetica-Bold",12}],Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006`],BaseStyle->{"Helvetica-Bold",12}]

Create two {x,y} data sets & plot the two data sets one below the other (or) side-by-side.

Now specify the two data sets dat1 and dat2. Double click the outer brace to see the two lists.

dat1={{0.45`,0.077`},{0.47`,0.098`},{0.49`,0.121`},{0.5`,0.146`},{0.52`,0.173`},{0.54`,0.201`},{0.56`,0.23`},{0.58`,0.26`},{0.6`,0.291`},{0.62`,0.322`},{0.63`,0.353`},{0.65`,0.385`},{0.67`,0.416`},{0.69`,0.446`},{0.71`,0.476`},{0.73`,0.506`},{0.74`,0.534`},{0.76`,0.561`},{0.78`,0.587`},{0.8`,0.612`},{0.82`,0.635`},{0.84`,0.657`},{0.86`,0.678`},{0.87`,0.697`},{0.89`,0.714`},{0.91`,0.73`},{0.93`,0.744`},{0.95`,0.756`},{0.97`,0.767`},{0.99`,0.777`},{1.`,0.784`},{1.02`,0.791`},{1.04`,0.796`},{1.06`,0.799`},{1.08`,0.801`},{1.1`,0.802`},{1.12`,0.801`},{1.13`,0.799`},{1.15`,0.796`},{1.17`,0.792`},{1.19`,0.787`},{1.21`,0.781`},{1.23`,0.774`},{1.25`,0.766`},{1.26`,0.758`},{1.28`,0.748`},{1.3`,0.739`},{1.32`,0.728`},{1.34`,0.717`},{1.36`,0.706`},{1.38`,0.694`},{1.39`,0.681`},{1.41`,0.669`},{1.43`,0.656`},{1.45`,0.643`},{1.47`,0.63`},{1.49`,0.616`},{1.51`,0.603`},{1.52`,0.589`},{1.54`,0.575`},{1.56`,0.562`},{1.58`,0.548`},{1.6`,0.534`},{1.62`,0.521`},{1.64`,0.507`},{1.65`,0.494`},{1.67`,0.481`},{1.69`,0.468`},{1.71`,0.455`},{1.73`,0.442`},{1.75`,0.429`},{1.77`,0.417`},{1.78`,0.405`},{1.8`,0.393`},{1.82`,0.381`},{1.84`,0.37`},{1.86`,0.359`},{1.88`,0.348`},{1.9`,0.337`},{1.91`,0.326`},{1.93`,0.316`},{1.95`,0.306`},{1.97`,0.296`},{1.99`,0.287`},{2.01`,0.277`},{2.03`,0.268`},{2.04`,0.259`},{2.06`,0.251`},{2.08`,0.243`},{2.1`,0.235`},{2.12`,0.227`},{2.14`,0.219`},{2.15`,0.212`},{2.17`,0.204`},{2.19`,0.197`},{2.21`,0.191`},{2.23`,0.184`},{2.25`,0.178`},{2.27`,0.172`},{2.28`,0.166`},{2.3`,0.16`},{2.32`,0.154`},{2.34`,0.149`},{2.36`,0.144`},{2.38`,0.139`},{2.4`,0.134`},{2.41`,0.129`},{2.43`,0.125`},{2.45`,0.12`},{2.47`,0.116`},{2.49`,0.112`},{2.51`,0.108`},{2.53`,0.104`},{2.54`,0.1`},{2.56`,0.097`},{2.58`,0.093`},{2.6`,0.09`},{2.62`,0.087`},{2.64`,0.084`},{2.66`,0.081`},{2.67`,0.078`},{2.69`,0.075`},{2.71`,0.072`},{2.73`,0.07`},{2.75`,0.067`},{2.77`,0.065`},{2.79`,0.063`},{2.8`,0.06`},{2.82`,0.058`},{2.84`,0.056`},{2.86`,0.054`},{2.88`,0.052`},{2.9`,0.05`},{2.92`,0.049`},{2.93`,0.047`},{2.95`,0.045`},{2.97`,0.044`},{2.99`,0.042`},{3.01`,0.041`},{3.03`,0.039`},{3.05`,0.038`},{3.06`,0.036`},{3.08`,0.035`},{3.1`,0.034`},{3.12`,0.033`},{3.14`,0.032`},{3.16`,0.03`},{3.18`,0.029`},{3.19`,0.028`},{3.21`,0.027`},{3.23`,0.026`},{3.25`,0.025`},{3.27`,0.025`},{3.29`,0.024`},{3.31`,0.023`},{3.32`,0.022`},{3.34`,0.021`},{3.36`,0.021`},{3.38`,0.02`},{3.4`,0.019`},{3.42`,0.018`},{3.43`,0.018`},{3.45`,0.017`},{3.47`,0.017`},{3.49`,0.016`},{3.51`,0.015`},{3.53`,0.015`},{3.55`,0.014`},{3.56`,0.014`},{3.58`,0.013`},{3.6`,0.013`},{3.62`,0.013`},{3.64`,0.012`},{3.66`,0.012`},{3.68`,0.011`},{3.69`,0.011`},{3.71`,0.011`},{3.73`,0.01`},{3.75`,0.01`},{3.77`,0.009`},{3.79`,0.009`},{3.81`,0.009`},{3.82`,0.009`},{3.84`,0.008`},{3.86`,0.008`},{3.88`,0.008`},{3.9`,0.007`},{3.92`,0.007`},{3.94`,0.007`},{3.95`,0.007`},{3.97`,0.006`},{3.99`,0.006`}};

dat2={{0.45`,0.064`},{0.47`,0.082`},{0.49`,0.102`},{0.5`,0.125`},{0.52`,0.149`},{0.54`,0.175`},{0.56`,0.203`},{0.58`,0.233`},{0.6`,0.263`},{0.62`,0.295`},{0.63`,0.327`},{0.65`,0.36`},{0.67`,0.394`},{0.69`,0.428`},{0.71`,0.461`},{0.73`,0.495`},{0.74`,0.528`},{0.76`,0.56`},{0.78`,0.591`},{0.8`,0.621`},{0.82`,0.65`},{0.84`,0.678`},{0.86`,0.704`},{0.87`,0.728`},{0.89`,0.75`},{0.91`,0.771`},{0.93`,0.79`},{0.95`,0.806`},{0.97`,0.821`},{0.99`,0.834`},{1.`,0.845`},{1.02`,0.853`},{1.04`,0.86`},{1.06`,0.865`},{1.08`,0.868`},{1.1`,0.869`},{1.12`,0.869`},{1.13`,0.867`},{1.15`,0.863`},{1.17`,0.858`},{1.19`,0.852`},{1.21`,0.844`},{1.23`,0.835`},{1.25`,0.826`},{1.26`,0.815`},{1.28`,0.803`},{1.3`,0.79`},{1.32`,0.777`},{1.34`,0.763`},{1.36`,0.748`},{1.38`,0.733`},{1.39`,0.718`},{1.41`,0.702`},{1.43`,0.686`},{1.45`,0.67`},{1.47`,0.653`},{1.49`,0.637`},{1.51`,0.62`},{1.52`,0.604`},{1.54`,0.587`},{1.56`,0.571`},{1.58`,0.554`},{1.6`,0.538`},{1.62`,0.522`},{1.64`,0.506`},{1.65`,0.491`},{1.67`,0.476`},{1.69`,0.461`},{1.71`,0.446`},{1.73`,0.431`},{1.75`,0.417`},{1.77`,0.403`},{1.78`,0.39`},{1.8`,0.377`},{1.82`,0.364`},{1.84`,0.351`},{1.86`,0.339`},{1.88`,0.327`},{1.9`,0.316`},{1.91`,0.305`},{1.93`,0.294`},{1.95`,0.283`},{1.97`,0.273`},{1.99`,0.263`},{2.01`,0.254`},{2.03`,0.244`},{2.04`,0.235`},{2.06`,0.227`},{2.08`,0.218`},{2.1`,0.21`},{2.12`,0.203`},{2.14`,0.195`},{2.15`,0.188`},{2.17`,0.181`},{2.19`,0.174`},{2.21`,0.167`},{2.23`,0.161`},{2.25`,0.155`},{2.27`,0.149`},{2.28`,0.144`},{2.3`,0.138`},{2.32`,0.133`},{2.34`,0.128`},{2.36`,0.123`},{2.38`,0.118`},{2.4`,0.114`},{2.41`,0.109`},{2.43`,0.105`},{2.45`,0.101`},{2.47`,0.097`},{2.49`,0.094`},{2.51`,0.09`},{2.53`,0.087`},{2.54`,0.084`},{2.56`,0.08`},{2.58`,0.077`},{2.6`,0.074`},{2.62`,0.072`},{2.64`,0.069`},{2.66`,0.066`},{2.67`,0.064`},{2.69`,0.061`},{2.71`,0.059`},{2.73`,0.057`},{2.75`,0.055`},{2.77`,0.053`},{2.79`,0.051`},{2.8`,0.049`},{2.82`,0.047`},{2.84`,0.045`},{2.86`,0.043`},{2.88`,0.042`},{2.9`,0.04`},{2.92`,0.039`},{2.93`,0.037`},{2.95`,0.036`},{2.97`,0.035`},{2.99`,0.033`},{3.01`,0.032`},{3.03`,0.031`},{3.05`,0.03`},{3.06`,0.029`},{3.08`,0.028`},{3.1`,0.027`},{3.12`,0.026`},{3.14`,0.025`},{3.16`,0.024`},{3.18`,0.023`},{3.19`,0.022`},{3.21`,0.021`},{3.23`,0.021`},{3.25`,0.02`},{3.27`,0.019`},{3.29`,0.018`},{3.31`,0.018`},{3.32`,0.017`},{3.34`,0.016`},{3.36`,0.016`},{3.38`,0.015`},{3.4`,0.015`},{3.42`,0.014`},{3.43`,0.014`},{3.45`,0.013`},{3.47`,0.013`},{3.49`,0.012`},{3.51`,0.012`},{3.53`,0.011`},{3.55`,0.011`},{3.56`,0.011`},{3.58`,0.01`},{3.6`,0.01`},{3.62`,0.01`},{3.64`,0.009`},{3.66`,0.009`},{3.68`,0.009`},{3.69`,0.008`},{3.71`,0.008`},{3.73`,0.008`},{3.75`,0.007`},{3.77`,0.007`},{3.79`,0.007`},{3.81`,0.007`},{3.82`,0.006`},{3.84`,0.006`},{3.86`,0.006`},{3.88`,0.006`},{3.9`,0.006`},{3.92`,0.005`},{3.94`,0.005`},{3.95`,0.005`},{3.97`,0.005`},{3.99`,0.005`}};

Here is where we ListPlot the dat1 and specify the PointSize.

pl1a=ListPlot[dat1,PlotRange->{{0.4,1.45},{0,.9}},Frame->True,PlotStyle->PointSize[0.015],FrameLabel->{Style["Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Convert pl1a to a graphics object with an AspectRatio = 0.5.

pl1=Show[pl1a,AspectRatio->0.5]

Here is where we ListPlot the dat2 and specify the PointSize.

pl2a=ListPlot[dat2,PlotRange->{{0.4,1.45},{0,.9}},Frame->True,PlotStyle->PointSize[0.015],FrameLabel->{Style["Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["Probability Density",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Convert pl2a to a graphics object with an AspectRatio = 0.5.

pl2=Show[pl2a,AspectRatio->0.5,DisplayFunction->Identity]

Plot the two graphics objects as one figure, one below the other.

fig=Show[GraphicsGrid[{{pl1},{pl2}},Spacings->{Scaled[0.0],Scaled[0.04]}]]

Plot the two graphics objects side-by-side.

fig=Show[GraphicsGrid[{{pl1,pl2}},Spacings->{Scaled[-0.1],Scaled[0.04]}]]

Plot the two graphics objects side-by-side and another copy below.

fig=Show[GraphicsGrid[{{pl1,pl2},{pl1,pl2}},Spacings->{Scaled[-0.1],Scaled[0.04]}]]

List and plot data with error bars in y coordinate

<<"ErrorBarPlots`"

dat={{10365.979236`,-7.6`,2.`},{10715.080012`,-7.4`,2.4`},{10786.759306`,2.`,2.9`},{10806.886343`,-3.7`,2.2`},{11010.115556`,-1.2`,2.`},{11012.08544`,1.9`,2.`},{11013.103947`,1.1`,2.3`},{11014.105914`,2.`,2.2`},{11070.992361`,0.3`,2.8`},{11170.793657`,6.7`,2.4`},{11374.123206`,-1.9`,2.3`},{11412.084051`,0.7`,2.7`},{11585.736539`,17.9`,2.1`},{11757.13662`,-7.2`,2.1`},{11883.801736`,0.2`,2.7`},{12098.097419`,-12.1`,2.4`},{12134.022928`,-19.2`,2.4`},{12162.926852`,-6.7`,2.9`},{12188.010926`,1.9`,2.6`},{12218.947315`,-13.8`,2.3`},{12235.761655`,-6.`,2.8`},{12489.047558`,-15.`,2.1`},{12516.010463`,-17.8`,2.6`},{12535.910926`,-5.8`,2.6`},{12572.946597`,-5.7`,2.8`},{12600.927569`,-10.6`,2.9`},{12651.762963`,-0.8`,2.4`},{12833.093715`,-3.`,2.4`},{12834.12772`,3.3`,2.6`},{12835.121528`,-1.2`,2.8`},{12836.075405`,0.`,2.7`},{12850.087384`,-5.9`,2.3`},{12851.131667`,-2.2`,2.3`},{12854.03162`,-2.3`,2.5`},{12855.114792`,-2.1`,2.7`},{12856.061181`,-2.7`,2.5`},{12897.920671`,-0.2`,2.6`},{12899.035324`,-6.9`,2.7`},{12924.926863`,-0.9`,2.6`}};

Details concerning data manipulation and statistics.

tarr=Transpose[dat];

tvec=N[tarr[[1]]];

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

errvec=N[tarr[[3]]];

nd=Length[dat]

data=Transpose[{tvec,dvec}];

Plot the data

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Julian day number",{"Helvetica-Bold",12}],Style["Velocity  (m (s^(-1)))",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp1a=Show[plshp1,Graphics[{Text["(a)",{10500,-18}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Use ErrorListPlot to plot data with errors in both coordinates

First we need to load <<"ErrorBarPlots`".

<<"ErrorBarPlots`"

Create a test data set consisting of x,y pairs and ErrorBar information.

data={{-35,0.5`},{-25,4.67`},{-15,6.25`},{-5,10.`},{5,13.5`},{15,13.7`},{25,17.5`},{35,23.`}};

Now define the errors of the x coordinates and y coordinates.

sigx={3,3,3,3,3,3,3,3};

sigy={0.761`,1.643`,0.569`,2.012`,1.643`,0.607`,1.273`,2.012`};

dataToPlot=Table[{data[[i]],ErrorBar[{-sigx[[i]],sigx[[i]]},{-sigy[[i]],sigy[[i]]}]},{i,1,8}]

ErrorListPlot[dataToPlot,PlotRange -> All,
 Frame -> True]

Plot two data sets on the same graph with error bars

In order to implement this and control the symbols that are plotted, we will need to use a combination of ErrorListPlot (which allows for options like SymbolShape) and the ErrorBar function.

So first, the necessary preliminaries:

<<"ErrorBarPlots`"

We suppose your data is already of the form {{x1,y1,yerr}....}, which is the form that the function ErrorListPlot takes, then it is simple enough to manipulate the data. First we create two data sets of this form.

list1 = Table[{x, 1.2 x,0.1},{x, 0, 1, 0.1}]

list2 = Table[{x, 1.8 x,0.1},{x, 0, 1, 0.1}];

newdata1=Map[{{#[[1]],#[[2]]},ErrorBar[#[[3]]]}&,list1];

newdata2=Map[{{#[[1]],#[[2]]},ErrorBar[#[[3]]]}&,list2];

Note the ErrorBar command can be used for errors in both  coordinates (see previous example)

And now we can make the plots

ErrorListPlot[{newdata1,newdata2},Axes->False, 
Frame->{True,True,False,False}]

Remove spurious line in previous plot with option Axes->False

Sometimes mathematica will plot a vertical or horizontal line for no obvious reason as shown below.

ErrorListPlot[
 {{1.5, 3.2},
  {{3.4, 5.2}, ErrorBar[{-0.5, 0.3}]},
  {{5.5, 2.1}, ErrorBar[{-0.4, 0.3}, {-0.2, 0.5}]} },
 PlotRange -> All,
 Frame -> True]

To eliminate this add the option Axes->False as shown below.

ErrorListPlot[
 {{1.5, 3.2},
  {{3.4, 5.2}, ErrorBar[{-0.5, 0.3}]},
  {{5.5, 2.1}, ErrorBar[{-0.4, 0.3}, {-0.2, 0.5}]} },
 PlotRange -> All,Axes->False,
 Frame -> True]

Add a plot within a plot

It is possible to create a plot within a plot using the Inset command. 

p1=Plot[Sin[x]/x,{x,-100,100},PlotRange->All,Frame->True]

p2=Plot[Sin[x]/x,{x,-10,10},PlotRange->All,Frame->True]

This plots p1within plot p2.

p3=Plot[Sin[x]/x,{x,-10,10},PlotRange->All,Frame->True,Epilog->Inset[p1,{6,.75},Center,9.]]

Another way to plot p1within plot p2.

Graphics[{Inset[p2,{0,0},Center,{5,4}],Inset[p1,{1.5,0.9},Center,{2,2}]}]

3 dimensional scatter plot using  ListPointPlot3D

no=6000;

Create a table of 6000 random numbers which are uniformly distributed in the interval 0 to 1. 

ran=RandomReal[{0,1},no];

Group the random numbers into triples for the 3 coordinates of random points. 

pointlist=Table[{ran[[i]],ran[[i+1]],ran[[i+2]]},{i,1,no-2,3}];

The same operation can also be accomplished with a Do loop but is less efficiently. 
The Table command is faster than using a Do loop.

pointlist={};Do[item={ran[[i]],ran[[i+1]],ran[[i+2]]};pointlist=Append[pointlist,item],{i,1,no-2,3}];

Plot the random points in 3 dimensions. 

pointgraph=ListPointPlot3D[pointlist,PlotStyle->PointSize[0.007`],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Contour plot

Create a two dimensional Gaussian function map to Contour. 

map[x_,y_]:=Exp[-((x^2)/(2*(0.5^2)))-((y^2)/(2*(0.5^2)))]

map[0.5,0.5]

ContourPlot[map[x,y],{x,-2,2},{y,-2,2},PlotPoints->50,PlotRange->{0.01,1.0},Contours->{0.1,0.3,0.6},ContourLabels->(Text[Framed[#3],{#1,#2}, Background->White]&)]

If we hadn't labeled the contours, simply moving the cursor over the contour causes the contour value to appear.

Now turn off the shading and make some contours dashed and colored.

ContourPlot[map[x,y],{x,-2,2},{y,-2,2},PlotPoints->50,PlotRange->{0.01,1.0},Contours->{0.1,0.3,0.6},ContourStyle->{{Black,Dashed},{Black},{Red,Dashed}},ContourLabels->(Text[Framed[#3],{#1,#2}, Background->White]&),ContourShading->None]

Now Contour a function with positive and negative values. 

f[x_,y_]=x/Exp[(x^2)+(y^2)]

ContourPlot[f[x,y],{x,-2,2},{y,-2,2},ContourLabels->(Text[Framed[#3],{#1,#2}, Background->White]&), Contours->{-.2,-.3,-.4,-.5,.11,.20,.3,.4,.5,.6,.7}]

Now Contour a MultinormalDistribution. 

Needs["MultivariateStatistics`"]

pdf[x_,y_]:=PDF[MultinormalDistribution[{(Subscript[μ, 1]),(Subscript[μ, 2])},{{((Subscript[σ, 11])^2),ρ*(Subscript[σ, 11])*(Subscript[σ, 22])},{ρ*(Subscript[σ, 11])*(Subscript[σ, 22]),((Subscript[σ, 22])^2)}}],{x,y}]

ContourPlot[pdf[x,y]/.{(Subscript[μ, 1])->0.0,(Subscript[μ, 2])->0.0,(Subscript[σ, 11])->0.5,(Subscript[σ, 22])->0.5,ρ->0.5},{x,-4,4},{y,-3,3},PlotPoints->50,PlotRange->{0.01,1.0},Contours->{0.1,0.3,0.6},ContourLabels->(Text[Framed[#3],{#1,#2}, Background->White]&),PlotLabel->Style["X Y Contour Plot",{"Helvetica-Bold",12}],FrameLabel->{Style["x axis",{"Helvetica-Bold",12}],Style["y",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006`],BaseStyle->{"Helvetica-Bold",12}]

3 dimensional plot of function

map[x_,y_]:=Sin[x Sin[x y]];

spl=Plot3D[map[x,y],{x,0,5},{y,0,5},PlotPoints->30]

Plot a Histogram

We first generate an array containing random numbers havinga distribution specified by ndist.

sigma=1.0;

ndist=NormalDistribution[0,sigma];

ran=Table[RandomReal[ndist],{300}];

Histogram[ran,ChartStyle->{GrayLevel[1]}]

We specify the bin boundaries.

Histogram[ran,{{-4, -3.5, -3, -2.5, -2, -1.5, -1, -0.5, 0, 0.5, 1, 1.5, 2, 2.5, 3, 3.5, 4}},ChartStyle->{Red,Green,Blue}]

Histogram3D

Create 5000 data points to Histogram3D with a MultinormalDistribution.

Needs["MultivariateStatistics`"]

dat=RandomReal[MultinormalDistribution[{0,1},{{1,1/2},{1/2,1}}],5000];

Display the first 3 data values.

Take[dat,3]

Histogram3D the dat values.

Histogram3D[dat,{{0.5},{0.5}},ColorFunction->"DarkRainbow"]

We can ListContourPlot the data if we use BinCounts to create a 3 dimensional data set first.

bcdat=BinCounts[dat,{-4,5,0.5},{-4,5,0.5}];

ListContourPlot[bcdat,Contours->{50,20,5,0.1},InterpolationOrder->3]

Plot a dynamic graph with sliders

First we define some special Frame labels for our graph, a mixture of italic and plain fonts.

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

ylabel=
StyleForm[StringForm["``",
StyleForm["f(x)",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->16]

Now plot a nondynamic version of the BetaDistribution.
(see Section 5.8 .4 on the BetaDistribution[α, β] of the text for info on this distribution)

pl1=Plot[PDF[BetaDistribution[0.5,1.5],x],{x,0,1},PlotRange->{{0,1},{0,2.1}},PlotStyle->{Black,Thick},
Frame->True,Axes->False,FrameTicks->{Automatic,Automatic,None,None},PlotLabel->Style["α = 0.5, β = 1.5",Medium],FrameLabel->{xlabel,ylabel},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Finally here is a dynamic version of the BetaDistribution that varies α,β using sliders
achieved with the command Manipulate.

Manipulate[Plot[PDF[BetaDistribution[α,β],x],{x,0,1},PlotRange->{{0,1},{0,2}},PlotStyle->{Black,Thick},
Frame->True,Axes->False,FrameTicks->{Automatic,Automatic,None,None},PlotLabel->{Style[α,Medium],Style[β,Medium]},FrameLabel->{xlabel,ylabel},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],{α,0.0001,3},{β,0.0001,3}]

A more primitive way of achieving  something similar with the value of each
dynamic variable given to the right of each slider.

Panel[Column[{Row[{Slider[Dynamic[α],{0.0001,3}],"α =" Dynamic[α]}],Row[{Slider[Dynamic[β],{0.0001,3}],"β ="Dynamic[β]}],Dynamic[Plot[PDF[BetaDistribution[α,β],x],{x,0,1},PlotRange->{{0,1},{0,2}},PlotStyle->{Black,Thick},
Frame->True,Axes->False,FrameTicks->{Automatic,Automatic,None,None},FrameLabel->{xlabel,ylabel},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]}]]

Plot an animated graph.

First we define some special Frame labels for our graph, a mixture of italic and plain fonts.

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

ylabel=
StyleForm[StringForm["``",
StyleForm["f(x)",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->16]

Now plot an animated version of the BetaDistribution[α,β], animated in variable α with variable β = 2.0
(see Section 5.8 .4 on the BetaDistribution[α, β] of the text for info on this distribution)

Animate[Plot[PDF[BetaDistribution[α,2.0],x],{x,0,1},PlotRange->{{0,1},{0,2}},PlotStyle->{Black,Thick},
Frame->True,Axes->False,FrameTicks->{Automatic,Automatic,None,None},PlotLabel->{Style[α,Medium]},FrameLabel->{xlabel,ylabel},LabelStyle->Directive[Orange],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],{α,0.0001,3.0}]

Output a graph as an EPS file for inclusion in a LATEX document

When creating a document which includes graphical figures, it is common practice to incorporate the figures into the document as encapsulated postscript (eps) figures. With the Mathematica fonts embedded in the eps figure, any other program that calls this eps file will then have the fonts needed. Without these, eps files with paretheses and greek symbols do not get displayed correctly.
How to achieve this depends on the version of Mathematica you are running.

For Mathematica version 4.2.1.0 or later:
in this case the Export command automatically includes all fonts needed. An example is given below.

Example, create a data sets & plot with ListPlot and Export as an EPS file

First specify a data sets dat1. Double click the outer brace to see the two lists.

dat1={{0.45`,0.077`},{0.47`,0.098`},{0.49`,0.121`},{0.5`,0.146`},{0.52`,0.173`},{0.54`,0.201`},{0.56`,0.23`},{0.58`,0.26`},{0.6`,0.291`},{0.62`,0.322`},{0.63`,0.353`},{0.65`,0.385`},{0.67`,0.416`},{0.69`,0.446`},{0.71`,0.476`},{0.73`,0.506`},{0.74`,0.534`},{0.76`,0.561`},{0.78`,0.587`},{0.8`,0.612`},{0.82`,0.635`},{0.84`,0.657`},{0.86`,0.678`},{0.87`,0.697`},{0.89`,0.714`},{0.91`,0.73`},{0.93`,0.744`},{0.95`,0.756`},{0.97`,0.767`},{0.99`,0.777`},{1.`,0.784`},{1.02`,0.791`},{1.04`,0.796`},{1.06`,0.799`},{1.08`,0.801`},{1.1`,0.802`},{1.12`,0.801`},{1.13`,0.799`},{1.15`,0.796`},{1.17`,0.792`},{1.19`,0.787`},{1.21`,0.781`},{1.23`,0.774`},{1.25`,0.766`},{1.26`,0.758`},{1.28`,0.748`},{1.3`,0.739`},{1.32`,0.728`},{1.34`,0.717`},{1.36`,0.706`},{1.38`,0.694`},{1.39`,0.681`}};

Here is where we ListPlot the data and specify the PointSize.

plot=ListPlot[dat1,PlotRange->{{0.4,1.45},{0,0.9}},Frame->True,PlotStyle->{Black,PointSize[0.015]},PlotLabel->Style["My Plot",{"Helvetica-Bold",12}],FrameLabel->{Style["Time axis",{"Helvetica-Bold",12}],Style["Function value",{"Helvetica-Bold",12}]},LabelStyle->Directive[Blue],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Export["c:\\temp\\fig1.eps", plot,ImageSize->72*6]

Vectors

Clear["Global`*"]

Vectors do not appear in Mathematica as a separate data type but are represented as lists. For instance, the dot product of two vectors is given by typing a dot between the vectors.

{x, y, z} . {a, b, c}

Vectors can be added and multiplied by scalars in the usual way.

{a, b, c} + {1, 2, 3}

4*{a, b, c}

<<VectorAnalysis`

vec1={a,b,c};vec2={d,e,f};

CrossProduct[vec1,vec2]

potential=-(GMm/(Sqrt[(x^2)+(y^2)+(z^2)]))

Grad[potential,Cartesian[x,y,z]]

Next three cells transform the gravitational potential from Cartesian to Spherical coordinates.

crd=CoordinatesToCartesian[{r,θ,ϕ},Spherical]

x=crd[[1]];y=crd[[2]];z=crd[[3]];

potentialspherical=potential//Simplify

Now take the gradient in spherical coordinates

Grad[potentialspherical,Spherical[r,θ,ϕ]]

Clear["Global`*"]

CoordinatesFromCartesian[{x,y,z},Spherical]

Matrices

Clear["Global`*"]

Matrices also do not appear in Mathematica as a separate data type. Rather, they are represented as lists of lists. For instance:

{{1, 2, 3}, {4, 5, 6}, {7, 8, 9}}

The commands TableForm and MatrixForm display the output as a two-dimensional table.

TableForm[%]

Alternatively, matrices can be input in rectangular form by using a menu item or palette items. For instance, choosing the menu item Insert ⊳ Table/Matrix ⊳ New... brings up a dialogue box. Clicking the Matrix button and accepting the default numbers of rows and columns gives an input cell with the following structure.

(({{□, □, □}, {□, □, □}, {□, □, □}}))

Clicking on the first small box here selects for entering an expression. The Tab key steps through the other positions.

As with lists themselves, matrices can be constructed by the Table command when the entries are given by some mathematical formula. Here is the 3 × 3 Hilbert matrix.

matrix=Table[(1/(i+j-1)), {i, 1, 3}, {j, 1, 3}]

matrix//TableForm

Instead of the prefix form TableForm[], we have used the suffix form of function application //TableForm here.

Product of two matrices. is accomplished with a dot. Consider the product of our previous 3x3 matrix with a 3x1 matrix called cmatrix which will be another 3x1 column matrix.

cmatrix= {1,2,3}

product= matrix.cmatrix

Find the Inverse of matrix.

Inverse[matrix]

The following calculation checks that the preceding result is the inverse of matrix.

% . matrix // TableForm

Another matrix operation

Eigenvalues[N[matrix]]

The command Eigenvalues also works for matrices with symbolic entries. 
For instance, try a general 2 × 2 matrix.

Eigenvalues[{{a, b}, {c, d}}] // Simplify

Writing and Reading data files

Write out files with Export, read in files with Import and Drop commands

First lets create an array of numbers and letters together with header information and column headings and call it data.

data={{Unwanted,Header,Information},{X1,X2,X3,Quality},{10,23,10,A},{67,34,78,B},{57,77,12,C}};

Now write it out as a file with the Export command on a Windows system to a directory named "temp" on the "c" hard drive. The "Table" option leaves off the {} brackets.

Export["c:\\temp\\test.dat",data,"Table"];

Or, write it out as a file with the Export command on a UNIX system.          
Remove (*   *) around command to make it functional.

(*Export["~gregory\\test.dat",data,"Table"];*)

Export can handle numerical and textual data, graphics , sounds, and material from notebooks. "Table" is one particular output format for numerical and textual data (many others available). Also, many formats are available for exporting graphics and images, such as JPEG, GIF, BMP, EPS. See the Mathematica  Help for the Export command.

Now we want to read in only the table of data values without header info and column headings. This is done with Drop[Import["file"], n] to drop the first n lines.

Drop[Import["c:\\temp\\test.dat"], 2]

There are many other Drop options.

Another common ways of writing out data files with OpenWrite

First lets create a test nested list and call it data. Each of the inner brackets contains a pair of x,y values.

data={{1.9741088234026352`,-43.43998127796311`,5.611242581932702`},{2.8938490495553095`,-43.6349569055089`,5.3188724549343105`},{3.8136036437305134`,-41.675770188426334`,5.391831593146907`},{4.733358237905717`,-40.37271109443557`,5.0647966000625075`},{5.653112832080921`,-44.91761449154993`,2.5137631763000394`},{6.572867426256124`,-43.68705637774003`,1.9648614286189052`},{7.492607652408799`,-40.7146366506234`,2.403122048675108`},{8.412362246584003`,-39.133383662060155`,3.1287269975404812`},{9.332116840759205`,-17.678892539342876`,17.958079800081066`},{10.25187143493441`,-8.81319693500418`,18.651768387998395`},{11.171626029109614`,18.570830842111345`,10.192977944758054`},{12.091380623284818`,40.249320002005376`,12.09035981395599`},{13.011120849437491`,48.20191758280714`,17.407148602671825`},{13.930875443612695`,41.67760682560539`,16.013636816989784`},{14.8506300377879`,24.502778148990334`,14.853283377523807`}}

Here is what the data looks like in MatrixForm.

MatrixForm[data]

This opens the file   "c:\temp\file.dat" on a Windows system and names it stmp.

stmp=OpenWrite["c:\\temp\\file.dat"];

You can also append numbers to an existing file by using OpenAppend instead.

This writes out to stmp the data together with the list brackets {} of mathematica format.

Write[stmp,data];

This closes stmp

Close[stmp]

Some other capabilities of OpenWrite.

In the Write statement PaddedForm controls total number of digits and number to the right of the decimal place, in this case 10 digits and 6 decimal places. TableForm will output a data table that will look like the typical data table you would expect to import from other software, i.e without the {} brackets. TableSpacing->{0,3} creates 0 extra spaces between table rows and leaves 3 spacings between each entry in each row. Finally we close the output stream.

stmp=OpenWrite["c:\\temp\\file1.dat",FormatType->OutputForm]

Write[stmp,PaddedForm[TableForm[data,
			TableSpacing->{0,3}],{10,6}]]

Close[stmp]

We can also controls total number of digits and number to the right of the decimal place with the statement PaddedForm, in this case 10 digits and 6 decimal places.

stmp=OpenWrite["c:\\temp\\file1.dat",FormatType->OutputForm]

Write[stmp,PaddedForm[TableForm[data,
			TableSpacing->{0,3}],{10,6}]]

Close[stmp]

Read the file back in to Mathematica

Import["c:\\temp\\file1.dat","Table"]

Another method is to open a file, reads it and closes the file.  You will need to remove the (* and *) at the ends of the line.

(*stmp=OpenRead["c:\\temp\\file.dat"];
data2=Read[stmp];Close[stmp]*)

Click here to see another example of how to read in a data file

Click here to see yet another example of how to read in a data file

Writing out a very large file (e.g. 100,000 lines)

If the file is very large it may be much faster to write it out line by line than all at once. In this example suppose you have a data set, "data", and want to output the last n lines (makes use of the Take command). We have also added the PageWidth command. The default is 78 columns but by setting it to Infinity this insures each line of data will not be split.

(*n=3;newdata=Take[data,-n];
stmp=OpenWrite["c:\\temp\\junk.dat",PageWidth->Infinity];
Do[Write[stmp,newdata[[i]]],{i,1,n}];Close[stmp]*)

To reduce the size of the output file you may want to customize how many decimal places are output for certain columns. In this example we Transpose the data set, define new columns with some rounded to the nearest 3 decimal places, re-transpose these columns to create the modified data set, and then output line by line.

(*trdata=Transpose[data];col1=trdata[[1]];col2=N[Round[1000*trdata[[2]]]/1000];col3=N[Round[1000*trdata[[3]]]/1000];col4=N[Round[1000*trdata[[4]]]/1000];col5=trdata[[5]];newdata=Transpose[{col1,col2,col3,col4,col5}];stmp=OpenWrite["c:\\temp\\filename.dat",PageWidth->Infinity];
Do[Write[stmp,newdata[[i]]],{i,1,n}];Close[stmp]*)

Write and Read multiple files

Clean Up

Clear["Global`*"]

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

Generate a Variable  File (string) Name

x=1;

name=StringJoin["file",ToString[x],".dat"]

Simulate Some Random Number Data

sigma=1.0;

ndist=NormalDistribution[0,sigma];

We now generate a array containing random numbers having
a distribution specified by ndist.

ran=Table[RandomReal[ndist],{16}];

data=Transpose[{Table[i,{i,1,16}],ran}]

Store  Data in a File On a Windows system

Note you will have to remove the (* and *) from the ends of the next 3 commands lines to make them executable lines.

(*stmp=OpenWrite["c:\\greg1\\math\\data.dat",FormatType->OutputForm]*)

You can also append numbers to an existing file by using OpenAppend instead.

(*Write[stmp,NumberForm[TableForm[data,
			TableSpacing->{0,1}],{8,3}]]*)

(*Close[stmp]*)

Repeatedly Simulate Data and Output Each
Data Set to a Different File using a variable file name

This uses a Do loop to create two files with different names. Each file contains 16 pairs of numbers  with each pair(an integer, random number). You will need to remove the (* and *) at the ends of each line to execute these commands.

(*Do[data=Transpose[{Table[i,{i,1,16}],Table[RandomReal[ndist],{16}]}];filename=StringJoin["c:\\temp\\file",ToString[x],".dat"];stmp=OpenWrite[filename,FormatType->OutputForm];Write[stmp,PaddedForm[TableForm[data,
			TableSpacing->{0,3}],{10,6}]];Close[stmp],{x,1,2}]*)

Read a File

Read in data (one pair of x y values per line) by first creating a stream "infile" which acts as a pointer to the data file.

(*infile=OpenRead["c:\\temp\\file1.dat"];*)

If you want to skip the first 4 lines because they contain text (date etc.) then invoke the skip comand by removing the (* and *) at each end of the line.

(* Skip[infile, Record, 4] *)

(*data=ReadList[infile,Number,RecordLists->True]*)

Sequentially Read and Print a Series of Files on a Windows system

You will need to remove the (* and *) at the ends of each line.

(*Do[filename=StringJoin["c:\\temp\\file",ToString[x],".dat"];infile=OpenRead[filename];datan=ReadList[infile,Number,RecordLists->True];Print[datan],{x,1,2}]*)

Solving equations

Clear["Global`*"]

Solve[2 x-3==5, x]

Solve [(x^4)-7 (x^3)+3 a (x^2)==0, x]

What about equations for which it is mathematically impossible to 
find explicit formulas. Here is one.

equation=2-4 x+(x^5)==0;

Solve[equation,x]

Mathematica uses Root objects to represent the solutions in this case. Even though
we can't get explicit formulas we can still find the solutions numerically.

solutions=N[%,17]

To check if these are solutions substitute them into equation.

equation /. solutions

Here we solve two simultaneous equations.

Solve[{(x^3)+(y^3)==1, (x^2)+(y^2)==1},{x,y}]

We can get a picture of some of these solutions. First need to load 
a Graphics package.

ImplicitPlot[{(x^3)+(y^3)==1, (x^2)+(y^2)==1},{x,-2,2}]

Simple programming

Mathemata provides a wide range of programming capabilities. Only a simple example is given.

Clear["Global`*"]

The data in this simple example is the number of fish moving up two fish ladders every 20 minutes as counted by two observers, Harry and George. The first item is the name of the observer given as a string. The second item is the number of fish and the third is a flag set to 1 or 0. If the flag is 0 then there is a problem with that count.

data={{"Harry",56,1},{"Harry",5,0},{"George",61,1},{"Harry",49,1},{"George",59,1},{"Harry",52,1},{"George",48,1},{"Harry",53,1},{"George",39,1}};

Lets look at the first item in the first observation, which should be the observers name.

data[[1,1]]

The program  below extracts only the counts made by Harry for which the flag is = 1, and create a new list called hlist. The program uses a Do loop, Do[operation,{i,1,no}],  and an  If statement, If[test,then,else]. The test is to match the first item in the ith  observation data[[i,1]] to the string "Harry" using the command StringMatchQ and to check the flag (3rd item) is > 0. The symbol && is the Boolean AND operation.  When the test is successful the observation is appended to hlist. If the program is unsuccessful no else operation is specified in this case. Successive items in the program are separated by a semi-colon. All separate steps in the program could be on a continuous line. Comments are specified by (* comment *) and can be any color you want, simply highlight the comment, click on menu item Format  then Text Color.

no=Length[data];(* determine the total number of observations*)
hlist={};                                (*create an empty list to store Harry's observations*)
Do[
If[StringMatchQ[data[[i,1]],"Harry"]&&data[[i,3]]>0,hlist=Append[hlist,data[[i]]],],
{i,1,no}];(* i is the iterator in the Do loop*)
hlist

Here is a much faster way to achieve the same with one command.

hlist=Cases[data,{x_/;x=="Harry",y_,z_/;z≠0}]

Naming symbols and Context

In Mathematica, you can use the notion of "contexts" to organize the names of symbols. Contexts are particularly important in Mathematica packages which introduce symbols whose names must not conflict with those of any other symbols. 

The basic idea is that the full name of any symbol is broken into two parts: a context and a short name. The full name is written as context`short, where the ` is the backquote, called a "context mark" in Mathematica. 

At any given point in a Mathematica session, there is always a current context $Context, analogous to the current working directory in many operating systems. You can refer to symbols that are in this context simply by giving their short names. You can always specify a particular file by giving its complete name, including its directory. But at any given point, there is usually a current working directory, analogous to the current Mathematica context. Files that are in this directory can then be specified just by giving their short names. The default context for Mathematica sessions is Global`.
 
When you start a Mathematica session, the default current context is Global`. Symbols that you introduce will usually be in this context. However, built-in symbols such as Pi are in the context System`. 

In order to let you easily access not only symbols in the context Global`, but also in contexts such as System`, Mathematica supports the notion of a context search path. At any point in a Mathematica session, there is both a current context $Context, and also a current context search path $ContextPath. The idea of the search path is to allow you to type in the short name of a symbol, then have Mathematica search in a sequence of contexts to find a symbol with that short name.
The context search path for symbols in Mathematica is analogous to the "search path" for program files provided in operating systems such as Unix and MS-DOS. 
 
To find the current Context and search path:

$Context

$ContextPath

You will frequently need to load in standard Mathematica packages with specific functions your analysis will require.

Calculus

Integration, Differentiation, Series, and Limits

Remove["Global`*"]

Integration

Start by defining some function we want to integrate

f[x_]:= x/(1 - x^3)

Mathematica carries out the standard operations of calculus in symbolic form. The command to find the antiderivative, or indefinite integral, of f[x] with respect to x is Integrate[f[x], x]. This integration is written in InputForm.

int = Integrate[f[x], x]

Using a palette,the same integration expression can be input in StandardForm notation as:

int=∫f[x]\[DifferentialD]x

The default output is given in StandardForm. We can convert the input or output form to what is called  TraditionalForm using the Menu item. To do that click on the cell bracket then enter menu item Cell ⊳ Convert To ⊳ TraditionalForm. Try this out.

Note: that the answer omits the constant of integration that all freshmen are told is required.

The expression Integrate[f[x], {x, a, b}] gives the definite integral of f[x] with respect to x from a to b.  NIntegrate finds numerical values of definite integrals of functions even if there is no closed form for their indefinite integral. The definite integral in StandardForm looks like this.

(∫_0^π)Sin[x]\[DifferentialD]x

Here is a more complicated integral with a parameter s. Examine the result and you will see it depends on the nature of the parameter which in general will be assumed to be complex.

(∫_0^∞)(E^(-((((x/s)))^2)))\[DifferentialD]x

We can incorporate assumptions about the nature of the parameter s by using the Assumptions option as shown next, but this only works if we use the input form for the definite integral. Our assumptions are that s is real and > 0.

Integrate[Exp[-(((x/s))^2)],{x,0,Infinity},Assumptions -> {s ∈ Reals, s > 0}]

NIntegrate finds numerical values of definite integrals of functions even if there is no closed form for their indefinite integral. The definite integral in StandardForm looks like this.

NIntegrate[Sin[Sin[x]],{x,0,π}]

There are some functions that will give NIntegrate trouble,using the default values. See Options[NIntegrate] and the help manual on how to get around the problem.

Differentiation

First define int, the quantity we will want to differentiate.

f[x_]:= x/(1 - x^3);int = Integrate[f[x], x]

Differentiation is the inverse operation to integration. It is one of the few commands that are abbreviated in Mathematica, being denoted just by D. Thus, D[f[x], x] means df(x)/dx. A good way to check the operation of integration is to differentiate the result, so differentiate the previous integral. The Standard syntax for the derivative of the preceding expression, int, with respect to x is  D[int, x].

D[int,x]

We can convert this to  StandardForm by clicking on the menu item 
Cell-> Convert to->StandardForm.

(∂_x) int

This doesn't look like the function we started with, but, after simplification, we get back the original expression.

Simplify[%]

Higher order derivatives are given by D[f[x], {x, n}], where n is the order.

D[f[x], {x, 2}]

We can convert this to  StandardForm by clicking on the menu item 
Cell-> Convert to->StandardForm.

(∂_({x,2}))int

Simplify[D[int, {x, 2}]]

Series

The command Series[f[x], {x, a, n}] finds the first n terms of the Taylor's series expansion of f[x] about the point a.

Series[(E^(-x)) Sin[2 x],{x,0,6}]

Limit

The command Limit[f[x], x -> a] finds the limit of f[x] as x approaches a.

Limit[((Sin[x]-Tan[x])/(x^3)),x->0]

Calculus of several variables

Clear["Global`*"]

Mixed derivatives are easily calculated. Start with some expression in x and y. We don't need to see it repeated as output so we suppress the output by following the definition with a semicolon.

exp=(x^3) Sin[(y^4)];

The mixed partial derivative of exp with respect to x and then y is given by using the same symbol D that is used for ordinary derivatives, with an extra argument for the second variable.

D[exp,x,y]

Now differentiate twice with respect to x and three times with respect to y. Standard notation is D[exp, {x, 2}, {y, 3}].

D[exp, {x, 2}, {y, 3}]

We can convert this to  StandardForm by clicking on the menu item 
Cell-> Convert to->StandardForm.

(∂_({x,2},{y,3}))exp

Just as D denotes ordinary or partial differentiation, Integrate denotes single or multiple integration. Converting Integrate[E^(-2x) Cos[y], x, y] to StandardForm gives

∫∫(E^(-2 x)) Cos[y]\[DifferentialD]y\[DifferentialD]x

Multiple definite integration uses two (or more) iterators. The Input notation Integrate[E^(-2x) Cos[y], {x, 0, Pi/4}, {y, 0, x}] when expressed in StandardForm gives

(∫_0^(π/4))(∫_0^x)(E^(-2 x)) Cos[y]\[DifferentialD]y\[DifferentialD]x

Notice that the second integration in the standard notation is performed first; that is, this result is the same as the iterated integral:

Integrate[Integrate[E^(-2x) Cos[y], {y, 0, x}], 
          {x, 0, Pi/4}]

Differential equations

Clear["Global`*"]

Non-Linear Equation Involving a Power of y'[x].

diffEqNonL = y''[x]+y[x] ((y'[x])^3)== 0;

solutionNonL = DSolve[diffEqNonL, y, x]

diffEqNonL  /.solutionNonL //FullSimplify

Numerical Solution for Differential Equations NDSolve

The fastest way to get a numerical solution is to use NDSolve. In order to use this it is necessary to give enough initial conditions to ensure a well-determined, numerical answer.

ndiffEq = y'''[x]+y''[x]+y'[x]+2y[x]==0;

numSolution = 
   NDSolve[{ndiffEq, y[0] == y'[0] == y''[0] == 1},
           y, {x, 0, 10}]

Plot[Evaluate[y[x]/. numSolution], {x, 0, 10}]

A planetary orbit

A more challenging problem is to determine the trajectory of a mass in the gravitational field caused by a very large mass at the origin. This is described by a pair of differential equations:

NDSolve requires that we also specify initial conditions for x and y and their derivatives at t = 0.

orbit =
	NDSolve[{x''[t]==((-x[t])/((((Sqrt[((x[t])^2)+((y[t])^2)])))^3)),
		                  y''[t]==((-y[t])/((((Sqrt[((x[t])^2)+((y[t])^2)])))^3)),
		                 x[0]==1, x'[0]==0.2,
			               y[0]==0, y'[0]==1.25},
		               {x, y}, {t, 0, 64}]

ParametricPlot[Evaluate[{x[t], y[t]}/.orbit],
{t, 0, 24}, AspectRatio->Automatic,PlotRange -> {{-5, 2}, {-2, 3}}]

As is to be expected, the picture shows that the result is an ellipse with one focus at the origin.

Two equal masses orbiting

A still more challenging problem is that of two bodies of equal mass acting under mutual gravitational attraction. If the bodies have coordinates (x1, y1) and (x2, y2), then the equations are essentially the same as before, except expressed in terms of the differences (x2 - x1) and (y2 - y1). One gets four second order equations, which require eight initial conditions. We start the bodies off located symmetrically with respect to the origin, the left one moving down and the right one moving up. Note that most of the space is just entering the differential equations and the initial conditions.

twoorbits =
NDSolve[
   {x1''[t]==-(x1[t]-x2[t])/(√((((x1[t]-x2[t]))^2)+(((y1[t]-y2[t]))^2)))^3,
		y1''[t] == -(y1[t]-y2[t])/(√((((x1[t]-x2[t]))^2)+(((y1[t]-y2[t]))^2)))^3,
		x2''[t]== -(x2[t]-x1[t])/(√((((x1[t]-x2[t]))^2)+(((y1[t]-y2[t]))^2)))^3,
		y2''[t]==-(y2[t]-y1[t])/(√((((x1[t]-x2[t]))^2)+(((y1[t]-y2[t]))^2)))^3,
		x1[0]==1,   x1'[0]==0.5,y1[0]==0,   y1'[0]==0.3,
		x2[0]==-1, x2'[0]==-0.5,y2[0]==0,   y2'[0]==-0.3},
		{x1, y1, x2, y2}, {t, 0, 25}]

ParametricPlot[
   Evaluate[{{x1[t], y1[t]} /. twoorbits, 
             {x2[t], y2[t]} /. twoorbits}],
   {t, 0, 24}, AspectRatio -> Automatic]

We chose the t-range so as to show not quite one complete orbit, making it easier to see how the masses are always located symmetrically with respect to their common center of gravity at the origin. The orbits are periodic, as one can see by increasing the t-range, and they appear to be ellipses again. The following picture shows the result if the initial velocities are changed to y1'[0] == 0.4 and y2'[0] == -0.2. The time interval is {t, 0, 10}.

Different forms of expressions

Clear["Global`*"]

Type in an expression.

expr = (2 - 3 x^2)/(a + Sin[3]) + Integrate[Tan[x^3], x]

We can get back the input form of this expression as an output if we want it.

InputForm[expr]

In TraditionalForm,

TraditionalForm[expr]

as well as an OutputForm.

OutputForm[expr]

StandardForm[ expr ]

These forms will be discussed more in the next section. We can also output the TeX form, the Fortran form, or the C form if they are needed.

TeXForm[expr]

FortranForm[expr]

CForm[expr]

These could then be copied and pasted into a TeX document, a Fortran program, or a C program.

How to interrupt and restart a Mathematica evaluation

To interrupt a calculation in Mathematica, go to the menu bar above and click Evaluation. Under this click Interrupt Evaluation. You will see a panel open on the right that allows you to enter a subsession where you can carry out other calculations before returning to the interrupted calculation.

To return to the interrupted calculation type Return[] and hit Shift Enter

Return[]

Ch. 1: Bayesian analysis of simulated hurricane data

Introduction

Simple exercise on Bayesian data analysis to determine the velocity and direction of a hurricane.  Plot the joint and marginal posterior PDF for the velocity and direction of a Hurricane from measurements of the longitude and latitude versus time.

CleanUp

Clear["Global`*"]

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

Plot the data and error bars

The data set consists of 6 measurements of (time,Δlongitude,Δlatitude),measured with respect the location of the hurricane at time zero.Longitude and latitude are measured in arcmin and time in hours.

data={{1,0.99`,0.22`},{3,2.95`,4.41`},{5,4.87`,1.25`},{6,5.89`,3.77`},{8,7.85`,9.32`},{10,9.84`,7.25`}}

no=Length[data]

Transpose the data so we can extract vectors of times, Δlongitude, and Δlatitude.

trdata=Transpose[data]

tvec=trdata[[1]]

longvec=trdata[[2]]

latvec=trdata[[3]]

Transpose the vectors of Δlongitude and Δlatitude to create pairs of  Δlongitude and Δlatitude for plotting.

longlatdata=Transpose[{longvec,latvec}]

Load the graphics package MultipleListPlot to plot the data with errors in both coordinates.

<<"ErrorBarPlots`"

Now define the errors of the Δlongitiude coordinates and Δlatitude coordinates.

siglong=Table[2,{no}]

siglat=Table[2,{no}]

dataToPlot=Table[{longlatdata[[i]],ErrorBar[{-siglong[[i]],siglong[[i]]},{-siglat[[i]],siglat[[i]]}]},{i,1,no}]

Plot the Δlongitiude coordinates and Δlatitude coordinates with error bars.

pldata=ErrorListPlot[dataToPlot,PlotRange->All,Frame->True,Axes->False,PlotLabel->Style["Hurricane  position  versus  time",{"Helvetica-Bold",11}],FrameLabel->{Style["ΔLongitude (arcmin)",{"Helvetica-Bold",12}],Style["Δlatitude (arcmin)",{"Helvetica-Bold",12}]},BaseStyle->{"Helvetica-Bold",12},FrameStyle->Thickness[0.006]]

Compute the Bayesian joint posterior p(v,θ|D,I) for the velocity and direction

We will neglect the curvature of the earth in our analysis and use a cartesian coordinate system where the direction angle θ is defined as positive for counterclockwise rotation from the x-axis. Since longitude is assumed to be measured positive to the west we will convert the longitude vector into an x vector with a sign reversal.

xvec=-longvec

yvec=latvec

Now define our model predictions for the x and y coordinates called mxvec and myvec.
These are given in terms of the unknown model parameters v and θ.

mxvec=v*tval*Cos[θ*π/180]/.tval->tvec

myvec=v*tval*Sin[θ*π/180]/.tval->tvec

Now compute the difference vectors between the measured position and model predictions.

exvec=xvec-mxvec

eyvec=yvec-myvec

Specify known (Subscript[σ, x]) and (Subscript[σ, y]) of  Gaussian uncertainty in the longitude and latitude measurements.

(Subscript[σ, x])=2;(Subscript[σ, y])=2;

- Use Bayes' theorem (neglecting the normalizing constant provided by the denominator) 
   to expand the joint posterior 
            p(v,θ|D,I) ∝ p(v,θ|I) × p(D|v,θ,I) = p(v|I)×p(θ|I) × p(D|v,θ,I),
   where we have assumed indepentent prior PDF's for v and θ.
- We will assume a uniform prior for v in the range 0 to 10 arcmin/hr.
- We will assume a uniform prior for θ in the range 0 to 360 degrees.
- With uniform priors the joint posterior probability p(v,θ|D,I) is simply proportional to the        
   likelihood function (provided the boundaries of the priors lie well outside the region where the
   likelihood function is significant).
- The proposition D = (Subscript[D, x]),(Subscript[D, y]) where (Subscript[D, x]) can represent the vector of x (longitude) measurements, and (Subscript[D, y]) can represent the vector of y (latitude) measurements.
- Therefore we can write p(D|v,θ,I) = p((Subscript[D, x]),(Subscript[D, y])|v,θ,I) 
- We can represent the (i^th) data value (Subscript[d, xi]) by the equation (Subscript[d, xi]) = (Subscript[m, xi])+(Subscript[e, xi]) , 
   where (Subscript[m, xi]) is the model prediction for the (i^th) data x-value and (Subscript[e, xi]) the (i^th) error component.
- Let (Subscript[M, x]) represent the set of x-value model predictions, and (Subscript[E, x]) the set of error values.
- Then proposition (Subscript[D, x]) = (Subscript[M, x]),(Subscript[E, x])  and similarly (Subscript[D, y]) = (Subscript[M, y]),(Subscript[E, y])
- We can write p(D|v,θ,I) = p((Subscript[D, x]),(Subscript[D, y])|v,θ,I) = p((Subscript[M, x]),(Subscript[E, x]) ,(Subscript[M, y]),(Subscript[E, y]) |v,θ,I)
    From the product rule  p((Subscript[M, x]),(Subscript[E, x]) ,(Subscript[M, y]),(Subscript[E, y]) |v,θ,I) =  p((Subscript[M, x]),(Subscript[M, y]) |v,θ,I)×p((Subscript[E, x]),(Subscript[E, y]) |(Subscript[M, x]),(Subscript[M, y]),v,θ,I)
    but p((Subscript[M, x]),(Subscript[M, y]) |v,θ,I) = 1  for our deterministic model, 
    and  p((Subscript[E, x]),(Subscript[E, y]) |(Subscript[M, x]),(Subscript[M, y]),v,θ,I) = p((Subscript[E, x]),(Subscript[E, y]) |v,θ,I) = p((Subscript[E, x]) |v,θ,I) ×p((Subscript[E, y]) |v,θ,I),
    since the errors are independent and information (Subscript[M, x]),(Subscript[M, y])is already specified by v,θ,I.
- Therefore we can write p(D|v,θ,I) =  p((Subscript[E, x]) |v,θ,I) ×p((Subscript[E, y]) |v,θ,I)
-  Since the errors are independent Gaussians, we can write
     p((Subscript[E, x])|v,θ,I) = (((2*π))^(-no/2))*((Subscript[σ, x])^(-no))*Exp[-(∑_(i=1)^no)(((((Subscript[e, xi])))^2)/(2*((Subscript[σ, x])^2)))]
                       = (((2*π))^(-no/2))*((Subscript[σ, x])^(-no))*Exp[-((exvec.exvec)/(2*((Subscript[σ, x])^2)))]
     p((Subscript[E, y])|v,θ,I) = (((2*π))^(-no/2))*((Subscript[σ, y])^(-no))*Exp[-((
eyvec.eyvec)/(2*((Subscript[σ, y])^2)))]
-  We will represent the joint posterior by prob

prob=(((2*π))^(-no/2))*((Subscript[σ, x])^(-no))*Exp[-((exvec.exvec)/(2*((Subscript[σ, x])^2)))]*(((2*π))^(-no/2))*((Subscript[σ, y])^(-no))*Exp[-((eyvec.eyvec)/(2*((Subscript[σ, y])^2)))];

prob/.{v->1.2,θ->145}

Here is a contour plot of the joint posterior.

plcont=ContourPlot[prob,{v,0,10},{θ,0,360},Contours->5,PlotRange->All,
	ContourShading->False,PlotPoints->100,ContourLabels->Automatic,PlotLabel->Style["Joint PDF",
				{"Helvetica-Bold",11}],FrameLabel->{Style["Velocity  (arcmin/hr)",{"Helvetica-Bold",12}],
		Style["Direction  (deg)",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 11},FrameStyle->Thickness[0.006]]

Compute the values of v and θ at the posterior peak.

peak=FindMaximum[prob,{{v,1.3},{θ,140}}]

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[{prob,v>1&&v<1.5},{v,θ}]

vpeak=peak[[2,1,2]]

θpeak=peak[[2,2,2]]

Now define the peak model predictions for the x and y coordinates called mxvecpeak and myvecpeak.

mxvecpeak=v*tval*Cos[θ*π/180]/.{tval->tvec,v->vpeak,θ->θpeak}

myvecpeak=v*tval*Sin[θ*π/180]/.{tval->tvec,v->vpeak,θ->θpeak}

Compute peak model prediction as longitude and latitude pairs.

peakmodel1=Transpose[{-mxvecpeak,myvecpeak}]

Add the reference longitude, latitude coordinate at 0,0.

peakmodel=Join[{{0,0}},peakmodel1]

Plot the peak model prediction.

plpeakmodel=ListPlot[peakmodel,PlotRange->All,Axes->False,Frame->True,PlotJoined->True,PlotLabel->Style["Hurricane  position  versus  time",{"Helvetica-Bold",11}],FrameLabel->{Style["ΔLongitude (arcmin)",{"Helvetica-Bold",12}],Style["Δlatitude (arcmin)",{"Helvetica-Bold",12}]},BaseStyle->{"Helvetica-Bold",12},FrameStyle->Thickness[0.006]]

Overlay the peak model prediction on measurements.

plfit=Show[pldata,plpeakmodel]

Compute and plot marginal PDF for hurricane velocity v

Now compute  p(v|D,I), the marginal posterior PDF for v
     p(v|D,I) ∝ p(v|I) (∫_0^360)p(θ|I)×p(v,θ|D,I)dθ
We will do this numerically by constructing a table of   p(v|D,I) for values of v in the range of interest between 0.8 to 1.7 as judged by the contour plot above.

margv=Table[{v,NIntegrate[prob,{θ,100,200}]},{v,0.8,1.7,0.005}];

To compute the normalizing factor for the marginal p(v|D,I) we will set up an interpolating function for our table of margv values.

infv=Interpolation[margv]

margvIntegral=NIntegrate[infv[x],{x,0.8,1.7}]

Need to transpose margv to obtain v values and probabilities separately.

trmargv=Transpose[margv];

xmargv=trmargv[[1]];

ymargv=trmargv[[2]];

Construct a table of v and normalized probabilities for plotting.

normmargv=Transpose[{xmargv,ymargv/margvIntegral}];

plmargv=ListPlot[normmargv,PlotJoined->False,Frame->True,Axes->False,PlotStyle->PointSize[0.015],	
		PlotLabel->Style["Marginal PDF for velocity",
				{"Helvetica-Bold",11}],
		FrameLabel->{Style["Velocity  (arcmin/hr)",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},
		BaseStyle -> {"Helvetica-Bold", 12},
		FrameStyle->Thickness[0.006]]

Compute and plot marginal PDF for hurricane direction θ

Now compute  p(θ|D,I), the marginal posterior PDF for θ
     p(θ|D,I) ∝ p(θ|I) (∫_0^10)p(v|I)×p(v,θ|D,I)dv
We will do this numerically by constructing a table of   p(θ|D,I) for values of θ in the range of interest between 100 to 200 as judged by the contour plot above.

margθ=Table[{θ,NIntegrate[prob,{v,0.8,1.7}]},{θ,100,200,1}];

To compute the normalizing factor for the marginal p(θ|D,I) we will set up an interpolating function for our table of margθ values.

infθ=Interpolation[margθ]

margθIntegral=NIntegrate[infθ[x],{x,100,200}]

Need to transpose margθ to obtain θ values and probabilities separately.

trmargθ=Transpose[margθ];

xmargθ=trmargθ[[1]];

ymargθ=trmargθ[[2]];

Construct a table of θ and normalized probabilities for plotting.

normmargθ=Transpose[{xmargθ,ymargθ/margθIntegral}];

plmargθ=ListPlot[normmargθ,PlotJoined->False,Frame->True,Axes->False,PlotStyle->PointSize[0.015],	
		PlotLabel->Style["Marginal PDF for direction",
				{"Helvetica-Bold",11}],
		FrameLabel->{Style["Direction  (deg)",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},
		BaseStyle -> {"Helvetica-Bold", 12},
		FrameStyle->Thickness[0.006]]

Plot a summary set of plots.

fig=Show[GraphicsGrid[{{plfit,plcont},{plmargv,plmargθ}},Spacings->{Scaled[-0.15],Scaled[0.1]}]]

Ch. 1: Joint probability distributions and marginalization

CleanUp

Clear["Global`*"]

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

Generate and ContourPlot a two dimensional probability density function

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

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 an 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)))));

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[" (A) Joint Probability",{"Helvetica-Bold",12}],FrameLabel->{Style["x axis",{"Helvetica-Bold",12}],
		Style["y axis",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

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 -> {"Helvetica-Bold", 12},MeshStyle->Thickness[0.001]]

Plot projection of  joint probability distribution along the x axis

Make a simple two dimensional table of 1's

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.02;dy=0.02;

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,Contours->20]

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 Plus@@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 Probability",{"Helvetica-Bold",12}]},BaseStyle-> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

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.

plfin=ListPlot[{xplmax,xmargprb},PlotJoined->True,Frame->True,PlotRange->All,PlotMarkers -> {{■, 10}, {□, 10}},PlotStyle->{Red,Blue} ,PlotStyle->{{Thickness[0.005],Dashing[{0.007,0.02}]},{Thickness[0.005],GrayLevel[0]}},
	PlotLabel->Style["(B) Marginal and Projected Probability",{"Helvetica-Bold",12}],FrameLabel->{Style["x axis",{"Helvetica-Bold",12}],
		Style["Probability Density",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Now some text to the figure.

plgraphics=Graphics[{Text[Style["Projected",FontSize->12,FontWeight->"Bold",Red],{0.4,0.5},{-1,0},{1,0}],Text[Style["Marginal",FontSize->12,FontWeight->"Bold",Blue],{0.4,0.2},{-1,0},{1,0}]}];

Here we combine the figure with the graphics item above.

plboth=Show[plfin,plgraphics,DisplayFunction->$DisplayFunction]

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

Here we will plot our two graphics items in an array using the Rectangle command to get the relative size and spacing we want. The initial plot may look very strange so simply click inside the plot window to display the plot frame, then grab a corner with the mouse and expand to a bigger size.

Show[Graphics[ {Rectangle[{-0.1, -0.2}, {0.9, 0.9}, plcont], Rectangle[{0.95, -.21}, {2.4, 1}, plboth]}],DisplayFunction->$DisplayFunction]

Plot two graphs side-by-side

fig=Show[GraphicsGrid[{{plcont,plboth}},Spacings->{Scaled[0.0],Scaled[0.04]}]]

Ch. 3: Draw contour containing 95% of a joint probability distribution.

Introduction

In the systematic error example of Section 3.11.1 we computed the marginal probability distribution for the galaxy distance allowing for a Gaussian uncertainty in the astronomical distance scale which is the Hubble constant. In this case we compute the joint probability density function (PDF) in distance and Hubble constant. Our goal is to plot a contour of this PDF which encloses 95% of the probability.

CleanUp

Clear["Global`*"]

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

Generate and ContourPlot the two dimensional probability density function

Let v = measured galaxy velocity (km (s^(-1))).
Let (Subscript[σ, v]) = uncertainty in velocity (1 σ Gaussian error) .

Let hc = best estimate of Hubble constant (Mpc (km^(-1))s).
Let (Subscript[σ, h]) = uncertainty in Hubble constant (1 σ Gaussian error) .

Let hLow = lower bound on Hubble constant for integration.
Let hHi = upper bound on Hubble constant for integration.

Let low = lower bound on uniform prior for distance for integration.
Let hi = upper bound on uniform prior for distance for integration.

v=100× (10^3);hc=70;hLow=40;hHi=100;(Subscript[σ, h])=10;(Subscript[σ, v])=5*(10^3);
low=900;hi=2600;

pdf0=Exp[-((((h-hc))^2)/(2*((Subscript[σ, h])^2)))] (1/((Sqrt[2 π])*(Subscript[σ, v]))) Exp[-((((v-x*h))^2)/(2*((Subscript[σ, v])^2)))]

pdfintegral=NIntegrate[pdf0,{h,hLow,hHi},{x,low,hi},MaxPoints->200000,WorkingPrecision->10]

pdf=pdf0/pdfintegral;

The contour line has a constant probability.  The following computes the total probability enclosed by the contour line with value p.  Note this works in this case because the pdf at points inside the contour will be greater than that of the contour (not true in general, but true for this distribution).

myfn[p_?NumericQ]:=NIntegrate[pdf*Boole[pdf≥p],{h,hLow,hHi},{x,low,hi},WorkingPrecision->10]

If the value of p is .00002, we get the .907... quantile.

myfn[.00002]

We can find the p value such that we get a .68 quantile contour using FindRoot.

percent95={p/.FindRoot[myfn[p]==.95,{p,.00002,.00001}]}

And now, we can plot the contour.

ContourPlot[pdf,{x,800,2600},{h,40,100},Contours->percent95,PlotRange->All,
	ContourShading->False,PlotPoints->100]

Multiple contours can be added by doing the FindRoot for different quantile values,here .68, .95 and .99.
Need to remove the commenting  symbols (* *)  at the ends for this to execute.

(*ContourPlot[pdf,{x,800,2600},{h,40,100},Contours->Map[(p/.FindRoot[myfn[p]==#,{p,.00002,.00001}])&,{.68,.95,.99}],PlotRange->All,
	ContourShading->False,PlotPoints->100]*)

Ch. 5: Random numbers and Central Limit Theorem

CleanUp

Clear["Global`*"]

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

Generate 100000 random numbers uniformily distributed in the interval 0-1.

ran=Table[RandomReal[],{1000000}];

Bin the random numbers

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

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

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

Adding additional Plot features like plot and axes labelling and plotstyle.

sh1=ListPlot[ranpl,PlotJoined->True,Frame->True,
		PlotRange->{{0,1.},{0,.06}},PlotStyle->Dashing[{0.01,0.01}],	PlotLabel->Style["My Plot",{"Helvetica-Bold",12}],FrameLabel->{Style["Bin Center",{"Helvetica-Bold",12}],
		Style["Count",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Demonstration of the 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.

nave=5;

Make a list of random numbers formed from averaging sets of nave random numbers generated in previous exercise.

Details

ranave=Table[Total[Take[ran,{i,i+nave-1}]]/nave,{i,1,100000,nave}];

Length[ranave]

binIncrement=0.05;ybinave=BinCounts[ranave,{0,1,binIncrement}]

ybinaveNormalized=(ybinave/(binIncrement*Total[ybinave]));

plranave=Transpose[{xbin,ybinaveNormalized}];

shave=ListPlot[plranave,PlotJoined->True,
		PlotRange->{{0,1},{0,1.2*Max[ybinaveNormalized]}},Frame->True]

Plot a Gaussian with the same mean and standard deviation.

sh2=Plot[PDF[NormalDistribution[0.5,StandardDeviation[ranave]],x],{x,0,1},PlotStyle->{Thickness[0.005],Dashing[{0.015,0.015}]},Frame->True,Axes->False]

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

Comparison of the distribution of the average of 5 values with a Gaussian 
of the same mean and standard deviation.

plcompare=Show[sh2,shave,PlotRange->{{0,1.},All},Frame->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",10}],FrameLabel->{Style[xlabel,{"Helvetica-Bold",16}],
		Style["PDF",{"Helvetica-Bold",14}]},BaseStyle -> {"Helvetica-Bold",12},FrameStyle->Thickness[0.006]]

Generalization: "Any quantity that stems from a large number of sub-processes 
                           is expected to have a Gaussian distribution."

The reason that the normal (Gaussian) distribution occurs so often 
                      is because measured quantities are frequently the result of a large 
                      number of effects, i.e., is some kind of averaged resultant of these
                      effects. Since the distribution of the average of a collection of random 
                      variables tends to a Gaussian, this is often what we observe.

The Central Limit Theorem (CLT) is both remarkable and of great practical value in data analysis. In frequentist statistics, we are frequently uncertain of the form of the sampling distribution the data is drawn from. 
The equivalent problem in a Bayesian analysis is the choice of likelihood function to use. 
By working with the averages of data points (frequently as few as 5 points), we can appeal to the CLT and make use of a Gaussian distribution for the likelihood function.

Ch. 5: Central Limit Theorem using convolution and the FFT

CleanUp

Remove["Global`*"]

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

Demonstration of the 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 a Fast Fourier Transform (FFT) implementation of convolution to compute the PDF of an average of m samples, following the example given in the text in chapter 5.

Create pr1 = a uniform PDF in the interval 0 to 1. Represent the distribution by n points 
with the Table command.

n=64;
d1=Table[1.0,{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 and plot

pr1=Join[d1,d2];

Set up a list of x values for the probability distribution

dx1=1.0/n;

xdata1=Table[i*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

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.},All},Frame->True,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",10}],FrameLabel->{Style[xlabel,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",16}]},BaseStyle -> {"Helvetica-Bold",12},FrameStyle->Thickness[0.006]]

Evaluate convolution for m = 2 case

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

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

m=2;
dx2=1.0/(m*n);
xdata2=Table[i*dx2,{i,ntot}];

Compute the normalization constant k2 to convert conv2 to a a normalized PDF pr2.
It insures the area under pr2 = 1.

k2=1.0/(Plus@@Re[conv2]*dx2)

pr2=k2*Re[conv2];

ave2=Transpose[{xdata2,pr2}];

area2= Plus@@pr2*dx2

mean2=Plus@@(xdata2*pr2)*dx2

var2=Plus@@((((xdata2-mean2))^2)*pr2)*dx2

sigma2=(Sqrt[var2])

Plot the probability distribution of the average of two points

pl2=ListPlot[ave2,PlotRange->{{0,1.},All},Frame->True,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",10}],FrameLabel->{Style[xlabel,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",16}]},BaseStyle -> {"Helvetica-Bold",12},FrameStyle->Thickness[0.006]]

Evaluate convolution for m = 4 case

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

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

m=4;
dx4=1.0/(m*n);
xdata4=Table[i*dx4,{i,ntot}];

Compute the normalization constant k4 to convert conv4 to a a normalized PDF pr4.
It insures the area under pr4 = 1.

k4=1.0/(Plus@@Re[conv4]*dx4)

pr4=k4*Re[conv4];

ave4=Transpose[{xdata4,pr4}];

area4= Plus@@pr4*dx4

mean4=Plus@@(xdata4*pr4)*dx4

var4=Plus@@((((xdata4-mean4))^2)*pr4)*dx4

sigma4=(Sqrt[var4])

Plot the probability distribution of the average of four points

pl4=ListPlot[ave4,PlotRange->{{0,1.},All},Frame->True,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",10}],FrameLabel->{Style[xlabel,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",16}]},BaseStyle -> {"Helvetica-Bold",12},FrameStyle->Thickness[0.006]]

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*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},PlotLabel->Style["",{"Helvetica-Bold",10}],FrameLabel->{Style[xlabel,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",16}]},BaseStyle -> {"Helvetica-Bold",12},FrameStyle->Thickness[0.006]]

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*dx8,{i,ntot}];

Compute the normalization constant k6 to convert conv6 to a a normalized PDF pr6.
It insures the area under pr6 = 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 eight points

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

Plot all cases on one graph

plall=Show[pl1,pl2,pl4,pl6,pl8,Graphics[{Text[StyleForm["n=1",FontSize->11,FontWeight->"Bold"],{0.8,1.6}],Arrow[{{0.75,1.55},{0.6,1.024}}],Text[StyleForm["n=2",FontSize->11,FontWeight->"Bold"],{0.75,2.24}],Arrow[{{0.7,2.21},{0.55,1.79}}],Text[StyleForm["n=4",FontSize->11,FontWeight->"Bold"],{0.7,2.88}],Arrow[{{0.65,2.82},{0.54,2.56}}],Text[StyleForm["n=6",FontSize->11,FontWeight->"Bold"],{0.67,3.52}],Arrow[{{0.62,3.46},{0.53,3.2}}],Text[StyleForm["n=8",FontSize->11,FontWeight->"Bold"],{0.3,3.65}],Arrow[{{0.34,3.58},{0.44,3.39}}]}],FrameStyle->Thickness[0.006]]

Compare computed PDF for m = 8 to Gaussian with the Same Mean and Variance

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

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

plboth=Show[GraphicsGrid[{{plall,plcompare}},Spacings->{Scaled[-0.1],Scaled[0.04]}]]

Ch. 5: Fourier test of random numbers

Introduction:

This notebook demonstrates a Fourier test of a sequence of random numbers as discussed in the section on pseudo-random numbers in the text.

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.

Remove["Global`*"]

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

Generate a pseudo-random sequence with a uniform distribution
in the interval -0.5 to +0.5

no=(2^18)

ran=Table[RandomReal[ ]-0.5,{no}];

Power spectral density from a FFT of the random sequence

Fourier analysis operations on digitally sampled data are efficiently carried out with the Discrete Fourier Transform  (DFT), and in particular with a fast version of the DFT called the Fast Fourier Transform (FFT). These topics are discussed in detail in the appendix entitled ``Discrete Fourier Transforms.'' Here we will simply give the Mathematica code for computing the one-sided power spectral density (PSD) from a FFT of the sequence of radom numbers. Details behind the one-sided PSD are given in Section B13 of the appendix.The first step involves computing the absolute value of the FFT. The PSD is proportional to the square of the absolute magnitude.

fftabs=Abs[Fourier[ran]];

psd2=fftabs fftabs;

Length[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 power spectral density = p1side

p1side=Table[f[i],{i,1,(no/2)+1}];

Now compute the frequency intervals. The frequency is the number of cycles in the total data sequence of no random numbers.

freq=Table[i-1,{i,1,(no/2)+1}];

PSD1=Transpose[{freq,p1side}];npsd1=Length[PSD1]

Plot the one-sided PSD

pl3=ListPlot[PSD1,PlotJoined->True,Frame->True,
PlotRange->{{0,40},{0,1.5}},FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["PSD",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Plot a histogram of the real component of the FFT of our random sequence

fftreal= Chop[Re[Fourier[ran]]];

plhist=Histogram[fftreal,Frame->True,PlotRange->All,FrameLabel->{Style["Fourier amplitude  (real)",{"Helvetica-Bold",12}],
		Style["Number",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

We can add the option HistogramScale->1 if we want to scale the heights of the bars so the area of the bars sum to unity. The ordinate is now a probability distribution function (PDF).

plhist1=Histogram[fftreal,Frame->True,PlotRange->All,HistogramScale->1,FrameLabel->{Style["Fourier amplitude  (real)",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

plcompare=Show[GraphicsGrid[{{pl3,plhist1}},Spacings->{Scaled[-0.1],Scaled[0.04]}]]

Make a repeating sequence of random numbers to see the effect of a periodicity

Take the first 50,000 random numbers from our original sequence.

n1=50000;ransub1=Take[ran,n1];Length[ransub1]

meanransub1=Mean[ransub1]

ransub=ransub1-meanransub1;

Make a sequence of 6 repeats of the 50,000 random numbers.

ran1a=Join[ransub,ransub,ransub,ransub,ransub,ransub];Length[ran1]

Take the first 262144  of this repeating sequence.

ran1=Take[ran1a,no];Length[ran1]

Now compute the one-sided PSD and histogram the real components of the FFT of this repeating random sequence.

fftabs1=Abs[Fourier[ran1]];

psd2=fftabs1 fftabs1;

Length[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.

p1side1=Table[f[i],{i,1,(no/2)+1}];

freq1=Table[i-1,{i,1,(no/2)+1}];

PSD1a=Transpose[{freq1,p1side1}];npsd1=Length[PSD1a]

Plot the one-sided PSD of the repeating sequence of random numbers

pl4=ListPlot[PSD1a,PlotJoined->True,Frame->True,Axes->False,
PlotRange->{{0,40},{0,1.5}},FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["PSD",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Plot a histogram of the real component of the FFT of the repeating sequence of random numbers

fftreal1= Chop[Re[Fourier[ran1]]];

Length[fftreal1]

fftreal1[[50]]

plhist2=Histogram[fftreal1,Frame->True,PlotRange->All,HistogramScale->1,FrameLabel->{Style["Fourier amplitude  (real)",{"Helvetica-Bold",12}],
		Style["Number",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Plot previous 4 graphs on the same plot

plcompare2=Show[GraphicsGrid[{{pl3,plhist1},{pl4,plhist2}},Spacings->{Scaled[-0.15],Scaled[0.1]}]]

Ch. 9: Bayesian analysis of two independent samples

Introduction

This is a Mathematrica implementation of the probability calculations discussed in the book in the section entitled,     
"Bayesian Comparison of Two Samples?".

Setup

Remove["Global`*"]

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

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.

(*directory="c:/gregory/";*)

fileprefix="riverB";

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

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

d1={13.2`,13.8`,8.7`,9.`,8.6`,9.9`,14.2`,9.7`,10.7`,8.3`,8.5`,9.2`}

d2={8.9`,9.1`,8.3`,6.`,7.7`,9.9`,9.9`,8.9`}

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=12;low=7;Rc=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))

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

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

sign=-Sign[(uH/uL)]

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

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

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

Mathematica does not allow variable definitions containing a character with an overhead bar so we will use Sbar to represent (OverBar[S]). 
 So pC(OverBar[S])k becomes pCSbark

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 Rc (((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 p(OverBar[C])Sk = p((OverBar[C]),S|(Subscript[D, 1]),(Subscript[D, 2]),I)× p((Subscript[D, 1]),(Subscript[D, 2])|I)

Mathematica does not allow variable definitions containing a character with an overhead bar so we will use Cbar to represent (OverBar[C]). 
 So p(OverBar[C])Sk becomes pCbarSk

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 (((Rc))^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 p(OverBar[C])(OverBar[S])k = p((OverBar[C]),(OverBar[S])|(Subscript[D, 1]),(Subscript[D, 2]),I)× p((Subscript[D, 1]),(Subscript[D, 2])|I)

Mathematica does not allow variable definitions containing a character with an overhead bar so we will use Sbar to represent (OverBar[S]). 
 So p(OverBar[C])(OverBar[S])k becomes pCbarSbark

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 (((Rc))^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

pCbar = 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

oddCbarC=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

oddSbarS=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},{"",""},{"            Hypothesis","Probability"},{"__________________________________________","___________"},{"C,S ≡ same mean, same standard deviation",pCS},{"(OverBar[C]),S ≡ different means, same standard deviation",pCbarS},{"C,(OverBar[S]) ≡same mean, different standard deviations",pCSbar},{"(OverBar[C]),(OverBar[S]) ≡different means, different standard deviations",pCbarSbar},{"",""},{"C ≡ means are the same",pC},{"(OverBar[C]) ≡ means are the different",pCbar},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[oddCbarC*100]/100]]},{"",""},{"S ≡ standard deviations are the same",pS},{"(OverBar[S]) ≡ standard deviations are different",pSbar},{"The odds ratio in favour of a difference","Odds="<>ToString[N[Round[oddSbarS*100]/100]]},{"",""},{"C,S ≡ same means and standard deviations",pCS},{"(OverBar[C])+(OverBar[S]) ≡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 (((Rc))^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,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["p(δ | S,(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

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 (((Rc))^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,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["δ  Mean Difference",{"Helvetica-Bold",12}],
		Style["p(δ | (Overscript[S, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

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},PlotJoined->True,Frame->True,PlotStyle->{Red,Blue,Green} ,Axes->False,	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}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Now some text to the figure.

plgraphicsδ=Graphics[{Text[Style["p(δ|S,D1,D2,I)",FontSize->12,FontWeight->"Bold",Blue],{1,0.15},{-1,0},{1,0}],Text[Style["p(δ | (Overscript[S, -]),D1,D2,I)",FontSize->12,FontWeight->"Bold",Green],{1,0.1},{-1,0},{1,0}],Text[Style["p(δ | D1,D2,I)",FontSize->12,FontWeight->"Bold",Red],{1,0.03},{-1,0},{1,0}]}];

Here we combine the figure with the graphics item above.

figδ=Show[{plδ,plgraphicsδ}]

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.  The upper and lower bounds on the plot can be varied by the user by setting scaleL and scaleH factors.

scaleL =30;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)]))/(Rc (((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,PlotJoined->True,Frame->True,Axes->False,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["p(r | C,(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

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.

scaleL =30;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(((Rc))^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,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["r  Standard Deviation Ratio",{"Helvetica-Bold",12}],
		Style["p(r | (Overscript[C, -]),(Subscript[D, 1]),(Subscript[D, 2]),I)",{"Helvetica-Bold",12}]},BaseStyle-> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

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 also computes the 95% credible region and the 99.9% credible region. 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 | s,D1,D2,I),  p(r | (Overscript[s, -]),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},PlotJoined->True,Frame->True,PlotStyle->{Red,Blue,Green} ,	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}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Now some text to the figure.

plgraphicsr=Graphics[{Text[Style["p(r|C,D1,D2,I)",FontSize->12,FontWeight->"Bold",Blue],{1.2,0.3},{-1,0},{1,0}],Text[Style["p(r | (Overscript[C, -]),D1,D2,I)",FontSize->12,FontWeight->"Bold",Green],{1.2,0.2},{-1,0},{1,0}],Text[Style["p(r | D1,D2,I)",FontSize->12,FontWeight->"Bold",Red],{1.2,0.1},{-1,0},{1,0}]}];

Here we combine the figure with the graphics item above.

figr=Show[{plr,plgraphicsr}]

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[figδ,DisplayFunction->$DisplayFunction]

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[figr,DisplayFunction->$DisplayFunction]

Following command will output the above graph as an EPS files with Mathematica fonts included.

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

Ch. 10: Joint credible region contouring

Clean up, turn off spelling warning & load std packages

Remove["Global`*"]

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

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).

ψ={{9.382716049382715`,371.60493827160485`},{371.60493827160485`,18802.469135802465`}};

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

AMPL={{-2.05451902811468`},{0.2753499821052214`}};

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[{locus95xy,locus68xy},PlotRange->All,PlotJoined->True,Frame->True,PlotStyle->{{Thickness[0.005],Dashing[{0.007,0.02}]},{Thickness[0.005],GrayLevel[0]}},Axes->False,FrameLabel->{Style["Intercept",{"Helvetica-Bold",12}],
		Style["Slope",{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]]

Ch. 11: Nonlinear Least-Squares Fit of multiple Gaussian spectral features

Nonlinear Least Squares 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.`,1.321621`},{1.18`,0.927121`},{1.36`,1.054724`},{1.54`,1.569297`},{1.72`,0.800868`},{1.9`,0.879037`},{2.08`,1.162857`},{2.26`,0.618547`},{2.44`,1.358476`},{2.62`,1.360688`},{2.8`,0.749667`},{2.98`,0.91112`},{3.16`,0.266897`},{3.34`,1.476439`},{3.52`,1.820672`},{3.7`,2.19999`},{3.88`,1.912508`},{4.06`,3.27174`},{4.24`,3.320367`},{4.42`,4.118385`},{4.6`,4.083971`},{4.78`,4.472147`},{4.96`,5.232908`},{5.14`,5.277042`},{5.32`,5.364467`},{5.5`,6.5799`},{5.68`,6.219237`},{5.86`,5.400785`},{6.04`,5.53652`},{6.22`,5.192352`},{6.4`,4.601292`},{6.58`,4.1967`},{6.76`,4.176883`},{6.94`,3.60271`},{7.12`,3.878649`},{7.3`,3.362851`},{7.48`,2.663747`},{7.66`,3.463277`},{7.84`,2.544788`},{8.02`,2.626185`},{8.2`,2.630755`},{8.38`,2.037979`},{8.56`,2.231781`},{8.74`,2.691214`},{8.92`,2.279144`},{9.1`,2.380645`},{9.28`,1.474731`},{9.46`,1.91148`},{9.64`,1.785421`},{9.82`,1.621869`},{10.`,2.278831`},{10.18`,2.869444`},{10.36`,3.449642`},{10.54`,3.396883`},{10.72`,4.378759`},{10.9`,4.079289`},{11.08`,4.470583`},{11.26`,4.612807`},{11.44`,4.983053`},{11.62`,5.488918`},{11.8`,4.61388`},{11.98`,4.64383`},{12.16`,4.409657`},{12.34`,3.825667`},{12.52`,3.233904`},{12.7`,3.1016`},{12.88`,2.012794`},{13.06`,2.948323`},{13.24`,1.617039`},{13.42`,1.897248`},{13.6`,1.421824`},{13.78`,1.578506`},{13.96`,1.379465`},{14.14`,1.320906`},{14.32`,1.039204`},{14.5`,1.006134`},{14.68`,0.74071`},{14.86`,1.005989`},{15.04`,0.920322`},{15.22`,1.196997`},{15.4`,1.01224`},{15.58`,1.327031`},{15.76`,0.770795`},{15.94`,0.834301`},{16.12`,0.683994`},{16.3`,0.957888`},{16.48`,0.863484`},{16.66`,0.752641`},{16.84`,0.957294`},{17.02`,0.539765`},{17.2`,1.023118`},{17.38`,1.042601`},{17.56`,0.59983`},{17.74`,1.192996`},{17.92`,1.085465`},{18.1`,1.014224`},{18.28`,0.760619`},{18.46`,0.791639`},{18.64`,0.98855`},{18.82`,0.84369`}};

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, and m = the number of fitted parameters. 
(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
Therefore (k^2) = ((Subscript[χ, meas]^2)/(n-m)), 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 (χ^2) of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the marginal (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, and m = the number of fitted parameters. 
(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
Therefore (k^2) = ((Subscript[χ, meas]^2)/(n-m)), 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]];

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 (χ^2) of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the marginal (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.0 },{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, and m = the number of fitted parameters. 
(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
Therefore (k^2) = ((Subscript[χ, meas]^2)/(n-m)), 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 (χ^2) of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the marginal (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.6},{c4, 4}};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).

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, and m = the number of fitted parameters. 
(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
Therefore (k^2) = ((Subscript[χ, meas]^2)/(n-m)), 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]];

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 (χ^2) of residuals

residmean=Mean[resids]

residvar=Variance[resids]

Compute the Laplacian approximation to the marginal (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 .

Before executing this section please rerun the the fit for the most probable model 
so the  parval and parerror variables will be correct for this part.

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))];

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.

npar=7;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]]}]

AbsoluteTiming[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"}]

Ch. 12: Markov chain Monte Carlo dynamic simulation using the Metropolis algorithm

Introduction

A Markov chain Monte Carlo (MCMC) simulation. Makes use of the Mathematica command Manipulate to dynamically explore the behavior of the MCMC as a function of the Gaussian proposal distribution characteristic width σ. For more information see Figure 12.3 of the text and accompanying explanation.

Setup

Clear["Global`*"]

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

Specify target probability distribution of interest labeled pdf.

pdf=0.087 (E^((1/2) (-(x-4) (0.595(x-4)-0.238 (y-3))-(-0.238(x-4)+0.595 (y-3))  (y-3))))+((E^((1/2) (-(x^2)-(y^2))))/(2 π));plcont=ContourPlot[pdf,{x,-4,10},{y,-4,10},PlotPoints->50,PlotRange->{{-5,10},{-5,10},{0,0.25}},Contours->15,ContourShading->False,PlotLabel->Style["",Medium],FrameLabel->{X,Y},LabelStyle->Directive[Black],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Manipulate operation that computes and displays MCMC results.

Manipulate[n=2000;x1=-4;y1=9;
xy=Table[{0,0},{i,1,n}];xy[[1,1]]=x1;xy[[1,2]]=y1;na=0;xpts=Table[0,{i,1,n}];ypts=Table[0,{i,1,n}];xpts[[1]]=x1;ypts[[1]]=y1;
xypts=Table[xm=xpts[[i-1]];ym=ypts[[i-1]];ndistx=NormalDistribution[xm,proposalSigma];ndisty=NormalDistribution[ym,proposalSigma];
ux=RandomReal[ndistx];uy=RandomReal[ndisty];p2=pdf/.{x->ux,y->uy};p1=pdf/.{x->xm,y->ym};r=p2/p1;u2=RandomReal[];If[u2≤r,xy[[i]]={ux,uy};xpts[[i]]=ux;ypts[[i]]=uy;na=na+1,xy[[i]]={xm,ym};xpts[[i]]=xm;ypts[[i]]=ym];xy[[i]],
{i,2,n}];plgraphics=Graphics[Text[Style["Proposal σ = "<>ToString[proposalSigma]<>"\nAcceptance rate = "<>ToString[100.*na/n]<>"%",FontSize->16,FontWeight->"Bold"],{-3,9},{-1,0},{1,0}]];
points=ListPlot[xypts,PlotRange->{{-5,10},{-5,10}},Frame->True,PlotLabel->Style["",Medium],PlotLabel->Style["",Medium],FrameLabel->{X,Y},LabelStyle->Directive[Black],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];xpoints=ListPlot[xpts,PlotRange->All,Frame->True,PlotLabel->Style["X  Trace",Medium],FrameLabel->{Iteration,X},LabelStyle->Directive[Black],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];ypoints=ListPlot[ypts,PlotRange->All,Frame->True,PlotLabel->Style["Y  Trace",Medium],FrameLabel->{Iteration,Y},LabelStyle->Directive[Black],FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];Show[GraphicsGrid[{{plgraphics,Show[plcont,points]},{xpoints,ypoints}}]],{proposalSigma,.2,10.2,1.0},SaveDefinitions->True]

Ch. 12: Markov chain Monte Carlo solution Problem 2 (spectral line model) with 
             the addition of an extra unknown noise parameter

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.

Eight 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 via a two stage adaptive control system. 
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 using restricted QuasiMonteCarlo integration, last stage in program.

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["PlotLegends`"]

Needs["ErrorBarPlots`"]

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];

nd=lendat=Length[dat1]

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,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Channel  number",{"Helvetica-Bold",14}],Style["Temperature",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.006]]

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

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]

Allowance for an extra noise term

Extra noise term, (Subscript[ϵ, 0i])

We can represent the measured data by the equation
                                             (Subscript[d, i])  = (Subscript[f, i]) + (Subscript[ϵ, i])+(Subscript[ϵ, 0i])
                (Subscript[d, i]) = (i^th)measured data value
                (Subscript[f, i]) = model prediction
                (Subscript[ϵ, i]) = component of  (Subscript[d, i]) which arises from measurement errors
                (Subscript[ϵ, 0i]) = any additional unknown measurement errors plus any real signal
                           in the data that cannot be explained by the model prediction (Subscript[f, i])

In the absence of detailed knowledge of the sampling distribution for  (Subscript[ϵ, 0i]) , other than that it has a finite variance, the Maximum Entropy principle tells us that a Gaussian distribution is the most conservative choice (i.e., maximally non committal about the information we don't have).
We therefore adopt a Gaussian distribution for  (Subscript[ϵ, 0i])  with a variance  (s^2). Thus the combination of  (Subscript[ϵ, i]) + (Subscript[ϵ, 0i]) has a Gaussian distribution with 
                                               variance = (Subscript[σ, i]^2) + (s^2)
In Bayesian analysis we can marginalize the unknown  s (integrate it out of the problem), which has the desirable effect of treating anything in the data that can't be explained by the model as noise, leading to most conservative estimates of the model parameters.

Significance of the (Subscript[ϵ, 0i]) term in model selection

Suppose we wanted to compare two models relevent to the problem of detecting extrasolar planets using precision radial velocity data. In this case let
 (Subscript[M, 0 ]) = no spectral line model. 
(Subscript[M, 0s ])= no line model including the possibility of extra noise beyond the known measurement errors.
(Subscript[M, 0 ]) =  1 spectral line model.

The program below allows for the addition of an extra noise parameter s

Parallel Tempering program

INITIALIZE PROGRAM VALUES

nthin=1; (* store MCMC iterations at a thinning interval of nthin *)

n=20000*nthin; (* number of MCMC iterations *)

For reasonable results the number of iterations, n >= 20, 000×nthin, where nthin is an option
that permits retaining the MCMC results at only every nthin iterations. Since successive
iterations are partially correlated using an nthin ≈ 10 reduces the correlation
and reduces the memory requirements for long iterations.

nβ=1;(* the number of choices of tempering parameter *)

βlis={1.0};
(* choice of tempering parameter values *)

(*βlis={0.12,0.18,0.32,0.56,1.0};*)
(* choice of tempering parameter values *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains *)

ns=10; (* ns is mean number of iterations between swap proposals *)

(* Note:the product nβ\[Cross]ns/(swap acceptance rate) should be ≈ 100 to 200*)

nplan=1; (* number of signal components to be fit each with its own set of parameters *)

np=4; (* np is the total number of model parameters computational explored + s if included *)

ncs=np; (* number of model parameter proposal sigma optimized by 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=1; (* 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 *)

avst[[4]]=StandardDeviation[dvec]; (* s start value. Remove if not using extra noise parameter *)

a4name= "s"; a4unit="  (mK)";(* name of parameter and units. Remove if not using extra noise parameter *)

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 *)

avmin[[4]]=0.;avMax[[4]]=0.5*ppeak;(* prior bounds on s *)

type={0,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;(* prior bounds on line center freq *)

bfmin[[2]]=0.1;bfMax[[2]]=100.0;(* prior bounds on line temperature *)

bfmin[[3]]=0.5;bfMax[[3]]=4.0;(* prior bounds on line width *)

bfmin[[4]]=0.;bfMax[[4]]=0.5*ppeak;(* prior bounds on s *)

STARTING PROPOSAL SIGMAS AND MINIMUM SIGMAS

σst=Table[0,{i,1,np}];(* initialize table of parameter proposal σ's *)

minσ=Table[0,{i,1,np}]; (* initialize table of parameter proposal σ's *)

Typically set start sigma to approximately 10 to 20% of the parameter search range. 
The proposal sigma for the first ncs are optimized by the control system. The remander are not changed.

σ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 *)

σst[[4]]=0.2*ppeak;(* sigma for proposal random Gaussian step *)

Set minimum proposal sigma for all np parameters that are explored not just the first ncs parameters.

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 *)

minσ[[4]]=Mean[errvec]/(Sqrt[nd]);(* 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))*np+3.1233*(10^(-4))*(np^2)-3.03567*(10^(-6))*(np^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/(np^((kalf^((βlis[[kn]])^(-1)))*alfm)))),{kn,1,nβ},{kj,1,ncs}]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS (depends on model)

mJlim=Mean[errvec];(* constant for modified Jeffreys prior for K *)

Version below include extra noise parameter s.

mJslim=Mean[errvec];(* constant for modified Jeffreys prior for s *)

c=-Log[(bfMax[[1]]-bfmin[[1]])*Log[((bfMax[[2]])/(bfmin[[2]]))]*(bfMax[[3]]-bfmin[[3]])*Log[((mJslim+bfMax[[4]])/mJslim)]];(* normalization constants for prior *)

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (depends on model)

Specify a procedure for calculation of basic work = prior×likelihood for model. 
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

Specify terms needed in calculation of model M1 likelihood

model[temperature_,f0_,σline_]:=temperature*Exp[-((((fvec-f0))^2)/(2*((σline)^2)))];(* specify the Gaussian line profile = likelihood dependence on f & T *)

Specify a procedure for calculation of 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]];s=av[[4]];
mvec=model[T,f,σl]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T*(s+mJslim)] ; (* the prior for parameters f & T *) 
serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(dvec-mvec)/serrvec;
loglike=logfact-Plus@@Log[serrvec]-0.5*y.y; (* likelihood fn for particular f,T,σl,s *)  
pvec={f,T,σl,s}]

MODULE THAT PROPOSES THE NEW PARAMETER SET 
(May need to add another parameter type depending 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 EXECUTES 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}]; 
swminσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ switches  *)
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;
σallT=Transpose[σall];σallT2=Take[σallT,ncs];σallTrem=Take[σallT,-(np-ncs)];
σallT2T=Transpose[σallT2];
Do[σallT2T[[k]]=σallT2T[[k]]*(Sqrt[((N[accept1[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept1[[k]]/n1]+0.01)))]),
{k,nβlow,nβ}];
σallT2TT=Transpose[σallT2T];σall=Transpose[Join[σallT2TT,σallTrem]];
(**************************************************************)
(* 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;
σallT=Transpose[σall];σallT2=Take[σallT,ncs];σallTrem=Take[σallT,-(np-ncs)];
σallT2T=Transpose[σallT2];
Do[σallT2T[[k]]=σallT2T[[k]]*(Sqrt[((N[accept2[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept1[[k]]/n1]+0.01)))]),
{k,nβlow,nβ}];
σallT2TT=Transpose[σallT2T];σall=Transpose[Join[σallT2TT,σallTrem]];
(**************************************************************)
(* 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

To output only the β = 1 tempering level results (need to remove the (* *) at the ends of lines).

(* tr=Transpose[logpdfβi];tr5=tr[[nβ]];ng=Length[tr5];stmp=OpenWrite["c:/greg1/math/P509/Ch12SolutionM7.dat",PageWidth->Infinity];
Do[Write[stmp,tr5[[i]]],{i,1,ng}];Close[stmp] *)

Here is how to input results (need to remove the (* *) at the ends of lines).

(* dataMC=ReadList["c:/greg1/math/P509/Ch12SolutionM7.dat"];logpdfβi=Transpose[Table[dataMC,{k,1,nβ}]];nnt=Length[logpdfβi];n=nthin*nnt;ng=nnt *)

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])

Evolution of control system error (er) in colour

The code below allows for an arbitary number of tempering levels.

erpl=Table[1,{nβ}];σertime={};If[tol2<1,diag1=diag,diag1=Join[diag,{Table[{sw[[k]],er[[k]],0,0,ncsys,0},{k,1,nβ}]},{Table[{0,0,0,0,n,0},{k,1,nβ}]}]];ndiag=Length[diag1];Do[Do[σertime=Append[σertime,{diag1[[i,j,5]],diag1[[i,j,2]]}],{i,ndiag}];erpl[[j]]=σertime;σertime={},{j,1,nβ}];plerCol=ListPlot[Table[erpl[[ii]],{ii,1,nβ}],Joined->True,Frame->True,PlotStyle->If[nβ>1,Table[If[ij<nβ,{Hue[1.0*(ij-1)/nβ],Thickness[0.005],Dashing[{0.015,0.015}]},{Hue[0.0],Thickness[0.01]}],{ij,1,nβ}],{Hue[0.0],Thickness[0.01]}],FrameLabel->{Style["Iteration",{"Helvetica-Bold",12}],Style["Error",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

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. Note: for a nearly circular orbit the two parameters χ and ω are highly correlated
and are separately not well determined. Even then, the combination 2 π χ + ω is well constrained.

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]

Note on test for convergence:

The Gelman-Rubin statistic is frequently used to decide on convergence of an MCMC chain. Normally, the MCMC test of
    convergence is to run repeated simulations with different starting points and compute the Gelman-Rubin
    statistic for each parameter from the post burn-in iterations of 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) simulation.
         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.

If parallel tempering MCMC is used (nβ>1), roughly every 2*(nthin = 10)*(nβ=8) = 160 iterations the β=1 iterations
    accepts a swap from its neigboring independent simulation some of which are to locations that are remote 
    in parameter space. The final β=1 simulation is thus a combination of a large number of independent 
    simulations. One can divide the final β=1 post burn-in iterations into typically 10 equal intervals and intercompare 
    the ten different and essentially independent distributions for each parameter using the Gelman-Rubin test.

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]

ncsys

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[trnnx,PlotRange->{0.995*Min[trnnx],1.0005*Max[trnnx]},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->{"Helvetica-Bold",12}],
plh[[i]]=Histogram[trnn[[i]],PlotRange->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->{"Helvetica-Bold",12}]],{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],Joined->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}];

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,Joined->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},Joined->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);

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},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.2],Scaled[-0.02]}]]

(*Export["c:/temp/Ch12Problem2SolutionM6AmeanFit.eps", plboth,ImageSize->72*7]*)

Summary graphs of above section.

plboth=Show[GraphicsGrid[{{plshp1r,plmapfitmeanb},{plshp2meanb,plmapfitmeanrb}},Spacings->{Scaled[-0.1],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,Joined->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},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]}]]

Summary graphs of above section.

plboth=Show[GraphicsGrid[{{plfitdatpk},{plshp2b}},Spacings->{Scaled[-0.2],Scaled[0]}]]

Compare models via 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β <nβmin.))
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 10) 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 marginal (global) likelihood for spectral line model

Here we compute  the log of the global likelihood of the model, which is designated by  logpDM1
                logpDM1=log[p(D|(Subscript[M, 1]),I)]=∫ (Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T,σl,s,I)] ⟩, β])  dβ
(Subscript[⟨ log[p(D|(Subscript[M, 1]),f,T,σl,s,I)] ⟩, β]) =expectation value oflog[p(D|(Subscript[M, 1]),f,T,σl,s,I)]  for given β
                                              =(1/n)(∑_(t=1)^n)  log[p(D|(Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),(Subscript[s, 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]].

{{0.0001, 52.8938, 0.399333, 4.44881, 1.88479, 8000, -118.278, -7.12372}, 
{0.001, 57.7844, 0.178494, 0.827143, 1.70917, 8000, -115.028, -6.35887}, 
{0.01, 34.303, 1.65567, 5.16243, 0.290197, 8000, -94.5869, -8.67527}, 
{0.025, 46.2336, 0.478354, 1.0978, 0.457332, 8000, -105.297, -9.24204}, 
{0.1, 38.8661, 1.18733, 5.02006, 0.475259, 8000, -95.3071, -17.0617}, 
{0.2, 54.0101, 0.445329, 3.70215, 0.673405, 8000, -105.178, -27.7119}, 
{0.3, 34.4672, 1.46945, 4.89045, 0.480744, 8000, -94.5159, -36.1026}, 
{0.45, 37.0857, 2.07919, 4.98019, 0.944996, 8000, -96.9313, -51.9867}, 
{0.6, 36.7766, 2.58806, 2.97222, 0.171109, 8000, -88.6293, -61.2568}, 
{0.75, 37.4222, 3.362, 1.77001, 0.183936, 8000, -86.6594, -73.3463}, 
{1., 36.9846, 1.99585, 4.25679, 0.160469, 8000, -90.8971, -98.7074}}

The quantity  log[p(D| (Subscript[M, 1]),(Subscript[f, t,β ]),(Subscript[T, t,β]) ,(Subscript[σl, t,β]),(Subscript[s, 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.

Set nβmin, the minimum number of tempering levels before it makes any sense to compute the 
global likelihood of the model by this method.

nβmin=10;

First check that you are happy with the burn -in value, nburn.

nburn

If[nβ>nβmin,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β>nβmin,expect]

If[nβ>nβmin,βlis]

If[nβ>nβmin,pl1=ListPlot[Transpose[{Log[10,βlis],expect}],Frame->True,Axes->False,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β>nβmin,Transpose[{Log[10,βlis],expect}]]

If[nβ>nβmin,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β>nβmin,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect]]

If[nβ>nβmin,,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β>nβmin,plBayesFactor=Show[pl1,pl4,PlotRange->All]]

Now we want to convert to a table with linear coordinates.

If[nβ>nβmin,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β>nβmin,logDpM1=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β>nβmin,Exp[logpDM1],]

Suppose we drop the first nn  β levels and redo the calculation of the log of the global likelihood for M1.

nn=1;

If[nβ>nβmin,Log[10,Drop[βlis,nn]]]

If[nβ>nβmin,Drop[expect,nn]]

If[nβ⩾(nβmin+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β⩾(nβmin+nn),newexpect2=Table[{x,spline2[x]},{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2]]

If[nβ⩾(nβmin+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β⩾(nβmin+nn),logpDM1A=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β⩾(nβmin+nn),Exp[logpDM1A],]

Compute p(D|M0,I), the marginal likelihood for no line model

Calculation details:

Assumes no line present and a random Gaussian extra noise term of unknown sigma s.

As a practical matter we need to choose suitable limits of integration of these two parameters.
If we simply use the prior limits NIntegrate may converge to slowly because of the huge dynamic 
range of the quantity to be integrated.

smintemp=avmin[[4]];(* lower integration limit for s parameter by default this should be avmin[[4]] *)

smaxtemp=avMax[[4]];(* upper integration limit for s parameter by default this should be avMax[[4]]*)

If[ncsys<n,s=.;
If[swb>0,
fact= ((((2 π))^(-nd/2))/(Log[1+((bfMax[[4]])/mJslim)]));wk=(serrvecsq=(errvec^2)+(s^2);term1=Times@@((serrvecsq^(-0.5)))/(s+mJslim)*Exp[-Plus@@(0.5*(dvec^2)/serrvecsq)]);term2=NIntegrate[term1,{s,smintemp,smaxtemp}];pDM0s=fact*term2];
pDM0=fact*term2
]

logpDM0=Log[pDM0]

Compute Bayes factor

If[nβ>nβmin,odds=Exp[logpDM1-logpDM0],]

If[nβ⩾(nβmin+nn),odds=Exp[logpDM1A-logpDM0],]

Compare models via the Bayes factor using restricted quasi Monte Carlo integration

Compares model M1 to model M2 (rejecting the first nburn samples). 
Quasi Monte Carlo (QMC) Bayes factor calculation is efficient for models with 
a  moderate number of parameters (< 12), 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 marginal (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;s=pars;mvec=model[T,f,σl]; (* define mvec, the vector of model predictions *)
logprior=c-Log[T*(s+mJslim)] ; (* the prior for parameters f & T *) 
serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(dvec-mvec)/serrvec;
loglike=logfact-Plus@@Log[serrvec]-0.5*y.y  
]

logpDM1B=Log[NIntegrate[work1;Exp[logprior+loglike],{parf,low[[1]],hi[[1]]},{parT,low[[2]],hi[[2]]},{parσl,low[[3]],hi[[3]]},{pars,low[[4]],hi[[4]]},Method->"QuasiMonteCarlo",AccuracyGoal->12]]

Exp[logpDM1B]

Compute p(D|M0,I), the marginal likelihood for no line model

Calculation details:

Assumes no line present and a random Gaussian extra noise term of unknown sigma s.

As a practical matter we need to choose suitable limits of integration of these two parameters.
If we simply use the prior limits NIntegrate may converge to slowly because of the huge dynamic 
range of the quantity to be integrated.

smintemp=avmin[[4]];(* lower integration limit for s parameter by default this should be avmin[[4]] *)

smaxtemp=avMax[[4]];(* upper integration limit for s parameter by default this should be avMax[[4]]*)

If[ncsys<n,s=.;
If[swb>0,
fact= ((((2 π))^(-nd/2))/(Log[1+((bfMax[[4]])/mJslim)]));wk=(serrvecsq=(errvec^2)+(s^2);term1=Times@@((serrvecsq^(-0.5)))/(s+mJslim)*Exp[-Plus@@(0.5*(dvec^2)/serrvecsq)]);term2=NIntegrate[term1,{s,smintemp,smaxtemp}];pDM0s=fact*term2];
pDM0=fact*term2
]

logpDM0=Log[pDM0]

Compute Bayes factor

odds=Exp[logpDM1B-logpDM0]

Ch. 12: Markov chain Monte Carlo powered Kepler periodogram

Introduction

This notebook was designed to analyse an astronomical data set consisting of precision radial velocity measurements of a star that is spected of having a planet (see Section 12.9 of my book). It employs a semi-automatic parallel tempering (Section 12.8 ) version of Markov Chain Monte Carlo. The program automates the selection of Gaussian proposal σ's, one for each parameter.

In this implementation multiple MCMC chains can be run in parallel each with a different tempering parameter β. The number of chains (β values) can easily be modified. The default set of β values have worked well for a variety of data sets. At random intervals, proposals to swap the parameter values of a random pair of chains is considered. Parallel tempering helps to prevent the MCMC from becoming trapped in a local probability peak region. 
The program employs a two stage statistical control system to automatically establish a useful set of Gaussian proposal distribution σ's. The user must specify an initial proposal σ for each parameter (typically, 1/10th the prior range of  the parameter). Useful parameter iterations are obtained after the control system terminates.

The program searches in continuous frequency space although the frequency parameter is stored as a period as this is usually of more interest for exoplanets.

For background information on this program please see: 
          1)  Secton 12.9 of the text.
          2) 'A Bayesian Analysis of Extrasolar Planet Data for HD 73526'
                     Gregory, P. C. (2005), Astrophysical Journal 631, 1198.  
            3) 'A Bayesian Kepler Periodogram Detects a Second Planet in HD 208487', 
                     Gregory, P.C. (2007), MNRAS, 374, pp. 1321-1333.
            4) 'A Bayesian Periodogram Finds Evidence for Three Planets in HD 11964 '', 
                     Gregory, P.C. (2007), MNRAS, 381, pp. 1607-1619

             All are available from my web site: http://www.physics.ubc.ca/~gregory/gregory.html

Models and calculation details

Hypothesis (model) space of interest

We can represent the measured radial velocities by the equation
                                             (Subscript[v, i])  = (Subscript[f, i]) + (Subscript[ϵ, i])+(Subscript[ϵ, 0i])
           (Subscript[v, i]) = measured radial velocity at (Subscript[t, i])
            (Subscript[f, i]) = model prediction of radial velocity at (Subscript[t, i])
           (Subscript[ϵ, i]) = component of  (Subscript[v, i]) which arises from measurement errors
        (Subscript[ϵ, 0i]) = any additional unknown measurement errors plus any real signal
                           in the data that cannot be explained by the model prediction (Subscript[f, i])

In the absence of detailed knowledge of the sampling distribution for  (Subscript[ϵ, 0i]) , other than that it has a finite variance, the Maximum Entropy principle tells us that a Gaussian distribution is the most conservative choice (i.e., maximally non committal about the information we don't have).
We therefore adopt a Gaussian distribution for  (Subscript[ϵ, 0i])  with a variance  (s^2). Thus the combination of  (Subscript[ϵ, i]) + (Subscript[ϵ, 0i]) has a Gaussian distribution with 
                                               variance = (Subscript[σ, i]^2) + (s^2)
In Bayesian analysis we can marginalize the unknown  s (integrate it out of the problem), which has the desirable effect of treating anything in the data that can't be explained by the model as noise, leading to most conservative estimates of the model parameters.

This analysis differs slightly from that presented in Section 12.9 of the text. In particular, Section 12.9 employed a noise scale parameter b (see equation 12.29). Here, instead we use an extra Gaussian noise term parameterized by the Gaussian standard deviation s following the treatment in my Astrophysical Journal paper referred to above.

Calculation details

Raw data consists of a time series (uniform sampling not required). 
In present example it consists of triples of 
{Julian Days, radial velocity (m (s^(-1))), uncertainty (m (s^(-1)))}.
Let tvec= a vector of dates.
Let dvec = a vector of the radial velocities (RV).
Let errvec = a vector of errors.

Let (Subscript[v, i]) = radial velocity at (Subscript[t, i]).
Let (Subscript[e, i]) = (i^(th ))radial velocity at error.

(Subscript[v, i]) = V + K [ cos(θ((Subscript[t, i]) + χ P)+ω) + e cos ω]

where K = ((2 π a sin i)/(P(Sqrt[1-(e^2)])))
a = semi-major axis
e = orbital eccentricity
θ = position of star in orbit as an angle measured with respect to periastron
P  = orbital period
i = inclination of orbit with respect to plane of the sky, i = 0 corresponds to orbit in sky plane
χ = fraction of an orbit, prior to (1^st) data point, that periastron occurred.
Thus χP = number of days prior to (Subscript[t, i]) =0.
ω = longitude of periastron, angle between periastron and ascending node 
V = systematic velocity of star

Re-parameterization: for a nearly circular orbit  the two parameters χ and ω are highly correlated 
    (i.e., periastron  meaningless for a circulr orbit)  and are separately not well determined.  
    Instead we use ψ = 2 π χ + ω and ϕ = 2 π χ - ω.
    The combination ψ = 2 π χ + ω is well constrained for all eccentricities.  
    The combination ϕ = 2 π χ - ω is not well constrained but is at least orthogonal to ψ.

Orbital time → Orbital phase

Convert (Subscript[t, i])to orbital phase θ((Subscript[t, i])) by finding the solution to the differential equation
((dθ[t])/dt)-(Sqrt[((G((SubStar[M])+(Subscript[M, planet])))/((a^3)(((1-(e^2)))^3)))])(((1+e Cos[θ]))^2)=0  

((dθ[t])/dt)-((2*π)/(P(((1-(e^2)))^(3/2))))(((1+e Cos[θ]))^2)=0 

assuming the initial condition θ[0] = ϕ.  
Here ϕ = location of star in orbit at start of data taking, an unknown parameter.

To solve for (Subscript[θ, i ])values use the following commands:

function = ((2*π)/(P*(((1-(e^2)))^(3/2))))(((1+e*Cos[θ[t]]))^2);

ndiffeq =θ'[t] - function==0;

numsol=NDSolve[{ndiffeq,θ[tstart]==ϕ},θ,{t,tstart,tend}];

θvec=Flatten[θ[tvec]/.numsol];

This function takes time values (in the same units as the period)  from periastron and 
converts them to orbit angles in radians.

The above scheme runs into problems when the period P is small because NDSolve produces an interpolation function that spans the range  {t,tstart,tend}. If there are many cycles a very large number of iteration steps are required and the procedure slows to a crawl.  The solution is to first convert the tvec to fvec, a vector of corresponding fractions of one orbit. Then we only need to produce an interpolation for one orbit {q,0,1}. The following code accomplishes this.

fvec=Mod[tvec/P+χ,1];
ndiffeq =θ'[q] - ((2*π)/(((1-(e^2)))^(3/2)))(((1+e*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];
θvec=Flatten[θ[fvec]/.numsol];

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["ErrorBarPlots`"]

List and plot data for HD 208487 (ref. Butler et al., Astrophysical Journal, 646, 505-522, 2006)

Each line of the data, named dat, consists of (Julian day - 2,440,000, RV (m (s^(-1))),  
uncertainty (m (s^(-1)))).

dat1={{11034.178356`,-19.`,5.8`},{11413.095781`,-27.9`,5.9`},{11683.285938`,-15.6`,6.1`},{11743.203438`,31.4`,7.`},{11767.121759`,10.5`,5.2`},{11828.936701`,0.6`,8.1`},{12062.284491`,-9.9`,5.3`},{12092.186042`,-0.2`,5.8`},{12130.090035`,16.5`,5.8`},{12151.060868`,10.`,5.9`},{12151.993854`,9.4`,5.4`},{12152.974595`,12.1`,4.8`},{12154.05537`,3.1`,6.7`},{12186.937095`,-18.1`,4.5`},{12188.013333`,-26.9`,4.5`},{12189.074748`,-23.4`,3.9`},{12189.959583`,-18.6`,4.9`},{12388.3075`,-0.6`,5.`},{12477.163264`,-7.7`,5.9`},{12598.945741`,0.6`,5.9`},{12784.267493`,17.7`,3.6`},{12859.141461`,2.4`,4.9`},{12943.068619`,4.4`,5.`},{12946.995428`,0.4`,5.4`},{13214.190574`,-15.4`,4.8`},{13215.185265`,-17.4`,3.8`},{13216.222735`,-21.2`,3.7`},{13243.248715`,-19.5`,5.8`},{13244.146101`,-15.5`,4.6`},{13245.140359`,-27.4`,5.5`},{13245.935417`,-17.9`,5.7`},{13282.010509`,-3.`,12.`},{13489.276689`,-11.9`,3.9`},{13573.180169`,31.7`,5.6`},{13664.985292`,11.1`,4.`}}

Details concerning data manipulation and statistics.

tarr1=Transpose[dat1];

tvec1=N[tarr1[[1]]];

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

errvec1=N[tarr1[[3]]];

Average data interval

Last[tvec1-tvec1[[1]]]/(Length[tvec1]-1)

Translate tvec1 values by subtracting off tvec1[[1]]

dat=Transpose[{tvec1-Mean[tvec1],dvec1,errvec1}];

nd=lendat=Length[dat]

tarr=Transpose[dat];

tvec=N[tarr[[1]]]

tstart=tvec[[1]];tend=tvec[[nd]];

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

errvec=N[tarr[[3]]]

Mean[errvec]

data=Transpose[{tvec,dvec}];

Compute reference Julian Day number

tvecAve=Mean[tvec1]

tvecRef=2440000.+tvecAve

IntegerPart[tvecRef]

FractionalPart[tvecRef]

cmp1=IntegerPart[tvecRef/(10^6)];
cmp2=IntegerPart[(tvecRef-cmp1*(10^6))/(10^5)];cmp3=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5))/(10^4)];cmp4=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4))/(10^3)];cmp5=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3))/(10^2)];cmp6=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2))/10];cmp7=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2)-cmp6*10)];
cmp8=IntegerPart[10*(tvecRef-IntegerPart[tvecRef])];cmp9=IntegerPart[100*(tvecRef-IntegerPart[tvecRef])-cmp8*10];cmp10=IntegerPart[1000*(tvecRef-IntegerPart[tvecRef])-cmp8*100-cmp9*10];cmp11=IntegerPart[10000*(tvecRef-IntegerPart[tvecRef])-cmp8*1000-cmp9*100-cmp10*10];timelabel=ToString[cmp1]<>","<>ToString[cmp2]<>ToString[cmp3]<>ToString[cmp4]<>","<>ToString[cmp5]<>ToString[cmp6]<>ToString[cmp7]<>"."<>ToString[cmp8]<>ToString[cmp9]<>ToString[cmp10]<>ToString[cmp11]

Plot the data

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",14}],Style["Velocity  ((ms^(-1)))",{"Helvetica-Bold",14}]},BaseStyle->{"Helvetica-Bold",13},FrameStyle->Thickness[0.006]]

plshp1a=Show[plshp1,Graphics[{Text["(a)",{0,-30}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Parallel tempering MCMC program:

INITIALIZE PROGRAM VALUES

nthin=1; (* store MCMC iterations at a thinning interval of nthin *)

n=40000*nthin; (* number of MCMC iterations *)

For reasonable results the number of iterations, n >= 20, 000×nthin, where nthin is an option
that permits retaining the MCMC results at only every nthin iterations. Since successive
iterations are partially correlated using an nthin ≈ 10 reduces the correlation
and reduces the memory requirements for long iterations.

nplan=1; (* number of planets to be fit *)

mstar=0.95; (* mass of star in units of a solar mass *)

nβ=4;(* the number of choices of tempering parameter *)

βlis={0.1,0.32,0.55,1.0};
(* choice of tempering parameter values *)

ns=10; (* ns is mean number of iterations between swap proposals *)

(* Note:the product nβ\[Cross]ns/(swap acceptance rate) should be ≈ 100 to 200*)

np=7; (* np is the number of model parameters computational explored + s if included *)

ncs=np; (* number of model parameter proposal sigma optimized by 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=1; (* 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]]=10.0; (* P parameter start value, make sure it is within the search range *)

a1name= "(Subscript[P, 1])"; a1unit="  (d)";(* name of parameter and units *)

avst[[2]]=0.0; (* eccentricity start value *)

a2name= "(Subscript[e, 1])"; a2unit=" "; (* name of parameter and units*)

avst[[3]]=0.0; (* systematic velocity start value *)

a3name= "V"; a3unit="  (m (s^(-1)))"; (* name of parameter and units *)

avst[[4]]=6.0; (* initial value of 2π χ + ω *)

a4name= "2π (Subscript[χ, 1]) + (Subscript[ω, 1])"; a4unit=" "; (* name of parameter and units *)

avst[[5]]=30.0; (* K start value *)

a5name= "(Subscript[K, 1])"; a5unit="  (m (s^(-1)))" ;(* name of parameter and units *)

avst[[6]]=0.0; (* 2π χ - ω start value *)

a6name= "2π (Subscript[χ, 1]) - (Subscript[ω, 1])"; a6unit=" "; (* name of parameter and units *)

avst[[7]]=StandardDeviation[dvec]; (* s start value. Remove if not using extra noise parameter *)

a7name= "s"; a7unit="  (m (s^(-1)))"; (* name of parameter  and units. Remove if not using extra noise parameter *)

PRIOR SEARCH RANGES

avmin[[1]]=1.01;avMax[[1]]=10.0*dur;(* prior bounds on orbital period *)

avmin[[2]]=0.0;avMax[[2]]=0.99;(* prior bounds on eccentricity *)

avmin[[3]]=-2129.;avMax[[3]]=2129.;(* limits on systematic velocity *)

avmin[[4]]=0.;avMax[[4]]=4*π;(* prior bounds on 2(Subscript[πχ, 1])+(Subscript[ω, 1])*)

avmin[[5]]=0.;avMax[[5]]=2129.;(* prior bounds on (Subscript[K, 1]) *)

avmin[[6]]=-2*π;avMax[[6]]=2*π;(* prior bounds on 2(Subscript[πχ, 1])-(Subscript[ω, 1]) *)

avmin[[7]]=0;avMax[[7]]=2129.;(* prior bounds on s *)

type={-1,0,0,2,5,4,0}; (* If type = -1, parameter is a period *)
(* type = 1, angular parameter, wrap around at 0 and 1 *)
(* type = 2, angular parameter, wrap around at 0 and 4π *)
(* type = 3, angular parameter, wrap around at 0 and 4π *)
(* type = 4, angular parameter, wrap around at -2π and 2π *)
(* type = 5, parameter is velocity amplitude (Subscript[K, 1]) *)
(* type = 6, parameter is velocity amplitude (Subscript[K, 2]) *)
(* type = 7, parameter is velocity amplitude (Subscript[K, 3]) *)
(* type = 8, parameter is velocity amplitude (Subscript[K, 4]) *)
(* type = 9, parameter is velocity amplitude (Subscript[K, 5]) *)
(* type = 0, all other parameters *)

PRIOR RANGE FOR BAYES FACTOR CALCULATION

bfmin[[1]]=1.01;bfMax[[1]]=365250.;(* prior bounds on orbital period *)

bfmin[[2]]=0.0;bfMax[[2]]=0.99;(* prior bounds on eccentricity *)

bfmin[[3]]=-2129.;bfMax[[3]]=2129.;(* limits on systematic velocity *)

bfmin[[4]]=0;bfMax[[4]]=4*π;(* prior bounds on 2πχ+ω*)

bfmin[[5]]=0;bfMax[[5]]=2129.;(* prior bounds on (Subscript[K, 1]) *)

bfmin[[6]]=-2π;bfMax[[6]]=2*π;(* prior bounds on 2πχ-ω *)

bfmin[[7]]=0;bfMax[[7]]=2129.;(* prior lower bound on s, extra noise term *)

STARTING PROPOSAL SIGMAS AND MINIMUM SIGMAS

σst=Table[0,{i,1,np}];(* initialize table of parameter proposal σ's *)

minσ=Table[0,{i,1,np}]; (* initialize table of parameter proposal σ's *)

Typically set start sigma to approximately 10 to 20% of the parameter search range. 
The proposal sigma for the first ncs are optimized by the control system. The remander are not changed.

σst[[1]]=0.1*(1./avmin[[1]]-1./avMax[[1]]);(* sigma for a1 proposal random Gaussian step *)

σst[[2]]=0.2; (* sigma for proposal random Gaussian step *)

σst[[3]]=30.0; (* sigma for roposal random Gaussian step *)

σst[[4]]=1.2; (* sigma for proposal random Gaussian step *)

σst[[5]]=20.0; (* sigma for proposal random Gaussian step *)

σst[[6]]=1.2; (* sigma for proposal random Gaussian step *)

σst[[7]]=10.;(* sigma for proposal random Gaussian step *)

Set minimum proposal sigmas for all np parameters that are explored not just the first ncs parameters.

dur=tend-tstart;

ppeak=Max[dvec]-Min[dvec];

sigTonoise=0.5*ppeak/Median[errvec];

minσ[[1]]=1/(1.6*sigTonoise*dur*(Sqrt[nd]));(* min sigma for proposal random Gaussian step *)

minσ[[2]]=0.5/(sigTonoise*(Sqrt[nd])); (* min sigma for proposal random Gaussian step *)

minσ[[3]]=Mean[errvec]/(Sqrt[nd]);  (* min sigma for proposal random Gaussian step *)

minσ[[4]]=0.5/(sigTonoise*(Sqrt[nd])); (* min sigma for proposal random Gaussian step *)

minσ[[5]]=Mean[errvec]/(Sqrt[nd]); (* min sigma for proposal random Gaussian step *)

minσ[[6]]=2.0/(sigTonoise*(Sqrt[nd])); (* min sigma for proposal random Gaussian step *)

minσ[[7]]=Mean[errvec]/(Sqrt[nd]);(* sigma for s proposal random Gaussian step *)

CONTROL SYSTEM PARAMETERS  (user don't change this)

minCS=10000; (* minimum number of iterations before Control System turned off *)

maxCS=15000; (* 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 *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains *)

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 *)

smp=0;(* smp=0 or 1, smp=1 better multiple peak detection, reduced acceptance rate*)

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=If[ nβ>1,Table[0.7-(nβ-i)*0.1/(nβ-1),{i,1,nβ}],0.7](* gain x scmax = max factor to reduce/increase proposal σ's *)

γ=1.6; (* damping exponent in annealing process *)

alfm=0.806096-1.12051*(10^(-2))*np+3.1233*(10^(-4))*(np^2)-3.03567*(10^(-6))*(np^3);(* Scaling exponent for calulation of accept rate for individual parameters 2nd stage CS *)

kalf=0.92; (* Empirical factor for scaling exponent, typical value 0.87 *)

accept=Table[(((λ))^(1/(np^((kalf^((βlis[[kn]])^(-1)))*alfm)))),{kn,1,nβ},{kj,1,ncs}]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS (depends on model)

mJlim=1.0;(* constant for modified Jeffreys prior for K *)

Version below include extra noise parameter s.

mJslim=1.0;(* constant for modified Jeffreys prior for s *)

c=Log[nplan!]-Log[(8^nplan)*((((π^2)))^nplan)*Log[((bfMax[[1]])/(bfmin[[1]]))]*(bfMax[[2]]-bfmin[[2]])*(bfMax[[3]]-bfmin[[3]])*Log[((mJslim+bfMax[[7]])/mJslim)]]

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (depends on model)

Specify a procedure for calculation of basic work = prior×likelihood for model. 
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

work:=Module[{a1,a2,a3,a4,a5,a6,aχ1,aω1,s,y},a1=av[[1]];a2=av[[2]];a3=av[[3]];a4=av[[4]];a5=av[[5]];a6=av[[6]];s=av[[7]];aχ1=0.25*(a4+a6)/π;aω1=0.5*(a4-a6);
fvec=Mod[tvec/a1+aχ1,1];
ndiffeq =θ'[q] - ((2*π)/(((1-(a2^2)))^(3/2)))(((1+a2*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];
θvec=Flatten[θ[fvec]/.numsol];
(* Create mvec, a vector of model radial velocity predictions *)
mvec=a3+a5*(Cos[θvec+aω1]+a2*Cos[aω1]);
logprior=Log[(a1/((a5+mJlim)*(s+mJslim)))]-Log[Log[1+((bfMax[[5]])/(mJlim*(Sqrt[1-(((a2))^2)])))*(((bfmin[[1]]/a1))^(1/3))]]+c ; (* the prior for parameters *) 
serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(dvec-mvec)/serrvec;
loglike=logfact-Plus@@Log[serrvec]-0.5*y.y; (* likelihood fn for particular parameters *)  
pvec={a1,a2,a3,a4,a5,a6,s}]

MODULE THAT PROPOSES THE NEW PARAMETER SET 
(May need to add another parameter type depending 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.
Module checks if proposed values lie outside prior borders, if so it reflects parameter at boundary or wraps 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 EXECUTES 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}]; 
swminσ=Table[0,{i,1,ncs}]; (* initialize table of parameter proposal σ switches  *)
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;
σallT=Transpose[σall];σallT2=Take[σallT,ncs];σallTrem=Take[σallT,-(np-ncs)];
σallT2T=Transpose[σallT2];
Do[σallT2T[[k]]=σallT2T[[k]]*(Sqrt[((N[accept1[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept1[[k]]/n1]+0.01)))]),
{k,nβlow,nβ}];
σallT2TT=Transpose[σallT2T];σall=Transpose[Join[σallT2TT,σallTrem]];
(**************************************************************)
(* 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;
σallT=Transpose[σall];σallT2=Take[σallT,ncs];σallTrem=Take[σallT,-(np-ncs)];
σallT2T=Transpose[σallT2];
Do[σallT2T[[k]]=σallT2T[[k]]*(Sqrt[((N[accept2[[k]]/n1]+0.01)/(accept[[k]]))(((1-accept[[k]]))/((1-N[accept2[[k]]/n1]+0.01)))]),
{k,nβlow,nβ}];
σallT2TT=Transpose[σallT2T];σall=Transpose[Join[σallT2TT,σallTrem]];
(**************************************************************)
(* 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.

bestpar=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

To output only the β = 1 tempering level results (need to remove the (* *) at the ends of lines).

(*tr=Transpose[logpdfβi];tr5=tr[[nβ]];ng=Length[tr5];stmp=OpenWrite["c:/temp/APT1planetHD208487",PageWidth->Infinity];
Do[Write[stmp,tr5[[i]]],{i,1,ng}];Close[stmp]*)

Here is how to input results (need to remove the (* *) at the ends of lines).

(*dataMC=ReadList["c:/temp/APT1planetHD208487"];logpdfβi=Transpose[Table[dataMC,{k,1,nβ}]];nnt=Length[logpdfβi];n=nthin*nnt;ng=nnt*)

(*logpdfβi=Transpose[Table[dataMC,{k,1,nβ}]];*)

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 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.

The line below lists the most probable parameter set and some diagnotics recorded at each MCMC iteration.

maxlogpdfAll

Earlier terminatons of the control system.

ncsysold

A control system diagnostic.

swminσ

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

Plot (Subscript[Log, 10]) Period  and (Subscript[Log, 10])[prior × (((likelihood))^β)] vs iteration 
for chain specified by the k value

k=nβ;niter=200;tr=Transpose[Take[Transpose[logpdfβi][[k]],{1,nnt,niter}]];lisP1=Join[{{-0.02,avst[[1]]}},Transpose[{tr[[n2l-1]]*(10^(-5)),tr[[2]]}]];
plPall=ListLogPlot[lisP1,Frame->True,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",14}],FrameLabel->{Style["Iterations  (\[Cross] (10^5))",{"Helvetica-Bold",14}],Style["Period",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{"Helvetica-Bold",13}];
lisLogProb=Join[{{-0.01,Min[tr[[nl]]]}},Transpose[{tr[[n2l-1]]*(10^(-5)),tr[[nl]]}]];plProb=ListPlot[lisLogProb,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",14}],FrameLabel->{Style["Iterations  (\[Cross] (10^5))",{"Helvetica-Bold",14}],Style["(Subscript[Log, 10])[Prior \[Cross] Like]",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.003],BaseStyle->{"Helvetica-Bold",13}];
pliter=Show[GraphicsGrid[{{plPall,plProb}},Spacings->{Scaled[-0.1],Scaled[-0.05]}]]

Plot eccentricity vs (Subscript[Log, 10]) Period 1 
for different chains specified by the k value

Specify a cutoff in (Subscript[log, 10]) (Prior × Likelihood )relative to the maximum and specify an interval in iteration number to plot.

cutoff=-5;

interval=30;xiterticks={3,10,30,100,300,1000,3000,10000,30000};

One plot for each of the nβ tempering levels.

Timing[plPerProb=Table[0,{nβ}];conv=Log[10,Exp[1.0]];k=nβ;
tr=Transpose[logpdfβi][[k]];(* extract values for the k=nβ chain *)
str=RotateLeft[Sort[RotateRight[tr,{0,1}],OrderedQ[{#2, #1}]&],{0,1}];(* rotate so prob is first item, sort in descending order, rotate back *)
besta1=str[[1,2]];
trn=Transpose[str];a1good=trn[[2]];a2good=trn[[3]];prob=trn[[nl]]-Log[a1good];ng=Length[trn[[1]]];probMax=Max[prob];logprob = conv*(prob - probMax);ppf=Transpose[{logprob,a1good,a2good}];pp=Select[ppf,#[[1]]>cutoff&];nppf=Length[pp];pint=Take[pp,{1,nppf,interval}];tpint=Transpose[pint];ppsel=Transpose[{tpint[[2]],tpint[[3]]}];nsel=Length[ppsel];pselA=Sort[ppsel,OrderedQ[{#2, #1}]&];(* above line orders the items in descending period *)
pntcol=ListLogLinearPlot[pselA,PlotRange->All,FrameTicks->{xiterticks,Automatic,Automatic,Automatic}];
plPerProb[[k]]=Show[pntcol,
Frame->True,AspectRatio->0.5,Axes->False,If[swb>0,PlotLabel->Style["(Subscript[P, 1]) = "<>ToString[besta1]<>" ; chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] Likelihood ) = "<>ToString[conv*probMax],{"Helvetica-Bold",9}],PlotLabel->Style["(Subscript[P, 1]) = "<>ToString[besta1]<>" ; chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] Likelihood ) = "<>ToString[conv*probMax],{"Helvetica-Bold",9}]
],
FrameLabel->{Style["Period (d)",{"Helvetica-Bold",12}],Style["Eccentricity",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
]

Setup some graph axes labels

Klabel=
StyleForm[StringForm["``  (m (s^(-1)))",
StyleForm["K",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Vlabel=
StyleForm[StringForm["``  (m (s^(-1)))",
StyleForm["V",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

elabel=
StyleForm[StringForm["Eccentricity  ``",
StyleForm["e",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

ωlabel=
StyleForm[StringForm["Longitude of periastron  ``",
StyleForm["ω"]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

blabel=
StyleForm[StringForm["Noise scale parameter  ``",
StyleForm["b",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

χlabel=
StyleForm[StringForm["``",
StyleForm["χ"]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

ω1label=
Style[StringForm["``",
Style["(Subscript[ω, 1])"]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

χ1label=
Style[StringForm["``",
Style["(Subscript[χ, 1])"]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

asinilabel=
StyleForm[StringForm["``",
StyleForm["a  (AU)",FontSlant->Italic],StyleForm["i",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

asinilabel1=
StyleForm[StringForm["``",
StyleForm["\!\(\*SubscriptBox[\(a\), \(\(1\)\(\\ \\ \\ \)\)]\)(AU)",FontSlant->Italic],StyleForm["i",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

asinilabel2=
StyleForm[StringForm["``",
StyleForm["\!\(\*SubscriptBox[\(a\), \(\(2\)\(\\ \\ \\ \)\)]\)(AU)",FontSlant->Italic],StyleForm["i",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Msinilabel=
StyleForm[StringForm["`` sin ``",
StyleForm["M",FontSlant->Italic],StyleForm["i    ((Subscript[M, J]))",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Msinilabel1=
StyleForm[StringForm["`` sin ``",
StyleForm["(Subscript[M, 1])",FontSlant->Italic],StyleForm["i    ((Subscript[M, J]))",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Msinilabel2=
StyleForm[StringForm["`` sin ``",
StyleForm["(Subscript[M, 2])",FontSlant->Italic],StyleForm["i    ((Subscript[M, J]))",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Extracting model parameter samples for the β = 1 MCMC chain

All the results are stored by the variable logpdfβi.
First let's look at an example of the output from MCMC iteration 10 given by logpdfβi[[10]].
{{0.12, 783.754, 0.702725, -7.51472, 1.16991, 30.6299, 5.6756, 40.5032, 
  30000, -169.768, -39.9451}, {0.3, 11522.5, 0.0825595, 0.34162, 1.32971, 
  7.2415, 4.17608, 11.4785, 30000, -153.506, -60.1522}, {0.48, 234.743, 
  0.26244, -5.32503, 2.36689, 1.00287, -4.45693, 16.8053, 
  30000, -146.797, -87.6518}, {0.72, 130.189, 0.198304, -0.219125, 0.656214, 
  20.2518, -3.07089, 5.83677, 30000, -120.989, -106.326}, {1., 129.683, 
  0.291881, 1.87903, 0.928945, 19.8093, -4.36264, 5.1344, 
  30000, -121.831, -140.923}}
Here is MatrixForm[logpdfβi[[10]]];
(({{0.12`, 783.7535193409451`, 0.702725472337294`, -7.514718249090343`, 1.1699116666248859`, 30.629871684883845`, 5.675600301744451`, 40.503182815953814`, 30000, -169.76783106731295`, -39.945095667921656`}, {0.3`, 11522.528688878847`, 0.08255945589142133`, 0.3416199019327868`, 1.3297129007612334`, 7.24150013424994`, 4.176081555694882`, 11.478535754288298`, 30000, -153.50594944881163`, -60.152201092085704`}, {0.48`, 234.74333609016745`, 0.2624402601749818`, -5.325034292399418`, 2.3668892329741045`, 1.0028699715743996`, -4.456929118923799`, 16.8053179964861`, 30000, -146.7967476178821`, -87.65179149759265`}, {0.72`, 130.18908873086215`, 0.19830418176238074`, -0.21912510330820528`, 0.6562135476711143`, 20.251777035695508`, -3.07089213513653`, 5.8367708442880755`, 30000, -120.98917191842439`, -106.32593254567519`}, {1.`, 129.6829883490139`, 0.2918813843172626`, 1.879029159080976`, 0.9289445159264917`, 19.80926824018558`, -4.3626366081047845`, 5.1343951298639166`, 30000, -121.8306570407864`, -140.92306276079233`}}))
The first row contains the result for β = 0.01 and the last row is for β = 1.0.
We want to extract the β = 1.0 values. Do this with tr = Transpose[logpdfβi][[nβ]];
Now look at the last 5 rows with the command MatrixForm[Take[tr,-3]].
(({{1.`, 130.36098883227228`, 0.27435386555681296`, 1.0590829036325595`, 0.9355212012109001`, 20.894381244214664`, -3.752035974988774`, 6.107650536915544`, 39998, -120.84937133140544`, -140.13348534672303`}, {1.`, 130.36098883227228`, 0.27435386555681296`, 1.0590829036325595`, 0.9355212012109001`, 20.894381244214664`, -3.752035974988774`, 6.107650536915544`, 39999, -120.84937133140544`, -140.13348534672303`}, {1.`, 130.36098883227228`, 0.27435386555681296`, 1.0590829036325595`, 0.9355212012109001`, 20.894381244214664`, -3.752035974988774`, 6.107650536915544`, 40000, -120.84937133140544`, -140.13348534672303`}}))
The first item in each row is the value of β, 
The next six items are the current values of the parameters P,e,V,2πχ+ω,K,2πχ-ω,s.
The next item is the iteration number.
The item 2nd from end is the Log of the likelihood, that is used in computing the 
global likelihood of the model for the Bayes factor calculation.
The last 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  parameter iterations with  a1good=trn[[2]]; a2good=trn[[3]]; etc.

Extract parameter iterations for the k = nβ member of the tempering levels.

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]];a5good=trn[[6]];a6good=trn[[7]];If[swb>0,sgood=trn[[8]],];prob=trn[[nl]];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.

nplan=Length[Flatten[Position[type,x_Integer/;x==2]]](* the number of planets being fit *)

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+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->{"Helvetica-Bold",12}];

Create plot of χ. For orbits with low eccentricity χ and ω cannot be determined well separately.

pos1=Flatten[Position[type,x_Integer/;x==2]];pos2=Flatten[Position[type,x_Integer/;x==4]];Do[label=ToExpression["χ"<>ToString[j]<>"label"];pl[[np+2+j]]=ListPlot[Take[Transpose[{fn,Mod[(trn[[pos1[[j]]+1]]+trn[[pos2[[j]]+1]])/(4π),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"}],
{j,1,nplan}
];

Create plot of ω. For orbits with low eccentricity χ and ω cannot be determined well separately.

pos1=Flatten[Position[type,x_Integer/;x==2]];pos2=Flatten[Position[type,x_Integer/;x==4]];Do[label=ToExpression["ω"<>ToString[j]<>"label"];pl[[np+nplan+2+j]]=ListPlot[Take[Transpose[{fn,Mod[(trn[[pos1[[j]]+1]]-trn[[pos2[[j]]+1]])/2,2π]}],{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"}],
{j,1,nplan}
];

Next line shows the final plots. Note: for a nearly circular orbit the two parameters χ and ω are highly correlated
and are separately not well determined. Even then, the combination 2 π χ + ω is well constrained.

plIter=Show[GraphicsGrid[If[EvenQ[np+2+2*nplan],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,np+2+2*nplan,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(np+2+2*nplan)/2]*2,2}],{{pl[[IntegerPart[(np+2+2*nplan)/2]*2+1]]}}]],Spacings->{Scaled[-0.15],Scaled[-0.05]}]]

Plot (Subscript[Log, 10])[prior × (((likelihood))^β)] vs (Subscript[Log, 10]) Period 1 
for different chains specified by the k value

Specify the interval in iteration number to plot.

interval=20;cutoff=-5;xiterticks={2,3,4,6,10,20,30,40,60,100,200,500,1000,3000};

One plot for each of the nβ tempering levels.

Timing[plPerProb=Table[0,{nβ}];conv=Log[10,Exp[1.0]];
Do[
tr=Transpose[logpdfβi][[k]];(* extract values for the k=nβ chain *)
str=RotateLeft[Sort[RotateRight[tr,{0,1}],OrderedQ[{#2, #1}]&],{0,1}];(* rotate so prob is first item, sort in descending order, rotate back *)
besta1=str[[1,2]];
trn=Transpose[str];a1good=trn[[2]];prob=trn[[nl]];ng=Length[trn[[1]]];probMax=Max[prob];logprob = conv*(prob - probMax);ppf=Transpose[{logprob,a1good}];nppf=Length[ppf];pp=Take[ppf,{1,nppf,interval}];ppsel=Select[pp,#[[1]]>cutoff&];nsel=Length[ppsel];pselA=Sort[RotateRight[ppsel,{0,1}],OrderedQ[{#2, #1}]&];(* above line orders the items in descending period *)
pntcol=ListLogLinearPlot[pselA,PlotRange->All];
plPerProb[[k]]=Show[pntcol,
Frame->True,AspectRatio->0.5,Axes->False,If[swb>0,PlotLabel->Style["(Subscript[P, 1]) = "<>ToString[besta1]<>" ; chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] Likelihood ) = "<>ToString[conv*probMax],{"Helvetica-Bold",9}],PlotLabel->Style["(Subscript[P, 1]) = "<>ToString[besta1]<>" ; chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] Likelihood ) = "<>ToString[conv*probMax],{"Helvetica-Bold",9}]
],
FrameLabel->{Style["Period (d)",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10]) (Prior\[Cross]\!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \)\(β\)\)]\))",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],{k,1,nβ}]
]

k=nβ;plprojprob=Show[GraphicsGrid[If[EvenQ[k],Table[{plPerProb[[ii]],plPerProb[[ii+1]]},{ii,1,k,2}],Join[Table[{plPerProb[[ii]],plPerProb[[ii+1]]},{ii,1,IntegerPart[k/2]*2,2}],{{plPerProb[[IntegerPart[k/2]*2+1]]}}]],Spacings->{Scaled[-0.15],Scaled[0.07]}],DisplayFunction->$DisplayFunction]

Plot eccentricity vs (Subscript[Log, 10]) Period 1 
for different chains specified by the k value

Specify a cutoff in (Subscript[log, 10]) (Prior × Likelihood )relative to the maximum.

cutoff=-5;

One plot for each of the nβ tempering levels.

conv=Log[10,Exp[1.0]];k=nβ;
tr=Transpose[logpdfβi][[k]];(* extract values for the k=nβ chain *)
str=RotateLeft[Sort[RotateRight[tr,{0,1}],OrderedQ[{#2, #1}]&],{0,1}];(* rotate so prob is first item, sort in descending order, rotate back *)
besta1=str[[1,2]];
trn=Transpose[str];a1good=trn[[2]];a2good=trn[[3]];prob=trn[[nl]];ng=Length[trn[[1]]];probMax=Max[prob];logprob = conv*(prob - probMax);ppf=Transpose[{logprob,a1good,a2good}];pp=Select[ppf,#[[1]]>cutoff&];nppf=Length[pp];pint=Take[pp,{1,nppf,interval}];tpint=Transpose[pint];xlowlim=Round[10*Min[tpint[[2]]]]/10.0;xhilim=Round[10*Max[tpint[[2]]]]/10.0;ppsel=Transpose[{tpint[[2]],tpint[[3]]}];nsel=Length[ppsel];pselA=Sort[ppsel,OrderedQ[{#2, #1}]&];(* above line orders the items in descending period *)
pntcol1=ListLogLinearPlot[pselA,PlotRange->All,FrameTicks->{{xlowlim,xhilim},Automatic,Automatic,Automatic}];
plPerEcc=Show[pntcol1,
Frame->True,AspectRatio->0.5,Axes->False,If[swb>0,PlotLabel->Style["(Subscript[P, 1]) = "<>ToString[besta1]<>" ; chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] Likelihood ) = "<>ToString[conv*probMax],{"Helvetica-Bold",9}],PlotLabel->Style["(Subscript[P, 1]) = "<>ToString[besta1]<>" ; chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] Likelihood ) = "<>ToString[conv*probMax],{"Helvetica-Bold",9}]
],
FrameLabel->{Style["Period (d)",{"Helvetica-Bold",12}],Style["Eccentricity",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

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]]]

(*RealDigits[Max[Abs[trnn[[12]]]]]]*)

Plot histograms of all the parameter iterations.

plh=Table[1,{i,np+2*nplan}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];
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}
];jj=1;
Do[label1=(Subscript[ToExpression["χ"], j]);label2=(Subscript[ToExpression["ω"], j]);extrahist=Mod[(trnn[[pos1[[j]]]]+trnn[[pos2[[j]]]])/(4π),1];plh[[np+jj]]=Histogram[extrahist,PlotRange->{{0.9995*Min[extrahist],1.0005*Max[extrahist]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label1,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];extrahist=Mod[(trnn[[pos1[[j]]]]-trnn[[pos2[[j]]]])/2,2π];plh[[np+jj+1]]=Histogram[extrahist,PlotRange->{{0.9995*Min[extrahist],1.0005*Max[extrahist]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label2,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];jj=jj+2,
{j,1,nplan}
]
plhis=Show[GraphicsGrid[If[EvenQ[np+2*nplan],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,np+2*nplan,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(np+2*nplan)/2]*2,2}],{{plh[[IntegerPart[(np+2*nplan)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Plot marginal  distribution for model parameters for best P.

Extract parameter iterations beyond burn-in for plotting. Specify the tempering level, normally k = nβ.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

(*RealDigits[Max[Abs[trnn[[12]]]]]]*)

Plot histograms of all the parameter iterations.

plh=Table[1,{i,np+2*nplan}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];
plh[[i]]=Histogram[trnn[[i]],PlotRange->{{0.99998*Min[trnn[[i]]],1.00002*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}
];
jj=1;
Do[label1=(Subscript[ToExpression["χ"], j]);label2=(Subscript[ToExpression["ω"], j]);extrahist=Mod[(trnn[[pos1[[j]]]]+trnn[[pos2[[j]]]])/(4π),1];plh[[np+jj]]=Histogram[extrahist,PlotRange->{{0.9995*Min[extrahist],1.0005*Max[extrahist]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label1,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];extrahist=Mod[(trnn[[pos1[[j]]]]-trnn[[pos2[[j]]]])/2,2π];plh[[np+jj+1]]=Histogram[extrahist,PlotRange->{{0.9995*Min[extrahist],1.0005*Max[extrahist]},All},Frame->True,Axes->False,AspectRatio->0.5,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label2,{"Helvetica-Bold",14}],
		Style["Number",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];jj=jj+2,
{j,1,nplan}
]
plhis=Show[GraphicsGrid[If[EvenQ[np+2*nplan],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,np+2*nplan,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(np+2*nplan)/2]*2,2}],{{plh[[IntegerPart[(np+2*nplan)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Plot binned marginal  distribution for model parameters for best P.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai=Table[0,{j,1,np+2*nplan}];maxai=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the parameters.
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

   Steps: add a second (repeat) cycle to each angular parameter
         aimarg2=Join[aimarg1,(aimarg1+usMax)];
  useMax = 2 π or 1 depending on whether it is an angular parameter or like χ a fraction of a cycle.
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[aidiff>0,,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}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai[[np+i]]=1000000000;maxai[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[np+i]],minai[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[np+i]],maxai[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai[[np+i]]=minai[[np+i]]-1;maxai[[np+i]]=maxai[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai[[np+i+nplan]]=1000000000;maxai[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[np+i+nplan]],minai[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[np+i+nplan]],maxai[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai[[np+i+nplan]]=minai[[np+i+nplan]]-2π;maxai[[np+i+nplan]]=maxai[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

Mean of marginal distribution for each parameter.

meanai

Median of marginal distribution for each parameter.

medianai

Mode of marginal distribution for each parameter.

modeai

Next are estimates of the upper and lower bounds of the 68% credible region (minai, maxai).

minai

maxai

Next step does the plotting of all parameters including 2πχ+ω & 2πχ-ω .

If[ncsys<n&&lsel>0&&aidiff<1,plmarg1all=Show[GraphicsGrid[If[EvenQ[np+2*nplan],Table[{plp[[ii]],plp[[ii+1]]},{ii,1,np+2*nplan,2}],Join[Table[{plp[[ii]],plp[[ii+1]]},{ii,1,IntegerPart[(np+2*nplan)/2]*2,2}],{{plp[[IntegerPart[(np+2*nplan)/2]*2+1]]}}]],Spacings->{Scaled[-0.1],Scaled[0.05]}]]]

Most probable set of parameters & 68.3% marginal credible regions for best P.

Extract parameter iterations beyond burn-in with period values between pLow and pHi. 
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.
Order the list of parameter iterations according to the joint probability density in descending order.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trs=RotateLeft[Sort[RotateRight[trPsel,{0,1}],OrderedQ[{#2,#1}]&],{0,1}],];lsel]

List the most probable iteration vector.

If[lsel>0,trs[[1]],]

The next command extracts the peak parameter values.

type

If[lsel>0,peakai=Table[0,{i,1,np+2*nplan}];probMax=trs[[1,nl]];
Do[
peakai[[i]]=trs[[1,i+1]],{i,1,np}
];jj=1;
Do[peakai[[np+j]]=Mod[(peakai[[pos1[[jj]]]]+peakai[[pos2[[jj]]]])/(4π),1];peakai[[np+nplan+j]]=Mod[(peakai[[pos1[[jj]]]]-peakai[[pos2[[jj]]]])/2,4π];jj=jj+1,
{j,1,nplan}
]
]

peakai

Tabulate the parameter peak values and 68% credible regions (relative to peak).

swn=1;
If[ncsys<n&&lsel>0&&aidiff<1,
l1={{"Item","Peak","Mean","Median","Mode"},{"","","","",""}};
l2=
Table[{
If[i≤np,
label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]],
If
[i>np&&i≤np+nplan,j=i-np;label=(Subscript[ToExpression["χ"], j]),
j=i-np;label=(Subscript[ToExpression["ω"], j])
]
],
peakai[[i]],meanai[[i]],medianai[[i]],modeai[[i]]},
{i,1,np+2*nplan}
];
l4={{"","","","",""},{"Item","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max","68%","68%"}};
l5=
Table[{
If[i≤np,
label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]],
If
[i>np&&i≤np+nplan,j=i-np;label=(Subscript[ToExpression["χ"], j]),
j=i-np;label=(Subscript[ToExpression["ω"], j])
]
],
minai[[i]],maxai[[i]],peakai[[i]]-minai[[i]],maxai[[i]]-peakai[[i]]},
{i,np+2*nplan}
];
smj=MatrixForm[Join[l1,l2,l4,l5]],]

Tabulate the parameter peak values and 68% credible regions (relative to median).

swn=1;
If[ncsys<n&&lsel>0&&aidiff<1,
l1={{"Item","Peak","Mean","Median","Mode"},{"","","","",""}};
l2=
Table[{
If[i≤np,
label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]],
If
[i>np&&i≤np+nplan,j=i-np;label=(Subscript[ToExpression["χ"], j]),
j=i-np;label=(Subscript[ToExpression["ω"], j])
]
],
peakai[[i]],meanai[[i]],medianai[[i]],modeai[[i]]},
{i,1,np+2*nplan}
];
l4={{"","","","",""},{"Item","68% Cred Reg","68% Cred Reg","Median-Min","Max-Median"},{"","Min","Max","68%","68%"}};
l5=
Table[{
If[i≤np,
label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]],
If
[i>np&&i≤np+nplan,j=i-np;label=(Subscript[ToExpression["χ"], j]),
j=i-np;label=(Subscript[ToExpression["ω"], j])
]
],
minai[[i]],maxai[[i]],medianai[[i]]-minai[[i]],maxai[[i]]-medianai[[i]]},
{i,np+2*nplan}
];
smj=MatrixForm[Join[l1,l2,l4,l5]],]

Note: the peak values correspond to the parameter values of the MCMC iteration having the largest 
joint posterior probability. The peak is the peak of the binned parameter marginals. It can happen
that one of the + or - error bar values can be a small negative quantity as the credible regions are 
based on the binned marginals.

Peak values of planets semimajor axis in AU, M sini, and periastron passage.

If[lsel>0,peaksemimajor1=(((((peakai[[1]])/365.25)))^(2/3))* (mstar^(1/3)),]

If[lsel>0,peakperipass1=tvecAve-Mod[peakai[[np+1]],1]*peakai[[1]],]

Mjupiter=317.894*5.974*(10^27)/(1.989*(10^33))

constantM=(((mstar))^(2/3))* (((1.028*(10^(-7))))^(1/3))*(10^(-3))/Mjupiter;

If[lsel>0,peakMpsini1=constantM*peakai[[5]]*((peakai[[1]])^(1/3))*(Sqrt[1-((peakai[[2]])^2)]),]

Plot marginal distribution for planet 1 derived quantities for most common peak 
and list 68.3% marginal credible regions.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.
The text in red is devoted to handling the angle parameters χ in a special way since it is Modulo 1. 
A problem can arise in calculating credible region of the periaston passage which depends on χ.
Suppose the PDF for χ has a bump at both ends of its range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The red code puts them together to achieve the minimum size credible region.

trn=.;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[nβ]],-(nnt-nburn)];trs=Sort[RotateLeft[tr,{0,1}],OrderedQ[{#2,#1}]&];trsel=RotateRight[Select[trs,#[[1]]>p1Low&&#[[1]]<p1Hi&],{0,1}];lrsel=Length[trsel];
If[lrsel>0,trn=Transpose[trsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];nai1=50;aimarg1=Mod[(trn[[pos1[[1]]+1]]+trn[[pos2[[1]]+1]])/(4π),1];aimarg2=Join[aimarg1,(aimarg1+1.0)];low1=0.0;hi1=2.0;dai1=(hi1-low1)/(2*nai1);aibin=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];aidif=Length[aimidpoints1]-Length[aibin];
If[aidif>0,,pbin1=Transpose[{aibin,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin4=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aχgood=Select[aimarg2,#>strtpbin4&&#<(strtpbin4+nai1*dai1)&]];a5good=trn[[6]];,],]

Plot histograms of the derived quantities from the set of parameter iterations.

If[ncsys<n&&lrsel>0&&aidif==0,pld=Table[1,{i,3}];Mjupiter=1.989*(10^33)/(317.894*5.974*(10^27));constantM=(((mstar))^(2/3))* (((1.028 (10^(-7))))^(1/3))*(10^(-3))*Mjupiter;
a0marg=((((a1good/365.25)))^(2/3))* (mstar^(1/3));meana0=Mean[a0marg];mediana0=Median[a0marg];pld[[1]]=Histogram[a0marg,PlotRange->All,Frame->True,AspectRatio->0.5,Axes->False,AspectRatio->0.5,FrameLabel->{Style[asinilabel1,{"Helvetica-Bold",12}],
		Style["Number",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
Mpsinimarg=constantM*a5good*(a1good^(1/3))*(Sqrt[1-(a2good^2)]);meanMpsini=Mean[Mpsinimarg];medianMpsini=Median[Mpsinimarg];
pld[[2]]=Histogram[Mpsinimarg,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,AspectRatio->0.5,FrameLabel->{Style[Msinilabel1,{"Helvetica-Bold",12}],
		Style["Number",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
peripassmarg=tvecAve-aχgood*a1good;meanperipass=Mean[peripassmarg];medianperipass=Median[peripassmarg];
pld[[3]]=Histogram[peripassmarg,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,AspectRatio->0.5,FrameLabel->{Style["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",12}],
		Style["Number",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
Show[GraphicsGrid[{{pld[[1]],pld[[2]]},{pld[[3]]}},Spacings->{Scaled[-0.15],Scaled[+0.05]}]]]

Details behind generating the marginal distributions (using nai bins).

Next we want to plot binned distributions of the derived quantities using nai bins and compute the 68% credible regions for these quantities.

If[ncsys<n&&lrsel>0&&aidif==0,nai=100;plpd=Table[1,{i,np}];
aimarg=((((a1good/365.25)))^(2/3))* (mstar^(1/3));(* set aimarg = the column of semimajor axis values *)
meana0=Mean[aimarg];mediana0=Median[aimarg];low=Round[10000000*Min[aimarg]]/10000000;hi=Round[10000000*Max[aimarg]]/10000000;dai=(hi-low)/nai;a0bin=BinCounts[aimarg,{low,hi,dai}];a0midpoints=Table[N[i],{i,low+dai/2,hi-dai/2,dai}];a0bintot=Plus@@a0bin;ya0=(a0bin/(a0bintot*dai));ya0sum=Plus@@ya0;pbin=Sort[Transpose[{ya0/ya0sum,a0midpoints}],OrderedQ[{#2, #1}]&];modea0=pbin[[1,2]];
(* The following lines computes boundaries of 68% credible region *)
area=0;j=1;mina0=1000000000;maxa0=-1000000000;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<mina0,mina0=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxa0,maxa0=pbin[[j,2]],Null];
j=j+1];areaa0=area;a0margbin=Transpose[{a0midpoints,ya0}];
(* Now create the P plot *)
plpd[[1]]=ListPlot[a0margbin,PlotRange->{{low,hi},{0,1.1*Max[ya0]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],Joined->True,AspectRatio->0.5,FrameLabel->{Style[asinilabel1,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
Mpsinimarg=constantM*a5good*(a1good^(1/3))*(Sqrt[1-(a2good^2)]);meanMpsini=Mean[Mpsinimarg];medianMpsini=Median[Mpsinimarg];low=Round[10000000*Min[Mpsinimarg]]/10000000;hi=Round[10000000*Max[Mpsinimarg]]/10000000;dai=(hi-low)/nai;Mpsinibin=BinCounts[Mpsinimarg,{low,hi,dai}];Mpsinimidpoints=Table[N[i],{i,low+dai/2,hi-dai/2,dai}];Mpsinibintot=Plus@@Mpsinibin;yMpsini=(Mpsinibin/(Mpsinibintot*dai));yMpsinisum=Plus@@yMpsini;pbin=Sort[Transpose[{yMpsini/yMpsinisum,Mpsinimidpoints}],OrderedQ[{#2, #1}]&];modeMpsini=pbin[[1,2]];minMpsini=1000000000;maxMpsini=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minMpsini,minMpsini=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxMpsini,maxMpsini=pbin[[j,2]],Null];
j=j+1];areaMpsini=area;Mpsinimargbin=Transpose[{Mpsinimidpoints,yMpsini}];plpd[[2]]=ListPlot[Mpsinimargbin,PlotRange->{{low,hi},{0,1.1*Max[yMpsini]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],Joined->True,AspectRatio->0.5,FrameLabel->{Style[Msinilabel1,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
peripassmarg=tvecAve-aχgood*a1good;meanperipass=Mean[peripassmarg];medianperipass=Median[peripassmarg];low=Round[1000000000*Min[peripassmarg]]/1000000000;hi=Round[1000000000*Max[peripassmarg]]/1000000000;dai=(hi-low)/nai;peripassbin=BinCounts[peripassmarg,{low,hi,dai}];peripassmidpoints=Table[N[i],{i,low+dai/2,hi-dai/2,dai}];peripassbintot=Plus@@peripassbin;yperipass=(peripassbin/(peripassbintot*dai));yperipasssum=Plus@@yperipass;pbin=Sort[Transpose[{yperipass/yperipasssum,peripassmidpoints}],OrderedQ[{#2, #1}]&];modeperipass=pbin[[1,2]];minperipass=1000000000;maxperipass=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minperipass,minperipass=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxperipass,maxperipass=pbin[[j,2]],Null];
j=j+1];areaperipass=area;peripassmargbin=Transpose[{peripassmidpoints,yperipass}];plpd[[3]]=ListPlot[peripassmargbin,PlotRange->{{low,hi},{0,1.1*Max[yperipass]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],Joined->True,AspectRatio->0.5,FrameLabel->{Style["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
plMjasiniPeriP1=Show[GraphicsGrid[{{plpd[[1]],plpd[[2]]},{plpd[[3]]}},Spacings->{Scaled[-0.15],Scaled[+0.05]}]]]

If[ncsys<n&&lrsel>0&&aidif==0,plMjasini=Show[GraphicsGrid[Table[{plpd[[i]]},{i,1,2}],Spacings->{Scaled[-0.15],Scaled[+0.05]}]]]

Tabulate the peak values and 68% credible regions.

If[ncsys<n&&lrsel>0&&aidif==0,
l1={{"Item","Peak","Mean","Median","Mode"},{"","","","",""}};l2={{"(Subscript[a, 1])",peaksemimajor1,meana0,mediana0,modea0}};l3={{"(Subscript[M, 1])sini",peakMpsini1,meanMpsini,medianMpsini,modeMpsini}};l4={{"Peripass1",peakperipass1,meanperipass,medianperipass,modeperipass}};l5={{"","","","",""},{"Item","68% Cred Reg","68% Cred Reg","Peak-Min","Max-Peak"},{"","Min","Max","68%","68%"}};l6={{"(Subscript[a, 1])",mina0,maxa0,peaksemimajor1-mina0,maxa0-peaksemimajor1}};l7={{"(Subscript[M, 1])sini",minMpsini,maxMpsini,peakMpsini1-minMpsini,maxMpsini-peakMpsini1}};l8={{"Peripass1",minperipass,maxperipass,peakperipass1-minperipass,maxperipass-peakperipass1}};
smj=MatrixForm[Join[l1,l2,l3,l4,l5,l6,l7,l8]],]

If[ncsys<n&&lrsel>0&&aidif==0,
l1={{"Item","Peak","Mean","Median","Mode"},{"","","","",""}};l2={{"(Subscript[a, 1])",peaksemimajor1,meana0,mediana0,modea0}};l3={{"(Subscript[M, 1])sini",peakMpsini1,meanMpsini,medianMpsini,modeMpsini}};l4={{"Peripass1",peakperipass1,meanperipass,medianperipass,modeperipass}};l5={{"","","","",""},{"Item","68% Cred Reg","68% Cred Reg","Median-Min","Max-Median"},{"","Min","Max","68%","68%"}};l6={{"(Subscript[a, 1])",mina0,maxa0,mediana0-mina0,maxa0-mediana0}};l7={{"(Subscript[M, 1])sini",minMpsini,maxMpsini,medianMpsini-minMpsini,maxMpsini-medianMpsini}};l8={{"Peripass1",minperipass,maxperipass,medianperipass-minperipass,maxperipass-medianperipass}};
smj=MatrixForm[Join[l1,l2,l3,l4,l5,l6,l7,l8]],]

Plot pairs of parameters to examine correlations.

We want to plot points at intervals of dn iterations.

dn=50;pLow=127.;pHi=132.;cutoff=-5;

Plot marginal K versus e

This step generate the data needed for plotting. Only use points with a relative 
joint probability density within cutoff = -5 decades of the maximum and with period 
values between pLow and pHi (corresponding to to range of equilibrium distribution around best P).

p1Low=128.0;p1Hi=132.0;
trn=.;lsel=0;
If[ncsys<n,tr=Take[Transpose[logpdfβi][[nβ]],-(nnt-nburn)];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]];a5good=trn[[6]];a6good=trn[[7]];If[swb>0,sgood=trn[[8]],],],];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

If[lsel>0,ppf=Transpose[{a2good,a5good}];nppf=Length[ppf];
pp1=Take[ppf,{1,nppf,dn}];pp=Sort[pp1,OrderedQ[{#2,#1}]&];npp=Length[pp],]

If[lsel>0,dnn=1;lphbw=Take[pp,{1,npp,dnn}];nlphbw=Length[lphbw];pla=Table[{lphbw[[i,1]],lphbw[[i,2]]},{i,1,nlphbw}];
plota2a5=ListPlot[pla,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style[a2name<>a2unit,{"Helvetica-Bold",12}],
		Style[a5name<>a5unit,{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],]

Two dimensional marginal plot.

If[ncsys<n&&npp>0,plota1a2h5a=Histogram3D[pp,HistogramScale->1,HistogramCategories->{10,10},
AxesLabel->{a2name<>a2unit,a5name<>a5unit<>"\n","Marginal \n    PDF"},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],]

Plot marginal P versus e

This step generate the data needed for plotting. Only use points with a relative 
joint probability density within cutoff = -5 decades of the maximum and with period 
values between pLow and pHi (corresponding to to range of equilibrium distribution around best P).

p1Low=128.0;p1Hi=132.0;
trn=.;lsel=0;
If[ncsys<n,tr=Take[Transpose[logpdfβi][[nβ]],-(nnt-nburn)];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]];a5good=trn[[6]];a6good=trn[[7]];If[swb>0,sgood=trn[[8]],],],];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

If[lsel>0,ppf=Transpose[{a2good,a1good}];nppf=Length[ppf];
pp1=Take[ppf,{1,nppf,dn}];pp=Sort[pp1,OrderedQ[{#2,#1}]&];npp=Length[pp],]

If[lsel>0,dnn=1;lphbw=Take[pp,{1,npp,dnn}];nlphbw=Length[lphbw];pla=Table[{lphbw[[i,1]],lphbw[[i,2]]},{i,1,nlphbw}];
plota2a1=ListPlot[pla,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style[a2name<>a2unit,{"Helvetica-Bold",12}],
		Style[a1name<>a1unit,{"Helvetica-Bold",12}]},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],]

Two dimensional marginal plot.

If[ncsys<n&&npp>0,plota1a2h1a=Histogram3D[pp,HistogramScale->1,HistogramCategories->{10,10},
AxesLabel->{a2name<>a2unit,a1name<>a1unit<>"\n","Marginal \n    PDF"},BaseStyle -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.006]],]

Plots of individual thinned MCMC iterations in the joint parameter space (proportional to marginal distribution).

If[ncsys<n,plcorr=Show[GraphicsGrid[{{plota2a1,plota2a5}},Spacings->{Scaled[-0.15],Scaled[-0.02]}]]]

Nelder-Mead estimate of MAP parameters

logfact=-(nd/2)*Log[2*π]

The Module, fm3, specifies the calculations to estmate of the most probable set of parameters using the Nelder-Mead algorithm starting from the MCMC solution.

fm3[a1_?NumericQ,a2_?NumericQ,a3_?NumericQ,a4_?NumericQ,a5_?NumericQ,a6_?NumericQ,s_?NumericQ]:=Module[{aχ1,aω1,y},aχ1=Mod[0.25*(a4+a6)/π,1.0];aω1=Mod[0.5*(a4-a6),2π];
fvec=Mod[tvec/a1+aχ1,1];
ndiffeq =θ'[q] - ((2*π)/(((1-(a2^2)))^(3/2)))(((1+a2*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];
θvec=Flatten[θ[fvec]/.numsol];
(* Create mvec, a vector of model radial velocity predictions *)
mvec=a3+a5*(Cos[θvec+aω1]+a2*Cos[aω1]);
logprior=Log[(a1/((a5+mJlim)*(s+mJslim)))]-Log[Log[1+((bfMax[[5]])/(mJlim*(Sqrt[1-(((a2))^2)])))*(((bfmin[[1]]/a1))^(1/3))]]+c ; (* the prior for parameters *) 
serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(dvec-mvec)/serrvec;
minusloglike=-logfact+Plus@@Log[serrvec]+0.5*y.y-logprior]

Extract the best parameter set found from the hybrid MCMC from maxlogpdfAll.

Sequence@@Take[maxlogpdfAll,{2,np+1}]

Evaluate fm3 for the best parameter set found from the hybrid MCMC.

bestMCMC=fm3[Sequence@@Take[maxlogpdfAll,{2,np+1}]]

Tabulate the 68% parameter boundaries found by the hybrid MCMC.

bound=Table[{ToExpression["vb"<>ToString[i]],minai[[i]],maxai[[i]]},{i,1,np}]

Here we execute Nelder-Mead.

switchNM=0; (* this switch must be set = 1 for Nelder-Maed section to run *)

If[switchNM>0,ans=Timing[NMinimize[{fm3[vb1,vb2,vb3,vb4,vb5,vb6,vb7]},bound,Method->"NelderMead",MaxIterations->4000,WorkingPrecision->12]]]

Compare this value of fm3 found by Nelder-Mead to that found above for the best parameter set from the hybrid MCMC.
Better means a smaller value, i.e., deeper minimum.

If[switchNM>0,bestNedlerMead=ans[[2,1]]]

Extract the parameter values found by Nelder-Mead method.

If[switchNM>0,vlist=ans[[2,2]]]

If[switchNM>0,ann=Table[ToExpression["vb"<>ToString[i]],{i,1,np}]]

If[switchNM>0,parMAP=ann/.vlist]

If Nelder-Mead does not find a more probable set of parameters, then execute following command to use the hybrid MCMC best values after re-ordering the parameters so lowest period parameters occur first, etc..

If[switchNM>0,If[bestMCMC<bestNedlerMead,parMap=Take[maxlogpdfAll,{2,np+1}]
]
]

The next command extracts the peak parameter values.

type

Compute χ and ω orbital parameters from the values of the re-parameterized angular parameters.

If[switchNM>0,peakMAP=Table[0,{i,1,np+2*nplan}];
Do[
peakMAP[[i]]=parMAP[[i]],{i,1,np}
];jj=1;
Do[peakMAP[[np+j]]=Mod[(parMAP[[pos1[[jj]]]]+parMAP[[pos2[[jj]]]])/(4π),1];peakMAP[[np+nplan+j]]=Mod[(parMAP[[pos1[[jj]]]]-parMAP[[pos2[[jj]]]])/2,4π];jj=jj+1,
{j,1,nplan}
]
]

Specify the full set of MAP (maximum a posterior) parameter values of interest.

If[switchNM>0,peakMAP]

Plot data points versus time with overlaid light curve for MAP solution & residuals.

By default peakMAP set at best set of parameters found from MCMC. If previous section run you might wish to use relace by values obtained using Nelder-Mead algorithm.

peakMAP=peakai

Check that the MAP value of the period specified by peakai[[1]] is sensible.

peakMAP[[1]]

Compute and plot the best model fit versus time together with the data.

fpeak=1/peakMAP[[1]];tlist=Table[t,{t,tstart,tend,peakMAP[[1]]/100}];fvec=Mod[fpeak*tlist+peakMAP[[8]],1];ndiffeq =θ'[q] - ((2*π)/(((1-((peakMAP[[2]])^2)))^(3/2)))(((1+peakMAP[[2]]*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];θvec=Flatten[θ[fvec]/.numsol];
mvel=peakMAP[[3]]+peakMAP[[5]]*(Cos[θvec+peakMAP[[9]]]+peakMAP[[2]]*Cos[peakMAP[[9]]]);modlist=Transpose[{tlist,mvel}];plfit=ListPlot[modlist,Joined->True,PlotStyle->{Thickness[0.002]},DisplayFunction->Identity];
plfitdat=Show[plshp1,plfit]

Create versions of above plot with added text for later plotting.

plfitdatpkc=Show[plfitdat,Graphics[{Text["(b)",{40,Min[dvec]}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Compute y = the best model fit residuals.

fpeak=1/peakMAP[[1]];fvec=Mod[fpeak*tvec+peakMAP[[8]],1];ndiffeq =θ'[q] - ((2*π)/(((1-((peakMAP[[2]])^2)))^(3/2)))(((1+peakMAP[[2]]*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];θvec=Flatten[θ[fvec]/.numsol];
mvec=peakMAP[[3]]+peakMAP[[5]]*(Cos[θvec+peakMAP[[6]]]+peakMAP[[2]]*Cos[peakMAP[[9]]])

y=dvec-mvec

respk=StandardDeviation[y]

Compute resid = the best model fit residuals and time.

resid=Transpose[{tvec,y}]

Plot best fit residuals and error bars versus time.

residerr=Table[{resid[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",12}],Style["Velocity residual  (m (s^(-1)))",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Create versions of above plot with added text for later plotting.

plshp2b=Show[plshp2,Graphics[{Text["(c)",{45,Min[y]}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Plot best fit and residuals versus time.

plboth=Show[GraphicsGrid[{{plshp1a},{plfitdatpkc},{plshp2b}},Spacings->{Scaled[-0.1],Scaled[0.0]}]]

Plot the MAP solution versus orbital  phase

peakMAP

f1peak=1/peakMAP[[1]];fvecdat=Mod[f1peak*tvec,1];dataph=Transpose[{fvecdat,dvec}];dataph2=Transpose[{fvecdat+1,dvec}];twocycle=Join[dataph,dataph2];twocycerr=Join[errvec,errvec];

datapherr=Table[{twocycle[[i]],ErrorBar[twocycerr[[i]]]},{i,2*nd}];
plshpP1=ErrorListPlot[datapherr,Frame->True,PlotRange->All,Axes->False,PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style["Orbital\!\(\*
StyleBox[\(\*
StyleBox["  ",
FontSlant->"Italic"]\\ \)]\)phase",{"Helvetica-Bold",14}],Style["Velocity  ((ms^(-1)))",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{13,FontFamily->"Helvetica-Bold"}]

f1peak=1/peakMAP[[1]];tlist=Table[t,{t,0,2*peakMAP[[1]],peakMAP[[1]]/100}];
f1vec=Mod[f1peak*tlist+peakMAP[[8]],1];ndiffeq=θ'[q] - ((2*π)/(((1-((peakMAP[[2]])^2)))^(3/2)))(((1+peakMAP[[2]]*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];θ1vec=Flatten[θ[f1vec]/.numsol];
mvel1=peakMAP[[3]]+peakMAP[[5]]*(Cos[θ1vec+peakMAP[[9]]]+peakMAP[[2]]*Cos[peakMAP[[9]]]);
modlist=Transpose[{tlist/peakMAP[[1]],mvel1}];plfitph=ListPlot[modlist,Joined->True,PlotStyle->{Thick}];
plfitdatphP1=Show[plshpP1,plfitph,Prolog->Thickness[0.005],DisplayFunction->$DisplayFunction]

plfitdatphP1b=Show[plfitdatphP1,Graphics[{Text["(d)",{1.0,Min[dvec]}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plboth=Show[GraphicsGrid[{{plshp1a,plfitdatpkc},{plshp2b,plfitdatphP1b}},Spacings->{Scaled[-0.15],Scaled[0.00]}]]

Plot data and fit residuals versus time with overlaid mean MCMC radial velocity curve.

We first select a sample (at an interval of r = 100 iterations) of the post burn-in MCMC parameter iterations that span the equilibrium distribution centered on the best period.

If[ncsys<n,k=nβ;r=100;p1Low=128.0;p1Hi=132.0;tr=Take[Transpose[logpdfβi][[nβ]],{nburn,nnt,r}];xsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];nsel=Length[xsel]
]

medianai

For each MCMC parameter set construct a model radial velocity curve at a list of times spanning the data. We accumulate these and then calculate the mean radial velocity curve and standard deviation.

tlist=Table[t,{t,tstart,tend,medianai[[1]]/100}];mvel={};
Do[str=Take[xsel[[i]],{2,np+1}];
aχ1=Mod[0.25*(str[[4]]+str[[6]])/π,1];
aω1=Mod[(str[[4]]-str[[6]])/2,2π];
fvec=Mod[tlist/str[[1]]+aχ1,1];ndiffeq =θ'[q] - ((2*π)/(((1-((str[[2]])^2)))^(3/2)))(((1+str[[2]]*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];θvec=Flatten[θ[fvec]/.numsol];
mvel=Append[mvel,str[[3]]+str[[5]]*(Cos[θvec+aω1]+str[[2]]*Cos[aω1])],{i,1,nsel}
]

Calculate the mean radial velocity curve.

meanmvel=Mean[mvel];

Calculate the standard deviation.

stdmvel=StandardDeviation[mvel];

Plot the mean curve.

modlist=Transpose[{tlist,meanmvel}];plfitmean=ListPlot[modlist,Joined->True,PlotStyle->{Black,Thickness[0.002]}];
plfitdatamean=Show[plshp1,plfitmean]

Make another plot with an indexing letter for later plotting with other graphs.

plmapfitmeanb=Show[plfitdatamean,Graphics[{Text["(b)",{0,-29}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Plot the (mean curve+ one standard deviation) and (mean - one standard deviation).

modlist1=Transpose[{tlist,(meanmvel+stdmvel)}];modlist2=Transpose[{tlist,(meanmvel-stdmvel)}];plfitmeanr=ListPlot[{modlist1,modlist2},Joined->True,PlotStyle->{Thickness[0.002]}];
plfitdatameanr=Show[plshp1,plfitmeanr]

For each MCMC parameter set construct a model radial velocity values at the actual times of the data for the purpose of computing the residuals between models and the data.

mvec={};
Do[str=Take[xsel[[i]],{2,np+1}];
aχ1=Mod[0.25*(str[[4]]+str[[6]])/π,1];
aω1=Mod[(str[[4]]-str[[6]])/2,2π];
fvec=Mod[tvec/str[[1]]+aχ1,1];ndiffeq =θ'[q] - ((2*π)/(((1-((str[[2]])^2)))^(3/2)))(((1+str[[2]]*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];θvec=Flatten[θ[fvec]/.numsol];

mvec=Append[mvec,str[[3]]+str[[5]]*(Cos[θvec+aω1]+str[[2]]*Cos[aω1])],{i,1,nsel}
]

Calculate values of the mean radial velocity curve corresponding to data times.

meanmvec=Mean[mvec]

Calculate values of the standard deviation of the radial velocity curve corresponding to data times.

stdmvec=StandardDeviation[mvec]

Compute residuals divided by the measurement errors from the mean radial velocity curve.

y=(meanmvec-dvec)/errvec

Compute the reduced (χ^2) of the fit assuming only the quoted measurement errors (does not include extra noise parameter).

reducedchi2=y.y/(nd-7)

StandardDeviation[meanmvec-dvec]

Mean[errvec]

Compute the RMS residuals to the fit assuming only the quoted measurement errors (does not include extra noise parameter).

rmsres=(Sqrt[(((meanmvec-dvec).(meanmvec-dvec))/nd)])

resid=Transpose[{tvec,dvec-meanmvec}];

respk=StandardDeviation[resid]

List the residuals.

resid

Plot the residuals.

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["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",14}],Style["Residuals  ((ms^(-1)))",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{13,FontFamily->"Helvetica-Bold"}]

plshp2meanb=Show[plshp2mean,Graphics[{Text["(d)",{0,-21}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

plboth=Show[GraphicsGrid[{{plshp1a},{plmapfitmeanb},{plshp2meanb}},Spacings->{Scaled[-0.1],Scaled[-0.02]}]]

(*Export["c:/greg4/Tinney/HD208487new/Fig/APTR3CS2plan208487NDdattimresAVEsig.eps", plboth,ImageSize->72*7]*)

Plot the mean MCMC solution versus orbital phase

If[ncsys<n,k=nβ;r=100;p1Low=128.0;p1Hi=132.0;tr=Take[Transpose[logpdfβi][[nβ]],{nburn,nnt,r}];xsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];nsel=Length[xsel]
]

cyc1={};
Do[str=Take[xsel[[i]],{2,np+1}];tlist=Table[t,{t,0,str[[1]],str[[1]]/100}];
aχ1=Mod[0.25*(str[[4]]+str[[6]])/π,1];
aω1=Mod[(str[[4]]-str[[6]])/2,2π];
fvec=Mod[tlist/str[[1]]+aχ1,1];fvecx=tlist/str[[1]]+aχ1;ndiffeq =θ'[q] - ((2*π)/(((1-((str[[2]])^2)))^(3/2)))(((1+str[[2]]*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];θvec=Flatten[θ[fvec]/.numsol];
mvel1=str[[3]]+str[[5]]*(Cos[θvec+aω1]+str[[2]]*Cos[aω1]);lisA=Transpose[{fvecx-fvecx[[1]],mvel1}];lisB=Transpose[{fvecx-fvecx[[1]]+1,mvel1}];cyc1=Append[cyc1,Join[lisA,lisB]],{i,1,nsel}]

mcyc1=Mean[cyc1];

stdmcyc1=StandardDeviation[cyc1];

ListPlot[mcyc1]

f1peak=1/medianai[[1]];fvecdat=Mod[f1peak*tvec,1];dataph=Transpose[{fvecdat,dvec}];dataph2=Transpose[{fvecdat+1,dvec}];twocycle=Join[dataph,dataph2];twocycerr=Join[errvec,errvec];

datapherr=Table[{twocycle[[i]],ErrorBar[twocycerr[[i]]]},{i,2*nd}];
plshp2P1=ErrorListPlot[datapherr,Frame->True,PlotRange->All,Axes->False,PlotStyle->Black,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["(Subscript[P, 1])  Orbital   phase",{"Helvetica-Bold",14}],Style["Velocity  ((ms^(-1)))",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{13,FontFamily->"Helvetica-Bold"}]

plfitph=ListPlot[mcyc1,Joined->True,PlotStyle->{Green,Thickness[0.006]},DisplayFunction->Identity];
plfitdatphP1=Show[plshp2P1,plfitph,Prolog->Thickness[0.005],DisplayFunction->$DisplayFunction]

plfitdatphP1b=Show[plfitdatphP1,Graphics[{Text["(a)",{1.0,-12}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

mcyc1up=mcyc1+stdmcyc1;

mcyc1low=mcyc1-stdmcyc1;

plfitph=ListPlot[{mcyc1up,mcyc1low},Joined->True,PlotStyle->{{Thickness[0.008],Red},{Thickness[0.006],Green}}];
plfitdatphP1std=Show[plshp2P1,plfitph,Prolog->Thickness[0.005],DisplayFunction->$DisplayFunction]

plfitdatphP1stdb=Show[plfitdatphP1std,Graphics[{Text["(c)",{1.0,-29}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plboth=Show[GraphicsGrid[{{plshp1a,plmapfitmeanb},{plfitdatphP1stdb,plshp2meanb}},Spacings->{Scaled[-0.15],Scaled[-0.02]}]]

Compute Marginal likelihood p(D|M1s,I) & Bayes factor from all tempering level results

Compares model (Subscript[M, 1s]) to model (Subscript[M, 0s]) (rejecting the first nburn samples). 
**NOTE: THIS SECTION WON'T EVALUATE IF nβ < nβmin.**
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 20) of β levels are used spanning the range β = 0 to 1. 
Otherwise use the Monte Carlo Bayes factor calculation in the next section.

Compute p(D|M1s,I), the marginal (global) likelihood for one elliptical orbit

Here we compute  the log of the global likelihood of the model, which is designated by  logpM1
                logpM1=log[p(D|M1,I)]=∫ (Subscript[⟨ln p(D|(Subscript[M, E]),P,K,V,χ,e,ω,s,I)⟩, β])  dβ
(Subscript[⟨ln p(D|(Subscript[M, E]),P,K,V,χ,e,ω,I)⟩, β]) =expectation value ofln [p(D|(Subscript[M, E]),P,K,V,χ,e,ω,s,I)] for given β
                                              =(1/n)(∑_(t=1)^n)  ln[p(D|M1,(Subscript[P, t,β ]),(Subscript[K, t,β ]),(Subscript[V, t,β ]),(Subscript[χ, t,β ]),(Subscript[e, t,β ]),(Subscript[ω, t,β ]),(Subscript[s, 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 an example of the first row of the output given by logpdfβi[[10]].
{{0.01,7.43225,11.9636,-2.43469,0.411467,0.471413,1.24757,49.4369,10,-191.477,-19.9781,105896},{0.02,8.99867,49.5881,18.9388,0.459489,0.498111,1.52728,29.8125,10,-211.178,-23.0778,110557},{0.03,20.9964,2.27292,-0.422451,0.00261718,0.424529,0.510628,37.7975,10,-192.347,-21.2114,123194},{0.05,20.895,6.39829,25.5155,0.780148,0.266431,0.644358,46.989,10,-196.099,-26.2335,123148},{0.09,17.8096,15.847,-46.3767,0.695441,0.00158928,1.32571,49.4125,10,-203.146,-35.7342,121498},{0.15,8.14429,20.2811,18.744,0.560011,0.27797,0.94402,32.6207,10,-207.27,-49.2426,108237},{0.25,9.13456,6.04247,-4.07761,0.854216,0.232009,0.138428,10.0514,10,-293.531,-89.6255,110886},{0.35,11.8251,83.8614,12.8864,0.513764,0.255267,0.623453,32.3857,10,-204.889,-90.8682,115843},{0.45,7.88423,10.7206,18.5161,0.519022,0.565257,1.02571,52.369,10,-193.419,-104.988,107431},{0.7,8.77798,84.8971,2.09296,0.629601,0.213728,0.973822,19.7356,10,-307.313,-234.257,110001},{1.,6.81597,34.6144,1.71895,0.170365,0.544609,1.45608,36.0986,10,-201.278,-220.197,103475}}
          The quantity  ln[p(D|M1,(Subscript[P, t,β ]),(Subscript[K, t,β ]),(Subscript[V, t,β ]),(Subscript[χ, t,β ]),(Subscript[e, t,β ]),(Subscript[ω, t,β ]),(Subscript[s, t,β ]),I)] is the (n2l item) in each row. 
The different rows correspond to different values of the tempering parameter β.

Set nβmin, the minimum number of tempering levels before it makes any sense to compute the 
global likelihood of the model by this method.

nβmin=20;

First check that you are happy with the burn -in value, nburn.

nburn

Generate the list expect = ⟨ln p(D|(Subscript[M, E]),P,K,V,χ,e,ω,s,I)⟩ , one for each tempering level 
provided nβ≥nβmin and ncsys<n, i.e., the turn-off of the control system was ≤nburn.

If[ncsys<n&&nβ≥nβmin,tr=Transpose[Take[logpdfβi,-(nnt-nburn)]];expect=Table[0.0,{i,1,nβ}];Do[trnb=Transpose[tr[[nb]]];tb1Num=trnb[[n2l]];logpdfβ=Total[tb1Num]/ng;expect[[nb]]=logpdfβ,{nb,1,nβ}],];

List ⟨ln p(D|(Subscript[M, E]),P,K,V,χ,e,ω,s,I)⟩ values, one for each tempering level.

If[ncsys<n&&nβ≥nβmin,expect,]

List the β tempering values.

If[ncsys<n&&nβ≥nβmin,βlis,]

Plot ⟨ln p(D|(Subscript[M, E]),P,K,V,χ,e,ω,s,I)⟩ values versus (Subscript[Log, 10 ])(βlis).

If[ncsys<n&&nβ≥nβmin,pl1=LogLinearListPlot[Transpose[{βlis,expect}],PlotStyle->PointSize[0.02],Frame->True,PlotRange->All,FrameLabel->{FontForm["Log β",{"Helvetica-Bold",15}],
		FontForm["⟨ln p(D|(Subscript[M, E]),P,K,V,χ,e,ω,I)⟩",{"Helvetica-Bold",14}]},DefaultFont -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.005],Prolog->Thickness[0.003]],]

Generate an interpolating function for a LogLinearPlot.

If[ncsys<n&&nβ≥nβmin,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[ncsys<n&&nβ>nβmin,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect]]

Plot the interpolation.

If[ncsys<n&&nβ≥nβmin,pl4=ListPlot[newexpect,Frame->True,PlotRange->All,Axes->False,FrameLabel->{FontForm["Log β",{"Helvetica-Bold",15}],
		FontForm["⟨ln p(D|(Subscript[M, E]),P,K,V,χ,e,ω,I)⟩",{"Helvetica-Bold",14}]},DefaultFont -> {"Helvetica-Bold", 12},FrameStyle->Thickness[0.005],Prolog->Thickness[0.003]],]

Plot the interpolation and expect values together.

If[ncsys<n&&nβ≥nβmin,plBayesFactor=Show[pl1,pl4,PlotRange->All],]

Now convert to a table with linear coordinates.

If[ncsys<n&&nβ≥nβmin,tnewexpext=Transpose[newexpect];newexpect1=Transpose[{(10^(tnewexpext[[1]]))-0.000001,tnewexpext[[2]]}],];

Next we approximate the integral by a sum of the table of interpolation values. Call it logpM1.

If[ncsys<n&&nβ≥nβmin,logpM1=Total[Table[0.5*(newexpect1[[i]][[2]]+newexpect1[[i+1]][[2]])*(newexpect1[[i+1]][[1]]-newexpect1[[i]][[1]]),{i,1,Length[newexpect1]-1}]],]

Here is how to Drop the lowest β value and corresponding value of expect.

If[ncsys<n&&nβ≥nβmin,Drop[βlis,1],]

If[ncsys<n&&nβ≥nβmin,Drop[expect,1],]

Suppose we drop the first nn  β levels and redo the 
calculation of the Log of the global likelihood for M1.

nn=1;

If[ncsys<n&&nβ⩾(nβmin+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[ncsys<n&&nβ≥(nβmin+nn),newexpect2=Table[spline2[x],{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2]]

If[ncsys<n&&nβ≥(nβmin+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[ncsys<n&&nβ≥(nβmin+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}]],]

Compute p(D|M0s,I), marginal likelihood of the zero planet model

Calculation details:

Assumes a model of an unknown V and an extra Gaussian noise term with unknown sigma s.

As a practical matter we need to choose suitable limits of integration of these two parameters.
If we simply use the prior limits NIntegrate may converge to slowly because of the huge dynamic 
range of the quantity to be integrated.

vmintemp=Min[dvec];(* lower integration limit for V parameter *)

vmaxtemp=Max[dvec];(* upper integration limit for V parameter *)

smintemp=0.0;(* lower integration limit for s parameter *)

smaxtemp=bfMax[[7]];(* upper integration limit for s parameter *)

swnew=0;If[swnew==1,smaxtemp=100.0];(* upper prior bound on s for computing Bayes factor *)

If[ncsys<n,s=.;ΔV=bfMax[[3]]-bfmin[[3]];
fact=((((2*π))^(-nd/2))/(ΔV*Log[1+((bfMax[[7]])/mJslim)]));
serrvecsq=(errvec^2)+(s^2);
term1=Times@@((serrvecsq^(-0.5)))/(s+mJslim)*Exp[-Total[0.5*(((dvec-V))^2)/serrvecsq]];
term2=NIntegrate[term1,{V,vmintemp,vmaxtemp},{s,smintemp,smaxtemp}];
pDM0s=fact*term2
]

If[ncsys<n,logpM0s=Log[pDM0s]]

Compute Bayes factor

Compute the odds for the first interpolation scheme.

If[lsel>0&&nβ≥nβmin,odds=Exp[logpM1-logpM0s],]

Compute the odds for the second interpolation where we dropped the lowest nn β values.

If[lsel>0&&nβ≥nβmin,odds=Exp[logpM1A-logpM0s],]

Compute Marginal likelihood p(D|M1s,I) & Bayes factor (Nested Restricted Mont Carlo Method)
                                                                                                  Gregory and Fischer, 2010, MNRAS, 403, 731

Monte Carlo Bayes factor calculation should be fairly efficient provided one uses the MCMC marginals to constrain the parameter ranges used in the MC integration, to regions where the posterior has significant probability. This is called restricted Monte Carlo (RMC). In this work we use a Nested version of RMC integration. Multiple boundaries are constructed based on credible regions ranging from 30% to > 99%, as needed. We are then able to compute the contribution to the total RMC integral from each nested interval and sum these contributions. For example, for the interval between the 30% and 60% credible regions, we generate random parameter samples within the
60% region and reject any sample that falls within the 30% region. Using the remaining samples we can compute the
contribution to the RMC integral from that interval.

Compute p(D|M1,I), the marginal likelihood for an elliptical orbit (11 stages of nesting 30,60,68,76,84,90,95,97,99,9995,9984)

This version is customized for analysis of RV data where we use the transformed parameters θ=2π χ+ω, ϕ=2π χ-ω. The  θ parameter is usually well determined and has two narrow credible regions separated by 2 π. We first combine these two regions with the Mod[θ,2 π] operation and perform the usual operation to find the minimum sized credible region. In the RMC operation we alternate between drawing random samples from this credible region and a second equal sized one located 2 π radians higher. In Nested RMC we separate out those samples that fall within the boundaries of the next smaller credible region. The ϕ coordinate is not well determined for low eccentricity orbits so we don't attempt to isolate separate regions differing by 2 π as with the θ parameter.

Plot marginal  distribution for model parameters for most common peak and 99% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai99=Table[0,{j,1,np+2*nplan}];maxai99=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai99[[np+i]]=1000000000;maxai99[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.99,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai99[[np+i]],minai99[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai99[[np+i]],maxai99[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai99[[np+i]]=minai99[[np+i]]-1;maxai99[[np+i]]=maxai99[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai99[[np+i+nplan]]=1000000000;maxai99[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.99,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai99[[np+i+nplan]],minai99[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai99[[np+i+nplan]],maxai99[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai99[[np+i+nplan]]=minai99[[np+i+nplan]]-2π;maxai99[[np+i+nplan]]=maxai99[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai99

maxai99

Plot marginal  distribution for model parameters for most common peak and 97% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai97=Table[0,{j,1,np+2*nplan}];maxai97=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai97[[i]]=1000000000;maxai97[[i]]=-1000000000;area=0;j=1;
While[area≤0.97,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai97[[i]],minai97[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai97[[i]],maxai97[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai97[[np+i]]=1000000000;maxai97[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.97,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai97[[np+i]],minai97[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai97[[np+i]],maxai97[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai97[[np+i]]=minai97[[np+i]]-1;maxai97[[np+i]]=maxai97[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai97[[np+i+nplan]]=1000000000;maxai97[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.97,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai97[[np+i+nplan]],minai97[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai97[[np+i+nplan]],maxai97[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai97[[np+i+nplan]]=minai97[[np+i+nplan]]-2π;maxai97[[np+i+nplan]]=maxai97[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai97

maxai97

Plot marginal  distribution for model parameters for most common peak and 95% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai95=Table[0,{j,1,np+2*nplan}];maxai95=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai95[[i]]=1000000000;maxai95[[i]]=-1000000000;area=0;j=1;
While[area≤0.95,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai95[[i]],minai95[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai95[[i]],maxai95[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai95[[np+i]]=1000000000;maxai95[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.95,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai95[[np+i]],minai95[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai95[[np+i]],maxai95[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai95[[np+i]]=minai95[[np+i]]-1;maxai95[[np+i]]=maxai95[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai95[[np+i+nplan]]=1000000000;maxai95[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.95,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai95[[np+i+nplan]],minai95[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai95[[np+i+nplan]],maxai95[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai95[[np+i+nplan]]=minai95[[np+i+nplan]]-2π;maxai95[[np+i+nplan]]=maxai95[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai95

maxai95

Plot marginal  distribution for model parameters for most common peak and 90% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai90=Table[0,{j,1,np+2*nplan}];maxai90=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai90[[i]]=1000000000;maxai90[[i]]=-1000000000;area=0;j=1;
While[area≤0.9,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai90[[i]],minai90[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai90[[i]],maxai90[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai90[[np+i]]=1000000000;maxai90[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.9,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai90[[np+i]],minai90[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai90[[np+i]],maxai90[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai90[[np+i]]=minai90[[np+i]]-1;maxai90[[np+i]]=maxai90[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai90[[np+i+nplan]]=1000000000;maxai90[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.9,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai90[[np+i+nplan]],minai90[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai90[[np+i+nplan]],maxai90[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai90[[np+i+nplan]]=minai90[[np+i+nplan]]-2π;maxai90[[np+i+nplan]]=maxai90[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai90

maxai90

Plot marginal  distribution for model parameters for most common peak and 84% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai84=Table[0,{j,1,np+2*nplan}];maxai84=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai84[[i]]=1000000000;maxai84[[i]]=-1000000000;area=0;j=1;
While[area≤0.84,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai84[[i]],minai84[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai84[[i]],maxai84[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai84[[np+i]]=1000000000;maxai84[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.84,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai84[[np+i]],minai84[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai84[[np+i]],maxai84[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai84[[np+i]]=minai84[[np+i]]-1;maxai84[[np+i]]=maxai84[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai84[[np+i+nplan]]=1000000000;maxai84[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.84,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai84[[np+i+nplan]],minai84[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai84[[np+i+nplan]],maxai84[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai84[[np+i+nplan]]=minai84[[np+i+nplan]]-2π;maxai84[[np+i+nplan]]=maxai84[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai84

maxai84

Plot marginal  distribution for model parameters for most common peak and 76% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai76=Table[0,{j,1,np+2*nplan}];maxai76=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai76[[i]]=1000000000;maxai76[[i]]=-1000000000;area=0;j=1;
While[area≤0.76,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai76[[i]],minai76[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai76[[i]],maxai76[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai76[[np+i]]=1000000000;maxai76[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.76,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai76[[np+i]],minai76[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai76[[np+i]],maxai76[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai76[[np+i]]=minai76[[np+i]]-1;maxai76[[np+i]]=maxai76[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai76[[np+i+nplan]]=1000000000;maxai76[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.76,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai76[[np+i+nplan]],minai76[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai76[[np+i+nplan]],maxai76[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai76[[np+i+nplan]]=minai76[[np+i+nplan]]-2π;maxai76[[np+i+nplan]]=maxai76[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai76

maxai76

Plot marginal  distribution for model parameters for most common peak and 68% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=5.3647;p1Hi=5.3704;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai68=Table[0,{j,1,np+2*nplan}];maxai68=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai68[[i]]=1000000000;maxai68[[i]]=-1000000000;area=0;j=1;
While[area≤0.68,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai68[[i]],minai68[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai68[[i]],maxai68[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai68[[np+i]]=1000000000;maxai68[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.68,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai68[[np+i]],minai68[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai68[[np+i]],maxai68[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai68[[np+i]]=minai68[[np+i]]-1;maxai68[[np+i]]=maxai68[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai68[[np+i+nplan]]=1000000000;maxai68[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.68,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai68[[np+i+nplan]],minai68[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai68[[np+i+nplan]],maxai68[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai68[[np+i+nplan]]=minai68[[np+i+nplan]]-2π;maxai68[[np+i+nplan]]=maxai68[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai68

maxai68

Plot marginal  distribution for model parameters for most common peak and 60% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai60=Table[0,{j,1,np+2*nplan}];maxai60=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai60[[i]]=1000000000;maxai60[[i]]=-1000000000;area=0;j=1;
While[area≤0.6,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai60[[i]],minai60[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai60[[i]],maxai60[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai60[[np+i]]=1000000000;maxai60[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.6,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai60[[np+i]],minai60[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai60[[np+i]],maxai60[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai60[[np+i]]=minai60[[np+i]]-1;maxai60[[np+i]]=maxai60[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai60[[np+i+nplan]]=1000000000;maxai60[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.60,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai60[[np+i+nplan]],minai60[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai60[[np+i+nplan]],maxai60[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai60[[np+i+nplan]]=minai60[[np+i+nplan]]-2π;maxai60[[np+i+nplan]]=maxai60[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai60

maxai60

Plot marginal  distribution for model parameters for most common peak and 30% credible region.

Extract parameter iterations beyond burn-in with period values between pLow and pHi.
By default pLow = avmin[[1]] and pHi = avMax[[1]], the search range.

trn=.;k=nβ;
If[ncsys<n,p1Low=128.0;p1Hi=133.0;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt,1}];trPsel=Select[tr,#[[2]]>p1Low&&#[[2]]<p1Hi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];trnn=Drop[trn,{1}]];ng=Length[trnn[[1]]]]

Details behind generating the marginal distributions (using nai bins).

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=150;plp=Table[1,{i,np+2*nplan}];meanai=Table[0,{j,1,np+2*nplan}];medianai=Table[0,{j,1,np+2*nplan}];modeai=Table[0,{j,1,np+2*nplan}];minai30=Table[0,{j,1,np+2*nplan}];maxai30=Table[0,{j,1,np+2*nplan}];areai=Table[0,{j,1,np+2*nplan}];

meanai

Next block computes the marginal PDF for the continuous parameters (the (Subscript[P, 1]) is discrete).
The text in red is devoted to handling the parameters χ and ω in a special way since
they are Modulo 1 and 2π, respectively. A problem can arise in calculating credible regions
if the PDF has a bump at both ends of the range and a gap in the middle. The two ends are 
actually close to one another in a wrap around sense because they are angular coordinates.
The aim of the red code is to put them together to achieve the minimum size credible region.

Recal we specified search ranges initially of
avmin[[4]]=0; avMax[[4]]=1.0;avmin[[6]]=0; avMax[[4]]=2π; 
The first step is to determine the repeat length of the angular parameters
If[avMax[[i]]>1.,useMax=2.0*π,useMax=1.0];
  Then add a second (repeat) cycle of each with
aimarg2=Join[aimarg1,(aimarg1+avMax[[i]]/2.)];
  Then we make a binned version (2 nai1 bins in total) of the double cycle.
  The idea is to Select one cycle (nai1 bins) of each varying the starting phase. 
  We compute the variance of each Select and note the start phase strtpbin2[[i]]
  of the first Select which has the minimum variance.
  Finally we Select one cycle from aimarg2 starting at a value strtpbin2[[i]].

strtpbin2=Table[0,{np+2*nplan}];swstrt=0;nai1=50;If[ncsys<n&&lsel>0,Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aidiff=0;aimarg=trn[[i+1]];swstrt=1;
If[type[[i]]==2,aimarg1=Mod[aimarg,2*π];useMax=2π;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[i]]&&#<(strtpbin2[[i]]+nai1*dai1)&]]];
If[aidiff>0,,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]];minai30[[i]]=1000000000;maxai30[[i]]=-1000000000;area=0;j=1;
While[area≤0.3,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai30[[i]],minai30[[i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai30[[i]],maxai30[[i]]=pbin[[j,2]],Null];
j=j+1];areai[[i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];plp[[i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,np}
];
Do[aimarg1=Mod[(trn[[pos1[[i]]+1]]+trn[[pos2[[i]]+1]])/(4π),1];
useMax=1;
       aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);
aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddiff,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i]]&&#<(strtpbin2[[np+i]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i]]=Mean[aimarg];medianai[[np+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[[np+i]]=pbin[[1,2]];minai30[[np+i]]=1000000000;maxai30[[np+i]]=-1000000000;area=0;j=1;
While[area≤0.3,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai30[[np+i]],minai30[[np+i]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai30[[np+i]],maxai30[[np+i]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i]]>1,modeai[[np+i]]=modeai[[np+i]]-1;medianai[[np+i]]=medianai[[np+i]]-1;meanai[[np+i]]=meanai[[np+i]]-1;minai30[[np+i]]=minai30[[np+i]]-1;maxai30[[np+i]]=maxai30[[np+i]]-1;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-1;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["χ"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]];
aimarg1=Mod[(trn[[pos1[[i]]+1]]-trn[[pos2[[i]]+1]])/2,2π];useMax=2π;aimarg2=Join[aimarg1,(aimarg1+useMax)];low1=0.0;hi1=N[2*useMax];dai1=(hi1-low1)/(2*nai1);aibin1=BinCounts[aimarg2,{low1,hi1,dai1}];
aimidpoints1=Table[N[k],{k,low1+dai1/2,hi1-dai1/2,dai1}];ddiff=Length[aimidpoints1]-Length[aibin1];If[ddiff>0,aidiff=ddif,];
If[aidiff>0,,pbin1=Transpose[{aibin1,aimidpoints1}];varbin0=10000000.0;Do[pbin2=Select[pbin1,#[[2]]>((j-1)*dai1)&&#[[2]]<(((j-1)+nai1)*dai1)&];tpbin2=Transpose[pbin2];sumpbin2=Plus@@tpbin2[[1]];meanpbin2=tpbin2[[1]].tpbin2[[2]]/(sumpbin2);varpbin2=tpbin2[[1]].(((tpbin2[[2]]-meanpbin2))^2)/(sumpbin2);If[varpbin2<varbin0,strtpbin2[[np+i+nplan]]=tpbin2[[2,1]]-dai1/2;varbin0=varpbin2,],{j,1,nai1}];
aimarg=Select[aimarg2,#>strtpbin2[[np+i+nplan]]&&#<(strtpbin2[[np+i+nplan]]+nai1*dai1)&]];
If[aidiff>0,,meanai[[np+i+nplan]]=Mean[aimarg];medianai[[np+i+nplan]]=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[[np+i+nplan]]=pbin[[1,2]];minai30[[np+i+nplan]]=1000000000;maxai30[[np+i+nplan]]=-1000000000;area=0;j=1;
While[area≤0.3,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai30[[np+i+nplan]],minai30[[np+i+nplan]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai30[[np+i+nplan]],maxai30[[np+i+nplan]]=pbin[[j,2]],Null];
j=j+1
];
areai[[np+i+nplan]]=area;
aimargbin=Transpose[{aimidpoints,yai}];If[modeai[[np+i+nplan]]>2π,modeai[[np+i+nplan]]=modeai[[np+i+nplan]]-2π;medianai[[np+i+nplan]]=medianai[[np+i+nplan]]-2π;meanai[[np+i+nplan]]=meanai[[np+i+nplan]]-2π;minai30[[np+i+nplan]]=minai30[[np+i+nplan]]-2π;maxai30[[np+i+nplan]]=maxai30[[np+i+nplan]]-2π;taimargbin=Transpose[aimargbin];btaimargbin=taimargbin[[1]]-2π;low=Min[btaimargbin];hi=Max[btaimargbin];aimargbin=Transpose[{btaimargbin,taimargbin[[2]]}],
];
label=ToExpression["ω"<>ToString[i]<>"label"];xaxisticks=Table[low+(hi-low)*(1+3*(j-1))/8.0,{j,1,3}];
plp[[np+i+nplan]]=ListPlot[aimargbin,PlotRange->{{low,hi},{0,1.1*Max[yai]}},Frame->True,FrameTicks->{xaxisticks,Automatic,Automatic,Automatic}, Axes->False,PlotStyle->{Black,Thickness[0.007],PointSize[0.05]},Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
],{i,1,nplan}
]
]

The line below gives the actual area within the credible region for each parameter achieved for the particular choice of the number of bins, nai.

If[ncsys<n&&lsel>0&&aidiff<1,N[areai],]

The 4th and 6th items of strtpbin2 are the lower boundaries of the phase windows for χ and ω 
that lead to the minimum credible regions for these two items..

strtpbin2

meanai

medianai

modeai

minai30

maxai30

Set up the loglikeoffset parameter.

loglikeoffset=140.0; (* offset added to loglike calculation to keep the calculations within the machine precision range which is of importance in the Marginal Likelihood part of the calculations via the Nested Restricted Mont Carlo Method. *)

The next step sets up a module for calculating the loglikelihood needed in this section.

workfreq:=Module[{a1,a2,a3,a4,a5,a6,aχ1,aω1,s,y},a1=av[[1]];a2=av[[2]];a3=av[[3]];a4=av[[4]];a5=av[[5]];a6=av[[6]];s=av[[7]];aχ1=0.25*(a4+a6)/π;aω1=0.5*(a4-a6);
fvec=Mod[tvec*a1+aχ1,1];
ndiffeq =θ'[q] - ((2*π)/(((1-(a2^2)))^(3/2)))(((1+a2*Cos[θ[q]]))^2) ==0;
numsol=NDSolve[{ndiffeq,θ[0]==0},θ,{q,0,1}];
θvec=Flatten[θ[fvec]/.numsol];
(* Create mvec, a vector of model radial velocity predictions *)
mvec=a3+a5*(Cos[θvec+aω1]+a2*Cos[aω1]);
logprior=Log[(1.0/(a1*(a5+mJlim)*(s+mJslim)))]-Log[Log[1+((bfMax[[5]])/(mJlim*(Sqrt[1-(((a2))^2)])))*(((bfmin[[1]]*a1))^(1/3))]]+c ; (* the prior for parameters *) serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(dvec-mvec)/serrvec;
loglike=loglikeoffset+logfact-Plus@@Log[serrvec]-0.5*y.y]

Compute the contribution to p(D|M1s,I) for each nested region.

Now, we find or specify the upper and lower parameter boundaries for the MC interation based on examination of the MCMC marginal parameter distributions which define the region in parameter space where the joint posterior has significant probability. For example minai30 and maxai30 specify the parameter values at the lower and upper boundaries of the 30% credible region. The first element is the period parameter. We will actually perform MC sampling in frequency space so part of the next step computing low30 and hi30 is to convert these periods to frequencies. low30 is the vector of the lowest parameter values to be found in the 30% credible region. Other tests are carried out to insure the parameters are in the expected range, e.g.,  non negative eccentricity.

minai30

maxai30

To insure an eccenticity term does not go negative.

low30=Table[x=maxai30[[i]];y=minai30[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi30=Table[x=maxai30[[i]];y=minai30[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMCi number of MCMC iterations. By default this is set to a low value to execute quickly. A better choice would be 40000.

nMCi=4000;

The next step evaluates the target posterior PDF at 8 times nMCi random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[av=
Table[valtype=type[[j]];
If[valtype≠2,RandomReal[{low30[[j]],hi30[[j]]}],
If[RandomReal[]<0.5,
RandomReal[{low30[[j]],hi30[[j]]}],
RandomReal[{low30[[j]]+2*π,hi30[[j]]+2*π}]
]
],{j,1,ncs}
];
workfreq;
pdfβ1=logprior+loglike; 
pdfβ1,{i,1,nMCi} 
];
logpdfM30=Flatten[workvals];
]

nwkv30=Length[logpdfM30]

zmax30=Max[logpdfM30]

Exp[zmax30]

pdfM30=Exp[logpdfM30-zmax30];

First[pdfM30]

First[pdfM30]*Exp[zmax30]

Last[pdfM30]*Exp[zmax30]

Now compute the mean value of the target posterior PDF .

mean30=Mean[pdfM30]*Exp[zmax30]

The volume of parameter space of interest is specified by volume.

hiA=hi30;lowA=low30;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

vol30=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integral30=mean30*vol30

The error estimate for the MC evaluation of p(D|(Subscript[M, 1s]),I)

stderr30=StandardDeviation[pdfM30]*Exp[zmax30]*vol30/(Sqrt[nwkv30])

Now compute the same quantities for 60% credible region zone.

low60=Table[x=maxai60[[i]];y=minai60[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi60=Table[x=maxai60[[i]];y=minai60[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low60[[j]],hi60[[j]]}];If[val≥low30[[j]]&&val<hi30[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low60[[j]],hi60[[j]]}];If[val≥low30[[j]]&&val<hi30[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low60[[j]]+2*π,hi60[[j]]+2*π}];If[val≥(low30[[j]]+2*π)&&val<(hi30[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM60out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout60=Length[logpdfM60out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin60=Length[tempwkvals];If[nwkvin60>1,logpdfM60in=Transpose[tempwkvals][[2]];nwkvin60=Length[logpdfM60in]];nwkvin60
]

The quatity nwkvin60 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin60

zmaxout60=Max[logpdfM60out]

Exp[zmaxout60]

pdfMout60=Exp[logpdfM60out-zmaxout60];

Now compute the mean value of the target posterior PDF .

meanout60=Mean[pdfMout60]*Exp[zmaxout60]

The volume of parameter space of interest is specified by volume.

hiA=hi60;lowA=low60;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout60=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout60=meanout60*(volout60-vol30)

The error estimate for the MC evaluation of p(D|M,I)

stderrout60=StandardDeviation[pdfMout60]*Exp[zmaxout60]*(volout60-vol30)/(Sqrt[nwkvout60])

Now compute the overall integral up to 60% credible region

integral60=integralout60+integral30

The error estimate for the MC evaluation of p(D|M,I)

stderr60=(Sqrt[(((stderrout60))^2)+(((stderr30))^2)])

Now compute the same quantities for 68% credible region zone.

low68=Table[x=maxai[[i]];y=minai[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>4*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi68=Table[x=maxai[[i]];y=minai[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>4*π,4*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low68[[j]],hi68[[j]]}];If[val≥low60[[j]]&&val<hi60[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low68[[j]],hi68[[j]]}];If[val≥low60[[j]]&&val<hi60[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low68[[j]]+2*π,hi68[[j]]+2*π}];If[val≥(low60[[j]]+2*π)&&val<(hi60[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM68out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout68=Length[logpdfM68out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin68=Length[tempwkvals];If[nwkvin68>1,logpdfM68in=Transpose[tempwkvals][[2]];nwkvin68=Length[logpdfM68in]];nwkvin68
]

The quatity nwkvin68 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin68

zmaxout68=Max[logpdfM68out]

Exp[zmaxout68]

pdfMout68=Exp[logpdfM68out-zmaxout68];

Now compute the mean value of the target posterior PDF .

meanout68=Mean[pdfMout68]*Exp[zmaxout68]

The volume of parameter space of interest is specified by volume.

hiA=hi68;lowA=low68;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout68=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout68=meanout68*(volout68-volout60)

The error estimate for the MC evaluation of p(D|M,I)

stderrout68=StandardDeviation[pdfMout68]*Exp[zmaxout68]*(volout68-volout60)/(Sqrt[nwkvout68])

Now compute the overall integral up to 68% credible region

integral68=integralout68+integral60

The error estimate for the MC evaluation of p(D|M,I)

stderr68=(Sqrt[(((stderrout68))^2)+(((stderr60))^2)])

Now compute the same quantities for 76% credible region zone.

low76=Table[x=maxai76[[i]];y=minai76[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi76=Table[x=maxai76[[i]];y=minai76[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low76[[j]],hi76[[j]]}];If[val≥low68[[j]]&&val<hi68[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low76[[j]],hi76[[j]]}];If[val≥low68[[j]]&&val<hi68[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low76[[j]]+2*π,hi76[[j]]+2*π}];If[val≥(low68[[j]]+2*π)&&val<(hi68[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM76out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout76=Length[logpdfM76out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin76=Length[tempwkvals];If[nwkvin76>1,logpdfM76in=Transpose[tempwkvals][[2]];nwkvin76=Length[logpdfM76in]];nwkvin76
]

The quatity nwkvin76 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin76

zmaxout76=Max[logpdfM76out]

Exp[zmaxout76]

pdfMout76=Exp[logpdfM76out-zmaxout76];

Now compute the mean value of the target posterior PDF .

meanout76=Mean[pdfMout76]*Exp[zmaxout76]

The volume of parameter space of interest is specified by volume.

hiA=hi76;lowA=low76;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout76=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout76=meanout76*(volout76-volout68)

The error estimate for the MC evaluation of p(D|M,I)

stderrout76=StandardDeviation[pdfMout76]*Exp[zmaxout76]*(volout76-volout68)/(Sqrt[nwkvout76])

Now compute the overall integral up to 76% credible region

integral76=integralout76+integral68

The error estimate for the MC evaluation of p(D|M,I)

stderr76=(Sqrt[(((stderrout76))^2)+(((stderr68))^2)])

Now compute the same quantities for 84% credible region zone.

low84=Table[x=maxai84[[i]];y=minai84[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi84=Table[x=maxai84[[i]];y=minai84[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low84[[j]],hi84[[j]]}];If[val≥low76[[j]]&&val<hi76[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low84[[j]],hi84[[j]]}];If[val≥low76[[j]]&&val<hi76[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low84[[j]]+2*π,hi84[[j]]+2*π}];If[val≥(low76[[j]]+2*π)&&val<(hi76[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM84out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout84=Length[logpdfM84out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin84=Length[tempwkvals];If[nwkvin84>1,logpdfM84in=Transpose[tempwkvals][[2]];nwkvin84=Length[logpdfM84in]];nwkvin84
]

The quatity nwkvin84 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin84

zmaxout84=Max[logpdfM84out]

Exp[zmaxout84]

pdfMout84=Exp[logpdfM84out-zmaxout84];

Now compute the mean value of the target posterior PDF .

meanout84=Mean[pdfMout84]*Exp[zmaxout84]

The volume of parameter space of interest is specified by volume.

hiA=hi84;lowA=low84;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout84=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout84=meanout84*(volout84-volout76)

The error estimate for the MC evaluation of p(D|M,I)

stderrout84=StandardDeviation[pdfMout84]*Exp[zmaxout84]*(volout84-volout76)/(Sqrt[nwkvout84])

Now compute the overall integral up to 84% credible region

integral84=integralout84+integral76

The error estimate for the MC evaluation of p(D|M,I)

stderr84=(Sqrt[(((stderrout84))^2)+(((stderr76))^2)])

Now compute the same quantities for 90% credible region zone.

low90=Table[x=maxai90[[i]];y=minai90[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi90=Table[x=maxai90[[i]];y=minai90[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low90[[j]],hi90[[j]]}];If[val≥low84[[j]]&&val<hi84[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low90[[j]],hi90[[j]]}];If[val≥low84[[j]]&&val<hi84[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low90[[j]]+2*π,hi90[[j]]+2*π}];If[val≥(low84[[j]]+2*π)&&val<(hi84[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM90out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout90=Length[logpdfM90out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin90=Length[tempwkvals];If[nwkvin90>1,logpdfM90in=Transpose[tempwkvals][[2]];nwkvin90=Length[logpdfM90in]];nwkvin90
]

The quatity nwkvin90 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin90

zmaxout90=Max[logpdfM90out]

Exp[zmaxout90]

pdfMout90=Exp[logpdfM90out-zmaxout90];

Now compute the mean value of the target posterior PDF .

meanout90=Mean[pdfMout90]*Exp[zmaxout90]

The volume of parameter space of interest is specified by volume.

hiA=hi90;lowA=low90;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout90=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout90=meanout90*(volout90-volout84)

The error estimate for the MC evaluation of p(D|M,I)

stderrout90=StandardDeviation[pdfMout90]*Exp[zmaxout90]*(volout90-volout84)/(Sqrt[nwkvout90])

Now compute the overall integral up to 90% credible region

integral90=integralout90+integral84

The error estimate for the MC evaluation of p(D|M,I)

stderr90=(Sqrt[(((stderrout90))^2)+(((stderr84))^2)])

Now compute the same quantities for 95% credible region zone.

low95=Table[x=maxai95[[i]];y=minai95[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi95=Table[x=maxai95[[i]];y=minai95[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low95[[j]],hi95[[j]]}];If[val≥low90[[j]]&&val<hi90[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low95[[j]],hi95[[j]]}];If[val≥low90[[j]]&&val<hi90[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low95[[j]]+2*π,hi95[[j]]+2*π}];If[val≥(low90[[j]]+2*π)&&val<(hi90[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM95out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout95=Length[logpdfM95out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin95=Length[tempwkvals];If[nwkvin95>1,logpdfM95in=Transpose[tempwkvals][[2]];nwkvin95=Length[logpdfM95in]];nwkvin95
]

The quatity nwkvin95 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin95

zmaxout95=Max[logpdfM95out]

Exp[zmaxout95]

pdfMout95=Exp[logpdfM95out-zmaxout95];

Now compute the mean value of the target posterior PDF .

meanout95=Mean[pdfMout95]*Exp[zmaxout95]

The volume of parameter space of interest is specified by volume.

hiA=hi95;lowA=low95;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout95=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout95=meanout95*(volout95-volout90)

The error estimate for the MC evaluation of p(D|M,I)

stderrout95=StandardDeviation[pdfMout95]*Exp[zmaxout95]*(volout95-volout90)/(Sqrt[nwkvout95])

Now compute the overall integral up to 95% credible region

integral95=integralout95+integral90

The error estimate for the MC evaluation of p(D|M,I)

stderr95=(Sqrt[(((stderrout95))^2)+(((stderr90))^2)])

Now compute the same quantities for 97% credible region zone.

low97=Table[x=maxai97[[i]];y=minai97[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi97=Table[x=maxai97[[i]];y=minai97[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low97[[j]],hi97[[j]]}];If[val≥low95[[j]]&&val<hi95[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low97[[j]],hi97[[j]]}];If[val≥low95[[j]]&&val<hi95[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low97[[j]]+2*π,hi97[[j]]+2*π}];If[val≥(low95[[j]]+2*π)&&val<(hi95[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM97out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout97=Length[logpdfM97out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin97=Length[tempwkvals];If[nwkvin97>1,logpdfM97in=Transpose[tempwkvals][[2]];nwkvin97=Length[logpdfM97in]];nwkvin97
]

The quatity nwkvin97 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin97

zmaxout97=Max[logpdfM97out]

Exp[zmaxout97]

pdfMout97=Exp[logpdfM97out-zmaxout97];

Now compute the mean value of the target posterior PDF .

meanout97=Mean[pdfMout97]*Exp[zmaxout97]

The volume of parameter space of interest is specified by volume.

hiA=hi97;lowA=low97;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout97=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout97=meanout97*(volout97-volout95)

The error estimate for the MC evaluation of p(D|M,I)

stderrout97=StandardDeviation[pdfMout97]*Exp[zmaxout97]*(volout97-volout95)/(Sqrt[nwkvout97])

Now compute the overall integral up to 97% credible region

integral97=integralout97+integral95

The error estimate for the MC evaluation of p(D|M,I)

stderr97=(Sqrt[(((stderrout97))^2)+(((stderr95))^2)])

Now compute the same quantities for 99% credible region zone.

low99=Table[x=maxai99[[i]];y=minai99[[i]];Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi99=Table[x=maxai99[[i]];y=minai99[[i]];Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low99[[j]],hi99[[j]]}];If[val≥low97[[j]]&&val<hi97[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low99[[j]],hi99[[j]]}];If[val≥low97[[j]]&&val<hi97[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low99[[j]]+2*π,hi99[[j]]+2*π}];If[val≥(low97[[j]]+2*π)&&val<(hi97[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM99out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout99=Length[logpdfM99out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin99=Length[tempwkvals];If[nwkvin99>1,logpdfM99in=Transpose[tempwkvals][[2]];nwkvin99=Length[logpdfM99in]];nwkvin99
]

The quatity nwkvin99 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin99

zmaxout99=Max[logpdfM99out]

Exp[zmaxout99]

pdfMout99=Exp[logpdfM99out-zmaxout99];

Now compute the mean value of the target posterior PDF .

meanout99=Mean[pdfMout99]*Exp[zmaxout99]

The volume of parameter space of interest is specified by volume.

hiA=hi99;lowA=low99;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout99=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout99=meanout99*(volout99-volout97)

The error estimate for the MC evaluation of p(D|M,I)

stderrout99=StandardDeviation[pdfMout99]*Exp[zmaxout99]*(volout99-volout97)/(Sqrt[nwkvout99])

Now compute the overall integral up to 99% credible region

integral99=integralout99+integral97

The error estimate for the MC evaluation of p(D|M,I)

stderr99=(Sqrt[(((stderrout99))^2)+(((stderr97))^2)])

Now compute the same quantities for 9995% credible region  zone

The credible region listed as 9995 % is defined as follows. Let XU99 and XL99 correspond to the upper and lower boundaries of the 99 % credible
region, respectively, for any of the parameters. Similarly, XU95 and XL95 are the upper and lower boundaries of the 95 % credible region for the parameter.Then XU9995 = XU99 + (XU99 − XU95) and XL9995 = XL99 + (XL99 − XL95). Similarly, XU9984 = XU99 + (XU99 − XU84).

low9995=Table[x=(2*maxai99[[i]]-maxai95[[i]]);y=(2*minai99[[i]]-minai95[[i]]);Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi9995=Table[x=(2*maxai99[[i]]-maxai95[[i]]);y=(2*minai99[[i]]-minai95[[i]]);Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low9995[[j]],hi9995[[j]]}];If[val≥low99[[j]]&&val<hi99[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low9995[[j]],hi9995[[j]]}];If[val≥low99[[j]]&&val<hi99[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low9995[[j]]+2*π,hi9995[[j]]+2*π}];If[val≥(low99[[j]]+2*π)&&val<(hi99[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM9995out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout9995=Length[logpdfM9995out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin9995=Length[tempwkvals];If[nwkvin9995>1,logpdfM9995in=Transpose[tempwkvals][[2]];nwkvin9995=Length[logpdfM9995in]];nwkvin9995
]

The quatity nwkvin9995 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin9995

zmaxout9995=Max[logpdfM9995out]

Exp[zmaxout9995]

pdfMout9995=Exp[logpdfM9995out-zmaxout9995];

Now compute the mean value of the target posterior PDF .

meanout9995=Mean[pdfMout9995]*Exp[zmaxout9995]

The volume of parameter space of interest is specified by volume.

hiA=hi9995;lowA=low9995;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout9995=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout9995=meanout9995*(volout9995-volout99)

The error estimate for the MC evaluation of p(D|M,I)

stderrout9995=StandardDeviation[pdfMout9995]*Exp[zmaxout9995]*(volout9995-volout99)/(Sqrt[nwkvout9995])

Now compute the overall integral up to 9995% credible region

integral9995=integralout9995+integral99

The error estimate for the MC evaluation of p(D|M,I)

stderr9995=(Sqrt[(((stderrout9995))^2)+(((stderr99))^2)])

Now compute the same quantities for 9984% credible region  zone

low9984=Table[x=(2*maxai99[[i]]-maxai84[[i]]);y=(2*minai99[[i]]-minai84[[i]]);Which[type[[i]]==-1,1.0/x,type[[i]]==2,If[(x-y)>2*π,0.0,y],type[[i]]==4,If[(x-y)>4*π,-2*π,y],type[[i]]>4,If[y<avmin[[i]],avmin[[i]],y],type[[i]]==0,Which[type[[i-1]]==-1,If[y<avmin[[i]],avmin[[i]],y],i==np,If[y<avmin[[i]],avmin[[i]],y],y==y,y],y==y,y],{i,1,np}]

hi9984=Table[x=(2*maxai99[[i]]-maxai84[[i]]);y=(2*minai99[[i]]-minai84[[i]]);Which[type[[i]]==-1,1.0/y,type[[i]]==2,If[(x-y)>2*π,2*π,x],type[[i]]==4,If[(x-y)>4*π,2*π,x],type[[i]]>4,If[x>avMax[[i]],avMax[[i]],x],type[[i]]==0,Which[type[[i-1]]==-1,If[x>avMax[[i]],avMax[[i]],x],i==np,If[x>avMax[[i]],avMax[[i]],x],x==x,x],x==x,x],{i,1,np}]

Now, we specify the nMC number of MCMC iterations. 
By default this is set to a low value of 2000 iterations to execute quickly. 
You will probably need to increase this to ≥ 200,000 iterations.

The next step evaluates the target posterior PDF at nMC random locations within the 
volume of parameter space of interest. 
Note: boundL[[1]] and boundH[[1]] are Period borders. We are sampling in frequency space 
          so need to use one over these quantities.

AbsoluteTiming[
workvals=
Table[swav=Table[0,{ncs}];
av=
Table[valtype=type[[j]];
If[valtype≠2,val=RandomReal[{low9984[[j]],hi9984[[j]]}];If[val≥low9995[[j]]&&val<hi9995[[j]],swav[[j]]=1,swav[[j]]=0],
If[RandomReal[]<0.5,val=RandomReal[{low9984[[j]],hi9984[[j]]}];If[val≥low9995[[j]]&&val<hi9995[[j]],swav[[j]]=1,swav[[j]]=0],
val=RandomReal[{low9984[[j]]+2*π,hi9984[[j]]+2*π}];If[val≥(low9995[[j]]+2*π)&&val<(hi9995[[j]]+2*π),swav[[j]]=1,swav[[j]]=0]
]
];val,{j,1,ncs}
];swavprod=Times@@swav;
workfreq;
pdfβ1=logprior+loglike; 
{swavprod,pdfβ1},{i,1,nMCi} 
];
logpdfM9984out=Transpose[Select[workvals,#[[1]]==0&]][[2]];nwkvout9984=Length[logpdfM9984out];tempwkvals=Select[workvals,#[[1]]==1&];nwkvin9984=Length[tempwkvals];If[nwkvin9984>1,logpdfM9984in=Transpose[tempwkvals][[2]];nwkvin9984=Length[logpdfM9984in]];nwkvin9984
]

The quatity nwkvin9984 is the number of MC samples not used because they lie inside the previous smaller credible region.

nwkvin9984

zmaxout9984=Max[logpdfM9984out]

Exp[zmaxout9984]

pdfMout9984=Exp[logpdfM9984out-zmaxout9984];

Now compute the mean value of the target posterior PDF .

meanout9984=Mean[pdfMout9984]*Exp[zmaxout9984]

The volume of parameter space of interest is specified by volume.

hiA=hi9984;lowA=low9984;

setA=Transpose[Select[Transpose[{type,hiA}],#[[1]]≠2&]][[2]]-Transpose[Select[Transpose[{type,lowA}],#[[1]]≠2&]][[2]];nsetA=Length[setA];volume=Product[setA[[j]],{j,1,nsetA}]*(∏_(j=1)^nplan)2*(hiA[[pos1[[j]]]]-lowA[[pos1[[j]]]]);

volout9984=volume

The value of integral is the Monte Carlo integration estimate of 
p(D|(Subscript[M, 1s]),I), the global likelihood of the model .

integralout9984=meanout9984*(volout9984-volout9995)

The error estimate for the MC evaluation of p(D|M,I)

stderrout9984=StandardDeviation[pdfMout9984]*Exp[zmaxout9984]*(volout9984-volout9995)/(Sqrt[nwkvout9984])

Now compute the overall integral up to 9984% credible region

integral9984=integralout9984+integral9995

The error estimate for the MC evaluation of p(D|M,I)

stderr9984=(Sqrt[(((stderrout9984))^2)+(((stderr9995))^2)])

Display the results from previous section.

vinteg11={{vol30,integral30},{volout60,integralout60},{volout68,integralout68},{volout76,integralout76},{volout84,integralout84},{volout90,integralout90},{volout95,integralout95},{volout97,integralout97},{volout99,integralout99},{volout9995,integralout9995},{volout9984,integralout9984}}

vintegsum11={{vol30,integral30},{volout60,integral60},{volout68,integral68},{volout76,integral76},{volout84,integral84},{volout90,integral90},{volout95,integral95},{volout97,integral97},{volout99,integral99},{volout9995,integral9995},{volout9984,integral9984}}

plnRMC11=ListLogLogPlot[{vinteg11,vintegsum11},PlotStyle->{{Green,Thickness[0.006]},{Blue,Thickness[0.006]}},Joined->True,Frame->True,FrameLabel->{Style["Restricted Monte Carlo Parameter volume",{"Helvetica-Bold",12}],Style["Marginal Likelihood",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Final marginal likelihood results and improved display.

Correct the marginal likelihood for loglikeoffset.

t1=Transpose[vinteg11];delmarglik=t1[[2]]/Exp[loglikeoffset]

t1sum=Transpose[vintegsum11];marglik=t1sum[[2]]/Exp[loglikeoffset]

logpM1s=Log[Last[marglik]]

Set up plotting variables.

volist1=Log[10,t1[[1]]]

vinteglist=Log[10,delmarglik]

vintegsumlist=Log[10,marglik]

Plot differential marginal likelihoods.

vinteg11cor=Transpose[{volist1,vinteglist}]

del=0.1*(Max[vinteglist]-Min[vinteglist]);plvintegAll=ListPlot[{vinteg11cor},PlotRange->{{1.03*First[volist1],1.3*Last[volist1]},{Min[vinteglist]-del,Max[vinteglist]+del}},Axes->False,PlotStyle->{Black,Thickness[0.006]},PlotMarkers->{{■,10},{●,10},{◆,10}},Joined->True,Frame->True,FrameLabel->{Style["(Subscript[Log, 10])[Restricted Monte Carlo parameter volume]",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10])[ΔMarginal Likelihood]",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot cumulative sum of differential marginal likelihoods.

vintegsum11cor=Transpose[{volist1,vintegsumlist}]

delsum=0.1*(Max[vintegsumlist]-Min[vintegsumlist]);plvintegsumAll=ListPlot[vintegsum11cor,PlotRange->{{1.03*First[volist1],1.3*Last[volist1]},{Min[vintegsumlist]-delsum,Max[vintegsumlist]+delsum}},Axes->False,PlotStyle->{Black,Thickness[0.006]},Joined->True,Frame->True,FrameLabel->{Style["(Subscript[Log, 10])[Restricted Monte Carlo parameter volume]",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10])[Marginal Likelihood]",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plintdiff=Show[plvintegsumAll,plvintegAll]

Plot differential marginal likelihoods with bin labeling.

minvinteglist=Min[vinteglist]
maxvinteglist=Max[vinteglist]
midmeanlist=0.5*(minvinteglist+maxvinteglist)

bot=minvinteglist-del;top=maxvinteglist+del;mid=minvinteglist-0.05;plintmarglike=Show[plvintegAll,Graphics[{Line[{{volist1[[1]],bot},{volist1[[1]],top}}],Text[Style["30%",FontSize->10,FontWeight->"Bold"],{volist1[[1]],mid},{-1,1},{0,1}],Line[{{volist1[[2]],bot},{volist1[[2]],top}}],Text[Style["60%",FontSize->10,FontWeight->"Bold"],{volist1[[2]],mid},{-1,1},{0,1}],Line[{{volist1[[3]],bot},{volist1[[3]],top}}],Text[Style["68%",FontSize->10,FontWeight->"Bold"],{volist1[[3]],mid},{-1,1},{0,1}],Line[{{volist1[[4]],bot},{volist1[[4]],top}}],Text[Style["76%",FontSize->10,FontWeight->"Bold"],{volist1[[4]],mid},{-1,1},{0,1}],Line[{{volist1[[5]],bot},{volist1[[5]],top}}],Text[Style["84%",FontSize->10,FontWeight->"Bold"],{volist1[[5]],mid},{-1,1},{0,1}],Line[{{volist1[[6]],bot},{volist1[[6]],top}}],Text[Style["90%",FontSize->10,FontWeight->"Bold"],{volist1[[6]],mid},{-1,1},{0,1}],Line[{{volist1[[7]],bot},{volist1[[7]],top}}],Text[Style["95%",FontSize->10,FontWeight->"Bold"],{volist1[[7]],mid},{-1,1},{0,1}],Line[{{volist1[[8]],bot},{volist1[[8]],top}}],Text[Style["97%",FontSize->10,FontWeight->"Bold"],{volist1[[8]],mid},{-1,1},{0,1}],Line[{{volist1[[9]],bot},{volist1[[9]],top}}],Text[Style["99%",FontSize->10,FontWeight->"Bold"],{volist1[[9]],mid},{-1,1},{0,1}],Line[{{volist1[[10]],bot},{volist1[[10]],top}}],Text[Style["9995%",FontSize->10,FontWeight->"Bold"],{volist1[[10]],mid+0},{-1,1},{0,1}],Line[{{volist1[[11]],bot},{volist1[[11]],top}}],Text[Style["9984%",FontSize->10,FontWeight->"Bold"],{volist1[[11]],mid+0},{-1,1},{0,1}]}]]

Plot cumulative sum of differential marginal likelihoods with bin labeling.

delsum=0.1*(Max[vintegsumlist]-Min[vintegsumlist]);plvintegsumAll=ListPlot[vintegsum11cor,PlotRange->{{1.03*First[volist1],1.3*Last[volist1]},{Min[vintegsumlist]-delsum,Max[vintegsumlist]+delsum}},Axes->False,PlotStyle->{Black,Thickness[0.006]},PlotMarkers->{■,10},Joined->True,Frame->True,FrameLabel->{Style["(Subscript[Log, 10])[Restricted Monte Carlo parameter volume]",{"Helvetica-Bold",12}],Style["(Subscript[Log, 10])[Marginal Likelihood]",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

minvinteglist=Min[vintegsumlist]
maxvinteglist=Max[vintegsumlist]
midmeanlist=0.5*(minvinteglist+maxvinteglist)

bot=minvinteglist-delsum;top=maxvinteglist+delsum;mid=minvinteglist-0.0;plintmarglikesum=Show[plvintegsumAll,Graphics[{Line[{{volist1[[1]],bot},{volist1[[1]],top}}],Text[Style["30%",FontSize->10,FontWeight->"Bold"],{volist1[[1]],mid},{-1,1},{0,1}],Line[{{volist1[[2]],bot},{volist1[[2]],top}}],Text[Style["60%",FontSize->10,FontWeight->"Bold"],{volist1[[2]],mid},{-1,1},{0,1}],Line[{{volist1[[3]],bot},{volist1[[3]],top}}],Text[Style["68%",FontSize->10,FontWeight->"Bold"],{volist1[[3]],mid},{-1,1},{0,1}],Line[{{volist1[[4]],bot},{volist1[[4]],top}}],Text[Style["76%",FontSize->10,FontWeight->"Bold"],{volist1[[4]],mid},{-1,1},{0,1}],Line[{{volist1[[5]],bot},{volist1[[5]],top}}],Text[Style["84%",FontSize->10,FontWeight->"Bold"],{volist1[[5]],mid},{-1,1},{0,1}],Line[{{volist1[[6]],bot},{volist1[[6]],top}}],Text[Style["90%",FontSize->10,FontWeight->"Bold"],{volist1[[6]],mid},{-1,1},{0,1}],Line[{{volist1[[7]],bot},{volist1[[7]],top}}],Text[Style["95%",FontSize->10,FontWeight->"Bold"],{volist1[[7]],mid},{-1,1},{0,1}],Line[{{volist1[[8]],bot},{volist1[[8]],top}}],Text[Style["97%",FontSize->10,FontWeight->"Bold"],{volist1[[8]],mid},{-1,1},{0,1}],Line[{{volist1[[9]],bot},{volist1[[9]],top}}],Text[Style["99%",FontSize->10,FontWeight->"Bold"],{volist1[[9]],mid},{-1,1},{0,1}],Line[{{volist1[[10]],bot},{volist1[[10]],top}}],Text[Style["9995%",FontSize->10,FontWeight->"Bold"],{volist1[[10]],mid+0},{-1,1},{0,1}],Line[{{volist1[[11]],bot},{volist1[[11]],top}}],Text[Style["9984%",FontSize->10,FontWeight->"Bold"],{volist1[[11]],mid+0},{-1,1},{0,1}]}]]

plDeltaSumMargLike=Show[GraphicsGrid[{{plintmarglike,plintmarglikesum}},Spacings->{Scaled[-0.0],Scaled[-0.05]}]]

Compute p(D|M0s,I), marginal likelihood of the zero planet model

Calculation details:

Assumes a model of an unknown V and an extra Gaussian noise term with unknown sigma s.

As a practical matter we need to choose suitable limits of integration of these two parameters.
If we simply use the prior limits NIntegrate may converge to slowly because of the huge dynamic 
range of the quantity to be integrated.

vmintemp=Min[dvec];(* lower integration limit for V parameter *)

vmaxtemp=Max[dvec];(* upper integration limit for V parameter *)

smintemp=0.0;(* lower integration limit for s parameter *)

smaxtemp=bfMax[[7]];(* upper integration limit for s parameter *)

swnew=0;If[swnew==1,smaxtemp=100.0];(* upper prior bound on s for computing Bayes factor *)

If[ncsys<n,s=.;ΔV=bfMax[[3]]-bfmin[[3]];
fact=((((2*π))^(-nd/2))/(ΔV*Log[1+((bfMax[[7]])/mJslim)]));
serrvecsq=(errvec^2)+(s^2);
term1=Times@@((serrvecsq^(-0.5)))/(s+mJslim)*Exp[-Total[0.5*(((dvec-V))^2)/serrvecsq]];
term2=NIntegrate[term1,{V,vmintemp,vmaxtemp},{s,smintemp,smaxtemp}];
pDM0s=fact*term2
]

If[ncsys<n,logpM0s=Log[pDM0s]]

Compute Bayes factor

If[ncsys<n,odds=Exp[logpM1s-logpM0s]]

Ch. 13: Problem: Bayesian insight regarding FFT power spectrum (discussed in Section 13.2)

CleanUp

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["ErrorBarPlots`"]

List and plot the data

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

List of data values

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]];

Subtract off the mean

datavec=tarr[[2]]-Mean[tarr[[2]]];

data1=Transpose[{timvec,datavec}];

Specify Gaussian noise sigma in the data

sigma=1.0;

err=Table[sigma,{i,1,no}];

datapoints=Table[{data1[[i]],ErrorBar[err[[i]]]},{i,1,no}];

Plot the data

plotdat=ErrorListPlot[datapoints,Frame->True,PlotRange->{{0,65},{-4,4}},AspectRatio->0.5,	
		PlotLabel->Style["SIMULATED TIME SERIES  [sin 2πft + noise (σ = 1)]",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Time axis",{"Helvetica-Bold",14}],
		Style["Signal Strength",{"Helvetica-Bold",14}]},
		BaseStyle -> {"Helvetica-Bold", 12},
		FrameStyle->Thickness[0.004]]

FFT of time series (no zero padding)

Note Mathematica defines the Fourier transform as
(Subscript[H, n]) = (1/(Sqrt[no]))  (Underoverscript[ ∑, (j=1), no])(Subscript[h, k])(e^(i 2π (n-1) (j-1)/no))       (n = 1,2,.....,(nz/2)+1,....,nz),
where no = number of data points.

fftabs=Abs[Fourier[datavec]];

ListPlot[fftabs,Joined->True,PlotRange->All,
	Frame->True]

psd2=fftabs fftabs;

Max[psd2]

Compute the one sided psd = P1side

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]]]

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.}},
		PlotLabel->Style["FOURIER POWER SPECTRAL DENSITY",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["Power Density",{"Helvetica-Bold",12}]},
		BaseStyle -> {"Helvetica-Bold", 12},
		FrameStyle->Thickness[0.004]]

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];

In the zero padded case the Mathematica Discrete Fourier transform is
(Subscript[H, n]) = (1/(Sqrt[nz]))  (Underoverscript[ ∑, (j=1), nz])(Subscript[h, j])(e^(i 2π (n-1) (j-1)/nz))        (n = 1,2,.....,(nz/2)+1,....,nz),
where nz = total points including zero pads, no = number of original data points.
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,Joined->True,PlotRange->All,
	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 df = fc/(nz/2) =1/nz.

df=1/nz;

freq=Table[(i-1)*df,{i,1,(nz/2)+1}];

PSD1=Transpose[{freq,P1side}];

Plot the one sided PSD

pl3=ListPlot[PSD1,Joined->True,Frame->True,
		PlotRange->{{0.0,0.5},{0.0,25.}},
		PlotLabel->Style["FOURIER POWER SPECTRAL DENSITY",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",12}],
		Style["Power Density",{"Helvetica-Bold",12}]},
		BaseStyle -> {"Helvetica-Bold", 12},
		FrameStyle->Thickness[0.004]]

maxP1side=Max[P1side]

NP1side=(P1side/maxP1side);

NPSD1=Transpose[{freq,NP1side}];

pl4=ListPlot[NPSD1,Joined->True,Frame->True,
		PlotRange->{{0.05,0.15},{0.,1.}},
		PlotStyle->Dashing[{0.01,0.01}],
			PlotLabel->Style["COMPARISON",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",14}],
		Style["",{"Helvetica-Bold",14}]},
		BaseStyle -> {"Helvetica-Bold", 13},
		FrameStyle->Thickness[0.004]]

Compute Bayesian posterior PDF after marginalizing over unknown noise sigma. 
This calculation uses P2side computed from the FFT. (see text Section 13.2.1)

The equation we need for the Bayesian posterior is p((Subscript[f, n])|D,I)∝(([1-((2 C((Subscript[f, n])))/(N (OverBar[(d^2)])))])^((2-N)/2))  (see text equ. 13.5)
It has the form of a Student's t probability distribution.

Let dbar = (OverBar[(d^2)])

dbar=((datavec.datavec)/no)

pstud=(((1-((2 P2side)/(no dbar))))^((2-no)/2));

sumpstud=Total[pstud]

freq=Table[(i-1)*df,{i,1,(nz/2)+1}];

normprobstud=Transpose[{freq,(pstud/((sumpstud*df)))}];

pl8a=ListPlot[normprobstud,Joined->True,Frame->True,PlotRange->All]

plb=ListPlot[PSD1,Joined->True,Frame->True,AspectRatio->0.5,
		PlotRange->All,
		PlotLabel->Style["FOURIER POWER SPECTRAL DENSITY",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",14}],
		Style["Power Density",{"Helvetica-Bold",14}]},
		BaseStyle -> {"Helvetica-Bold", 13},
		FrameStyle->Thickness[0.004]]

plc=ListPlot[normprobstud,Joined->True,Frame->True,AspectRatio->0.5,
		PlotRange->All,
		PlotLabel->Style["BAYESIAN PROBABILITY DENSITY",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",14}],
		Style["PDF",{"Helvetica-Bold",14}]},
		BaseStyle -> {"Helvetica-Bold", 13},
		FrameStyle->Thickness[0.004]]

fig=Show[GraphicsGrid[{{plotdat},{plb},{plc}},Spacings->{Scaled[-0.2],Scaled[0.1]}]]

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,Joined->True,Frame->True,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,Joined->True,Frame->True,AspectRatio->0.5,
		PlotRange->All,Axes->False,
		PlotLabel->Style["Log [BAYESIAN PROBABILITY DENSITY]",
				{"Helvetica-Bold",12}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",14}],
		Style["Log[PDF]",{"Helvetica-Bold",14}]},
		BaseStyle -> {"Helvetica-Bold", 13},
		FrameStyle->Thickness[0.004]]

fig=Show[GraphicsGrid[{{plb},{pld}},Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Ch. 13: Lomb-Scargle periodogram and Bayesian generalization

CleanUp:

Clear["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["ErrorBarPlots`"]

List the data which contains gaps and plot.

data={{1.`,0.972598`},{2.`,0.328312`},{3.`,0.24693`},{4.`,-0.387671`},{5.`,-0.87943`},{6.`,-1.022901`},{7.`,-0.19031`},{8.`,0.925053`},{9.`,-0.041976`},{10.`,-0.690563`},{11.`,1.151705`},{12.`,0.384582`},{13.`,-0.744414`},{14.`,1.049991`},{22.`,1.294219`},{23.`,-0.501608`},{24.`,-0.569449`},{25.`,-2.502854`},{26.`,-0.198632`},{27.`,0.953326`},{28.`,-0.030189`},{30.`,1.305802`},{31.`,2.280684`},{32.`,0.026086`},{33.`,1.704482`},{34.`,-1.009354`},{35.`,-0.930374`},{36.`,0.094932`},{37.`,0.615171`},{38.`,1.191529`},{39.`,0.737313`},{40.`,-0.774413`},{41.`,-1.154428`},{42.`,-0.150099`},{43.`,-1.615657`},{44.`,-1.459619`},{48.`,1.605626`},{49.`,0.203707`},{50.`,1.981984`},{51.`,0.396015`},{52.`,-0.195109`},{53.`,0.321488`},{54.`,0.207762`},{58.`,-0.210903`},{59.`,-0.804667`},{60.`,-0.201265`},{61.`,1.870225`},{62.`,0.300619`},{63.`,-0.429399`},{64.`,-1.214098`}};

nd=Length[data]

Transpose the data and extract the time (tvec) and amplitude (dvec) components.
Subtract off the mean value of dvec.

tarr=Transpose[data];

tvec=tarr[[1]];

dvec=tarr[[2]]-Mean[tarr[[2]]];

Specify Gaussian noise sigma in the data

sigma=1.0;

err=Table[sigma,{i,1,nd}];

Create a table of data points with errors ready for plotting

datapoints=Table[{data[[i]],ErrorBar[err[[i]]]},{i,1,nd}];

Plot data points using MultipleListPlot

plotdat=ErrorListPlot[datapoints,Frame->True,PlotRange->{{0,65},{-5,5}},PlotStyle->{Black,PointSize[0.015]},	
		PlotLabel->Style["Simulation  [0.8 sin 2πft + noise (σ = 1)]",{"Helvetica-Bold",10}],
		FrameLabel->{Style["Time  axis",{"Helvetica-Bold",14}],
		Style["Signal  strength",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Generate another plot of above with a different AspectRatio for later plotting. The option DisplayFunction->Identity inhibits the displaying of this plot.

pla=Show[plotdat,Graphics[{Text["(a)",{32,4}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Lomb-Scargle periodogram calculations.

Note: Mean[dvec] should already have been subtracted in the list and plot section, but as a precaution we do it here.

dvec=dvec-Mean[dvec];

Define the function per[f_] to compute the periodogram.

per[f_]:=(ω=2 π f;ω2=4 π f;
θ= (1/2)ArcTan[((Plus@@Sin[ω2*tvec])/(Plus@@Cos[ω2*tvec]+(10^(-20))))];
c=Cos[ω*tvec- θ];s=Sin[ω*tvec- θ];
cc=c.c;ss=s.s;
rLS=Plus@@(dvec*Cos[ω*tvec- θ]);
iLS=Plus@@(dvec*Sin[ω*tvec- θ]);
((((rLS))^2)/cc)+((((iLS))^2)/ss))

Evaluate the periodogram for frequencies in the range >0 to the Nyquist frequency = 1/(2 sample interval) = 0.5. One advantage of nonuniform sampling is to increase the effective bandwidth (see Section 13.6 of the text), namely the largest spectral window free of aliases, compared to the same number of uniformly samples in the same time window. The aliasing phenomenon returns at a sufficiently high frequency due to one of the following reasons. (a) The sampling times although nonuniform, are all integer multiples of some small interval ΔT, because the times are all derived from some finite clock interval. (b) The data are only recorded to a finite number of decimal places which has the same effect as (a).

Timing[perLS=Table[{f,per[f]},{f,0.001,0.5,0.001}];]

Plot the periodogram.

plLS=ListPlot[perLS,Joined->True,Frame->True,
		PlotRange->{{-0.01,0.51},{0.0,12}},PlotStyle->{Black,PointSize[0.015]},
		PlotLabel->Style["Lomb-Scargle  Periodogram",
				{"Helvetica-Bold",10}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",14}],
		Style["Power  density",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plLSa=Show[plLS,Graphics[{Text["(b)",{0.25,11}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Compute Bretthorst's Bayesian generalization of Lomb-Scargle periodogram

bayesversion=(1/(Sqrt[cc*ss]))(((nd*(OverBar[(d^2)]) - perLS))^((2-no)/2))
nd*(OverBar[(d^2)]) = (∑_(i=1)^no)(dvec^(2 )) call this  nd2

nd2=dvec.dvec

bayes[f_]:=(ω=2 π f;ω2=4 π f;
θ= (1/2)ArcTan[((Plus@@Sin[ω2*tvec])/(Plus@@Cos[ω2*tvec]+(10^(-20))))];
c=Cos[ω*tvec- θ];s=Sin[ω*tvec- θ];
cc=c.c;ss=s.s;
rLS=Plus@@(dvec*Cos[ω*tvec- θ]);
iLS=Plus@@(dvec*Sin[ω*tvec- θ]);((((nd2-(((((rLS))^2)/cc)+((((iLS))^2)/ss))))^(1-0.5*nd))/(Sqrt[cc*ss])))

Evaluate the Bayesian p(f|D,I) for 0 < frequencies < Nyquist. 
The Nyquist frequency = 1/(2 sample interval) = 0.5.
Need to avoid f=0 and f=0.5 because the denominator (Sqrt[cc*ss]) can become very small.

Timing[df1=0.0005;bretLS=Table[{f,bayes[f]},{f,0.0005,0.499,df1}];]

trbretLS=Transpose[bretLS];

Normalize the probability density to an area of 1.

normbretLS=trbretLS[[2]]/(Total[trbretLS[[2]]]*df1);

Combine the frequencies and normalized probability densities.

bretLSnorm=Transpose[{trbretLS[[1]],normbretLS}];

plbretLS=ListPlot[bretLSnorm,Joined->True,Frame->True,PlotRange->All,PlotStyle->{Black,PointSize[0.015]},
		PlotLabel->Style["Bayesian  Lomb-Scargle  Probability",
				{"Helvetica-Bold",10}],
		FrameLabel->{Style["Frequency",{"Helvetica-Bold",14}],
		Style["Probability  density",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plLSb=Show[plbretLS,Graphics[{Text["(c)",{0.25,70}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Results: plot of all graphs together

figcomp=Show[GraphicsGrid[{{pla},{plLSa},{plLSb}},Spacings->{Scaled[-0.0],Scaled[0.05]}]]

Ch. 13: Lomb-Scargle periodogram and Bayesian generalization (Extra-solar planet example)

Introduction

Concerns the search for periodicities in the motion of the star HD 73526 which is now known to have two planets based on the analysis of radial velocity data.

CleanUp:

Clear["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["ErrorBarPlots`"]

Plot radial velocity measurements for the star HD 73526 
(ref. Tinney, G. C. 2003, Astrophysical Journal, 587, p. 423)

Each line of the data consists of Julian day - 2,451,000, RV (m (s^(-1))),  uncertainty (m (s^(-1))).

dat1={{212.1302,23.5,12.9},{213.1314,66.8,13.7},{214.2389,61.6,14.9},{236.1465,48.4,10.9},{630.0280,35.5,11.0},{717.9000,-120.7,12.8},{920.1419,-32.0,13.4},{984.0378,78.0,9.3},{1009.0976,71.8,9.7},{1060.8844,-58.9,7.4},{1091.8465,-149.8,13.6},{1386.9003,51.8,6.8},{1387.8921,64.0,6.2},{1420.9248,-14.4,7.8},{1421.9199,-9.6,6.5},{1422.8602,-9.8,7.3},{1424.9237,-19.1,10.4},{1454.8529,-109.0,6.3}};

Transpose the data and extract the time (tvec) and amplitude (dvec) components. 
Subtract off the mean value of dvec.

tarr=Transpose[dat1];

tvec1=tarr[[1]];

dvec=tarr[[2]]-Mean[tarr[[2]]];

errvec=tarr[[3]];

Translate tvec1 values by subtracting off tvec1[[1]] and subtract off the mean data value.

tvec=tvec1-tvec1[[1]]

dur=Last[tvec]

nd=Length[tvec]

data=Transpose[{tvec,dvec}];

tvecRef=2451000+tvec1[[1]]

ref1=IntegerPart[tvecRef]

FractionalPart[tvecRef]

Plot data points using ErrorListPlot

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plotdat=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,AspectRatio->0.5,PlotStyle->{Black,PointSize[0.015]},PlotLabel->Style["HD 73526 data",{"Helvetica-Bold",12}],FrameLabel->{Style["Julian day number (- 2,451,212.1302)",{"Helvetica-Bold",14}],Style["Velocity  (m (s^(-1)))",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Generate another plot with label (a) and a different AspectRatio for later plotting.

pla=Show[plotdat,Graphics[{Text["(a)",{600,75}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Compute the Lomb-scargle periodogram:

Note: Mean[dvec] should already have been subtracted in the list and plot section, but as a precaution we do it here.

dvec=dvec-Mean[dvec];

Define the function per[f_] to compute the periodogram.

per[f_]:=(ω=2 π f;ω2=4 π f;
θ= (1/2)ArcTan[((Plus@@Sin[ω2*tvec])/(Plus@@Cos[ω2*tvec]+(10^(-20))))];
c=Cos[ω*tvec- θ];s=Sin[ω*tvec- θ];
cc=c.c;ss=s.s;
rLS=Plus@@(dvec*Cos[ω*tvec- θ]);
iLS=Plus@@(dvec*Sin[ω*tvec- θ]);
((((rLS))^2)/cc)+((((iLS))^2)/ss))

periodLow=50.0;
periodHi=Last[tvec];
freqLow=1.0/periodHi;
freqHi=1.0/periodLow;freqResolution=0.00005;

Timing[freqLS=Table[{f,per[f]},{f,freqLow,freqHi,freqResolution}];]

sigma=Mean[errvec]

The first element of perLS consist of a frequency and the periodogram value .

freqLS[[1]]

Convert perLS the frequencies to periods for plotting .

tperLS=Transpose[freqLS];

perLS=Transpose[{1/tperLS[[1]],tperLS[[2]]}];

Specify x axis tick values for plotting .

xticks={2,3,4,6,10,20,30,50,100,200,400,1000};

plLS=ListLogLinearPlot[perLS,Frame->True,Joined->True,AspectRatio->0.5,
		PlotRange->All,FrameTicks->{xticks,Automatic,Automatic,Automatic},
		PlotLabel->Style["Lomb-Scargle  periodogram",
				{"Helvetica-Bold",13}],
		FrameLabel->{Style["Period  (d)",{"Helvetica-Bold",14}],
		Style["Power  density",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Compute Larry Bretthorst's Bayesian generalization of Lomb-Scargle periodogram

Bretthorst's Bayesian version of Lomb-Scargle assumes independent Gaussian noise 
for each data point with an unknown sigma.  The resulting periodogram has been marginalized 
over this sigma parameter. Any component of the data that cannot be accounted for by
the assumed sinusoidal signal model is treated as noise and swept up into this sigma parameter.
bayesVersion=(1/(Sqrt[cc*ss]))(((nd*(OverBar[(d^2)]) - per))^((2-nd)/2))
nd*(OverBar[(d^2)]) = (∑_(i=1)^nd)(dvec^(2 )) call this  nd2

nd2=dvec.dvec

bayes[f_]:=(ω=2 π f;ω2=4 π f;
θ= (1/2)ArcTan[((Plus@@Sin[ω2*tvec])/(Plus@@Cos[ω2*tvec]+(10^(-20))))];
c=Cos[ω*tvec- θ];s=Sin[ω*tvec- θ];
cc=c.c;ss=s.s;
rLS=Plus@@(dvec*Cos[ω*tvec- θ]);
iLS=Plus@@(dvec*Sin[ω*tvec- θ]);((((nd2-(((((rLS))^2)/cc)+((((iLS))^2)/ss))))^(1-0.5*nd))/(Sqrt[cc*ss])))

Need to avoid f=0 and f=0.5 because the denominator (Sqrt[cc*ss]) can become very small.

Note: the Bayesian version of the periodogram can produce arbitrarily sharp spectral features which depends on the signal/noise level. Thus in general you need to set the frequency resolution (freqRes) smaller than you used for straight Lomb-Scargle. A good guide for the frequency resolution is equation 13.4 of the textbook,   δf ∼1/(1.6*sigTonoise*dur*(Sqrt[nd])), where dur = duration of the data and nd is the number of data points. If dur is in days, δf is in units of cycles per day.

sigTonoise=0.5*(Max[dvec]-Min[dvec])/((Sqrt[2])*Mean[errvec])

freqRes=1/(1.6*sigTonoise*dur*(Sqrt[nd]))

Timing[bretLS=Table[{f,bayes[f]},{f,freqLow,freqHi,freqRes}];]

The first element of perLS consist of a frequency and the periodogram value .

bretLS[[1]]

Normalize the probability density to an area of 1.

tbretLS=Transpose[bretLS];

normbretLS=tbretLS[[2]]/(Total[tbretLS[[2]]]*freqRes);

Combine the frequencies and normalized probability densities.

bayesfreqLS=Transpose[{tbretLS[[1]],normbretLS}];

plbretfreqLS=ListLogLinearPlot[bayesfreqLS,Frame->True,Joined->True,AspectRatio->0.5,
		PlotRange->All,
		PlotLabel->Style["Bretthorst's  Bayesian  periodogram",
				{"Helvetica-Bold",13}],
		FrameLabel->{Style["Frequency  (Hz)",{"Helvetica-Bold",14}],
		Style["PDF",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Convert perLS the frequencies to periods for plotting .

Note: Here we are plotting probability density per unit frequency but labelling the x axis according to P.

bayesPerLS=Transpose[{1/tbretLS[[1]],normbretLS}];

xticks={50,100,200,400,1000};

plbretLS=ListLogLinearPlot[bayesPerLS,Frame->True,Joined->True,AspectRatio->0.5,
		PlotRange->All,FrameTicks->{xticks,Automatic,Automatic,Automatic},
		PlotLabel->Style["Bretthorst's  Bayesian  periodogram",
				{"Helvetica-Bold",13}],
		FrameLabel->{Style["Period  (d)",{"Helvetica-Bold",14}],
		Style["PDF",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Blow up a small region around the peak to check we have sufficient density of frequency points.

plbretLSpeak=ListLogLinearPlot[bayesPerLS,Frame->True,Joined->True,AspectRatio->0.5,
		PlotRange->{{180,205},All},
		PlotLabel->Style["Bretthorst's  Bayesian  periodogram",
				{"Helvetica-Bold",13}],
		FrameLabel->{Style["Period  (d)",{"Helvetica-Bold",14}],
		Style["PDF",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

To see other lower level peaks we plot the (Subscript[Log, 10])(probability  density) 
after normalizing the probability density to have a maximum value of 1.0.

maxnormbretLS=Max[normbretLS]

bayesPerLSmax=Transpose[{1/tbretLS[[1]],Log[10,normbretLS/maxnormbretLS]}];

plbretLSLog=ListLogLinearPlot[bayesPerLSmax,Joined->True,Frame->True,AspectRatio->0.5,PlotRange->All,FrameTicks->{xticks,Automatic,Automatic,Automatic},
		PlotLabel->Style["Bretthorst  periodogram",
				{"Helvetica-Bold",13}],
		FrameLabel->{Style["Period  (d)",{"Helvetica-Bold",14}],
		Style["(Subscript[Log, 10]) PDF",{"Helvetica-Bold",14}]},
		FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Results: plot of all graphs together

figcomp=Show[GraphicsGrid[{{plotdat,plLS},{plbretLS,plbretLSLog}},Spacings->{Scaled[-0.15],Scaled[0.1]}]]

Ch. 13: Gaussian version of Gregory-Loredo Bayesian algorithm for detection 
             of a periodic signal of unknown shape, MCMC implementation 
             Includes signal shape + shape error calculation, exact phase marginalization.

Introduction

This algorithm is a useful Bayesian solution to the question: "How to find a periodic signal of unknown shape and period in a time series with independent Gaussian noise?" Note: if you have strong prior information concerning the form of the signal then you can construct a more efficient Bayesian periodogram. For this algorithm the samples can have unequal spacings and the Gaussian noise σ different for each point.
To use this algorithm effectively, the user should become familiar with the paper listed below and Chapter 12 of my book which is entitled, "Bayesian Logical Data analysis for the Physical Sciences," published by Cambridge University Press. The algorithm employs a non parametric histogram model where the the number of bins, m, is itself a parameter. For each choice of m, marginalization over the unknown shape parameters is done analytically.

This notebook employs a automatic parallel tempering  (Section 12.8) version of Markov Chain Monte Carlo (MCMC) to evaluate the Gregory-Loredo algorithm (Gaussian noise case). The basic equations where developed in a paper entitled "Bayesian Periodic Signal Detection 1: Analysis of 20 Years of Radio Flux Measurements of the X-ray Binary LS I +61 303,"  Gregory, P. C., Astrophysical Journal, 520, pp.361-375, 1999. This version is a modified implementation which employs an extra Gaussian noise parameter, s,  (explained in claculation details below) instead of the noise scale parameter, b, used in the paper. This program also performs exact phase marginalization (see item 2 of Appendix A in Gregory and Loredo, Astrophysical Journal, 398, pp. 146, 1992).

The program can be run with any number of parallel MCMC chains. To do a quick search set the number of chains, nβ = 1 and n ≥ 20,000. To look for multiple periods typically set nβ = 8 chains are run in parallel, each with a different temperature parameter specified by βlis. At random intervals, a proposal to swap the parameter values of a randomly selected pair of adjacent chains is considered. This prevents the MCMC from becoming trapped in one probability peak region.  The program incorporates  a two stage control system that automates the selection of Gaussian proposal σ's, one for each parameter in a two stage adaptive control system. The program uses a unique fusion MCMC algorithm which incorporates parallel tempering, simulated annealing and a genetic crossover operation to increase the chance of detecting a global maximum in the joint posterior probability distribution. The current problem with only 3 parameters does not really justifies the use of an MCMC approach. The real advantage of the fusion MCMC approach is best realized in problems with many more parameters. Further details of fusion MCMC can be found in Gregory, Monthly Notices of the Royal Astronomical Society, 415, pp. 2523-2545, 2011.

Calculation details (ref: (1) Gregory, P. C.,  Astrophysical Journal, 520, pp. 361-375, 1999 and
 (2) Gregory, P. C., Peracaula, M. & Taylor, A. R.,  Astrophysical Journal, 520, pp. 376-390, 1999)

This analysis differs slightly from that presented in ref. 1. In particular, ref. 1 employed a noise scale parameter b (see equation 2). Here, instead we use an extra Gaussian noise term parameterized by the Gaussian standard deviation s.

We can represent the measured data by the equation
                                   (Subscript[d, i])  = (Subscript[f, i]) + (Subscript[ϵ, i])+(Subscript[ϵ, 0])
       (Subscript[d, i]) = measured data at (Subscript[t, i])
       (Subscript[f, i]) = periodic model or constant model prediction at (Subscript[t, i])
       (Subscript[ϵ, i]) = component of  (Subscript[d, i]) which arises from measurement errors
         (Subscript[ϵ, 0])= any additional unknown measurement errors plus any real signal
                           in the data that cannot be explained by the model prediction (Subscript[f, i])

The term (Subscript[ϵ, 0 ]) plays a significant role in model comparison as well. 
Let (Subscript[M, per]) ≡ the data contains a periodic signal  plus known measurement noise  (Subscript[ϵ, i]) .
Let (Subscript[M, 1]) ≡ the data consists of a constant plus known measurement noise  (Subscript[ϵ, i]) .
Let (Subscript[M, 1s]) ≡ the data consists of a constant plus known measurement noise  (Subscript[ϵ, i]),
                      plus extra independent Gaussian noise  (Subscript[ϵ, 0])  of unknown variance (s^2).
To usefully claim the presence of a periodic signal we want
              p((Subscript[M, per])|D,I) > both  p((Subscript[M, 1])|D,I) and p((Subscript[M, 1s])|D,I).

If  p((Subscript[M, per])|D,I) > p((Subscript[M, 1])|D,I) but not p((Subscript[M, 1s])|D,I),
then we would be saying that the addition of an independent Gaussian random component 
was more successful in accounting for the variations than a periodic signal model.

In what follows, we allow the periodic model to have an extra noise term as well, thus we
     let (Subscript[M, per]) ≡ the data contains a periodic signal  plus known measurement noise  (Subscript[ϵ, i]) ,
                         plus extra independent Gaussian noise  (Subscript[ϵ, 0])  of unknown variance (s^2). 
               Of course the variance of the extra noise term will be different for the periodic and constant models.

We use a modified Jeffreys prior for  p(s|I) of the form
                   p(s|I) = (1/((s+a)*Log[((a+smax)/a)]))
For s ≪ a, the prior behaves like a uniform prior. For s≫ a it becomes a Jeffreys prior.
Typically we set a ≈ the typical (Subscript[ϵ, i]) term.
a is designated by the variable mJs in the program below.

To replace  b, the noise scale parameter,by the s parameter, make the following changes
to the equations of ref. 1.
          1. Replace the Jeffreys prior for b by a modified Jeffreys prior for s.
  2. Set b = 1 everywhere else.  
3. Repace the estimated noise variance  (Subscript[s, i])  by (Subscript[σ, i]^2)+(s^2).

Raw data consists of a time series (uniform sampling not required). 
In present example it consists of triples of 
{time (days), timing residuals (days), estimated error in timing residuals  (days)}.
Let tvec= a vector of the times.
Let dvec = a vector of the timing residuals.
Let errvec = a vector of dvec errors.

The philosophy of the Gregory-Loredo method is detailed in Section 13.4 of the text book and Ref. 1.
To address the periodic signal detection problem,compute the ratio of
the probabilities (odds) of two models Mper and M1. Model Mper is a family of periodic models capable of describing a background plus a periodic signal of arbitrary shape. A priori, we assume that M1 and Mper have equal probability. Each member of the family of periodic models is a histogram with m bins, with m ranging from 2 to some upper limit, typically 12.

The unknown parameters are P (period), ϕ (phase offset of start of data and beginning of first bin), m (number of bins), and s (extra Gaussian noise parameter).
 
The first step in the calculation is to convert tvec to jvec, a vector of bin numbers corresponding to tvec. 

jvec=IntegerPart[1+m*Mod[tvec/P+ϕp,1]];  a variant of equ.6 ref (1)

ϕp = ϕ/2π, where ϕ is in radians.

sortnjvec = Transpose[{jvec,dvec,serrvec}];   constructs triples of jvec, dvec, serrvec
                                                                            where serrvec = (Sqrt[(errvec^2)+ (s^2)])

Now convert sortnjvec to a m list of {nj,Wj,meandWj,chi2j,wj},
where nj indicates the number of data points in bin j,
Wj = sum of the weights for bin j  equ.13 ref (1), 
meandWj = (OverBar[(Subscript[d, Wj ])])=mean value of dvec for bin j  equ.14 ref (1),
chi2j = (Subscript[χ, j]^2)  value for bin j  equ.16 ref (1),
wj is =1 if nj ≥ 2 or wj=0 if nj < 2  equ.A1 ref (1)  
( wj is a weight that allows use of small data sets )

Now we evaluate the prior and likelihood function, see equation 25 ref prior=((c*P)/(2*π*(s+mJs))) ; (* the prior for parameters for frequency search *) 

where  c=1/((mmax-mmin)*Log[((mJs+smax)/mJs)]*Log[(Pmax/Pmin)]);
(* normalization constants for prior *)

like=((Δr)^(-m))*fact*Times@@(serrvec^(-1))*((((π/2)))^(m/2))*Exp[-0.5*sumchi2j]*complerrfnterm; (* likelihood fn for particular parameters *) 
where  fact=(((2 π))^(-N/2)) ;and Δr  is given by  equ. 19 ref(1), 
and complerrfnterm is = (∏_(j=1)^m){(Wj^(-1/2))[Erfc[yjmin] - Erfc[yjmax]]}
where yjmin = (Sqrt[(Wj/2)])((Subscript[r, min]) - (OverBar[(Subscript[d, Wj ])])) and  where yjmax = (Sqrt[(Wj/2)])((Subscript[r, max]) - (OverBar[(Subscript[d, Wj ])]))
As long as  yjmin<-1.5 and  yjmax>1.5, complerrfnterm is ≈ (∏_(j=1)^m){(Wj^(-1/2))×2.0}; 
pdf1= like;
pdfβ1= prior*(((like))^β); factor needed to decide on tempering swap 

To keep the calculations within the machine precision range, for faster calculations,
we compute the Log[prior] and Log[like] below.

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (exact phase integration) 
Specify a procedure for calculation of basic work = prior×likelihood for periodic family of models 
and the quantities needed in computing the lightcurve shape.

workP:=Module[{P,s,m},P=avs[[1]];s=avs[[2]];m=Round[avs[[3]]];binph=m*Mod[tvec/P,1.0];
phidis=1-FractionalPart[binph];(* phidis = phase distance to next m bin boundary for the time set tvec *)
wtvec=1/((errvec^2)+(s^2));prodsqrtwtvec=Times@@(Sqrt[wtvec]);
jvec=IntegerPart[1+binph];(* jvec = bin numbers corresponding to tvec *)
sortnjvec=Sort[Transpose[{phidis,jvec,wtvec,wtvec*dvec,wtvec*(dvec^2)}]];
tsort=Transpose[sortnjvec];sphidis=tsort[[1]];(* shpidis = the set of phidis corresponding to tvec sorted in ascending order *)
shiftsphidis=Take[Join[{0.0},sphidis],nd];
incphi=sphidis-shiftsphidis;
cph=0.5*(sphidis+shiftsphidis);
(* cph = quantity needed for weighting lightcurve shape estimates according to phase *)
jincphvec=Transpose[{tsort[[2]],tsort[[3]],tsort[[4]],tsort[[5]]}];trjsel=Table[0,{iw,1,nd},{jm,1,m}];
(* there are nd phase increments for each m that need to be considered, iw labels these *)
Do[selj=Select[jincphvec,#[[1]]==jm &];(* for the current set of parameters, select all samples that fall in bin jm jvec for the zero phase bin *)
nj=Length[selj];If[nj≥1,trsel=Transpose[selj];Wj=Total[trsel[[2]]];dWj=Total[trsel[[3]]];sqdWj=Total[trsel[[4]]];If[nj≥2,wj=1,wj=0];item={jm,nj,dWj,sqdWj,Wj,wj},item={jm,0,0.0,0.0,0.0,0}
];trjsel[[1,jm]]=item,{jm,1,m}];
(* compute the same entries for trjsel for the remaining phase increments *)
Do[trjsel[[iw]]=trjsel[[iw-1]];njiw=tsort[[2,iw-1]];If[njiw<m,njiw2=njiw+1,njiw2=1];Wjd=tsort[[3,iw-1]];
ddWj=tsort[[4,iw-1]];
dsqdWj=tsort[[5,iw-1]];item1={0,1,ddWj,dsqdWj,Wjd,0};vec1=trjsel[[iw,njiw]]-item1;If[vec1[[2]]>1,vec1[[6]]=1;trjsel[[iw,njiw]]=vec1,vec1[[6]]=0;trjsel[[iw,njiw]]=vec1];trjsel[[iw,njiw]]=trjsel[[iw,njiw]]/.x_Real/;Abs[x]<(10^(-10))->0.0;vec2=trjsel[[iw,njiw2]]+item1;If[vec2[[2]]>1,vec2[[6]]=1;trjsel[[iw,njiw2]]=vec2,vec2[[6]]=0;trjsel[[iw,njiw2]]=vec2],{iw,2,nd}];
     valsh=Table[tt=Transpose[trjsel[[iw]]];corWj=tt[[5]]/.x_/;x==0.0->1.0;
colWj=corWj;colmeandWj=tt[[3]]/corWj;colmeansqdWj=tt[[4]]/corWj;colchi2j=colWj*(colmeansqdWj-(((colmeandWj))^2));colwj=tt[[6]];sumchi2j=m*(Total[colwj*colchi2j])/Total[colwj];(* the next paragraph explains how the above line allows small data sets to be used *)

Ref : P. C. Gregory, Astrophysical Journal, 520 : 361 - 375, 1999

complerrfnterm=Times@@((colWj^(-1/2))*2); 
loglikeA=-0.5*sumchi2j+Log[complerrfnterm]; 
{loglikeA,colmeandWj,colWj,colwj},{iw,nd}];
valsht=Transpose[valsh];maxloglikeA=Max[valsht[[1]]];adjlikeA=Exp[valsht[[1]]-maxloglikeA];
(* - maxloglikeA factor reduces the dynamic range required in phase integration *)
valnd=Table[adjlikeAinciw=adjlikeA[[iw]]*incphi[[iw]];{adjlikeAinciw,adjlikeAinciw*valsht[[2,iw]],adjlikeAinciw*valsht[[3,iw]],adjlikeAinciw*valsht[[4,iw]],adjlikeAinciw*cph[[iw]]},{iw,nd}];tvalnd=Total[valnd];
ff=1/tvalnd[[1]];
    logprior=Log[((P*c)/((2*π*(s+mJs))))];logdterm=Log[m*tvalnd[[1]]]+maxloglikeA;
(* the factor of m multiplying tvalnd[[1]] allows for the phase integration *) (* over a single bin to be extended to a whole period, the + maxloglikeA *)
    (* corrects for the - maxloglikeA factor used above *)
      loglike=-m*Log[rmax-rmin]+logfact+logprodsqrtwtvec+(m/2)*Log[(π/2)]+logdterm;
ϕ=ff*tvalnd[[5]];ffwj=ff*tvalnd[[4]];ffwj=ffwj/.x_/;x<0.5->0;ffwj=ffwj/.x_/;x≥0.5->1;pvec={P,s,m,ϕ};
pvecA={ff*tvalnd[[2]],ff*tvalnd[[3]],ffwj}];

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["ComputationalGeometry`"]

Needs["ErrorBarPlots`"]

List and plot the data for LSI 6(1^o)303

Each line of the data, named dat, consists of (Julian day - 2,451,000, Flux Density (mJy),  
uncertainty ( mJy).

dat1={{0.00,284.,33.},{718.03,100.,33.},{1096.99,66.,33.},{1457.09,309.,33.},{2524.06,84.,33.},{3607.69,184.,33.},{3630.08,164.,33.},{4033.06,64.,33.},{4161.26,112.,33.},{5355.86,198.,33.},{5469.07,148.,50.},{6012.44,138.,33.},{6038.33,200.,33.},{6063.17,116.,33.},{6089.25,227.,33.},{6117.15,214.,33.},{6147.25,167.,33.},{6172.11,262.,33.},{6198.04,170.,33.},{6224.82,186.,33.},{6251.98,294.,33.},{6276.75,265.,33.},{6306.77,296.,33.},{6361.43,166.,50.},{6411.38,283.,33.},{6440.47,245.,33.},{6467.07,169.,33.},{6492.31,232.,33.},{6519.10,300.,33.},{6543.92,306.,33.},{6572.00,244.,33.},{6597.80,320.,33.},{6623.64,236.,33.},{6651.89,254.,50.},{6677.78,242.,33.},{6705.78,269.,33.},{6731.41,229.,33.},{7048.72,216.,33.},{7075.66,62.,33.},{7103.53,117.,33.},{7133.61,193.,33.},{7164.37,147.,33.},{7185.31,119.,33.},{7211.18,132.,33.},{7244.19,101.,33.},{7267.13,164.,33.},{7292.06,188.,33.},{7324.94,94.,33.},{7339.89,186.,33.},{7369.88,93.,33.},{7398.69,100.,33.},{7427.77,124.,33.},{7451.70,92.,33.},{7473.64,61.,33.},{7494.61,135.,33.},{7520.46,120.,33.}};

Details concerning data manipulation and statistics.

tarr1=Transpose[dat1];

tvec1=N[tarr1[[1]]];

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

errvec1=N[tarr1[[3]]];

Average data interval

Last[tvec1-tvec1[[1]]]/(Length[tvec1]-1)

Translate tvec1 and dvec1 values by subtracting off Mean[tvec1] & Mean[dvec1], respectively.

mntvec1=Mean[tvec1];

dat=Transpose[{tvec1-mntvec1,dvec1,errvec1}];

nd=lendat=Length[dat]

tarr=Transpose[dat];

tvec=N[tarr[[1]]]

tstart=tvec[[1]];tend=tvec[[nd]];

dur=(tend-tstart)

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

errvec=N[tarr[[3]]]

Mean[errvec]

datasigma=StandardDeviation[dvec]

data=Transpose[{tvec,dvec}];

Plot the data

tvecAve=Mean[tvec1]

tvecAve-IntegerPart[tvecAve]

tvecRef=2451000.+tvecAve

IntegerPart[tvecRef]

cmp1=IntegerPart[tvecRef/(10^6)];
cmp2=IntegerPart[(tvecRef-cmp1*(10^6))/(10^5)];cmp3=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5))/(10^4)];cmp4=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4))/(10^3)];cmp5=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3))/(10^2)];cmp6=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2))/10];cmp7=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2)-cmp6*10)];
cmp8=IntegerPart[10*(tvecRef-IntegerPart[tvecRef])];cmp9=IntegerPart[100*(tvecRef-IntegerPart[tvecRef])-cmp8*10];cmp10=IntegerPart[1000*(tvecRef-IntegerPart[tvecRef])-cmp8*100-cmp9*10];cmp11=IntegerPart[10000*(tvecRef-IntegerPart[tvecRef])-cmp8*1000-cmp9*100-cmp10*10];timelabel=ToString[cmp1]<>","<>ToString[cmp2]<>ToString[cmp3]<>ToString[cmp4]<>","<>ToString[cmp5]<>ToString[cmp6]<>ToString[cmp7]<>"."<>ToString[cmp8]<>ToString[cmp9]<>ToString[cmp10]<>ToString[cmp11]

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp1a=Show[plshp1,Graphics[{Text["(a)",{0,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Parallel tempering MCMC program itself:

INITIALIZE PROGRAM VALUES

npara=10; (* number of iterations in one parallel step *)

nthin=npara; (* store MCMC iterations at a thinning interval of nthin *)

n=1000*nthin; (* number of MCMC iterations *)

By default number of iterations n is set = 1000*(npara = 10) and nβ = 1 so that it will execute quickly. 
For reasonable results need to change n >= 2000*(npara = 10).

minCS=1000; (* minimum iterations before 1st stage Control System (CS) turned off *)

maxCS=4000; (* maximum iterations before 1st stage CS turned off *)

deltaN=5000; (*iteration interval for CS to decide whether to rerun 2nd stage CS *)

loglikeoffset=400.0; (* offset to keep results within machine precision range *)

nβ=1;(* the number of choices of tempering parameter *)

(*ratioT=1.77;*) (* ratio of temperature values for different chains (temperature ∝ 1/β *)

(*βlis=Reverse[Table[(ratioT^(-(k-1))),{k,1,nβ}]];*)

βlis={1.0};(* tempering parameter values, in this example only one *)

To look for multiple periods nβ typical set >= 4   chains, each with a different 
 temperature parameter β specified by βlis.

(*βlis={0.00004,0.0005,0.001,0.002,0.005,0.01,0.02,0.032,0.08,0.11,0.17,0.25,0.3,0.35,0.4,0.45,0.51,0.57,0.63,0.69,0.75,0.82,0.90,1.0};*) 
(* useful set of tempering parameter values for Bayes factor calculation which requires many *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains (don't change this) *)

ns=1*npara; (* ns is number of iterations between swap proposals *)

np=4; (* np is the number of model parameters computational explored + s if included *)

ngs=3; (* # Gaussian proposal distributions,ngs=3 for P,s,m, don't change *)

ncs=3; (* ncs = number of model parameters used in 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) *)

swg=1; (* swg=1 if gene swap included, swg = 0 otherwise *)

smp=1;(* smp=0 or 1, smp=1 better multiple peak detection, reduced acceptance rate*)

STARTING PARAMETER VALUES

avst=Table[0,{ncs}]; (* initialize table of start parameter values *)
avmin=Table[0,{ncs}];(* initialize table of parameter search lower bounds *)
avMax=Table[0,{ncs}];(* initialize table of parameter search upper bounds *)
bfmin=Table[0,{ncs}];(* parameter lower bounds for Bayes factor calulation*)
bfMax=Table[0,{ncs}];(* parameter upper bounds for Bayes factor calulation*)

avst[[1]]=950.0; (* parameter 1 start value *)

a1name= "P"; a1unit="  (d)";(* name of parameter 1 and units *)

avst[[2]]=4.0; (* extra noise parameter start value *)

a2name= "s"; a2unit="  (mJy)";(* name of extra noise parameter and units *)

avst[[3]]=5.0; (* parameter 3 start value *)

a3name= "m"; a3unit=" "; (* name of parameter 3 and units *)

PRIOR SEARCH RANGES

avmin[[1]]=800.0;avMax[[1]]=2800.;(* search bounds on period *)

avmin[[2]]=0.0;avMax[[2]]= 100.0;(* search bounds on extra noise term s *)

avmin[[3]]=2;avMax[[3]]=12;(* limits on number of model bins, m *)

mmin=avmin[[3]];mMax=avMax[[3]];(* limits on number of model bins, m *)

rmin=-20.0;rmax= 400.0;(* lower and upper bounds on mean signal + bkgd *)

type={-1,0,-2}; (* If type = -1, parameter is a period, reflect at boundaries *)
(* type = -2, Round to nearest integer *)
(* type = 1, angular parameter, wrap around at 0 and 1 *)
(* type = 2, angular parameter, wrap around at 0 and 2π *)
(* type = 0, all other parameters, reflect at boundaries *)

PRIOR RANGE FOR BAYES FACTOR CALCULATION

bfmin[[1]]=800.0;bfMax[[1]]=dur/2;(* prior bounds on period *)

bfmin[[2]]=0.0;bfMax[[2]]= 100.;(* prior bounds on extra noise term s *)

bfmin[[3]]=2;bfMax[[3]]= 12;(* limits on number of bins, m *)

rmin=-20.0;rmax= 400.0;(* lower and upper bounds on mean signal + bkgd *)

STARTING PROPOSAL 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  *)

σst[[1]]=0.1*(1./avmin[[1]]-1./avMax[[1]]);(* sigma for a1 proposal random Gaussian step, don't change *)

(* Note: parameter m has an integer values, pick new ones from random walk *)

σst[[2]]=10.0; (* sigma for noise scale parameter *)

σst[[3]]=2.0; (* sigma for m parameter *)

minσ[[1]]=1/(1.6*10*dur*(Sqrt[nd]));

minσ[[2]]=Mean[errvec]/(Sqrt[nd]);

minσ[[3]]=0.6; (* empirically determined *)

GENE BOUNDARIES

ngene=1;

genst=Table[0,{ngene}]; (* initialize table of gene start boundaries *)

genend=Table[0,{ngene}]; (* initialize table of gene end boundaries *)

genst[[1]]= 1; (* start of gene 1 *)

genend[[1]]= ncs; (* end of gene 1 *)

CONTROL SYSTEM PARAMETERS  (user don't change this)

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=If[ nβ>1,Table[0.7-(nβ-i)*0.1/(nβ-1),{i,1,nβ}],0.7](* 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=1.2 (* Empirical factor for scaling exponent, typical value for n>10 is 0.9 *)

accept=Table[((((((λ))^(1/(ncs^(kalf*alfm))))))^((βlis[[kn]])^(-0.06))),{kn,1,nβ},{kj,1,ncs}](* Calulation of accept rate for individual parameters in 2nd stage CS *)

accept[[1,1]]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS (user don't change this)

mJlim=1.0;(* constant for modified Jeffreys prior for P parameter*)
mJs=10.0;(* constant for modified Jeffreys prior for s *)

c=-Log[2*π*(bfMax[[3]]-bfmin[[3]])*Log[((bfMax[[1]])/(bfmin[[1]]))]*Log[((mJs+bfMax[[2]])/mJs)]];

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (user don't change this)

Specify a procedure for calculation of basic work = prior×likelihood for model. 
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

Now compute the likelihood and quantities needed in computing the lightcurve shape later on.

Version below includes extra noise parameter s.

workP:=Module[{P,s,m},P=avs[[1]];s=avs[[2]];m=Round[avs[[3]]];binph=m*Mod[tvec/P,1.0];
phidis=1-FractionalPart[binph];wtvec=1/((errvec^2)+(s^2));logprodsqrtwtvec=Log[Times@@(Sqrt[wtvec])];
jvec=IntegerPart[1+binph];sortnjvec=Sort[Transpose[{phidis,jvec,wtvec,wtvec*dvec,wtvec*(dvec^2)}]];
tsort=Transpose[sortnjvec];sphidis=tsort[[1]];shiftsphidis=Take[Join[{0.0},sphidis],nd];
incphi=sphidis-shiftsphidis;cph=0.5*(sphidis+shiftsphidis);
jincphvec=Transpose[{tsort[[2]],tsort[[3]],tsort[[4]],tsort[[5]]}];trjsel=Table[0,{iw,1,nd},{jm,1,m}];Do[selj=Select[jincphvec,#[[1]]==jm &];nj=Length[selj];If[nj≥1,trsel=Transpose[selj];Wj=Total[trsel[[2]]];dWj=Total[trsel[[3]]];sqdWj=Total[trsel[[4]]];If[nj≥2,wj=1,wj=0];item={jm,nj,dWj,sqdWj,Wj,wj},item={jm,0,0.0,0.0,0.0,0}
];trjsel[[1,jm]]=item,{jm,1,m}];Do[trjsel[[iw]]=trjsel[[iw-1]];njiw=tsort[[2,iw-1]];If[njiw<m,njiw2=njiw+1,njiw2=1];Wjd=tsort[[3,iw-1]];
ddWj=tsort[[4,iw-1]];
dsqdWj=tsort[[5,iw-1]];item1={0,1,ddWj,dsqdWj,Wjd,0};vec1=trjsel[[iw,njiw]]-item1;If[vec1[[2]]>1,vec1[[6]]=1;trjsel[[iw,njiw]]=vec1,vec1[[6]]=0;trjsel[[iw,njiw]]=vec1];trjsel[[iw,njiw]]=trjsel[[iw,njiw]]/.x_Real/;Abs[x]<(10^(-10))->0.0;vec2=trjsel[[iw,njiw2]]+item1;If[vec2[[2]]>1,vec2[[6]]=1;trjsel[[iw,njiw2]]=vec2,vec2[[6]]=0;trjsel[[iw,njiw2]]=vec2],{iw,2,nd}];
       valsh=Table[tt=Transpose[trjsel[[iw]]];corWj=tt[[5]]/.x_/;x==0.0->1.0;
colWj=corWj;colmeandWj=tt[[3]]/corWj;colmeansqdWj=tt[[4]]/corWj;colchi2j=colWj*(colmeansqdWj-(((colmeandWj))^2));colwj=tt[[6]];sumchi2j=m*(Total[colwj*colchi2j])/Total[colwj];
complerrfnterm=Times@@((colWj^(-1/2))*2); 
loglikeA=-0.5*sumchi2j+Log[complerrfnterm]; 
{loglikeA,colmeandWj,colWj,colwj},{iw,nd}];
valsht=Transpose[valsh];maxloglikeA=Max[valsht[[1]]];adjlikeA=Exp[valsht[[1]]-maxloglikeA];
valnd=Table[adjlikeAinciw=adjlikeA[[iw]]*incphi[[iw]];{adjlikeAinciw,adjlikeAinciw*valsht[[2,iw]],adjlikeAinciw*valsht[[3,iw]],adjlikeAinciw*valsht[[4,iw]],adjlikeAinciw*cph[[iw]]},{iw,nd}];
tvalnd=Total[valnd];
     ff=1/tvalnd[[1]];
     logprior=Log[(P/((s+mJs)))]+c;logdterm=Log[m*tvalnd[[1]]]+maxloglikeA;
     loglike=loglikeoffset-m*Log[rmax-rmin]+logfact+logprodsqrtwtvec+(m/2)*Log[(π/2)]+logdterm;ϕ=ff*tvalnd[[5]];ffwj=Round[ff*tvalnd[[4]]];
pvec={P,s,m,ϕ};
    pvecA={ff*tvalnd[[2]],ff*tvalnd[[3]],ffwj}]

MODULE THAT PROPOSES THE NEW PARAMETER SET (user don't change this)

Propose new parameter values uses Switch and type[[ii]]to handle different par. types. 
Update P = av[[1]] via frequency calculation.
Check if proposed values lie outside prior borders, if so reflect parameter or wrap angular parameters.

Version that proposes a change to all of the avs parameter values.

proposeP:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,avs[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,avs[[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*σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
-2,
avm2=Round[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]]];avs[[ii]]=avm2;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm2<avmint,avs[[ii]]=Mod[2*avmint-avm2,(avMaxt-avmint),avmint],avm2>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm2,(avMaxt-avmint),avmint]],
1,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],1],
2,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],2π],
3,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
4,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[1]]/avs[[1]]))^(1/3))*(((1-((avs[[2]])^2)))^(-0.5));
Which[av5<avmint,avs[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,avs[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[7]]/avs[[7]]))^(1/3))*(((1-((avs[[8]])^2)))^(-0.5));
Which[av6<avmint,avs[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,avs[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[12]]/avs[[12]]))^(1/3))*(((1-((avs[[13]])^2)))^(-0.5));
Which[av7<avmint,avs[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,avs[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]],
8,
av8=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av8;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[17]]/avs[[17]]))^(1/3))*(((1-((avs[[18]])^2)))^(-0.5));
Which[av8<avmint,avs[[ii]]=Mod[2*avmint-av8,(avMaxt-avmint),avmint],av8>avMaxt,avs[[ii]]=Mod[2*avMaxt-av8,(avMaxt-avmint),avmint]],
9,
av9=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av9;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[22]]/avs[[22]]))^(1/3))*(((1-((avs[[23]])^2)))^(-0.5));
Which[av9<avmint,avs[[ii]]=Mod[2*avmint-av9,(avMaxt-avmint),avmint],av9>avMaxt,avs[[ii]]=Mod[2*avMaxt-av9,(avMaxt-avmint),avmint]],
10,
av10=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av10;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[27]]/avs[[27]]))^(1/3))*(((1-((avs[[28]])^2)))^(-0.5));
Which[av10<avmint,avs[[ii]]=Mod[2*avmint-av10,(avMaxt-avmint),avmint],av10>avMaxt,avs[[ii]]=Mod[2*avMaxt-av10,(avMaxt-avmint),avmint]]
];avs[[ii]]
]

Version that proposes a change to one of the avs parameter values (needed for 2nd stage of control system).

proposeP1:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,avs[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,avs[[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*σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
-2,
avm2=Round[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]]];avs[[ii]]=avm2;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm2<avmint,avs[[ii]]=Mod[2*avmint-avm2,(avMaxt-avmint),avmint],avm2>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm2,(avMaxt-avmint),avmint]],
1,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],1],
2,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],2π],
3,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
4,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[1]]/avs[[1]]))^(1/3))*(((1-((avs[[2]])^2)))^(-0.5));
Which[av5<avmint,avs[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,avs[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[7]]/avs[[7]]))^(1/3))*(((1-((avs[[8]])^2)))^(-0.5));
Which[av6<avmint,avs[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,avs[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[12]]/avs[[12]]))^(1/3))*(((1-((avs[[13]])^2)))^(-0.5));
Which[av7<avmint,avs[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,avs[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]],
8,
av8=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av8;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[17]]/avs[[17]]))^(1/3))*(((1-((avs[[18]])^2)))^(-0.5));
Which[av8<avmint,avs[[ii]]=Mod[2*avmint-av8,(avMaxt-avmint),avmint],av8>avMaxt,avs[[ii]]=Mod[2*avMaxt-av8,(avMaxt-avmint),avmint]],
9,
av9=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av9;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[22]]/avs[[22]]))^(1/3))*(((1-((avs[[23]])^2)))^(-0.5));
Which[av9<avmint,avs[[ii]]=Mod[2*avmint-av9,(avMaxt-avmint),avmint],av9>avMaxt,avs[[ii]]=Mod[2*avMaxt-av9,(avMaxt-avmint),avmint]],
10,
av10=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av10;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[27]]/avs[[27]]))^(1/3))*(((1-((avs[[28]])^2)))^(-0.5));
Which[av10<avmint,avs[[ii]]=Mod[2*avmint-av10,(avMaxt-avmint),avmint],av10>avMaxt,avs[[ii]]=Mod[2*avMaxt-av10,(avMaxt-avmint),avmint]]
];avs
]

MODULE THAT ACCEPTS THE NEW PARAMETER SET & store frequency changes (user don't change this)

acceptP:=Module[{pdfβi,pdfβiA},
pdfβi=logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA=logprior+loglike;
testr1=pdfβi-logpdftempk[[nl]];
If[testr1>-uflow,If[testr1<uflow,r1=Exp[testr1],r1=1.0],r1=-1.0];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,If[i>n0,nc2k=nc2k+1;If[nc4<1,nak=nak+1]];
pdfβiB1=Join[{β},pvec,{i},{loglike},{pdfβi},pvecA];
If[pdfβi>maxlogpdfβik[[nl]],maxlogpdfβik=pdfβiB1];If[pdfβiA>maxlogpdfAlla[[nl]],maxlogpdfAlla=Join[{β},pvec,{i},{loglike},{pdfβiA}]];
pdfβiB={{pdfβiA},{loglike},pdfβiB1,{nc2k},{nak},maxlogpdfβik,maxlogpdfAlla}
,pdfβiC=logpdftempk;pdfβiC[[n2l-1]]=i;
pdfβiB={{pdfβiA},{loglike},pdfβiC,{nc2k},{nak},maxlogpdfβik,maxlogpdfAlla}
];pdfβiB
]

For use in second stage Control System use acceptP1.

acceptP1:=Module[{pdfβi,pdfβiA},
pdfβi=logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA=logprior+loglike;
testr1=pdfβi-logpdftempk[[nl]];
If[testr1>-uflow,If[testr1<uflow,r1=Exp[testr1],r1=1.0],r1=-1.0]; (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,nc2k=nc2k+1;
pdfβiB1=Join[{β},pvec,{i},{loglike},{pdfβi},pvecA];
If[pdfβi>maxlogpdfβik[[nl]],maxlogpdfβik=pdfβiB1];If[pdfβiA>maxlogpdfAlla[[nl]],maxlogpdfAlla=Join[{β},pvec,{i},{loglike},{pdfβiA}]];
pdfβiB={{pdfβiA},{loglike},pdfβiB1,{nc2k},maxlogpdfβik,maxlogpdfAlla}
,pdfβiC=logpdftempk;pdfβiC[[n2l-1]]=i;
pdfβiB={{pdfβiA},{loglike},pdfβiC,{nc2k},maxlogpdfβik,maxlogpdfAlla}
];pdfβiB
]

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 *) 
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 *)
uflow=Log[$MaxNumber/10.0];(* set number to avoid underflow messages *) 
na=Table[0,{nβ}];  (* initialize acceptance array *)
nacor=Table[0,{nβ}];  (* initialize acceptance array for correlated move sampler *)
nb=Table[0,{k,1,nβ},{ncs}];  (* initialize array to store #accepted proposals in minor cycle *)(* for each parameter proposal σ *)
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,{ncs}];*) (* inintialize parameter array *)
σall1=Table[0,{ncs}];  
Do[σall1[[i]]=σst[[i]],{i,1,ncs}];(*initialize σall1 array*)
σall=Table[σst[[i]],{k,1,nβ},{i,1,ncs}];  
(* initialize σall array *)
σallold={};(* record previous best σall *)
pdfβiAmax2old={};(* record previous best logprior+loglike 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 *)
cs2cnt=1;(* initialize second stage CS counter *)
cs2cnt2=0;(* initialize counter to track how often 2nd stage CS is repeated a second time in a row *)
(*nacatot=Table[0,{nβ}];*)(* initialize counter of parameter sets added to movarray[[nβ]] *)
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)*Log[2*π] ;
(*logfactA=-(nast/2)*Log[2*π];*)
kvals=Table[i,{i,1,nβ}];
(* Evaluate the probability for the i=0 sample for each tempering level*)
Do[(* iteration over β *) β=βlis[[k]];avs=avst;
 (* initiate parameter values *)
(* ******************** Basic working *********************** *)
workP;
(* ********************************************************* *)
pdf1= loglike;
pdfβ1= logprior+β*loglike; (* factor needed to decide on tempering swap *)
logpdf[[1,k]]=Join[{β},pvec,{0,pdf1,pdfβ1},pvecA],{k,1,nβ} 
];  (* close first Do loop iterating over β *)
maxlogpdfβi=logpdf[[1]];
maxlogpdfAll=Take[logpdf[[1,nβ]],nl];(* initialize this array in each processor (chain) *)
Do[ (* start calculation for ith iteration beginning at i = 1 *)
If[i>n0,nc1=nc1+npara];If[nc1<npara+1&&i>n0,logpdftemp=logpdfinow,logpdftemp=logpdf[[1]]];
iV=i+1-npara;sw6=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw6k=sw6[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[
If[sw6k<1,i=iV;logpdftempk=logpdftemp[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=nc2[[k]];nak=na[[k]];sw6k=sw6k+1,
i=i+1;logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values
];
Do[proposeP,{ii,1,ncs}];workP;acceptP,
{isub,1,npara}
];pdfβiB,
{k,1,nβ} 
];
tworkvals=Transpose[workvals];logpdf[[2]]=tworkvals[[3]];nc2=Flatten[Transpose[tworkvals[[4]]]];na=Flatten[Transpose[tworkvals[[5]]]];maxlogpdfβi=tworkvals[[6]];lastworkvals=tworkvals[[7]];
acceptvec=Sort[workvals,OrderedQ[{#2,#1}]&];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax=kbestvec[[nl]];
If[pdfβiAmax>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
(* Consider a swap between 2 tempering levels if i an integer multiple of ns *)
If[nc4>0,Goto[anneal]];
If[nβ<2,Goto[genecrossover]];
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,nl+3}];
logpdf[[2,k1,n2l]]=loglike2;logpdf[[2,k1,nl]]=p21;
Do[logpdf[[2,k2,ji]]=temp[[ji]],{ji,2,nl+3}];
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 *)
(* Gene swap/crossover between top chain(s) and values in maxlogpdfAll *)
Label[genecrossover];
If[swg>0&&IntegerQ[i/(2*nthin)],
If[nβ<2,
If[ngene<2,
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[βnow=topvalues[[3,1]];
nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avtop[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avtop[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
{kg,1,ngene} 
],(* end of ngene=1 & nβ=1 option *)
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
avs=avcurmax;βnow=topvalues[[3,1]];
Do[avs[[ii]]=avtop[[ii]],{ii,genst[[kg]],genend[[kg]]}];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
{kg,1,ngene} 
]
],(* end of ngene>1 & nβ=1 option *)
If[ngene<2,
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];secvalues=acceptvec[[2]];avsec=Take[secvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
Which[kg≤ngene,βnow=topvalues[[3,1]];nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avtop[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avtop[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
kg≤2*ngene,βnow=secvalues[[3,1]];nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avsec[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avsec[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike;
pdfβiB={{pdfβiA},Join[{2+βnow},pvec,{i},{loglike},{pdfβiA}]}
],
{kg,1,2*ngene} 
],(* end of ngene=1 & nβ>1 option *)
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];secvalues=acceptvec[[2]];avsec=Take[secvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
If[kg≤ngene,avs=avcurmax;βnow=topvalues[[3,1]];
Do[avs[[ii]]=avtop[[ii]],{ii,genst[[kg]],genend[[kg]]}];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
avs=avcurmax;βnow=secvalues[[3,1]];kgg=kg-ngene;
Do[avs[[ii]]=avsec[[ii]],{ii,genst[[kgg]],genend[[kgg]]}];
workP;pdfβiA=logprior+loglike;
pdfβiB={{pdfβiA},Join[{2+βnow},pvec,{i},{loglike},{pdfβiA}]}
],
{kg,1,2*ngene} 
]
]
];
acceptvec1=Sort[workvals,OrderedQ[{#2,#1}]&];
kbestvec=acceptvec1[[1]];pdfβiAmax=kbestvec[[1,1]];If[pdfβiAmax>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];
maxlogpdfAll=kbestvec[[2]]];
];(* end of gene swap/crossover If statement *)
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[σallprop=scminus[[k]]*σall[[k,nc5[[ik]]]];   If[σallprop>avMax[[ik]],σall[[k,nc5[[ik]]]]=avMax[[ik]],σall[[k,nc5[[ik]]]]=σallprop]; 
              If[k==nβ&&(nbmax[[k]]-nc5)>0,swminσ[[ik]]=0,],{ik,1,lnc5}],
           Do[σallprop=σall[[k,ik]]*scminus[[k]];If[σallprop>avMax[[ik]],σall[[k,ik]]=avMax[[ik]],σ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;If[i<maxCS,sw4=1]];
σ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[maxlogpdfAll,{2,ncs+1}];
Do[(* iteration over β *) β=βlis[[k]];avs=bestvec;
 (* initiate parameter values *)
(* ******************** Basic working ********************** *)
workP;
(* ********************************************************* *)
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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
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]]>Abs[avMax[[ip2]]],σall[[k,ip2]]=Abs[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]]],
8,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
9,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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
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]]>Abs[avMax[[ip2]]],σall[[k,ip2]]=Abs[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]]],
8,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
9,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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
Do[accept3[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
If[Min[N[accept3[[nβ]]/n1]]<0.2||Max[N[accept3[[nβ]]/n1]]>0.9,nagain=1,nagain=0];
If[cs2cnt<2&&nagain>0,sw4=1;cs2cnt=cs2cnt+1;cs2cnt2=cs2cnt2+1,sw4=0;cs2cnt=1]
]; (* complete If statement *)
If[i>ncsys&&IntegerQ[(i-ncsys)/deltaN]&&(maxlogpdfAll[[nl]]-pdfβiAmax2)>3.0,sw4=1;ncsysold=Append[ncsysold,ncsys];σallold=Append[σallold,σall];pdfβiAmax2old=Append[pdfβiAmax2old,pdfβiAmax2];na=Table[0,{nβ}];ncsys=i,
];(* complete If statement *)
,{i,npara,n,npara} (* 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).

ncsys

Best parameter vector found.

bestvecFound=Take[maxlogpdfAll,{2,np+1}]

MemoryInUse[]

To output the whole MCMC data set. (usually not done for storage space reasons)

(*ng=Length[logpdfβi];stmp=OpenWrite["c:/Users/Philip/Documents/greg8/55Cancri/APT5planGenC55cancri.dat",PageWidth->Infinity];
Do[Write[stmp,logpdfβi[[i]]],{i,1,ng}];Close[stmp]*)

To output only the β = 1 tempering level results. Need to remove (*  *) for these commands to execute.

(*tr=Transpose[logpdfβi];tr5=tr[[nβ]];ng=Length[tr5];stmp=OpenWrite["c:/greg7/glMCMC/M6APTglShp.dat",PageWidth->Infinity];
Do[Write[stmp,tr5[[i]]],{i,1,ng}];Close[stmp]*)

Here is how to input results. Need to remove (*  *) for these commands to execute.

(*dataMC=ReadList["c:/greg7/glMCMC/M6APTglShp.dat"];nnt=Length[dataMC];
n=nthin*nnt;ng=nnt *)

The subsequent analysis steps assume the data for all chains are stored in an array called logpdfβi, generated when the above program steps are run. This array contains results from all the parallel MCC chains. What happens when we want to re-analyse the MCMC samples? In general we only store the samples from the top chain to minimize storage space. The next line populates the data for all chains with the values read back in for the top chain. This trick enables the subsequent analysis programs to execute properly without any changes to the input formats. Since the subsequent analysis (except for last item dealing with the Bayes factor calculation) only computes on the top chain it doesn't matter what we have in the other chains.

(*logpdfβi=Transpose[Table[dataMC,{k,1,nβ}]];*)

Analysis of evolution of control system error & 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 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 the code designer.

swminσ

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["P",FontWeight->"Bold",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

tmklabel=
StyleForm[StringForm["``  (d)",
StyleForm["P",FontSlant->"Italic"]],
FontFamily->Times,FontWeight->"Bold",FontSize->13]

slabel=
StyleForm[StringForm["``  (m (s^(-1)))",
StyleForm["s",FontSlant->"Italic"]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Extracting parameter samples for the β = 1 (k = nβ) MCMC chain

All the results are stored by the variable logpdfβi.
First let's look at an example of the first row of the output given by logpdfβi[[1]].
{{0.7`,959.9570426550547`,8.410472623513195`,8,0.184423242856966`,10,-359.62532691196645`,-253.1455838368756`,{156.89277789375976`,170.56510914858458`,212.06113676644097`,155.5687786722197`,172.05437469063716`,263.34566311302075`,258.14650838999955`,65.00000147130324`},{0.004798399215619782`,0.008268349917487159`,0.008175878554497472`,0.00810576171560245`,0.00991916701353707`,0.003809601030024318`,0.002065348350492186`,0.0017245290682693423`},{1,1,1,1,1,1,1,1}},{1.`,915.483426027098`,49.521858039985666`,8,0.8344017176514003`,10,-332.9801915080576`,-335.9621806242566`,{129.06270535700554`,211.6799395240604`,153.22840275420063`,188.3271444616131`,185.46990009010187`,169.0932214984301`,238.63740694566013`,148.2293410557676`},{0.0005960212853256656`,0.0016856185266010406`,0.0028603385052064904`,0.0027413014669901013`,0.0027571737729362457`,0.002828341849558241`,0.0015247096953809956`,0.0005786509307537253`},{1,1,1,1,1,1,1,1}}}
There are 2 lists one for each of the 2 parallel MCMC chains.
The first list contains the result for β = 0.01 and the last list 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 last 2 lists with the command Take[tr,-5].
{{1.`,1601.2647748555332`,27.96272168752309`,6,0.11614611831917314`,19990,-300.57441153031`,-302.4688583545684`,{187.0901230354528`,257.87722679996403`,266.64682315098946`,186.29519219451439`,130.7404519851376`,106.09893880637397`},{0.004818152199780243`,0.005105963105584811`,0.004584912790835392`,0.001864254972704946`,0.0064362393413150915`,0.0064329812603021765`},{1,1,1,1,1,1}},
{1.`,1623.6240446019028`,11.22046901066641`,6,0.1133348300401571`,20000,-301.0338046237546`,-302.13628298560104`,{186.95461941035077`,260.04777171906886`,266.4085052025349`,190.5427767088951`,125.5429661791475`,106.01884433765404`},{0.007445110430441424`,0.007955126622175377`,0.00676801242071224`,0.0032959775130001986`,0.00997081154614048`,0.009332455694764165`},{1,1,1,1,1,1}}}
Item (1) in each list is the value of β, 
Items (2-5) are the current values of the parameters P,s,m,ϕ.
Item (6) is the iteration number.
Item (7) is the Log of the likelihood, used in computing the global likelihood of the model for the 
    Bayes factor calculation.
Item (9) is the value of   prior*(((like))^β) for the particular set of parameter values.
Item (9) is a list of m values of colmeandWj = (OverBar[(Subscript[d, Wj])]), one for each bin, for signal shape calculation.
Item (10) is a list of m values of colWj = (Subscript[W, j]) , one for each bin, for signal shape calculation.
Item (11) is a list of m values of colwj = (Subscript[w, j]), one for each bin, for signal shape calculation.

Extract parameter iterations for the k = nβ member of the tempering levels. 
To obtain columns of each quantity use trn = Transpose[tr].

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];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=5;(* with niter = 100, plot only every 100th point *)

nburn1=100;(* skip first nburn1 iterations for 2nd (upper right) plot *)

pl=Table[0,{i,ncs+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

xiterticks={500,1000,1500,2000};

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==27,pl[[i+2]]=ListLogPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}],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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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,ncs}
];

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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}];

plIter=Show[GraphicsGrid[If[EvenQ[ncs+2],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,ncs+2,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(ncs+2)/2]*2,2}],{{pl[[IntegerPart[(ncs+2)/2]*2+1]]}}]],Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Set the burn-in value nburn.

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 *)

Examine post burn-in parameter iterations for the β = 1   MCMC chain.

k=nβ;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt}];trn=Transpose[tr];ng=Length[trn[[1]]]

Sart by choosing some display parameters.

niter=1;(* with niter = 100, plot only every 100th point *)

nburn1=100;(* skip first nburn1 iterations for 2nd (upper right) plot *)

pl=Table[0,{i,ncs+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

xiterticks={500,1000,1500,2000};

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==27,pl[[i+1]]=ListLogPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}],pl[[i+1]]=ListPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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,ncs}
];

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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}];

plIter=Show[GraphicsGrid[If[EvenQ[ncs+1],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,ncs+1,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(ncs+1)/2]*2,2}],{{pl[[IntegerPart[(ncs+1)/2]*2+1]]}}]],Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Plot pairs of parameters to examine correlations for highest peak only.     
(uses a PDF cutoff and shows PDF by point size and BW)

We want to plot points at intervals of dn iterations.

dn=3;

Plot m versus s

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

pLow=800.0;pHi=2400.;
trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];trPsel=Select[tr,#[[2]]>pLow&&#[[2]]<pHi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]],],];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a2good,a3good}];plms=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a2name<>a2unit,{"Helvetica-Bold",12}],
		Style[a3name<>a3unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plotsmh=Histogram3D[ppf,
AxesLabel->{a2name<>a2unit,a3name<>a3unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Plot P versus s

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

pLow=800.0;pHi=2400.;
trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];trPsel=Select[tr,#[[2]]>pLow&&#[[2]]<pHi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]],],];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a2good,a1good}];plPs=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a2name<>a2unit,{"Helvetica-Bold",12}],
		Style[a1name<>a1unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plotsph=Histogram3D[ppf,
AxesLabel->{a2name<>a2unit,a1name<>a1unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Plot m versus P

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

pLow=800.0;pHi=2400.;
trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];trPsel=Select[tr,#[[2]]>pLow&&#[[2]]<pHi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]],],];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a1good,a3good}];plmP=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a1name<>a1unit,{"Helvetica-Bold",12}],
		Style[a3name<>a3unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plmPh=Histogram3D[ppf,
AxesLabel->{a1name<>a1unit,a3name<>a3unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

If[ncsys<n,plcorrallBW=Show[GraphicsGrid[{{plms,plPs},{plmP,}},Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]]

Plot (Subscript[Log, 10])[prior × (((likelihood))^β)] versus orbital period for the (k^th) chain in βlis. 
           (e.g., k = nβ corresponds to β = 1)

We will only plot points with (Subscript[Log, 10])[prior × (((likelihood))^β)] > cutoff , where 
(Subscript[Log, 10])[prior × (((likelihood))^β)] is first scaled to have a maximum value of 0.
Also, only plot points separated by an amount = interval.

interval=1;cutoff=-5;

k=nβ;(* k specifies which of the nβ chains to plot *)

tr=Transpose[logpdfβi][[k]];(* extract values for the k=nβ chain *)

Extract parameters and prob=prior*likelihood as separate columns. Find probMax = maximum value of prob and then convert prob values to logprob=Log[10,prob/probMax].

trn=Transpose[tr];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]];prob=trn[[nl]];ng=Length[trn[[1]]];probMax=Max[prob];logprob=Log[10,E]*(prob-probMax);

Make a list of {logprob, parameter values}, then extract a subset of this list specified by interval.
Sort list according to logprob in descending order.
Select all values for which logprob > cutoff.  Then extract the parameter values besta1, besta2, besta3, besta4 (for figure header information)  corresponding to the maximum logprob. Finally, Transpose the selected parameter sets ppsel so that pairs of parameters can be plotted.

ppf=Transpose[{logprob,a1good,a2good,a3good,a4good}];nppf=Length[ppf];pp=Take[ppf,{1,nppf,interval}];pps=Sort[pp,OrderedQ[{#2, #1}]&];ppsel=Select[pps,#[[1]]>cutoff&];nsel=Length[ppsel];lsp=First[ppsel];yval=lsp[[1]];besta1=lsp[[2]];besta2=lsp[[3]];besta3=lsp[[4]];besta4=lsp[[5]];bestLogprob=yval+Log[10,E]*probMax;psel=Transpose[ppsel];

Plot {period, logprob} pairs.

If[nsel>0,
ppn=Transpose[{psel[[2]],psel[[1]]}];plms=ListPlot[ppn,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["P = "<>ToString[besta1]<>" ;  s = "<>ToString[besta2]<>" ;  m = "<>ToString[besta3]<>" ;chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] \!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \\ \\ \)\(β\)\)]\) ) = "<>ToString[bestLogprob],{"Helvetica-Bold",9}],FrameLabel->{Style[a1name<>a1unit,{"Helvetica-Bold",12}],
		Style["(Subscript[Log, 10]) (Prior\[Cross]\!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \)\(β\)\)]\))",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
]

Repeat above but plots the location where possible harmonics 
and subharmonics of the most probable orbital period.

If[nsel>0,
ppn=Transpose[{psel[[2]],psel[[1]]}];plProbP=ListPlot[ppn,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["P = "<>ToString[besta1]<>" ;  s = "<>ToString[besta2]<>" ;  m = "<>ToString[besta3]<>" ;chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] \!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \\ \\ \)\(β\)\)]\) ) = "<>ToString[bestLogprob],{"Helvetica-Bold",9}],FrameLabel->{Style[a1name<>a1unit,{"Helvetica-Bold",12}],
		Style["(Subscript[Log, 10]) (Prior\[Cross]\!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \)\(β\)\)]\))",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
Show[plProbP,Graphics[{Thickness[0.002],Red,Line[{{besta1,0},{besta1,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{besta1/2,0},{besta1/2,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{besta1/3,0},{besta1/3,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{besta1/4,0},{besta1/4,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{2*besta1,0},{2*besta1,cutoff}}]}]]
]

Use ListPlot3D to plot triplets of (Subscript[Log, 10])[prior × (((likelihood))^β)], s, P

We will only plot points with (Subscript[Log, 10])[prior × (((likelihood))^β)] > cutoff , where 
(Subscript[Log, 10])[prior × (((likelihood))^β)] is first scaled to have a maximum value of 0.
Also, only plot points separated by an amount = interval.

interval=1;cutoff=-5;

k=nβ;(* k specifies which of the nβ chains to plot *)

tr=Transpose[logpdfβi][[k]];(* extract values for the k=nβ chain *)

Extract parameters and prob=prior*likelihood as separate columns. Find probMax = maximum value of prob and then convert prob values to logprob=Log[10,prob/probMax].

trn=Transpose[tr];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]];prob=trn[[nl]];ng=Length[trn[[1]]];probMax=Max[prob];logprob=Log[10,E]*(prob-probMax);

Make a list of {logprob, parameter values}, then extract a subset of this list specified by interval.
Sort list according to logprob in descending order.
Select all values for which logprob > cutoff.  Then extract the parameter values besta1, besta2, besta3, besta4 (for figure header information)  corresponding to the maximum logprob. Finally, Transpose the selected parameter sets ppsel so that pairs of parameters can be plotted.

ppf=Transpose[{logprob,a1good,a2good,a3good,a4good}];nppf=Length[ppf];pp=Take[ppf,{1,nppf,interval}];pps=Sort[pp,OrderedQ[{#2, #1}]&];ppsel=Select[pps,#[[1]]>cutoff&];nsel=Length[ppsel];psel=Transpose[ppsel];pp3=Transpose[{psel[[1]],psel[[2]],psel[[3]]}];

If[nsel>0,ListPointPlot3D[pp3]]

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]]]

plh=Table[1,{i,ncs}];
Do[
If[i==0,lmed=Median[trnn[[i]]];loglmed=Floor[Log[10,lmed]];loglmed10=N[10^Floor[Log[10,lmed]]];trnni=trnn[[i]]/loglmed10;
sf[n_]:=ToString[HoldForm[(10^n)],StandardForm];label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>"   (×"<> sf[loglmed]<>")"<>ToExpression["a"<>ToString[i]<>"unit"]];
plh[[i]]=Histogram[trnni,PlotRange->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"}],label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];plh[[i]]=Histogram[trnn[[i]],PlotRange->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,ncs-1}
];
label=StringForm[ToExpression["a"<>ToString[ncs]<>"name"]<>ToExpression["a"<>ToString[ncs]<>"unit"]];aimarg=Take[trn[[ncs+1]],-(ng-nburn)];
ybin=BinCounts[aimarg,{mmin-0.5,mMax+0.5}];totybin=Plus@@ybin;nybin=N[ybin/totybin];y0bin=Table[0,{i,mmin,Length[ybin]+mmin-1}];xbin=Table[i,{i,mmin,Length[ybin]+mmin-1}];xAbin=Table[0.9999*i,{i,mmin,Length[ybin]+mmin-1}];xBbin=Table[1.0001*i,{i,mmin,Length[ybin]+mmin-1}];mbin=Transpose[{xbin,nybin}];mAbin=Transpose[{xAbin,y0bin}];mBbin=Transpose[{xBbin,y0bin}];mallbin=Sort[Join[mAbin,mbin,mBbin]];pbin=Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&];plh[[ncs]]=ListPlot[mallbin,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,Joined->True,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Probability",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
plhis=Show[GraphicsGrid[If[EvenQ[ncs],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,ncs,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(ncs)/2]*2,2}],{{plh[[IntegerPart[(ncs)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Redo using BinCounts to compute errors and result statistics

nai=200;njump=0;plp=Table[1,{i,ncs}];meanai=Table[0,{j,1,ncs}];medianai=Table[0,{j,1,ncs}];modeai=Table[0,{j,1,ncs}];minai=Table[0,{j,1,ncs}];maxai=Table[0,{j,1,ncs}];areai=Table[0,{j,1,ncs}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=Take[trn[[i+1]],-(ng-nburn)];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[100000*Min[aimarg]]/100000;hi=Round[100000*Max[aimarg]]/100000;If[hi==low,njump=1;Break[],];dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Total[aibin];If[aibintot<1,njump=1;Break[],];yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2, #1}]&];modeai[[i]]=pbin[[1,2]];minai[[i]]=avMax[[i]];maxai[[i]]=avmin[[i]];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}];aimargbinA=Join[{{First[aimidpoints]-dai,0.0}},aimargbin,{{Last[aimidpoints]+dai,0.0}}];plp[[i]]=ListPlot[MovingAverage[aimargbinA,{(1/37),(2/37),(4/37),(4/37),(5/37),(5/37),(5/37),(4/37),(4/37),(2/37),(1/37)}],PlotRange->{{0.98*low,1.01*hi},{0,0.75*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],{i,1,ncs-1}
];
label=StringForm[ToExpression["a"<>ToString[ngs]<>"name"]<>ToExpression["a"<>ToString[ngs]<>"unit"]];aimarg=Take[trn[[ngs+1]],-(ng-nburn)];meanai[[ngs]]=Mean[aimarg];medianai[[ngs]]=Median[aimarg];modeai[[ngs]]=Commonest[aimarg][[1]];
ybin=BinCounts[aimarg,{mmin-0.5,mMax+0.5}];totybin=Plus@@ybin;nybin=N[ybin/totybin];y0bin=Table[0,{i,mmin,Length[ybin]+mmin-1}];xbin=Table[i,{i,mmin,Length[ybin]+mmin-1}];xAbin=Table[0.9999*i,{i,mmin,Length[ybin]+mmin-1}];xBbin=Table[1.0001*i,{i,mmin,Length[ybin]+mmin-1}];mbin=Transpose[{xbin,nybin}];mAbin=Transpose[{xAbin,y0bin}];mBbin=Transpose[{xBbin,y0bin}];mallbin=Sort[Join[mAbin,mbin,mBbin]];pbin=Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&];minai[[ngs]]=1000000000;maxai[[ngs]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[ngs]],minai[[ngs]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[ngs]],maxai[[ngs]]=pbin[[j,2]],Null];
j=j+1];areai[[ngs]]=area;plp[[ncs]]=ListPlot[mallbin,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,Joined->True,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Probability",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];If[njump<1,plmarg=Show[GraphicsGrid[{{plp[[1]],plp[[2]]},{plp[[3]],}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]],Print["Not enough iterations"]
]

Find mProbMax = m value with largest probability.

mPMax=First[Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&]][[2]]

Calculate the sum of the probabilities of the periodic models with m ≠ mPMax to prob. of model with m = mPMax.

pri=Transpose[{xbin,nybin}];priX=Select[pri,#[[1]]==mPMax&];prinotX=Select[pri,#[[1]]≠mPMax&];prnotXtoX=Plus@@(Transpose[prinotX][[2]])/priX[[1,2]]

Most probable set of parameters & 68.3% marginal credible regions

Use next command block if working from dataMC input from file.

tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5s=Sort[tr5,#1[[nl]]>#2[[nl]]&];

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5s[[1]]

Note: the second item in the list is the raw phase, for most of our calculations we need Mod[ϕ,2*π/m], which is what we display in the various plots above .

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5s[[1,i+1]],{i,1,ncs}];peakai

Make a 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,ncs}];

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,ncs}];

smj=MatrixForm[Join[l1,l2,l4,l5]]

Plot mean & median light curves and std deviation marginalizing over m.

Allows for selecting MCMC samples with period between cutoff1 and cutoff2.

cutoff1=800;cutoff2=2800;tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5Ps=Select[tr5,#[[2]]>cutoff1&&#[[2]]<cutoff2&];tr5Psel=Sort[tr5Ps,#1[[nl]]>#2[[nl]]&];
trn=Transpose[tr5Psel];
permarg=trn[[2]];
Length[tr5Psel]
pbar=Mean[permarg]

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5Psel[[1]]

Identify parameter values with maximum (peak) probability, e.g., peaks is the value for extra noise parameter s.

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5Psel[[1,i+1]],{i,1,ncs+1}];peaks=peakai[[2]]

Steps in computing the mean and median light curve shape and 1 sigma uncertainty

Divide the most probable period (peakai[[1]]) into a list of  nshape time steps labelled ts.  
Recall that for each set of parameters, we computed and stored the vector: {β,P,s,m,ϕ, i,Log[pdfi],pdfβi,colmeandWj,colWj,colwj},
where colmeandWj,colWj,colwj each consist of a vector of m values one for each of the m bins.
For each set of parameter values convert each ts into a bin number and extract the 
 (OverBar[(Subscript[d, Wj])]) = dWjvec, Wj = Wjvec, wj (correction for no data)= wjvec for that bin corresponding to that set of parameter values using the Extract command. Transpose those quantities to obtain shpwjt,  shpWjt,  shpt. 
 Next form wjshplistk = Transpose[{shpwjt[[k]], shpt[[k]], shpWjt[[k]]}]. 
 Next form selk=Select[wjshplistk,#[[1]]= = 1 &] which selects only shape info where shpwjt[[k]] is non zero.
 Then compute the mean shape[[k]] and mean shsig[[k]] for each k. 
 We also store shlist so we can obtain a histogram of shape values for each k.

This version below works even if there is only one data point in certain bins

Timing[interval=10;nshape=80;ts=Table[i*peakai[[1]]/nshape,{i,nshape}];
shp={};shpWj={};shpwj={};nused=Length[tr5Psel];datgood=Take[tr5Psel,{1,nused,interval}];nu=Length[datgood];
Do[P=datgood[[i,2]];m=datgood[[i,4]];ϕp=datgood[[i,5]]/m;dWjvec=datgood[[i,nl+1]];Wjvec=datgood[[i,nl+2]];wjvec=datgood[[i,nl+3]];jvec=IntegerPart[1+m*Mod[ts/P+ϕp,1]];tjvec=Transpose[{jvec}];shpi=Extract[dWjvec,tjvec];Wji=Extract[Wjvec,tjvec];wji=Extract[wjvec,tjvec];shp=Append[shp,shpi];shpWj=Append[shpWj,Wji];shpwj=Append[shpwj,wji],{i,1,nu}
];
shpt=Transpose[shp];shpWjt=Transpose[shpWj];shpwjt=Transpose[shpwj];shlist=Table[0,{k,nshape}];shape=Table[0,{k,nshape}];medianshape=Table[0,{k,nshape}];shsig=Table[0,{k,nshape}];nselk=Table[0,{k,nshape}];Do[wjshplistk=Transpose[{shpwjt[[k]],shpt[[k]],shpWjt[[k]]}];If[Length[wjshplistk]<1,Print["no data for bin "<>ToString[k]];Break[],];tselk=Transpose[wjshplistk];shlist[[k]]=tselk[[2]];medianshape[[k]]=Median[shlist[[k]]];shape[[k]]=Mean[shlist[[k]]];nselk[[k]]=Length[shlist[[k]]];shsig[[k]]=Mean[(((tselk[[3]]))^(-1/2))],{k,nshape}];shape]

Plot shape = the mean shape.

ListPlot[shape]

Plot shape = the mean shape.

ListPlot[medianshape]

Plot shsig = the mean shape sigma value.

ListPlot[shsig]

Plot mean shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,shape+shsig}];shpup1=Transpose[{ph1,shape+shsig}];shpup2=Transpose[{ph2,shape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,shape-shsig}];shpdn1=Transpose[{ph1,shape-shsig}];shpdn2=Transpose[{ph2,shape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot median shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,medianshape+shsig}];shpup1=Transpose[{ph1,medianshape+shsig}];shpup2=Transpose[{ph2,medianshape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,medianshape-shsig}];shpdn1=Transpose[{ph1,medianshape-shsig}];shpdn2=Transpose[{ph2,medianshape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2median=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase.

The next two lines cause the data error bars to be increased by the most probable value of the extra noise term.

Do[If[StringMatchQ[ToExpression["a"<>ToString[i]<>"name"],"s"],nsi=i,],{i,1,ncs}];

meanai[[nsi]]

pserrvec=(Sqrt[(errvec^2)+((meanai[[nsi]])^2)]);

nsi

phvec1=Mod[tvec,pbar]/pbar;phvec2=phvec1+1;phdat1=Transpose[{phvec1,dvec,pserrvec}];
phdat2=Transpose[{phvec2,dvec,pserrvec}];phdat=Join[phdat1,phdat2];
tphdat=Transpose[phdat];phd=Transpose[{tphdat[[1]],tphdat[[2]]}];phdvec=Table[{phd[[i]],ErrorBar[tphdat[[3]][[i]]]},{i,Length[phd]}];
plphdvec=ErrorListPlot[phdvec,Frame->True,PlotRange->{{-0.05,2.0},Automatic},Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase with light curve overlaid.

plshpAllm=Show[plphdvec,plphshp2]

plshpAllmb=Show[plshpAllm,Graphics[{Text["(a)",{1.,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plshpAllmMedian=Show[plphdvec,plphshp2median]

Plot individual data points versus time with overlaid Mean light curve.

pldatvst=ErrorListPlot[Transpose[{tvec,dvec,pserrvec}],Frame->True,Axes->False,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ncycle=6;shpupt={};Do[Do[shpupt=Append[shpupt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]+shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
shpdnt={};Do[Do[shpdnt=Append[shpdnt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]-shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
plshpt1=ListPlot[{shpupt,shpdnt},Frame->True,PlotRange->All,Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

pltimfitdat=Show[pldatvst,plshpt1,Axes->False]

pltimfitdatb=Show[pltimfitdat,Graphics[{Text["(b)",{0,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5];

Plot residuals for mean solution (m = all bins).

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;shperr0=Transpose[{ph0,shape,shsig}];shperr1=Transpose[{ph1,shape,shsig}];shperr2=Transpose[{ph2,shape,shsig}];shperr=Join[shperr0,shperr1,shperr2];tshperr=Transpose[shperr];phaseshp=Transpose[{tshperr[[1]],tshperr[[2]]}];phaseshp=Table[phaseshp[[i]],{i,3*nshape}];
plphshp1=ListPlot[phaseshp,Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ifnshp=Interpolation[phaseshp]

phvec1

mvec=ifnshp[phvec1];Length[mvec]

y=dvec-mvec

Computed weighted std dev.

wresmap=(Sqrt[((((y/errvec)).((y/errvec)))/((1/errvec).(1/errvec)))])

resmap=StandardDeviation[y]

resid=Transpose[{tvec,y}];

residerr=Table[{resid[[i]],ErrorBar[pserrvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Error residuals (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp2b=Show[plshp2,Graphics[{Text["(c)",{0,-110}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plMAP3=Show[GraphicsGrid[{{plshpAllmb},{pltimfitdatb},{plshp2b}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]]

Plot mean & median light curves and std deviation for m = mchoice.

Allows for selecting MCMC samples with period between cutoff1 and cutoff2 and m = mchoice.

Set mchoice yourself (typically the largest value of m with an appreciable probability) or use the default mPMax found earlier.
mPMax is the value of m with the largest probability.

mchoice=mPMax

cutoff1=800;cutoff2=2800;tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5Ps=Select[tr5,#[[2]]>cutoff1&&#[[2]]<cutoff2&&#[[4]]==mchoice&];tr5Psel=Sort[tr5Ps,#1[[nl]]>#2[[nl]]&];
trn=Transpose[tr5Psel];
permarg=trn[[2]];
Length[tr5Psel]
pbar=Mean[permarg]

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5Psel[[1]]

Identify parameter values with maximum (peak) probability, e.g., peaks is the value for extra noise parameter s.

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5Psel[[1,i+1]],{i,1,ncs+1}];peaks=peakai[[2]]

Steps in computing the mean and median light curve shape and 1 sigma uncertainty

Divide the most probable period (peakai[[1]]) into a list of  nshape time steps labelled ts.  
Recall that for each set of parameters, we computed and stored the vector: {β,P,s,m,ϕ, i,Log[pdfi],pdfβi,colmeandWj,colWj,colwj},
where colmeandWj,colWj,colwj each consist of a vector of m values one for each of the m bins.
For each set of parameter values convert each ts into a bin number and extract the 
 (OverBar[(Subscript[d, Wj])]) = dWjvec, Wj = Wjvec, wj (correction for no data)= wjvec for that bin corresponding to that set of parameter values using the Extract command. Transpose those quantities to obtain shpwjt,  shpWjt,  shpt. 
 Next form wjshplistk = Transpose[{shpwjt[[k]], shpt[[k]], shpWjt[[k]]}]. 
 Next form selk=Select[wjshplistk,#[[1]]= = 1 &] which selects only shape info where shpwjt[[k]] is non zero.
 Then compute the mean shape[[k]] and mean shsig[[k]] for each k. 
 We also store shlist so we can obtain a histogram of shape values for each k.

This version below works even if there is only one data point in certain bins

Timing[interval=10;nshape=80;ts=Table[i*peakai[[1]]/nshape,{i,nshape}];
shp={};shpWj={};shpwj={};nused=Length[tr5Psel];datgood=Take[tr5Psel,{1,nused,interval}];nu=Length[datgood];
Do[P=datgood[[i,2]];m=datgood[[i,4]];ϕp=datgood[[i,5]]/m;dWjvec=datgood[[i,nl+1]];Wjvec=datgood[[i,nl+2]];wjvec=datgood[[i,nl+3]];jvec=IntegerPart[1+m*Mod[ts/P+ϕp,1]];tjvec=Transpose[{jvec}];shpi=Extract[dWjvec,tjvec];Wji=Extract[Wjvec,tjvec];wji=Extract[wjvec,tjvec];shp=Append[shp,shpi];shpWj=Append[shpWj,Wji];shpwj=Append[shpwj,wji],{i,1,nu}
];
shpt=Transpose[shp];shpWjt=Transpose[shpWj];shpwjt=Transpose[shpwj];shlist=Table[0,{k,nshape}];shape=Table[0,{k,nshape}];medianshape=Table[0,{k,nshape}];shsig=Table[0,{k,nshape}];nselk=Table[0,{k,nshape}];Do[wjshplistk=Transpose[{shpwjt[[k]],shpt[[k]],shpWjt[[k]]}];If[Length[wjshplistk]<1,Print["no data for bin "<>ToString[k]];Break[],];tselk=Transpose[wjshplistk];shlist[[k]]=tselk[[2]];medianshape[[k]]=Median[shlist[[k]]];shape[[k]]=Mean[shlist[[k]]];nselk[[k]]=Length[shlist[[k]]];shsig[[k]]=Mean[(((tselk[[3]]))^(-1/2))],{k,nshape}];shape]

Plot shape = the mean shape.

ListPlot[shape]

Plot shsig = the mean shape sigma value.

ListPlot[shsig]

Plot mean shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,shape+shsig}];shpup1=Transpose[{ph1,shape+shsig}];shpup2=Transpose[{ph2,shape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,shape-shsig}];shpdn1=Transpose[{ph1,shape-shsig}];shpdn2=Transpose[{ph2,shape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot median shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,medianshape+shsig}];shpup1=Transpose[{ph1,medianshape+shsig}];shpup2=Transpose[{ph2,medianshape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,medianshape-shsig}];shpdn1=Transpose[{ph1,medianshape-shsig}];shpdn2=Transpose[{ph2,medianshape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2median=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase.

The next two lines cause the data error bars to be increased by the most probable value of the extra noise term.

Do[If[StringMatchQ[ToExpression["a"<>ToString[i]<>"name"],"s"],nsi=i,],{i,1,ncs}];

meanai[[nsi]]

pserrvec=(Sqrt[(errvec^2)+((meanai[[nsi]])^2)]);

nsi

phvec1=Mod[tvec,pbar]/pbar;phvec2=phvec1+1;phdat1=Transpose[{phvec1,dvec,pserrvec}];
phdat2=Transpose[{phvec2,dvec,pserrvec}];phdat=Join[phdat1,phdat2];
tphdat=Transpose[phdat];phd=Transpose[{tphdat[[1]],tphdat[[2]]}];phdvec=Table[{phd[[i]],ErrorBar[tphdat[[3]][[i]]]},{i,Length[phd]}];
plphdvec=ErrorListPlot[phdvec,Frame->True,PlotRange->{{-0.05,2.0},Automatic},Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase with light curve overlaid.

plshpAllm=Show[plphdvec,plphshp2]

plshpAllmb=Show[plshpAllm,Graphics[{Text["(a)",{1.,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plshpAllmMedian=Show[plphdvec,plphshp2median]

Plot individual data points versus time with overlaid Mean light curve.

pldatvst=ErrorListPlot[Transpose[{tvec,dvec,pserrvec}],Frame->True,Axes->False,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ncycle=6;shpupt={};Do[Do[shpupt=Append[shpupt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]+shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
shpdnt={};Do[Do[shpdnt=Append[shpdnt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]-shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
plshpt1=ListPlot[{shpupt,shpdnt},Frame->True,PlotRange->All,Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

pltimfitdat=Show[pldatvst,plshpt1,Axes->False]

pltimfitdatb=Show[pltimfitdat,Graphics[{Text["(b)",{0,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5];

Plot residuals for mean solution (m = mchoice).

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;shperr0=Transpose[{ph0,shape,shsig}];shperr1=Transpose[{ph1,shape,shsig}];shperr2=Transpose[{ph2,shape,shsig}];shperr=Join[shperr0,shperr1,shperr2];tshperr=Transpose[shperr];phaseshp=Transpose[{tshperr[[1]],tshperr[[2]]}];phaseshp=Table[phaseshp[[i]],{i,3*nshape}];
plphshp1=ListPlot[phaseshp,Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ifnshp=Interpolation[phaseshp]

phvec1

mvec=ifnshp[phvec1];Length[mvec]

y=dvec-mvec

Computed weighted std dev.

wresmap=(Sqrt[((((y/errvec)).((y/errvec)))/((1/errvec).(1/errvec)))])

resmap=StandardDeviation[y]

resid=Transpose[{tvec,y}];

residerr=Table[{resid[[i]],ErrorBar[pserrvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Error residuals (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp2b=Show[plshp2,Graphics[{Text["(c)",{0,-110}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plMAP4=Show[GraphicsGrid[{{plshpAllmb},{pltimfitdatb},{plshp2b}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]]

Compute the Bayes factor from all tempering level results

Compares model (Subscript[M, per]) to model (Subscript[M, 1]) (rejecting the first nburn samples). 
((NOTE: THIS SECTION WON'T EVALUATE IF nβ < nβmin.))
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 20) of β levels are used spanning the range β = 0 to 1. 
Otherwise use the restricted Monte Carlo Bayes factor calculation in the next section.

Compute p(D|Mper,I), the global likelihood for the periodic model

Here we compute  the log of the global likelihood of the model, which is designated by  logpMper
                logpMper=log[p(D|Mper,I)]=∫ (Subscript[⟨ log[p(D|Mper,X,I)] ⟩, β])  dβ
(Subscript[⟨ log[p(D|Mper,X,I)] ⟩, β]) =expectation value oflog[p(D|Mper,X,I)]  for given β
                                              =(1/n)(∑_(t=1)^n)  log[p(D|Mper,(Subscript[X, 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 an example of the first row of the output given by logpdfβi[[1,1]].
         {1.`,1273.9726060784137`,40.803985991174834`,5,0.35303805202159366`,10,76.0136129133192`,73.543571479479`,{148.91745708656111`,194.36292184504748`,240.09863821079406`,201.68614548468776`,132.11148679054986`},{0.0065844726825486505`,0.0051319390270891255`,0.004495349418625844`,0.001429003958843216`,0.002333596595333784`},{1,1,1,1,1}}
          The quantity  log[p(D|Mper,(Subscript[X, t,β ]) ,I)] is the (7^th) item (n2l item) in each list. 
The different list correspond to different values of the tempering parameter β.

Set nβmin, the minimum number of tempering levels before it makes any sense to compute the 
global likelihood of the model by this method.

nβmin=20;

First check that you are happy with the burn -in value, nburn.

nburn

Generate the list expect = ⟨ln p(D|(Subscript[M, per]),X,I)⟩ , one for each tempering level 
provided nβ≥nβmin and ncsys<n, i.e., the turn-off of the control system was ≤nburn.

If[ncsys<n&&nβ≥nβmin,ngood=(nnt-nburn);tr=Transpose[Take[logpdfβi,-ngood]];expect=Table[0.0,{i,1,nβ}];Do[trnb=Transpose[tr[[nb]]];tb1Num=trnb[[n2l]];logpdfβ=Total[tb1Num]/ngood;expect[[nb]]=logpdfβ,{nb,1,nβ}],];

ngood

List ⟨ln p(D|(Subscript[M, per]),PX,I)⟩ values, one for each tempering level.

If[ncsys<n&&nβ≥nβmin,expect,]

List the β tempering values.

If[ncsys<n&&nβ≥nβmin,βlis,]

Plot ⟨ln p(D|(Subscript[M, per]),X,I)⟩ values versus (Subscript[Log, 10 ])(βlis+0.000001).

If[ncsys<n&&nβ≥nβmin,pl1=ListPlot[Transpose[{Log[10,βlis],expect}],PlotStyle->PointSize[0.02],Axes->False,Frame->True,PlotRange->All,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D|(Subscript[M, 2]),X,I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Generate an interpolating function for a LogLinearPlot.

If[ncsys<n&&nβ≥nβmin,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[ncsys<n&&nβ>nβmin,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect]]

Plot the interpolation.

If[ncsys<n&&nβ≥nβmin,pl4=ListPlot[newexpect,Frame->True,PlotRange->All,Axes->False,Joined->True,PlotStyle->{Thickness->0.004},FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D|(Subscript[M, 2]),X,I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

Plot the interpolation and expect values together.

If[ncsys<n&&nβ≥nβmin,plBayesFactor=Show[pl1,pl4,PlotRange->All],]

If[ncsys<n&&nβ≥nβmin,plBayesFactorA=Show[pl1,pl4,PlotRange->{{-2.1,0.01},{60,105}}]]

If[ncsys<n&&nβ≥nβmin,plBayesFactorB=Show[pl1,pl4,PlotRange->{{-1,0.01},{80,100}}]]

If[ncsys<n&&nβ≥nβmin,plBayesFactorC=Show[pl1,pl4,PlotRange->{{-0.3,0.01},{95,99}}],]

plBayesFactor2=Show[plBayesFactor,Epilog->Inset[plBayesFactorA,Scaled[{0.3,0.55}],Scaled[{0.1,0.1}],Scaled[{0.7,0.7}]]
]

Now convert to a table with linear coordinates.

If[ncsys<n&&nβ≥nβmin,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 logpMper.

If[ncsys<n&&nβ≥nβmin,logpMper1=Total[Table[0.5*(newexpect1[[i]][[2]]+newexpect1[[i+1]][[2]])*(newexpect1[[i+1]][[1]]-newexpect1[[i]][[1]]),{i,1,Length[newexpect1]-1}]]]

(E^logpMper1)

Suppose we drop the first nn  β levels and redo the 
calculation of the Log of the global likelihood for M1.

nn=3;

If[ncsys<n&&nβ⩾(nβmin+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[ncsys<n&&nβ≥(nβmin+nn),newexpect2=Table[spline2[x],{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2]]

If[ncsys<n&&nβ≥(nβmin+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[ncsys<n&&nβ≥(nβmin+nn),logpMper2=Total[Table[0.5*(newexpect3[[i]][[2]]+newexpect3[[i+1]][[2]])*(newexpect3[[i+1]][[1]]-newexpect3[[i]][[1]]),{i,1,Length[newexpect3]-1}]],]

(E^logpMper2)

Compute p(D|M1,I), global likelihood of constant one bin model

Calculation details:

Assumes a model of an unknown rmin and a random Gaussian variability of unknown sigma s.

As a practical matter we need to choose suitable limits of integration of these two parameters.
If we simply use the prior limits NIntegrate may converge too slowly because of the huge dynamic 
range of the quantity to be integrated.

rmintemp=-20.0;(* lower integration limit for r parameter *)

rmaxtemp=400.0;(* upper integration limit for r parameter *)

smintemp=0.0;(* lower integration limit for s parameter *)

smaxtemp=100.0;(* upper integration limit for s parameter *)

If[ncsys<n,s=.;r=.;logfactor=Log[((((2*π))^(-nd/2))/((rmax-rmin)*Log[((mJs+bfMax[[2]])/mJs)]))];
serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(((dvec-r))/serrvec);logpriorlike=loglikeoffset+logfactor-Log[(s+mJs)]+Log[Times@@((serrvec^(-1)))]-0.5*y.y;term1=Exp[logpriorlike];
pDM1=NIntegrate[term1,{r,rmintemp,rmaxtemp},{s,smintemp,smaxtemp}]
]

logpM1=Log[pDM1]

Compute Bayes factor

If[ncsys<n&&nβ≥nβmin,odds=Exp[logpMper1-logpM1]]

Ch. 13: Gaussian version of Gregory-Loredo algorithm, MCMC implementation (faster version) 
             Includes shape + shape error calculation, treats phase as another MCMC parameter.

Introduction

This algorithm is a useful Bayesian solution to the question: "How to find a periodic signal of unknown shape and period in a time series with independent Gaussian noise?" Note: if you have strong prior information concerning the form of the signal then you can construct a more efficient Bayesian periodogram. For this algorithm the samples can have unequal spacings and the Gaussian noise σ different for each point.
To use this algorithm effectively, the user should become familiar with the paper listed below and Chapter 12 of my book which is entitled, "Bayesian Logical Data analysis for the Physical Sciences," published by Cambridge University Press. The algorithm employs a non parametric histogram model where the the number of bins, m, is itself a parameter. For each choice of m, marginalization over the unknown shape parameters is done analytically. This version sacrifices exact phase marginalization for speed (∼ 7 times) although it generally requires twice as many iterations than the exact phase marginalize version. The phase marginalization is achieved by treating phase as just another MCMC parameter. 

This notebook employs a automatic parallel tempering  (Section 12.8) version of Markov Chain Monte Carlo (MCMC) to evaluate the Gregory-Loredo algorithm (Gaussian noise case). The basic equations where developed in a paper entitled "Bayesian Periodic Signal Detection 1: Analysis of 20 Years of Radio Flux Measurements of the X-ray Binary LS I +61 303,"  Gregory, P. C., Astrophysical Journal, 520, pp.361-375, 1999. This version is a modified implementation which employs an extra Gaussian noise parameter, s,  (explained in calculation details below) instead of the noise scale parameter, b, used in the paper. This program also performs exact phase marginalization (see item 2 of Appendix A in Gregory and Loredo, Astrophysical Journal, 398, pp. 146, 1992).

The program can be run with any number of parallel MCMC chains. To do a quick search set the number of chains, nβ = 1 and n ≥ 20,000. To look for multiple periods typically set nβ = 8 chains are run in parallel, each with a different temperature parameter specified by βlis. At random intervals, a proposal to swap the parameter values of a randomly selected pair of adjacent chains is considered. This prevents the MCMC from becoming trapped in one probability peak region.  The program incorporates  a two stage control system that automates the selection of Gaussian proposal σ's, one for each parameter in a two stage adaptive control system. The program uses a unique fusion MCMC algorithm which incorporates parallel tempering, simulated annealing and a genetic crossover operation to increase the chance of detecting a global maximum in the joint posterior probability distribution. The current problem with only 4 parameters barely justifies the use of an MCMC approach. The real advantage of the MCMC approach is best realized in problems with many more parameters.  Further details of fusion MCMC can be found in Gregory, Monthly Notices of the Royal Astronomical Society, 415, pp. 2523-2545, 2011.

Calculation details (ref: (1) Gregory, P. C.,  Astrophysical Journal, 520, pp. 361-375, 1999 and
 (2) Gregory, P. C., Peracaula, M. & Taylor, A. R.,  Astrophysical Journal, 520, pp. 376-390, 1999)

This analysis differs slightly from that presented in ref. 1. In particular, ref. 1 employed a noise scale parameter b 
(see equation 2). Here, instead we use an extra Gaussian noise term parameterized by the Gaussian standard deviation s.

We can represent the measured data by the equation
                                   (Subscript[d, i])  = (Subscript[f, i]) + (Subscript[ϵ, i])+(Subscript[ϵ, 0])
       (Subscript[d, i]) = measured data at (Subscript[t, i])
       (Subscript[f, i]) = periodic model or constant model prediction at (Subscript[t, i])
       (Subscript[ϵ, i]) = component of  (Subscript[d, i]) which arises from measurement errors
         (Subscript[ϵ, 0])= any additional unknown measurement errors plus any real signal
                           in the data that cannot be explained by the model prediction (Subscript[f, i])

The term (Subscript[ϵ, 0 ]) plays a significant role in model comparison as well. 
Let (Subscript[M, per]) ≡ the data contains a periodic signal  plus known measurement noise  (Subscript[ϵ, i]) .
Let (Subscript[M, 1]) ≡ the data consists of a constant plus known measurement noise  (Subscript[ϵ, i]) .
Let (Subscript[M, 1s]) ≡ the data consists of a constant plus known measurement noise  (Subscript[ϵ, i]),
                      plus extra independent Gaussian noise  (Subscript[ϵ, 0])  of unknown variance (s^2).
To usefully claim the presence of a periodic signal we want
              p((Subscript[M, per])|D,I) > both  p((Subscript[M, 1])|D,I) and p((Subscript[M, 1s])|D,I).

If  p((Subscript[M, per])|D,I) > p((Subscript[M, 1])|D,I) but not p((Subscript[M, 1s])|D,I),
then we would be saying that the addition of an independent Gaussian random component 
was more successful in accounting for the variations than a periodic signal model.

In what follows, we allow the periodic model to have an extra noise term as well, thus we
let (Subscript[M, per]) ≡ the data contains a periodic signal  plus known measurement noise  (Subscript[ϵ, i]) ,
                         plus extra independent Gaussian noise  (Subscript[ϵ, 0])  of unknown variance (s^2). 
               Of course the variance of the extra noise term will be different for the periodic and constant models.

We use a modified Jeffreys prior for  p(s|I) of the form
                   p(s|I) = (1/((s+a)*Log[((a+smax)/a)]))
For s ≪ a, the prior behaves like a uniform prior. For s≫ a it becomes a Jeffreys prior.
Typically we set a ≈ the typical (Subscript[ϵ, i]) term.
a is designated by the variable mJs in the program below.

To replace  b, the noise scale parameter,by the s parameter, make the following changes
to the equations of ref. 1.
          1. Replace the Jeffreys prior for b by a modified Jeffreys prior for s.
  2. Set b = 1 everywhere else.  
3. Repace the estimated noise variance  (Subscript[s, i])  by (Subscript[σ, i]^2)+(s^2).

Raw data consists of a time series (uniform sampling not required). 
In present example it consists of triples of 
{time (days), timing residuals (days), estimated error in timing residuals  (days)}.
Let tvec= a vector of the times.
Let dvec = a vector of the timing residuals.
Let errvec = a vector of dvec errors.

The philosophy of the Gregory-Loredo method is detailed in Section 13.4 of the text book and Ref. 1.
To address the periodic signal detection problem,compute the ratio of
the probabilities (odds) of two models Mper and M1. Model Mper is a family of periodic models capable of describing a background plus a periodic signal of arbitrary shape. A priori, we assume that M1 and Mper have equal probability. Each member of the family of periodic models is a histogram with m bins, with m ranging from 2 to some upper limit, typically 12.

The unknown parameters are P (period), ϕ (phase offset of start of data and beginning of first bin), m (number of bins), and s (extra Gaussian noise parameter).
 
The first step in the calculation is to convert tvec to jvec, a vector of bin numbers corresponding to tvec. 

jvec=IntegerPart[1+m*Mod[tvec/P+ϕp,1]];  a variant of equ.6 ref (1)

ϕp = ϕ/2π, where ϕ is in radians.

sortnjvec = Transpose[{jvec,dvec,serrvec}];   constructs triples of jvec, dvec, serrvec
                                                                            where serrvec = (Sqrt[(errvec^2)+ (s^2)])

Now convert sortnjvec to a m list of {nj,Wj,meandWj,chi2j,wj},
where nj indicates the number of data points in bin j,
Wj = sum of the weights for bin j  equ.13 ref (1), 
meandWj = (OverBar[(Subscript[d, Wj ])])=mean value of dvec for bin j  equ.14 ref (1),
chi2j = (Subscript[χ, j]^2)  value for bin j  equ.16 ref (1),
wj is =1 if nj ≥ 2 or wj=0 if nj < 2  equ.A1 ref (1)  
( wj is a weight that allows use of small data sets )

Now we evaluate the prior and likelihood function, see equation 25 ref prior=((c*P)/(2*π*(s+mJs))) ; (* the prior for parameters for frequency search *) 

where  c=1/((mmax-mmin)*Log[((mJs+smax)/mJs)]*Log[(Pmax/Pmin)]);
(* normalization constants for prior *)

like=((Δr)^(-m))*fact*Times@@(serrvec^(-1))*((((π/2)))^(m/2))*Exp[-0.5*sumchi2j]*complerrfnterm; (* likelihood fn for particular parameters *) 
where  fact=(((2 π))^(-N/2)) ;and Δr  is given by  equ. 19 ref(1), 
and complerrfnterm is = (∏_(j=1)^m){(Wj^(-1/2))[Erfc[yjmin] - Erfc[yjmax]]}
where yjmin = (Sqrt[(Wj/2)])((Subscript[r, min]) - (OverBar[(Subscript[d, Wj ])])) and  where yjmax = (Sqrt[(Wj/2)])((Subscript[r, max]) - (OverBar[(Subscript[d, Wj ])]))
As long as  yjmin<-1.5 and  yjmax>1.5, complerrfnterm is ≈ (∏_(j=1)^m){(Wj^(-1/2))×2.0}; 

pdf1= like;
pdfβ1= prior*(((like))^β); factor needed to decide on tempering swap 

To keep the calculations within the machine precision range (for faster calculation),
we compute the Log[prior] and Log[like] below.

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL 
Specify a procedure for calculation of basic work = prior×likelihood for periodic family of models 
and the quantities needed in computing the lightcurve shape.

workP:=Module[{P,ϕ,s,m},P=avs[[1]];ϕ=avs[[2]];s=avs[[3]];m=Round[avs[[4]]];ϕ1=Mod[ϕ,2*π/m];
ϕp=ϕ1/(2 π);jvec=IntegerPart[1+m*Mod[tvec/P+ϕp,1]];sserrvec=((errvec^2)+(s^2));wtvec=1/sserrvec;logprodsqrtwtvec=Log[Times@@(Sqrt[wtvec])];
sortnjvec=Transpose[{jvec,dvec,sserrvec}];(* need to convert sortnjvec to a m list of {nj,Wj,meandWj,chi2j,wj} where nj indicates the number of data points in bin j, wj is =1 if nj≥2 or wj=0 if nj<2 *)
trselj={};
Do[selj=Select[sortnjvec,#[[1]]==j &];nj=Length[selj];If[nj≥1,trsel=Transpose[selj];Wij=1/trsel[[3]];Wj=Total[Wij];rWj=1/Wj;meandWj=rWj*Total[Wij*trsel[[2]]];meansqdWj=rWj*Total[Wij*(((trsel[[2]]))^2)];chi2j=Wj*(meansqdWj-(((meandWj))^2));If[nj≥2,wj=1,wj=0];item={nj,Wj,meandWj,chi2j,wj},item={0,1,0,0,0}
];(* end If loop *)
trselj=Append[trselj,item],{j,1,m}
]; (* end m bin Do loop *)
q=Transpose[trselj];colWj=q[[2]];colmeandWj=q[[3]];colchi2j=q[[4]];colwj=q[[5]];sumchi2j=m*(Total[colwj*colchi2j])/Total[colwj];

       (* the next paragraph explains how the above line allows small data sets to be used *)

Ref : P. C. Gregory, Astrophysical Journal, 520 : 361 - 375, 1999

(* Continuation of code *)

complerrfn=Times@@((colWj^(-1/2))*2.0); 
loglikeA=-0.5*sumchi2j+Log[complerrfn]; 
logprior=Log[((P*c)/((2*π*(s+mJs))))];
      loglike=loglikeoffset-m*Log[rmax-rmin]+logfact+logprodsqrtwtvec+(m/2)*Log[(π/2)]+loglikeA;
pvec={P,ϕ,s,m};pvecA={colmeandWj,colWj,colwj}];

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["ComputationalGeometry`"]

Needs["ErrorBarPlots`"]

List and plot the data for LSI 6(1^o)303

Each line of the data, named dat, consists of (Julian day - 2,451,000, Flux Density (mJy),  
uncertainty ( mJy).

dat1={{0.00,284.,33.},{718.03,100.,33.},{1096.99,66.,33.},{1457.09,309.,33.},{2524.06,84.,33.},{3607.69,184.,33.},{3630.08,164.,33.},{4033.06,64.,33.},{4161.26,112.,33.},{5355.86,198.,33.},{5469.07,148.,50.},{6012.44,138.,33.},{6038.33,200.,33.},{6063.17,116.,33.},{6089.25,227.,33.},{6117.15,214.,33.},{6147.25,167.,33.},{6172.11,262.,33.},{6198.04,170.,33.},{6224.82,186.,33.},{6251.98,294.,33.},{6276.75,265.,33.},{6306.77,296.,33.},{6361.43,166.,50.},{6411.38,283.,33.},{6440.47,245.,33.},{6467.07,169.,33.},{6492.31,232.,33.},{6519.10,300.,33.},{6543.92,306.,33.},{6572.00,244.,33.},{6597.80,320.,33.},{6623.64,236.,33.},{6651.89,254.,50.},{6677.78,242.,33.},{6705.78,269.,33.},{6731.41,229.,33.},{7048.72,216.,33.},{7075.66,62.,33.},{7103.53,117.,33.},{7133.61,193.,33.},{7164.37,147.,33.},{7185.31,119.,33.},{7211.18,132.,33.},{7244.19,101.,33.},{7267.13,164.,33.},{7292.06,188.,33.},{7324.94,94.,33.},{7339.89,186.,33.},{7369.88,93.,33.},{7398.69,100.,33.},{7427.77,124.,33.},{7451.70,92.,33.},{7473.64,61.,33.},{7494.61,135.,33.},{7520.46,120.,33.}};

Details concerning data manipulation and statistics.

tarr1=Transpose[dat1];

tvec1=N[tarr1[[1]]];

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

errvec1=N[tarr1[[3]]];

Average data interval

Last[tvec1-tvec1[[1]]]/(Length[tvec1]-1)

Translate tvec1 and dvec1 values by subtracting off Mean[tvec1] & Mean[dvec1], respectively.

mntvec1=Mean[tvec1];

dat=Transpose[{tvec1-mntvec1,dvec1,errvec1}];

nd=lendat=Length[dat]

tarr=Transpose[dat];

tvec=N[tarr[[1]]]

tstart=tvec[[1]];tend=tvec[[nd]];

dur=(tend-tstart)

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

errvec=N[tarr[[3]]]

Mean[errvec]

datasigma=StandardDeviation[dvec]

data=Transpose[{tvec,dvec}];

Plot the data

tvecAve=Mean[tvec1]

tvecAve-IntegerPart[tvecAve]

tvecRef=2451000.+tvecAve

IntegerPart[tvecRef]

cmp1=IntegerPart[tvecRef/(10^6)];
cmp2=IntegerPart[(tvecRef-cmp1*(10^6))/(10^5)];cmp3=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5))/(10^4)];cmp4=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4))/(10^3)];cmp5=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3))/(10^2)];cmp6=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2))/10];cmp7=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2)-cmp6*10)];
cmp8=IntegerPart[10*(tvecRef-IntegerPart[tvecRef])];cmp9=IntegerPart[100*(tvecRef-IntegerPart[tvecRef])-cmp8*10];cmp10=IntegerPart[1000*(tvecRef-IntegerPart[tvecRef])-cmp8*100-cmp9*10];cmp11=IntegerPart[10000*(tvecRef-IntegerPart[tvecRef])-cmp8*1000-cmp9*100-cmp10*10];timelabel=ToString[cmp1]<>","<>ToString[cmp2]<>ToString[cmp3]<>ToString[cmp4]<>","<>ToString[cmp5]<>ToString[cmp6]<>ToString[cmp7]<>"."<>ToString[cmp8]<>ToString[cmp9]<>ToString[cmp10]<>ToString[cmp11]

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp1a=Show[plshp1,Graphics[{Text["(a)",{0,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Parallel tempering MCMC program itself:

INITIALIZE PROGRAM VALUES

npara=10; (* number of iterations in one parallel step *)

nthin=npara; (* store MCMC iterations at a thinning interval of nthin *)

n=4000*nthin; (* number of MCMC iterations *)

By default number of iterations n is set = 1000*(npara = 10) and nβ = 1 so that it will execute quickly. 
For reasonable results need to change n >= 2000*(npara = 10).

minCS=2000; (* minimum iterations before 1st stage Control System (CS) turned off *)

maxCS=4000; (* maximum iterations before 1st stage CS turned off *)

deltaN=5000; (*iteration interval for CS to decide whether to rerun 2nd stage CS *)

loglikeoffset=400.0; (* offset to keep results within machine precision range *)

nβ=1;(* the number of choices of tempering parameter *)

(*ratioT=1.77;*) (* ratio of temperature values for different chains (temperature ∝ 1/β *)

(*βlis=Reverse[Table[(ratioT^(-(k-1))),{k,1,nβ}]];*)

βlis={1.0};(* tempering parameter values, in this example only one *)

To look for multiple periods nβ typical set >= 4   chains, each with a different 
 temperature parameter β specified by βlis.

(*βlis={0.00004,0.0005,0.001,0.002,0.005,0.01,0.02,0.032,0.08,0.11,0.17,0.25,0.3,0.35,0.4,0.45,0.51,0.57,0.63,0.69,0.75,0.82,0.90,1.0};*) 
(* useful set of tempering parameter values for Bayes factor calculation which requires many *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains (don't change this) *)

ns=1*npara; (* ns is number of iterations between swap proposals *)

np=4; (* np is the number of model parameters computational explored + s if included *)

ngs=4; (* # Gaussian proposal distributions,ngs=4 for P,ϕ,s,m, don't change *)

ncs=4; (* ncs = number of model parameters used in 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) *)

swg=1; (* swg=1 if gene swap included, swg = 0 otherwise *)

smp=1;(* smp=0 or 1, smp=1 better multiple peak detection, reduced acceptance rate*)

STARTING PARAMETER VALUES

avst=Table[0,{ncs}]; (* initialize table of start parameter values *)
avmin=Table[0,{ncs}];(* initialize table of parameter search lower bounds *)
avMax=Table[0,{ncs}];(* initialize table of parameter search upper bounds *)
bfmin=Table[0,{ncs}];(* parameter lower bounds for Bayes factor calulation*)
bfMax=Table[0,{ncs}];(* parameter upper bounds for Bayes factor calulation*)

avst[[1]]=950.0; (* parameter 1 start value *)

a1name= "P"; a1unit="  (d)";(* name of parameter 1 and units *)

avst[[2]]=0; (* parameter 2 start value *)

a2name= "ϕ"; a2unit="  (rad)";(* name of parameter 2 and units *)

avst[[3]]=4.0; (* extra noise parameter start value *)

a3name= "s"; a3unit="  (mJy)";(* name of extra noise parameter and units *)

avst[[4]]=5.0; (* parameter 3 start value *)

a4name= "m"; a4unit=" "; (* name of parameter 4 and units *)

PRIOR SEARCH RANGES

avmin[[1]]=800.0;avMax[[1]]=2800.;(* search bounds on period *)

avmin[[2]]=0;avMax[[2]]=2*π;(* search bounds on phase *)

avmin[[3]]=0.0;avMax[[3]]= 100.0;(* search bounds on extra noise term s *)

avmin[[4]]=2;avMax[[4]]=12;(* limits on number of model bins, m *)

mmin=avmin[[4]];mMax=avMax[[4]];(* limits on number of model bins, m *)

rmin=-20.0;rmax= 400.0;(* lower and upper bounds on mean signal + bkgd *)

type={-1,2,0,-2}; (* If type = -1, parameter is a period *)
(* type = -2, Round to nearest integer *)
(* type = 1, angular parameter, wrap around at 0 and 1 *)
(* type = 2, angular parameter, wrap around at 0 and 2π *)
(* type = 0, all other parameters *)

PRIOR RANGE FOR BAYES FACTOR CALCULATION

bfmin[[1]]=800.0;bfMax[[1]]=dur/2;(* prior bounds on period *)

bfmin[[2]]=0;bfMax[[2]]=2*π;(* prior bounds on phase *)

bfmin[[3]]=0.0;bfMax[[3]]= 100.;(* prior bounds on extra noise term s *)

bfmin[[4]]=2;bfMax[[4]]=12;(* limits on number of model bins, m *)

STARTING PROPOSAL 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  *)

σst[[1]]=0.1*(1./avmin[[1]]-1./avMax[[1]]);(* sigma for a1 proposal random Gaussian step, don't change *)

σst[[2]]=0.1*2*π; (* sigma for a2 proposal random Gaussian step *)

σst[[3]]=10.0; (* sigma for noise scale parameter *)

σst[[4]]=2.0; (* sigma for m parameter *)

(* Note: parameter m has an integer values, pick new ones from random walk *)

minσ[[1]]=1/(1.6*10*dur*(Sqrt[nd]));

minσ[[2]]=0.000001;

minσ[[3]]=Mean[errvec]/(Sqrt[nd]);

minσ[[4]]=0.6;

GENE BOUNDARIES

ngene=1;

genst=Table[0,{ngene}]; (* initialize table of gene start boundaries *)

genend=Table[0,{ngene}]; (* initialize table of gene end boundaries *)

genst[[1]]= 1; (* start of gene 1 *)

genend[[1]]= ncs; (* end of gene 1 *)

CONTROL SYSTEM PARAMETERS  (user don't change this)

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.35; (* 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=If[ nβ>1,Table[0.7-(nβ-i)*0.1/(nβ-1),{i,1,nβ}],0.7](* 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=1.2 (* Empirical factor for scaling exponent, typical value for n>10 is 0.9 *)

accept=Table[((((((λ))^(1/(ncs^(kalf*alfm))))))^((βlis[[kn]])^(-0.06))),{kn,1,nβ},{kj,1,ncs}](* Calulation of accept rate for individual parameters in 2nd stage CS *)

accept[[1,1]]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS (user don't change this)

mJlim=1.0;(* constant for modified Jeffreys prior for P parameter*)
mJs=10.0;(* constant for modified Jeffreys prior for s *)

c=-Log[2*π*(bfMax[[4]]-bfmin[[4]])*Log[((bfMax[[1]])/(bfmin[[1]]))]*Log[((mJs+bfMax[[3]])/mJs)]];

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (user don't change this)

Specify a procedure for calculation of basic work = prior×likelihood for model. 
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

Now compute the likelihood and quantities needed in computing the lightcurve shape later on.

Version below includes extra noise parameter s.

workP:=Module[{P,ϕ,s,m},P=avs[[1]];ϕ=avs[[2]];s=avs[[3]];m=Round[avs[[4]]];ϕ1=Mod[ϕ,2*π/m];
ϕp=ϕ1/(2 π);jvec=IntegerPart[1+m*Mod[tvec/P+ϕp,1]];sserrvec=((errvec^2)+(s^2));wtvec=1/sserrvec;logprodsqrtwtvec=Log[Times@@(Sqrt[wtvec])];
sortnjvec=Transpose[{jvec,dvec,sserrvec}];(* need to convert sortnjvec to a m list of {nj,Wj,meandWj,chi2j,wj} where nj indicates the number of data points in bin j, wj is =1 if nj≥2 or wj=0 if nj<2 *)
trselj={};
Do[selj=Select[sortnjvec,#[[1]]==j &];nj=Length[selj];If[nj≥1,trsel=Transpose[selj];Wij=1/trsel[[3]];Wj=Total[Wij];rWj=1/Wj;meandWj=rWj*Total[Wij*trsel[[2]]];meansqdWj=rWj*Total[Wij*(((trsel[[2]]))^2)];chi2j=Wj*(meansqdWj-(((meandWj))^2));If[nj≥2,wj=1,wj=0];item={nj,Wj,meandWj,chi2j,wj},item={0,1,0,0,0}
];(* end If loop *)
trselj=Append[trselj,item],{j,1,m}
]; (* end m bin Do loop *)
q=Transpose[trselj];colWj=q[[2]];colmeandWj=q[[3]];colchi2j=q[[4]];colwj=q[[5]];sumchi2j=m*(Total[colwj*colchi2j])/Total[colwj];
complerrfn=Times@@((colWj^(-1/2))*2.0); 
loglikeA=-0.5*sumchi2j+Log[complerrfn]; 
logprior=Log[(P/((2*π*(s+mJs))))]+c;
      loglike=loglikeoffset-m*Log[rmax-rmin]+logfact+logprodsqrtwtvec+(m/2)*Log[(π/2)]+loglikeA;
pvec={P,ϕ,s,m};pvecA={colmeandWj,colWj,colwj}];

MODULE THAT PROPOSES THE NEW PARAMETER SET (user don't change this)

Propose new parameter values uses Switch and type[[ii]]to handle different par. types. 
Update P = av[[1]] via frequency calculation.
Check if proposed values lie outside prior borders, if so reflect parameter or wrap angular parameters.

Version that proposes a change to all of the avs parameter values.

proposeP:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,avs[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,avs[[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*σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
-2,
avm2=Round[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]]];avs[[ii]]=avm2;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm2<avmint,avs[[ii]]=Mod[2*avmint-avm2,(avMaxt-avmint),avmint],avm2>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm2,(avMaxt-avmint),avmint]],
1,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],1],
2,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],2π],
3,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
4,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[1]]/avs[[1]]))^(1/3))*(((1-((avs[[2]])^2)))^(-0.5));
Which[av5<avmint,avs[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,avs[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[7]]/avs[[7]]))^(1/3))*(((1-((avs[[8]])^2)))^(-0.5));
Which[av6<avmint,avs[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,avs[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[12]]/avs[[12]]))^(1/3))*(((1-((avs[[13]])^2)))^(-0.5));
Which[av7<avmint,avs[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,avs[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]],
8,
av8=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av8;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[17]]/avs[[17]]))^(1/3))*(((1-((avs[[18]])^2)))^(-0.5));
Which[av8<avmint,avs[[ii]]=Mod[2*avmint-av8,(avMaxt-avmint),avmint],av8>avMaxt,avs[[ii]]=Mod[2*avMaxt-av8,(avMaxt-avmint),avmint]],
9,
av9=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av9;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[22]]/avs[[22]]))^(1/3))*(((1-((avs[[23]])^2)))^(-0.5));
Which[av9<avmint,avs[[ii]]=Mod[2*avmint-av9,(avMaxt-avmint),avmint],av9>avMaxt,avs[[ii]]=Mod[2*avMaxt-av9,(avMaxt-avmint),avmint]],
10,
av10=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av10;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[27]]/avs[[27]]))^(1/3))*(((1-((avs[[28]])^2)))^(-0.5));
Which[av10<avmint,avs[[ii]]=Mod[2*avmint-av10,(avMaxt-avmint),avmint],av10>avMaxt,avs[[ii]]=Mod[2*avMaxt-av10,(avMaxt-avmint),avmint]]
];avs[[ii]]
]

Version that proposes a change to one of the avs parameter values (needed for 2nd stage of control system).

proposeP1:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,avs[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,avs[[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*σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
-2,
avm2=Round[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]]];avs[[ii]]=avm2;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm2<avmint,avs[[ii]]=Mod[2*avmint-avm2,(avMaxt-avmint),avmint],avm2>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm2,(avMaxt-avmint),avmint]],
1,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],1],
2,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],2π],
3,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
4,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[1]]/avs[[1]]))^(1/3))*(((1-((avs[[2]])^2)))^(-0.5));
Which[av5<avmint,avs[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,avs[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[7]]/avs[[7]]))^(1/3))*(((1-((avs[[8]])^2)))^(-0.5));
Which[av6<avmint,avs[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,avs[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[12]]/avs[[12]]))^(1/3))*(((1-((avs[[13]])^2)))^(-0.5));
Which[av7<avmint,avs[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,avs[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]],
8,
av8=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av8;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[17]]/avs[[17]]))^(1/3))*(((1-((avs[[18]])^2)))^(-0.5));
Which[av8<avmint,avs[[ii]]=Mod[2*avmint-av8,(avMaxt-avmint),avmint],av8>avMaxt,avs[[ii]]=Mod[2*avMaxt-av8,(avMaxt-avmint),avmint]],
9,
av9=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av9;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[22]]/avs[[22]]))^(1/3))*(((1-((avs[[23]])^2)))^(-0.5));
Which[av9<avmint,avs[[ii]]=Mod[2*avmint-av9,(avMaxt-avmint),avmint],av9>avMaxt,avs[[ii]]=Mod[2*avMaxt-av9,(avMaxt-avmint),avmint]],
10,
av10=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av10;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[27]]/avs[[27]]))^(1/3))*(((1-((avs[[28]])^2)))^(-0.5));
Which[av10<avmint,avs[[ii]]=Mod[2*avmint-av10,(avMaxt-avmint),avmint],av10>avMaxt,avs[[ii]]=Mod[2*avMaxt-av10,(avMaxt-avmint),avmint]]
];avs
]

MODULE THAT ACCEPTS THE NEW PARAMETER SET & store frequency changes (user don't change this)

acceptP:=Module[{pdfβi,pdfβiA},
pdfβi=logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA=logprior+loglike;
testr1=pdfβi-logpdftempk[[nl]];
If[testr1>-uflow,If[testr1<uflow,r1=Exp[testr1],r1=1.0],r1=-1.0];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,If[i>n0,nc2k=nc2k+1;If[nc4<1,nak=nak+1]];
pdfβiB1=Join[{β},pvec,{i},{loglike},{pdfβi},pvecA];
If[pdfβi>maxlogpdfβik[[nl]],maxlogpdfβik=pdfβiB1];If[pdfβiA>maxlogpdfAlla[[nl]],maxlogpdfAlla=Join[{β},pvec,{i},{loglike},{pdfβiA}]];
pdfβiB={{pdfβiA},{loglike},pdfβiB1,{nc2k},{nak},maxlogpdfβik,maxlogpdfAlla}
,pdfβiC=logpdftempk;pdfβiC[[n2l-1]]=i;
pdfβiB={{pdfβiA},{loglike},pdfβiC,{nc2k},{nak},maxlogpdfβik,maxlogpdfAlla}
];pdfβiB
]

For use in second stage Control System use acceptP1.

acceptP1:=Module[{pdfβi,pdfβiA},
pdfβi=logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA=logprior+loglike;
testr1=pdfβi-logpdftempk[[nl]];
If[testr1>-uflow,If[testr1<uflow,r1=Exp[testr1],r1=1.0],r1=-1.0]; (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,nc2k=nc2k+1;
pdfβiB1=Join[{β},pvec,{i},{loglike},{pdfβi},pvecA];
If[pdfβi>maxlogpdfβik[[nl]],maxlogpdfβik=pdfβiB1];If[pdfβiA>maxlogpdfAlla[[nl]],maxlogpdfAlla=Join[{β},pvec,{i},{loglike},{pdfβiA}]];
pdfβiB={{pdfβiA},{loglike},pdfβiB1,{nc2k},maxlogpdfβik,maxlogpdfAlla}
,pdfβiC=logpdftempk;pdfβiC[[n2l-1]]=i;
pdfβiB={{pdfβiA},{loglike},pdfβiC,{nc2k},maxlogpdfβik,maxlogpdfAlla}
];pdfβiB
]

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 *) 
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 *)
uflow=Log[$MaxNumber/10.0];(* set number to avoid underflow messages *) 
na=Table[0,{nβ}];  (* initialize acceptance array *)
nacor=Table[0,{nβ}];  (* initialize acceptance array for correlated move sampler *)
nb=Table[0,{k,1,nβ},{ncs}];  (* initialize array to store #accepted proposals in minor cycle *)(* for each parameter proposal σ *)
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}]; 
σall1=Table[0,{ncs}];  
Do[σall1[[i]]=σst[[i]],{i,1,ncs}];(*initialize σall1 array*)
σall=Table[σst[[i]],{k,1,nβ},{i,1,ncs}];  
(* initialize σall array *)
σallold={};(* record previous best σall *)
pdfβiAmax2old={};(* record previous best logprior+loglike 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 *)
cs2cnt=1;(* initialize second stage CS counter *)
cs2cnt2=0;(* initialize counter to track how often 2nd stage CS is repeated a second time in a row *)
(*nacatot=Table[0,{nβ}];*)(* initialize counter of parameter sets added to movarray[[nβ]] *)
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)*Log[2*π] ;
(*logfactA=-(nast/2)*Log[2*π];*)
kvals=Table[i,{i,1,nβ}];
(* Evaluate the probability for the i=0 sample for each tempering level*)
Do[(* iteration over β *) β=βlis[[k]];avs=avst;
 (* initiate parameter values *)
(* ******************** Basic working *********************** *)
workP;
(* ********************************************************* *)
pdf1= loglike;
pdfβ1= logprior+β*loglike; (* factor needed to decide on tempering swap *)
logpdf[[1,k]]=Join[{β},pvec,{0,pdf1,pdfβ1},pvecA],{k,1,nβ} 
];  (* close first Do loop iterating over β *)
maxlogpdfβi=logpdf[[1]];
maxlogpdfAll=Take[logpdf[[1,nβ]],nl];(* initialize this array in each processor (chain) *)
Do[ (* start calculation for ith iteration beginning at i = 1 *)
If[i>n0,nc1=nc1+npara];If[nc1<npara+1&&i>n0,logpdftemp=logpdfinow,logpdftemp=logpdf[[1]]];
iV=i+1-npara;sw6=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw6k=sw6[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[
If[sw6k<1,i=iV;logpdftempk=logpdftemp[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=nc2[[k]];nak=na[[k]];sw6k=sw6k+1,
i=i+1;logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values
];
Do[proposeP,{ii,1,ncs}];workP;acceptP,
{isub,1,npara}
];pdfβiB,
{k,1,nβ} 
];
tworkvals=Transpose[workvals];logpdf[[2]]=tworkvals[[3]];nc2=Flatten[Transpose[tworkvals[[4]]]];na=Flatten[Transpose[tworkvals[[5]]]];maxlogpdfβi=tworkvals[[6]];lastworkvals=tworkvals[[7]];
acceptvec=Sort[workvals,OrderedQ[{#2,#1}]&];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax=kbestvec[[nl]];
If[pdfβiAmax>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
(* Consider a swap between 2 tempering levels if i an integer multiple of ns *)
If[nc4>0,Goto[anneal]];
If[nβ<2,Goto[genecrossover]];
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,nl+3}];
logpdf[[2,k1,n2l]]=loglike2;logpdf[[2,k1,nl]]=p21;
Do[logpdf[[2,k2,ji]]=temp[[ji]],{ji,2,nl+3}];
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 *)
(* Gene swap/crossover between top chain(s) and values in maxlogpdfAll *)
Label[genecrossover];
If[swg>0&&IntegerQ[i/(2*nthin)],
If[nβ<2,
If[ngene<2,
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[βnow=topvalues[[3,1]];
nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avtop[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avtop[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
{kg,1,ngene} 
],(* end of ngene=1 & nβ=1 option *)
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
avs=avcurmax;βnow=topvalues[[3,1]];
Do[avs[[ii]]=avtop[[ii]],{ii,genst[[kg]],genend[[kg]]}];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
{kg,1,ngene} 
]
],(* end of ngene>1 & nβ=1 option *)
If[ngene<2,
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];secvalues=acceptvec[[2]];avsec=Take[secvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
Which[kg≤ngene,βnow=topvalues[[3,1]];nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avtop[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avtop[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
kg≤2*ngene,βnow=secvalues[[3,1]];nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avsec[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avsec[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike;
pdfβiB={{pdfβiA},Join[{2+βnow},pvec,{i},{loglike},{pdfβiA}]}
],
{kg,1,2*ngene} 
],(* end of ngene=1 & nβ>1 option *)
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];secvalues=acceptvec[[2]];avsec=Take[secvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
If[kg≤ngene,avs=avcurmax;βnow=topvalues[[3,1]];
Do[avs[[ii]]=avtop[[ii]],{ii,genst[[kg]],genend[[kg]]}];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
avs=avcurmax;βnow=secvalues[[3,1]];kgg=kg-ngene;
Do[avs[[ii]]=avsec[[ii]],{ii,genst[[kgg]],genend[[kgg]]}];
workP;pdfβiA=logprior+loglike;
pdfβiB={{pdfβiA},Join[{2+βnow},pvec,{i},{loglike},{pdfβiA}]}
],
{kg,1,2*ngene} 
]
]
];
acceptvec1=Sort[workvals,OrderedQ[{#2,#1}]&];
kbestvec=acceptvec1[[1]];pdfβiAmax=kbestvec[[1,1]];If[pdfβiAmax>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];
maxlogpdfAll=kbestvec[[2]]];
];(* end of gene swap/crossover If statement *)
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[σallprop=scminus[[k]]*σall[[k,nc5[[ik]]]];   If[σallprop>avMax[[ik]],σall[[k,nc5[[ik]]]]=avMax[[ik]],σall[[k,nc5[[ik]]]]=σallprop]; 
              If[k==nβ&&(nbmax[[k]]-nc5)>0,swminσ[[ik]]=0,],{ik,1,lnc5}],
           Do[σallprop=σall[[k,ik]]*scminus[[k]];If[σallprop>avMax[[ik]],σall[[k,ik]]=avMax[[ik]],σ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;If[i<maxCS,sw4=1]];
σ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[maxlogpdfAll,{2,ncs+1}];
Do[(* iteration over β *) β=βlis[[k]];avs=bestvec;
 (* initiate parameter values *)
(* ******************** Basic working ********************** *)
workP;
(* ********************************************************* *)
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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
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]])],
-2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=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]]>Abs[avMax[[ip2]]],σall[[k,ip2]]=Abs[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]]],
8,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
9,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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
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]])],
-2,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=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]]>Abs[avMax[[ip2]]],σall[[k,ip2]]=Abs[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]]],
8,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
9,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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
Do[accept3[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
If[Min[N[accept3[[nβ]]/n1]]<0.2||Max[N[accept3[[nβ]]/n1]]>0.9,nagain=1,nagain=0];
If[cs2cnt<2&&nagain>0,sw4=1;cs2cnt=cs2cnt+1;cs2cnt2=cs2cnt2+1,sw4=0;cs2cnt=1]
]; (* complete If statement *)
If[i>ncsys&&IntegerQ[(i-ncsys)/deltaN]&&(maxlogpdfAll[[nl]]-pdfβiAmax2)>3.0,sw4=1;ncsysold=Append[ncsysold,ncsys];σallold=Append[σallold,σall];pdfβiAmax2old=Append[pdfβiAmax2old,pdfβiAmax2];na=Table[0,{nβ}];ncsys=i,
];(* complete If statement *)
,{i,npara,n,npara} (* 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).

ncsys

Best parameter vector found.

bestvecFound=Take[maxlogpdfAll,{2,np+1}]

MemoryInUse[]

To output the whole MCMC data set. (usually not done for storage space reasons)

(*ng=Length[logpdfβi];stmp=OpenWrite["c:/Users/Philip/Documents/greg8/55Cancri/APT5planGenC55cancri.dat",PageWidth->Infinity];
Do[Write[stmp,logpdfβi[[i]]],{i,1,ng}];Close[stmp]*)

To output only the β = 1 tempering level results. Need to remove (*  *) for these commands to execute.

(*tr=Transpose[logpdfβi];tr5=tr[[nβ]];ng=Length[tr5];stmp=OpenWrite["c:/greg7/glMCMC/M6APTglShp.dat",PageWidth->Infinity];
Do[Write[stmp,tr5[[i]]],{i,1,ng}];Close[stmp]*)

Here is how to input results. Need to remove (*  *) for these commands to execute.

(*dataMC=ReadList["c:/greg7/glMCMC/M6APTglShp.dat"];nnt=Length[dataMC];
n=nthin*nnt;ng=nnt *)

The subsequent analysis steps assume the data for all chains are stored in an array called logpdfβi, generated when the above program steps are run. This array contains results from all the parallel MCC chains. What happens when we want to re-analyse the MCMC samples? In general we only store the samples from the top chain to minimize storage space. The next line populates the data for all chains with the values read back in for the top chain. This trick enables the subsequent analysis programs to execute properly without any changes to the input formats. Since the subsequent analysis (except for last item dealing with the Bayes factor calculation) only computes on the top chain it doesn't matter what we have in the other chains.

(*logpdfβi=Transpose[Table[dataMC,{k,1,nβ}]];*)

Analysis of evolution of control system error & 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 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 the code designer.

swminσ

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["P",FontWeight->"Bold",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

tmklabel=
StyleForm[StringForm["``  (d)",
StyleForm["P",FontSlant->"Italic"]],
FontFamily->Times,FontWeight->"Bold",FontSize->13]

slabel=
StyleForm[StringForm["``  (m (s^(-1)))",
StyleForm["s",FontSlant->"Italic"]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Extracting parameter samples for the β = 1 (k = nβ) MCMC chain

All the results are stored by the variable logpdfβi.
First let's look at an example of the first row of the output given by logpdfβi[[1]].
{{0.7`,959.9570426550547`,8.410472623513195`,8,0.184423242856966`,10,-359.62532691196645`,-253.1455838368756`,{156.89277789375976`,170.56510914858458`,212.06113676644097`,155.5687786722197`,172.05437469063716`,263.34566311302075`,258.14650838999955`,65.00000147130324`},{0.004798399215619782`,0.008268349917487159`,0.008175878554497472`,0.00810576171560245`,0.00991916701353707`,0.003809601030024318`,0.002065348350492186`,0.0017245290682693423`},{1,1,1,1,1,1,1,1}},{1.`,915.483426027098`,49.521858039985666`,8,0.8344017176514003`,10,-332.9801915080576`,-335.9621806242566`,{129.06270535700554`,211.6799395240604`,153.22840275420063`,188.3271444616131`,185.46990009010187`,169.0932214984301`,238.63740694566013`,148.2293410557676`},{0.0005960212853256656`,0.0016856185266010406`,0.0028603385052064904`,0.0027413014669901013`,0.0027571737729362457`,0.002828341849558241`,0.0015247096953809956`,0.0005786509307537253`},{1,1,1,1,1,1,1,1}}}
There are 2 lists one for each of the 2 parallel MCMC chains.
The first list contains the result for β = 0.01 and the last list 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 last 2 lists with the command Take[tr,-5].
{{1.`,1601.2647748555332`,27.96272168752309`,6,0.11614611831917314`,19990,-300.57441153031`,-302.4688583545684`,{187.0901230354528`,257.87722679996403`,266.64682315098946`,186.29519219451439`,130.7404519851376`,106.09893880637397`},{0.004818152199780243`,0.005105963105584811`,0.004584912790835392`,0.001864254972704946`,0.0064362393413150915`,0.0064329812603021765`},{1,1,1,1,1,1}},
{1.`,1623.6240446019028`,11.22046901066641`,6,0.1133348300401571`,20000,-301.0338046237546`,-302.13628298560104`,{186.95461941035077`,260.04777171906886`,266.4085052025349`,190.5427767088951`,125.5429661791475`,106.01884433765404`},{0.007445110430441424`,0.007955126622175377`,0.00676801242071224`,0.0032959775130001986`,0.00997081154614048`,0.009332455694764165`},{1,1,1,1,1,1}}}
Item (1) in each list is the value of β, 
Items (2-5) are the current values of the parameters P,s,m,ϕ.
Item (6) is the iteration number.
Item (7) is the Log of the likelihood, used in computing the global likelihood of the model for the 
    Bayes factor calculation.
Item (9) is the value of   prior*(((like))^β) for the particular set of parameter values.
Item (9) is a list of m values of colmeandWj = (OverBar[(Subscript[d, Wj])]), one for each bin, for signal shape calculation.
Item (10) is a list of m values of colWj = (Subscript[W, j]) , one for each bin, for signal shape calculation.
Item (11) is a list of m values of colwj = (Subscript[w, j]), one for each bin, for signal shape calculation.

Extract parameter iterations for the k = nβ member of the tempering levels. 
To obtain columns of each quantity use trn = Transpose[tr].

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];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=5;(* with niter = 100, plot only every 100th point *)

nburn1=100;(* skip first nburn1 iterations for 2nd (upper right) plot *)

pl=Table[0,{i,ncs+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

xiterticks={500,1000,1500,2000};

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==27,pl[[i+2]]=ListLogPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}],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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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,ncs}
];

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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}];

plIter=Show[GraphicsGrid[If[EvenQ[ncs+2],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,ncs+2,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(ncs+2)/2]*2,2}],{{pl[[IntegerPart[(ncs+2)/2]*2+1]]}}]],Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Set the burn-in value nburn.

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 *)

Examine post burn-in parameter iterations for the β = 1   MCMC chain.

k=nβ;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt}];trn=Transpose[tr];ng=Length[trn[[1]]]

Sart by choosing some display parameters.

niter=1;(* with niter = 100, plot only every 100th point *)

nburn1=100;(* skip first nburn1 iterations for 2nd (upper right) plot *)

pl=Table[0,{i,ncs+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

xiterticks={500,1000,1500,2000};

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==27,pl[[i+1]]=ListLogPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}],pl[[i+1]]=ListPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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,ncs}
];

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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}];

plIter=Show[GraphicsGrid[If[EvenQ[ncs+1],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,ncs+1,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(ncs+1)/2]*2,2}],{{pl[[IntegerPart[(ncs+1)/2]*2+1]]}}]],Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Plot pairs of parameters to examine correlations for highest peak only.     
(uses a PDF cutoff and shows PDF by point size and BW)

We want to plot points at intervals of dn iterations.

dn=3;

Plot m versus s

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

pLow=800.0;pHi=2400.;
trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];trPsel=Select[tr,#[[2]]>pLow&&#[[2]]<pHi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]]]];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a3good,a4good}];plms=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a3name<>a3unit,{"Helvetica-Bold",12}],
		Style[a4name<>a4unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plotsmh=Histogram3D[ppf,
AxesLabel->{a3name<>a3unit,a4name<>a4unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Plot ϕ versus P

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

pLow=800.0;pHi=2400.;
trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];trPsel=Select[tr,#[[2]]>pLow&&#[[2]]<pHi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]]]];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a2good,a1good}];plPh=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a2name<>a2unit,{"Helvetica-Bold",12}],
		Style[a1name<>a1unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plotsph=Histogram3D[ppf,
AxesLabel->{a2name<>a2unit,a1name<>a1unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Plot P versus s

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

pLow=800.0;pHi=2400.;
trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];trPsel=Select[tr,#[[2]]>pLow&&#[[2]]<pHi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]]]];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a3good,a1good}];plPs=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a3name<>a3unit,{"Helvetica-Bold",12}],
		Style[a1name<>a1unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plotsph=Histogram3D[ppf,
AxesLabel->{a3name<>a3unit,a1name<>a1unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Plot m versus P

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

pLow=800.0;pHi=2400.;
trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];trPsel=Select[tr,#[[2]]>pLow&&#[[2]]<pHi&];lsel=Length[trPsel];If[lsel>0,trn=Transpose[trPsel];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]]]];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a1good,a4good}];plmP=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a1name<>a1unit,{"Helvetica-Bold",12}],
		Style[a4name<>a4unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plmPh=Histogram3D[ppf,
AxesLabel->{a1name<>a1unit,a4name<>a4unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

If[ncsys<n,plcorrallBW=Show[GraphicsGrid[{{plms,plmPh},{plPs,plmP}},Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]]

Plot (Subscript[Log, 10])[prior × (((likelihood))^β)] versus orbital period for the (k^th) chain in βlis. 
           (e.g., k = nβ corresponds to β = 1)

We will only plot points with (Subscript[Log, 10])[prior × (((likelihood))^β)] > cutoff , where 
(Subscript[Log, 10])[prior × (((likelihood))^β)] is first scaled to have a maximum value of 0.
Also, only plot points separated by an amount = interval.

interval=1;cutoff=-5;

k=nβ;(* k specifies which of the nβ chains to plot *)

tr=Transpose[logpdfβi][[k]];(* extract values for the k=nβ chain *)

Extract parameters and prob=prior*likelihood as separate columns. Find probMax = maximum value of prob and then convert prob values to logprob=Log[10,prob/probMax].

trn=Transpose[tr];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]];prob=trn[[nl]];ng=Length[trn[[1]]];probMax=Max[prob];logprob=Log[10,E]*(prob-probMax);

Make a list of {logprob, parameter values}, then extract a subset of this list specified by interval.
Sort list according to logprob in descending order.
Select all values for which logprob > cutoff.  Then extract the parameter values besta1, besta2, besta3, besta4 (for figure header information)  corresponding to the maximum logprob. Finally, Transpose the selected parameter sets ppsel so that pairs of parameters can be plotted.

ppf=Transpose[{logprob,a1good,a2good,a3good,a4good}];nppf=Length[ppf];pp=Take[ppf,{1,nppf,interval}];pps=Sort[pp,OrderedQ[{#2, #1}]&];ppsel=Select[pps,#[[1]]>cutoff&];nsel=Length[ppsel];lsp=First[ppsel];yval=lsp[[1]];besta1=lsp[[2]];besta2=lsp[[3]];besta3=lsp[[4]];besta4=lsp[[5]];bestLogprob=yval+Log[10,E]*probMax;psel=Transpose[ppsel];

Plot {period, logprob} pairs.

If[nsel>0,
ppn=Transpose[{psel[[2]],psel[[1]]}];plms=ListPlot[ppn,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["P = "<>ToString[besta1]<>" ;  s = "<>ToString[besta2]<>" ;  m = "<>ToString[besta3]<>" ;chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] \!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \\ \\ \)\(β\)\)]\) ) = "<>ToString[bestLogprob],{"Helvetica-Bold",9}],FrameLabel->{Style[a1name<>a1unit,{"Helvetica-Bold",12}],
		Style["(Subscript[Log, 10]) (Prior\[Cross]\!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \)\(β\)\)]\))",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]
]

Repeat above but plots the location where possible harmonics 
and subharmonics of the most probable orbital period.

If[nsel>0,
ppn=Transpose[{psel[[2]],psel[[1]]}];plProbP=ListPlot[ppn,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["P = "<>ToString[besta1]<>" ;  ϕ = "<>ToString[besta2]<>" ;  s = "<>ToString[besta3]<>" ;  m = "<>ToString[besta4]<>" ;chain  β = "<>ToString[βlis[[k]]]<>" ;\nMax  (Subscript[log, 10]) (Prior \[Cross] \!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \\ \\ \)\(β\)\)]\) ) = "<>ToString[bestLogprob],{"Helvetica-Bold",9}],FrameLabel->{Style[a1name<>a1unit,{"Helvetica-Bold",12}],
		Style["(Subscript[Log, 10]) (Prior\[Cross]\!\(\*SuperscriptBox[\(Likelihood\), \(\(\\ \\ \)\(β\)\)]\))",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
Show[plProbP,Graphics[{Thickness[0.002],Red,Line[{{besta1,0},{besta1,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{besta1/2,0},{besta1/2,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{besta1/3,0},{besta1/3,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{besta1/4,0},{besta1/4,cutoff}}]}],Graphics[{Thickness[0.002],Red,Line[{{2*besta1,0},{2*besta1,cutoff}}]}]]
]

Use ListPlot3D to plot triplets of (Subscript[Log, 10])[prior × (((likelihood))^β)], s, P

We will only plot points with (Subscript[Log, 10])[prior × (((likelihood))^β)] > cutoff , where 
(Subscript[Log, 10])[prior × (((likelihood))^β)] is first scaled to have a maximum value of 0.
Also, only plot points separated by an amount = interval.

interval=1;cutoff=-5;

k=nβ;(* k specifies which of the nβ chains to plot *)

tr=Transpose[logpdfβi][[k]];(* extract values for the k=nβ chain *)

Extract parameters and prob=prior*likelihood as separate columns. Find probMax = maximum value of prob and then convert prob values to logprob=Log[10,prob/probMax].

trn=Transpose[tr];a1good=trn[[2]];a2good=trn[[3]];a3good=trn[[4]];a4good=trn[[5]];prob=trn[[nl]];ng=Length[trn[[1]]];probMax=Max[prob];logprob=Log[10,E]*(prob-probMax);

Make a list of {logprob, parameter values}, then extract a subset of this list specified by interval.
Sort list according to logprob in descending order.
Select all values for which logprob > cutoff.  Then extract the parameter values besta1, besta2, besta3, besta4 (for figure header information)  corresponding to the maximum logprob. Finally, Transpose the selected parameter sets ppsel so that pairs of parameters can be plotted.

ppf=Transpose[{logprob,a1good,a2good,a3good,a4good}];nppf=Length[ppf];pp=Take[ppf,{1,nppf,interval}];pps=Sort[pp,OrderedQ[{#2, #1}]&];ppsel=Select[pps,#[[1]]>cutoff&];nsel=Length[ppsel];psel=Transpose[ppsel];pp3=Transpose[{psel[[1]],psel[[2]],psel[[4]]}];

If[nsel>0,ListPointPlot3D[pp3]]

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]]]

plh=Table[1,{i,ncs}];
Do[
If[i==0,lmed=Median[trnn[[i]]];loglmed=Floor[Log[10,lmed]];loglmed10=N[10^Floor[Log[10,lmed]]];trnni=trnn[[i]]/loglmed10;
sf[n_]:=ToString[HoldForm[(10^n)],StandardForm];label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>"   (×"<> sf[loglmed]<>")"<>ToExpression["a"<>ToString[i]<>"unit"]];
plh[[i]]=Histogram[trnni,PlotRange->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"}],label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];plh[[i]]=Histogram[trnn[[i]],PlotRange->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,ncs-1}
];
label=StringForm[ToExpression["a"<>ToString[ncs]<>"name"]<>ToExpression["a"<>ToString[ncs]<>"unit"]];aimarg=Take[trn[[ncs+1]],-(ng-nburn)];
ybin=BinCounts[aimarg,{mmin-0.5,mMax+0.5}];totybin=Plus@@ybin;nybin=N[ybin/totybin];y0bin=Table[0,{i,mmin,Length[ybin]+mmin-1}];xbin=Table[i,{i,mmin,Length[ybin]+mmin-1}];xAbin=Table[0.9999*i,{i,mmin,Length[ybin]+mmin-1}];xBbin=Table[1.0001*i,{i,mmin,Length[ybin]+mmin-1}];mbin=Transpose[{xbin,nybin}];mAbin=Transpose[{xAbin,y0bin}];mBbin=Transpose[{xBbin,y0bin}];mallbin=Sort[Join[mAbin,mbin,mBbin]];pbin=Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&];plh[[ncs]]=ListPlot[mallbin,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,Joined->True,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Probability",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
plhis=Show[GraphicsGrid[If[EvenQ[ncs],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,ncs,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(ncs)/2]*2,2}],{{plh[[IntegerPart[(ncs)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Redo using BinCounts to compute errors and result statistics

nai=200;njump=0;plp=Table[1,{i,ncs}];meanai=Table[0,{j,1,ncs}];medianai=Table[0,{j,1,ncs}];modeai=Table[0,{j,1,ncs}];minai=Table[0,{j,1,ncs}];maxai=Table[0,{j,1,ncs}];areai=Table[0,{j,1,ncs}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=Take[trn[[i+1]],-(ng-nburn)];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[100000*Min[aimarg]]/100000;hi=Round[100000*Max[aimarg]]/100000;If[hi==low,njump=1;Break[],];dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Total[aibin];If[aibintot<1,njump=1;Break[],];yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2, #1}]&];modeai[[i]]=pbin[[1,2]];minai[[i]]=avMax[[i]];maxai[[i]]=avmin[[i]];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}];aimargbinA=Join[{{First[aimidpoints]-dai,0.0}},aimargbin,{{Last[aimidpoints]+dai,0.0}}];plp[[i]]=ListPlot[MovingAverage[aimargbinA,{(1/37),(2/37),(4/37),(4/37),(5/37),(5/37),(5/37),(4/37),(4/37),(2/37),(1/37)}],PlotRange->{{0.98*low,1.01*hi},{0,0.75*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],{i,1,ncs-1}
];
label=StringForm[ToExpression["a"<>ToString[ngs]<>"name"]<>ToExpression["a"<>ToString[ngs]<>"unit"]];aimarg=Take[trn[[ngs+1]],-(ng-nburn)];meanai[[ngs]]=Mean[aimarg];medianai[[ngs]]=Median[aimarg];modeai[[ngs]]=Commonest[aimarg][[1]];
ybin=BinCounts[aimarg,{mmin-0.5,mMax+0.5}];totybin=Plus@@ybin;nybin=N[ybin/totybin];y0bin=Table[0,{i,mmin,Length[ybin]+mmin-1}];xbin=Table[i,{i,mmin,Length[ybin]+mmin-1}];xAbin=Table[0.9999*i,{i,mmin,Length[ybin]+mmin-1}];xBbin=Table[1.0001*i,{i,mmin,Length[ybin]+mmin-1}];mbin=Transpose[{xbin,nybin}];mAbin=Transpose[{xAbin,y0bin}];mBbin=Transpose[{xBbin,y0bin}];mallbin=Sort[Join[mAbin,mbin,mBbin]];pbin=Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&];minai[[ngs]]=1000000000;maxai[[ngs]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[ngs]],minai[[ngs]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[ngs]],maxai[[ngs]]=pbin[[j,2]],Null];
j=j+1];areai[[ngs]]=area;plp[[ncs]]=ListPlot[mallbin,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,Joined->True,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Probability",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];If[njump<1,plmarg=Show[GraphicsGrid[{{plp[[1]],plp[[2]]},{plp[[3]],plp[[4]]}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]],Print["Not enough iterations"]
]

Find mProbMax = m value with largest probability.

mPMax=First[Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&]][[2]]

Calculate the sum of the probabilities of the periodic models with m ≠ mPMax to prob. of model with m = mPMax.

pri=Transpose[{xbin,nybin}];priX=Select[pri,#[[1]]==mPMax&];prinotX=Select[pri,#[[1]]≠mPMax&];prnotXtoX=Plus@@(Transpose[prinotX][[2]])/priX[[1,2]]

Most probable set of parameters & 68.3% marginal credible regions

Use next command block if working from dataMC input from file.

tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5s=Sort[tr5,#1[[nl]]>#2[[nl]]&];

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5s[[1]]

Note: the second item in the list is the raw phase, for most of our calculations we need Mod[ϕ,2*π/m], which is what we display in the various plots above .

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5s[[1,i+1]],{i,1,ncs}];peakai

Make a 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,ncs}];

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,ncs}];

smj=MatrixForm[Join[l1,l2,l4,l5]]

Plot mean & median light curves and std deviation marginalizing over m.

Allows for selecting MCMC samples with period between cutoff1 and cutoff2.

cutoff1=800;cutoff2=2800;tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5Ps=Select[tr5,#[[2]]>cutoff1&&#[[2]]<cutoff2&];tr5Psel=Sort[tr5Ps,#1[[nl]]>#2[[nl]]&];
trn=Transpose[tr5Psel];
permarg=trn[[2]];
Length[tr5Psel]
pbar=Mean[permarg]

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5Psel[[1]]

Identify parameter values with maximum (peak) probability, e.g., peaks is the value for extra noise parameter s.

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5Psel[[1,i+1]],{i,1,ncs+1}];peaks=peakai[[2]]

Steps in computing the mean and median light curve shape and 1 sigma uncertainty

Divide the most probable period (peakai[[1]]) into a list of  nshape time steps labelled ts.  
Recall that for each set of parameters, we computed and stored the vector: {β,P,s,m,ϕ, i,Log[pdfi],pdfβi,colmeandWj,colWj,colwj},
where colmeandWj,colWj,colwj each consist of a vector of m values one for each of the m bins.
For each set of parameter values convert each ts into a bin number and extract the 
 (OverBar[(Subscript[d, Wj])]) = dWjvec, Wj = Wjvec, wj (correction for no data)= wjvec for that bin corresponding to that set of parameter values using the Extract command. Transpose those quantities to obtain shpwjt,  shpWjt,  shpt. 
 Next form wjshplistk = Transpose[{shpwjt[[k]], shpt[[k]], shpWjt[[k]]}]. 
 Next form selk=Select[wjshplistk,#[[1]]= = 1 &] which selects only shape info where shpwjt[[k]] is non zero.
 Then compute the mean shape[[k]] and mean shsig[[k]] for each k. 
 We also store shlist so we can obtain a histogram of shape values for each k.

This version below works even if there is only one data point in certain bins

Timing[interval=10;nshape=80;ts=Table[i*peakai[[1]]/nshape,{i,nshape}];
shp={};shpWj={};shpwj={};nused=Length[tr5Psel];datgood=Take[tr5Psel,{1,nused,interval}];nu=Length[datgood];
Do[P=datgood[[i,2]];m=datgood[[i,5]];ϕp=Mod[datgood[[i,3]],2*π/m]/(2*π);dWjvec=datgood[[i,nl+1]];Wjvec=datgood[[i,nl+2]];wjvec=datgood[[i,nl+3]];jvec=IntegerPart[1+m*Mod[ts/P+ϕp,1]];tjvec=Transpose[{jvec}];shpi=Extract[dWjvec,tjvec];Wji=Extract[Wjvec,tjvec];wji=Extract[wjvec,tjvec];shp=Append[shp,shpi];shpWj=Append[shpWj,Wji];shpwj=Append[shpwj,wji],{i,1,nu}
];
shpt=Transpose[shp];shpWjt=Transpose[shpWj];shpwjt=Transpose[shpwj];shlist=Table[0,{k,nshape}];shape=Table[0,{k,nshape}];medianshape=Table[0,{k,nshape}];shsig=Table[0,{k,nshape}];nselk=Table[0,{k,nshape}];Do[wjshplistk=Transpose[{shpwjt[[k]],shpt[[k]],shpWjt[[k]]}];If[Length[wjshplistk]<1,Print["no data for bin "<>ToString[k]];Break[],];tselk=Transpose[wjshplistk];shlist[[k]]=tselk[[2]];medianshape[[k]]=Median[shlist[[k]]];shape[[k]]=Mean[shlist[[k]]];nselk[[k]]=Length[shlist[[k]]];shsig[[k]]=Mean[(((tselk[[3]]))^(-1/2))],{k,nshape}];shape]

Plot shape = the mean shape.

ListPlot[shape]

Plot shape = the mean shape.

ListPlot[medianshape]

Plot shsig = the mean shape sigma value.

ListPlot[shsig]

Plot mean shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,shape+shsig}];shpup1=Transpose[{ph1,shape+shsig}];shpup2=Transpose[{ph2,shape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,shape-shsig}];shpdn1=Transpose[{ph1,shape-shsig}];shpdn2=Transpose[{ph2,shape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot median shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,medianshape+shsig}];shpup1=Transpose[{ph1,medianshape+shsig}];shpup2=Transpose[{ph2,medianshape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,medianshape-shsig}];shpdn1=Transpose[{ph1,medianshape-shsig}];shpdn2=Transpose[{ph2,medianshape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2median=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase.

The next two lines cause the data error bars to be increased by the most probable value of the extra noise term.

Do[If[StringMatchQ[ToExpression["a"<>ToString[i]<>"name"],"s"],nsi=i,],{i,1,ncs}];

meanai[[nsi]]

pserrvec=(Sqrt[(errvec^2)+((meanai[[nsi]])^2)]);

nsi

phvec1=Mod[tvec,pbar]/pbar;phvec2=phvec1+1;phdat1=Transpose[{phvec1,dvec,pserrvec}];
phdat2=Transpose[{phvec2,dvec,pserrvec}];phdat=Join[phdat1,phdat2];
tphdat=Transpose[phdat];phd=Transpose[{tphdat[[1]],tphdat[[2]]}];phdvec=Table[{phd[[i]],ErrorBar[tphdat[[3]][[i]]]},{i,Length[phd]}];
plphdvec=ErrorListPlot[phdvec,Frame->True,PlotRange->{{-0.05,2.0},Automatic},Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase with light curve overlaid.

plshpAllm=Show[plphdvec,plphshp2]

plshpAllmb=Show[plshpAllm,Graphics[{Text["(a)",{1.,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plshpAllmMedian=Show[plphdvec,plphshp2median]

Plot individual data points versus time with overlaid Mean light curve.

pldatvst=ErrorListPlot[Transpose[{tvec,dvec,pserrvec}],Frame->True,Axes->False,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ncycle=6;shpupt={};Do[Do[shpupt=Append[shpupt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]+shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
shpdnt={};Do[Do[shpdnt=Append[shpdnt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]-shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
plshpt1=ListPlot[{shpupt,shpdnt},Frame->True,PlotRange->All,Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

pltimfitdat=Show[pldatvst,plshpt1,Axes->False]

pltimfitdatb=Show[pltimfitdat,Graphics[{Text["(b)",{0,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5];

Plot residuals for mean solution (m = all bins).

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;shperr0=Transpose[{ph0,shape,shsig}];shperr1=Transpose[{ph1,shape,shsig}];shperr2=Transpose[{ph2,shape,shsig}];shperr=Join[shperr0,shperr1,shperr2];tshperr=Transpose[shperr];phaseshp=Transpose[{tshperr[[1]],tshperr[[2]]}];phaseshp=Table[phaseshp[[i]],{i,3*nshape}];
plphshp1=ListPlot[phaseshp,Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ifnshp=Interpolation[phaseshp]

phvec1

mvec=ifnshp[phvec1];Length[mvec]

y=dvec-mvec

Computed weighted std dev.

wresmap=(Sqrt[((((y/errvec)).((y/errvec)))/((1/errvec).(1/errvec)))])

resmap=StandardDeviation[y]

resid=Transpose[{tvec,y}];

residerr=Table[{resid[[i]],ErrorBar[pserrvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Error residuals (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp2b=Show[plshp2,Graphics[{Text["(c)",{0,-110}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plMAP3=Show[GraphicsGrid[{{plshpAllmb},{pltimfitdatb},{plshp2b}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]]

Plot mean & median light curves and std deviation for m = mchoice.

Allows for selecting MCMC samples with period between cutoff1 and cutoff2 and m = mchoice.

Set mchoice yourself (typically the largest value of m with an appreciable probability) or use the default mPMax found earlier.
mPMax is the value of m with the largest probability.

mchoice=mPMax

cutoff1=800;cutoff2=2800;tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5Ps=Select[tr5,#[[2]]>cutoff1&&#[[2]]<cutoff2&&#[[5]]==mchoice&];tr5Psel=Sort[tr5Ps,#1[[nl]]>#2[[nl]]&];
trn=Transpose[tr5Psel];
permarg=trn[[2]];
Length[tr5Psel]
pbar=Mean[permarg]

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5Psel[[1]]

Identify parameter values with maximum (peak) probability, e.g., peaks is the value for extra noise parameter s.

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5Psel[[1,i+1]],{i,1,ncs+1}];peaks=peakai[[2]]

Steps in computing the mean and median light curve shape and 1 sigma uncertainty

Divide the most probable period (peakai[[1]]) into a list of  nshape time steps labelled ts.  
Recall that for each set of parameters, we computed and stored the vector: {β,P,s,m,ϕ, i,Log[pdfi],pdfβi,colmeandWj,colWj,colwj},
where colmeandWj,colWj,colwj each consist of a vector of m values one for each of the m bins.
For each set of parameter values convert each ts into a bin number and extract the 
 (OverBar[(Subscript[d, Wj])]) = dWjvec, Wj = Wjvec, wj (correction for no data)= wjvec for that bin corresponding to that set of parameter values using the Extract command. Transpose those quantities to obtain shpwjt,  shpWjt,  shpt. 
 Next form wjshplistk = Transpose[{shpwjt[[k]], shpt[[k]], shpWjt[[k]]}]. 
 Next form selk=Select[wjshplistk,#[[1]]= = 1 &] which selects only shape info where shpwjt[[k]] is non zero.
 Then compute the mean shape[[k]] and mean shsig[[k]] for each k. 
 We also store shlist so we can obtain a histogram of shape values for each k.

This version below works even if there is only one data point in certain bins

Timing[interval=10;nshape=80;ts=Table[i*peakai[[1]]/nshape,{i,nshape}];
shp={};shpWj={};shpwj={};nused=Length[tr5Psel];datgood=Take[tr5Psel,{1,nused,interval}];nu=Length[datgood];
Do[P=datgood[[i,2]];m=datgood[[i,5]];ϕp=datgood[[i,3]]/m;dWjvec=datgood[[i,nl+1]];Wjvec=datgood[[i,nl+2]];wjvec=datgood[[i,nl+3]];jvec=IntegerPart[1+m*Mod[ts/P+ϕp,1]];tjvec=Transpose[{jvec}];shpi=Extract[dWjvec,tjvec];Wji=Extract[Wjvec,tjvec];wji=Extract[wjvec,tjvec];shp=Append[shp,shpi];shpWj=Append[shpWj,Wji];shpwj=Append[shpwj,wji],{i,1,nu}
];
shpt=Transpose[shp];shpWjt=Transpose[shpWj];shpwjt=Transpose[shpwj];shlist=Table[0,{k,nshape}];shape=Table[0,{k,nshape}];medianshape=Table[0,{k,nshape}];shsig=Table[0,{k,nshape}];nselk=Table[0,{k,nshape}];Do[wjshplistk=Transpose[{shpwjt[[k]],shpt[[k]],shpWjt[[k]]}];If[Length[wjshplistk]<1,Print["no data for bin "<>ToString[k]];Break[],];tselk=Transpose[wjshplistk];shlist[[k]]=tselk[[2]];medianshape[[k]]=Median[shlist[[k]]];shape[[k]]=Mean[shlist[[k]]];nselk[[k]]=Length[shlist[[k]]];shsig[[k]]=Mean[(((tselk[[3]]))^(-1/2))],{k,nshape}];shape]

Plot shape = the mean shape.

ListPlot[shape]

Plot shsig = the mean shape sigma value.

ListPlot[shsig]

Plot mean shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,shape+shsig}];shpup1=Transpose[{ph1,shape+shsig}];shpup2=Transpose[{ph2,shape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,shape-shsig}];shpdn1=Transpose[{ph1,shape-shsig}];shpdn2=Transpose[{ph2,shape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot median shape ± one sigma repeated for two cycles of phase

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;
shpup0=Transpose[{ph0,medianshape+shsig}];shpup1=Transpose[{ph1,medianshape+shsig}];shpup2=Transpose[{ph2,medianshape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,medianshape-shsig}];shpdn1=Transpose[{ph1,medianshape-shsig}];shpdn2=Transpose[{ph2,medianshape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2median=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase.

The next two lines cause the data error bars to be increased by the most probable value of the extra noise term.

Do[If[StringMatchQ[ToExpression["a"<>ToString[i]<>"name"],"s"],nsi=i,],{i,1,ncs}];

meanai[[nsi]]

pserrvec=(Sqrt[(errvec^2)+((meanai[[nsi]])^2)]);

nsi

phvec1=Mod[tvec,pbar]/pbar;phvec2=phvec1+1;phdat1=Transpose[{phvec1,dvec,pserrvec}];
phdat2=Transpose[{phvec2,dvec,pserrvec}];phdat=Join[phdat1,phdat2];
tphdat=Transpose[phdat];phd=Transpose[{tphdat[[1]],tphdat[[2]]}];phdvec=Table[{phd[[i]],ErrorBar[tphdat[[3]][[i]]]},{i,Length[phd]}];
plphdvec=ErrorListPlot[phdvec,Frame->True,PlotRange->{{-0.05,2.0},Automatic},Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase with light curve overlaid.

plshpAllm=Show[plphdvec,plphshp2]

plshpAllmb=Show[plshpAllm,Graphics[{Text["(a)",{1.,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plshpAllmMedian=Show[plphdvec,plphshp2median]

Plot individual data points versus time with overlaid Mean light curve.

pldatvst=ErrorListPlot[Transpose[{tvec,dvec,pserrvec}],Frame->True,Axes->False,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ncycle=6;shpupt={};Do[Do[shpupt=Append[shpupt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]+shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
shpdnt={};Do[Do[shpdnt=Append[shpdnt,{(ph1[[i]]+(j-5))*pbar,shape[[i]]-shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
plshpt1=ListPlot[{shpupt,shpdnt},Frame->True,PlotRange->All,Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

pltimfitdat=Show[pldatvst,plshpt1,Axes->False]

pltimfitdatb=Show[pltimfitdat,Graphics[{Text["(b)",{0,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5];

Plot residuals for mean solution (m = mchoice).

ph0=ts/pbar-1;ph1=ts/pbar;ph2=ts/pbar+1;shperr0=Transpose[{ph0,shape,shsig}];shperr1=Transpose[{ph1,shape,shsig}];shperr2=Transpose[{ph2,shape,shsig}];shperr=Join[shperr0,shperr1,shperr2];tshperr=Transpose[shperr];phaseshp=Transpose[{tshperr[[1]],tshperr[[2]]}];phaseshp=Table[phaseshp[[i]],{i,3*nshape}];
plphshp1=ListPlot[phaseshp,Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ifnshp=Interpolation[phaseshp]

phvec1

mvec=ifnshp[phvec1];Length[mvec]

y=dvec-mvec

Computed weighted std dev.

wresmap=(Sqrt[((((y/errvec)).((y/errvec)))/((1/errvec).(1/errvec)))])

resmap=StandardDeviation[y]

resid=Transpose[{tvec,y}];

residerr=Table[{resid[[i]],ErrorBar[pserrvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Error residuals (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp2b=Show[plshp2,Graphics[{Text["(c)",{0,-110}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plMAP4=Show[GraphicsGrid[{{plshpAllmb},{pltimfitdatb},{plshp2b}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]]

Compute the Bayes factor from all tempering level results

Compares model (Subscript[M, per]) to model (Subscript[M, 1]) (rejecting the first nburn samples). 
((NOTE: THIS SECTION WON'T EVALUATE IF nβ < nβmin.))
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 20) of β levels are used spanning the range β = 0 to 1. 
Otherwise use the restricted Monte Carlo Bayes factor calculation in the next section.

Compute p(D|Mper,I), the global likelihood for the periodic model

Here we compute  the log of the global likelihood of the model, which is designated by  logpMper
                logpMper=log[p(D|Mper,I)]=∫ (Subscript[⟨ log[p(D|Mper,X,I)] ⟩, β])  dβ
(Subscript[⟨ log[p(D|Mper,X,I)] ⟩, β]) =expectation value oflog[p(D|Mper,X,I)]  for given β
                                              =(1/n)(∑_(t=1)^n)  log[p(D|Mper,(Subscript[X, 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 an example of the first row of the output given by logpdfβi[[1,1]].
         {1.`,1273.9726060784137`,40.803985991174834`,5,0.35303805202159366`,10,76.0136129133192`,73.543571479479`,{148.91745708656111`,194.36292184504748`,240.09863821079406`,201.68614548468776`,132.11148679054986`},{0.0065844726825486505`,0.0051319390270891255`,0.004495349418625844`,0.001429003958843216`,0.002333596595333784`},{1,1,1,1,1}}
          The quantity  log[p(D|Mper,(Subscript[X, t,β ]) ,I)] is the (7^th) item (n2l item) in each list. 
The different list correspond to different values of the tempering parameter β.

Set nβmin, the minimum number of tempering levels before it makes any sense to compute the 
global likelihood of the model by this method.

nβmin=20;

First check that you are happy with the burn -in value, nburn.

nburn

Generate the list expect = ⟨ln p(D|(Subscript[M, per]),X,I)⟩ , one for each tempering level 
provided nβ≥nβmin and ncsys<n, i.e., the turn-off of the control system was ≤nburn.

If[ncsys<n&&nβ≥nβmin,ngood=(nnt-nburn);tr=Transpose[Take[logpdfβi,-ngood]];expect=Table[0.0,{i,1,nβ}];Do[trnb=Transpose[tr[[nb]]];tb1Num=trnb[[n2l]];logpdfβ=Total[tb1Num]/ngood;expect[[nb]]=logpdfβ,{nb,1,nβ}],];

ngood

List ⟨ln p(D|(Subscript[M, per]),PX,I)⟩ values, one for each tempering level.

If[ncsys<n&&nβ≥nβmin,expect,]

List the β tempering values.

If[ncsys<n&&nβ≥nβmin,βlis,]

Plot ⟨ln p(D|(Subscript[M, per]),X,I)⟩ values versus (Subscript[Log, 10 ])(βlis+0.000001).

If[ncsys<n&&nβ≥nβmin,pl1=ListPlot[Transpose[{Log[10,βlis],expect}],PlotStyle->PointSize[0.02],Axes->False,Frame->True,PlotRange->All,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D|(Subscript[M, 2]),X,I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Generate an interpolating function for a LogLinearPlot.

If[ncsys<n&&nβ≥nβmin,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[ncsys<n&&nβ>nβmin,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect]]

Plot the interpolation.

If[ncsys<n&&nβ≥nβmin,pl4=ListPlot[newexpect,Frame->True,PlotRange->All,Axes->False,Joined->True,PlotStyle->{Thickness->0.004},FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D|(Subscript[M, 2]),X,I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

Plot the interpolation and expect values together.

If[ncsys<n&&nβ≥nβmin,plBayesFactor=Show[pl1,pl4,PlotRange->All],]

If[ncsys<n&&nβ≥nβmin,plBayesFactorA=Show[pl1,pl4,PlotRange->{{-2.1,0.01},{60,105}}]]

If[ncsys<n&&nβ≥nβmin,plBayesFactorB=Show[pl1,pl4,PlotRange->{{-1,0.01},{80,100}}]]

If[ncsys<n&&nβ≥nβmin,plBayesFactorC=Show[pl1,pl4,PlotRange->{{-0.3,0.01},{95,99}}],]

plBayesFactor2=Show[plBayesFactor,Epilog->Inset[plBayesFactorA,Scaled[{0.3,0.55}],Scaled[{0.1,0.1}],Scaled[{0.7,0.7}]]
]

Now convert to a table with linear coordinates.

If[ncsys<n&&nβ≥nβmin,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 logpMper.

If[ncsys<n&&nβ≥nβmin,logpMper1=Total[Table[0.5*(newexpect1[[i]][[2]]+newexpect1[[i+1]][[2]])*(newexpect1[[i+1]][[1]]-newexpect1[[i]][[1]]),{i,1,Length[newexpect1]-1}]]]

(E^logpMper1)

Suppose we drop the first nn  β levels and redo the 
calculation of the Log of the global likelihood for M1.

nn=3;

If[ncsys<n&&nβ⩾(nβmin+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[ncsys<n&&nβ≥(nβmin+nn),newexpect2=Table[spline2[x],{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2]]

If[ncsys<n&&nβ≥(nβmin+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[ncsys<n&&nβ≥(nβmin+nn),logpMper2=Total[Table[0.5*(newexpect3[[i]][[2]]+newexpect3[[i+1]][[2]])*(newexpect3[[i+1]][[1]]-newexpect3[[i]][[1]]),{i,1,Length[newexpect3]-1}]],]

(E^logpMper2)

Compute p(D|M1,I), global likelihood of constant one bin model

Calculation details:

Assumes a model of an unknown rmin and a random Gaussian variability of unknown sigma s.

As a practical matter we need to choose suitable limits of integration of these two parameters.
If we simply use the prior limits NIntegrate may converge too slowly because of the huge dynamic 
range of the quantity to be integrated.

rmintemp=-20.0;(* lower integration limit for r parameter *)

rmaxtemp=400.0;(* upper integration limit for r parameter *)

smintemp=0.0;(* lower integration limit for s parameter *)

smaxtemp=100.0;(* upper integration limit for s parameter *)

If[ncsys<n,s=.;r=.;logfactor=Log[((((2*π))^(-nd/2))/((rmax-rmin)*Log[((mJs+bfMax[[2]])/mJs)]))];
serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(((dvec-r))/serrvec);logpriorlike=loglikeoffset+logfactor-Log[(s+mJs)]+Log[Times@@((serrvec^(-1)))]-0.5*y.y;term1=Exp[logpriorlike];
pDM1=NIntegrate[term1,{r,rmintemp,rmaxtemp},{s,smintemp,smaxtemp}]
]

logpM1=Log[pDM1]

Compute Bayes factor

If[ncsys<n&&nβ≥nβmin,odds=Exp[logpMper1-logpM1]]

Ch. 13:  Source variability detection using a non parametric stepwise model based on the 
              Gaussian version of Gregory-Loredo with period set equal to the data duration. 
              MCMC implementation with exact phase marginalization, 
              includes signal shape + shape error calculation.
              Employs a periodic boundary condition with phase wrap-around

Introduction

The Gaussian version of the Gregory-Loredo algorithm is a useful Bayesian solution to the question: "How to detect a periodic signal of unknown shape and period in a time series with independent Gaussian noise?" If we fix the unknown period = data duration, it provides a useful Bayesian solution to the question: "How to detect a variable signal of unknown shape and in a time series with independent Gaussian noise?" Note: if you have strong prior information concerning the form of the signal then you can construct a more efficient Bayesian algorithm. For this algorithm the samples can have unequal spacings and the Gaussian noise σ  can be different for each point.
To use this algorithm effectively, the user should become familiar with the paper listed below and Chapter 12 of my book which is entitled, "Bayesian Logical Data analysis for the Physical Sciences," published by Cambridge University Press.
The basic equations where developed in a paper entitled "Bayesian Periodic Signal Detection 1: Analysis of 20 Years of Radio Flux Measurements of the X-ray Binary LS I +61 303,"  Gregory, P. C., Astrophysical Journal, 520, pp.361-375, 1999. This version is a modified implementation which employs an extra Gaussian noise parameter, s,  (explained in claculation details below) instead of the noise scale parameter, b, used in the paper. This program also performs exact phase marginalization (see item 2 of Appendix A in Gregory and Loredo, Astrophysical Journal, 398, pp. 146, 1992).

This notebook employs a automatic parallel tempering  (Section 12.8) version of Markov Chain Monte Carlo (MCMC) to evaluate the Gregory-Loredo algorithm (Gaussian noise case). 
The program can be run with any number of parallel MCMC chains. To do a quick search set the number of chains, nβ = 1 and n ≥ 20,000. To look for multiple periods typically set nβ = 8 chains are run in parallel, each with a different temperature parameter specified by βlis. At random intervals, a proposal to swap the parameter values of a randomly selected pair of adjacent chains is considered. This prevents the MCMC from becoming trapped in one probability peak region.  The program incorporates  a two stage control system that automates the selection of Gaussian proposal σ's, one for each parameter in a two stage adaptive control system. The program uses a unique fusion MCMC algorithm which includes simulated annealing and a genetic crossover operation to greatly increase the chance of detecting a global minimum in (χ^( 2)). The current problem with only 4 parameters barely justifies the use of an MCMC approach. The real advantage of the fusion MCMC approach is best realized in problems with many more parameters. Further details of fusion MCMC can be found in Gregory, Monthly Notices of the Royal Astronomical Society, 415, pp. 2523-2545, 2011.

Calculation details (ref: (1) Gregory, P. C.,  Astrophysical Journal, 520, pp. 361-375, 1999 and
 (2) Gregory, P. C., Peracaula, M. & Taylor, A. R.,  Astrophysical Journal, 520, pp. 376-390, 1999)

Many astrophysical sources are observed to exhibit nonperiodic variability on a variety of temporal scales. A stepwise model can just as easily represent a nonperiodic variable lightcurve (Appendix C: Gregory & Loredo, Astrophysical J., 398, 146, 1992, 
and Gregory & Loredo, Proc. 12th Int. Conf. on Maximum Entropy and Bayesian Methods, ed. Mohammad-Djafari & Demoment, Dordrecht:Kluwer, p. 225, 1993). Therefore, the GL calculations can also be used to compare a constant rate model to a variable model, or to compare both constant and variable nonperiodic alternatives to periodic models. All that is necessary is to set the period P = dur, the total duration of the observations.

This analysis differs slightly from that presented in ref. 1. In particular, ref. 1 employed a noise scale parameter b (see equation 2). Here, instead we use an extra Gaussian noise term parameterized by the Gaussian standard deviation s.

We can represent the measured data by the equation
                                   (Subscript[d, i])  = (Subscript[f, i]) + (Subscript[ϵ, i])+(Subscript[ϵ, 0])
       (Subscript[d, i]) = measured data at (Subscript[t, i])
       (Subscript[f, i]) = periodic model or constant model prediction at (Subscript[t, i])
       (Subscript[ϵ, i]) = component of  (Subscript[d, i]) which arises from measurement errors
         (Subscript[ϵ, 0])= any additional unknown measurement errors plus any real signal
                           in the data that cannot be explained by the model prediction (Subscript[f, i])

The term (Subscript[ϵ, 0 ]) plays a significant role in model comparison as well. 
Let (Subscript[M, var]) ≡ the data contains a variable signal  plus known measurement noise  (Subscript[ϵ, i]) .
Let (Subscript[M, 1]) ≡ the data consists of a constant plus known measurement noise  (Subscript[ϵ, i]) .
Let (Subscript[M, 1s]) ≡ the data consists of a constant plus known measurement noise  (Subscript[ϵ, i]),
                      plus extra independent Gaussian noise  (Subscript[ϵ, 0])  of unknown variance (s^2).
To usefully claim the presence of a periodic signal we want
              p((Subscript[M, var])|D,I) > both  p((Subscript[M, 1])|D,I) and p((Subscript[M, 1s])|D,I).

If  p((Subscript[M, var])|D,I) > p((Subscript[M, 1])|D,I) but not p((Subscript[M, 1s])|D,I),
then we would be saying that the addition of an independent Gaussian random component 
was more successful in accounting for the variations than a periodic signal model.

In what follows, we allow the periodic model to have an extra noise term as well, thus we
     let (Subscript[M, var]) ≡ the data contains a variable signal  plus known measurement noise  (Subscript[ϵ, i]) ,
                         plus extra independent Gaussian noise  (Subscript[ϵ, 0])  of unknown variance (s^2). 
               Of course the variance of the extra noise term will be different for the periodic and constant models.

We use a modified Jeffreys prior for  p(s|I) of the form
                   p(s|I) = (1/((s+a)*Log[((a+smax)/a)]))
For s ≪ a, the prior behaves like a uniform prior. For s≫ a it becomes a Jeffreys prior.
Typically we set a ≈the typical (Subscript[ϵ, i]) term.
a is designated by the variable mJs in the program below.

To replace  b, the noise scale parameter,by the s parameter, make the following changes
to the equations of ref. 1.
          1. Replace the Jeffreys prior for b by a modified Jeffreys prior for s.
  2. Set b = 1 everywhere else.  
3. Repace the estimated noise variance  (Subscript[s, i])  by (Subscript[σ, i]^2)+(s^2).

Raw data consists of a time series (uniform sampling not required). 
In present example it consists of triples of 
{time (days), timing residuals (days), estimated error in timing residuals  (days)}.
Let tvec= a vector of the times.
Let dvec = a vector of the timing residuals.
Let errvec = a vector of dvec errors.

To address the variable signal detection problem,compute the ratio of
the probabilities (odds) of two models (Subscript[M, var]) and (Subscript[M, 1]). Model (Subscript[M, var]) is a family of variable models capable of describing a background plus a variable signal of arbitrary shape. A priori, we assume that (Subscript[M, 1]) and (Subscript[M, var]) have equal probability. Each member of the family of periodic models is a histogram with m bins, with m ranging from 2 to some upper limit, typically 12.

The unknown parameters are ϕ (phase offset of start of data and beginning of first bin), m (number of bins), and s (extra Gaussian noise parameter).
 
The first step in the calculation is to convert tvec to jvec, a vector of bin numbers corresponding to tvec. In the equation below dur = data duration.

jvec=IntegerPart[1+m*Mod[tvec/dur+ϕp,1]];  a variant of equ.6 ref (1)

ϕp = ϕ/2π, where ϕ is in radians.

sortnjvec = Transpose[{jvec,dvec,serrvec}];   constructs triples of jvec, dvec, serrvec
                                                                            where serrvec = (Sqrt[(errvec^2)+ (s^2)])

Now convert sortnjvec to a m list of {nj,Wj,meandWj,chi2j,wj},
where nj indicates the number of data points in bin j,
Wj = sum of the weights for bin j  equ.13 ref (1), 
meandWj = (OverBar[(Subscript[d, Wj ])])=mean value of dvec for bin j  equ.14 ref (1),
chi2j = (Subscript[χ, j]^2)  value for bin j  equ.16 ref (1),
wj is =1 if nj ≥ 2 or wj=0 if nj < 2  equ.A1 ref (1)  
( wj is a weight that allows use of small data sets )

Now we evaluate the prior and likelihood function, see equation 25 ref and drop P as a parameter
prior=(c/(2*π*(s+mJs))) ; (* the prior for parameters for frequency search *) 

where  c=1/((mmax-mmin)*Log[((mJs+smax)/mJs)]);
(* normalization constants for prior *)

like=((Δr)^(-m))*fact*Times@@(serrvec^(-1))*((((π/2)))^(m/2))*Exp[-0.5*sumchi2j]*complerrfnterm; (* likelihood fn for particular parameters *) 
where  fact=(((2 π))^(-N/2)) ;and Δr  is given by  equ. 19 ref(1), 
and complerrfnterm is = (∏_(j=1)^m){(Wj^(-1/2))[Erfc[yjmin] - Erfc[yjmax]]}
where yjmin = (Sqrt[(Wj/2)])((Subscript[r, min]) - (OverBar[(Subscript[d, Wj ])])) and  where yjmax = (Sqrt[(Wj/2)])((Subscript[r, max]) - (OverBar[(Subscript[d, Wj ])]))
As long as  yjmin<-1.5 and  yjmax>1.5, complerrfnterm is ≈ (∏_(j=1)^m){(Wj^(-1/2))×2.0}; 
pdf1= like;
pdfβ1= prior*(((like))^β); factor needed to decide on tempering swap 

To keep the calculations within the machine precision range, for faster calculations,
we compute the Log[prior] and Log[like] below.

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (exact phase integration) 
Specify a procedure for calculation of basic work = prior×likelihood for periodic family of models 
and the quantities needed in computing the lightcurve shape.

workP:=Module[{s,m},s=avs[[1]];m=Round[avs[[2]]];binph=m*Mod[tvec/dur,1.0];
(* phidis = phase distance to next m bin boundary for the time set tvec *)
phidis=1-FractionalPart[binph];wtvec=1/((errvec^2)+(s^2));logprodsqrtwtvec=Log[Times@@(Sqrt[wtvec])];
jvec=IntegerPart[1+binph];sortnjvec=Sort[Transpose[{phidis,jvec,wtvec,wtvec*dvec,wtvec*(dvec^2)}]];
tsort=Transpose[sortnjvec];sphidis=tsort[[1]];
(* shpidis = the set of phidis corresponding to tvec sorted in ascending order *)shiftsphidis=Take[Join[{0.0},sphidis],nd];
incphi=sphidis-shiftsphidis;cph=0.5*(sphidis+shiftsphidis);
jincphvec=Transpose[{tsort[[2]],tsort[[3]],tsort[[4]],tsort[[5]]}];trjsel=Table[0,{iw,1,nd},{jm,1,m}];
(* there are nd phase increments for each m that need to be considered, iw labels these *)Do[selj=Select[jincphvec,#[[1]]==jm &];(* for the current set of parameters, select all samples that fall in bin jm jvec for the zero phase bin *)
nj=Length[selj];If[nj≥1,trsel=Transpose[selj];Wj=Total[trsel[[2]]];dWj=Total[trsel[[3]]];sqdWj=Total[trsel[[4]]];If[nj≥2,wj=1,wj=0];item={jm,nj,dWj,sqdWj,Wj,wj},item={jm,0,0.0,0.0,0.0,0}
];trjsel[[1,jm]]=item,{jm,1,m}];
(* compute the same entries for trjsel for the remaining phase increments *)Do[trjsel[[iw]]=trjsel[[iw-1]];njiw=tsort[[2,iw-1]];If[njiw<m,njiw2=njiw+1,njiw2=1];Wjd=tsort[[3,iw-1]];
ddWj=tsort[[4,iw-1]];
dsqdWj=tsort[[5,iw-1]];item1={0,1,ddWj,dsqdWj,Wjd,0};vec1=trjsel[[iw,njiw]]-item1;If[vec1[[2]]>1,vec1[[6]]=1;trjsel[[iw,njiw]]=vec1,vec1[[6]]=0;trjsel[[iw,njiw]]=vec1];trjsel[[iw,njiw]]=trjsel[[iw,njiw]]/.x_Real/;Abs[x]<(10^(-10))->0.0;vec2=trjsel[[iw,njiw2]]+item1;If[vec2[[2]]>1,vec2[[6]]=1;trjsel[[iw,njiw2]]=vec2,vec2[[6]]=0;trjsel[[iw,njiw2]]=vec2],{iw,2,nd}];
       valsh=Table[tt=Transpose[trjsel[[iw]]];corWj=tt[[5]]/.x_/;x==0.0->1.0;
colWj=corWj;colmeandWj=tt[[3]]/corWj;colmeansqdWj=tt[[4]]/corWj;colchi2j=colWj*(colmeansqdWj-(((colmeandWj))^2));colwj=tt[[6]];sumchi2j=m*(Total[colwj*colchi2j])/Total[colwj];(* the next paragraph explains how the above line allows small data sets to be used *)

Ref : P. C. Gregory, Astrophysical Journal, 520 : 361 - 375, 1999

complerrfnterm=Times@@((colWj^(-1/2))*2); 
loglikeA=-0.5*sumchi2j+Log[complerrfnterm]; 
{loglikeA,colmeandWj,colWj,colwj},{iw,nd}];
valsht=Transpose[valsh];maxloglikeA=Max[valsht[[1]]];adjlikeA=Exp[valsht[[1]]-maxloglikeA];
(* - maxloglikeA factor reduces the dynamic range required in phase integration *)
valnd=Table[adjlikeAinciw=adjlikeA[[iw]]*incphi[[iw]];{adjlikeAinciw,adjlikeAinciw*valsht[[2,iw]],adjlikeAinciw*valsht[[3,iw]],adjlikeAinciw*valsht[[4,iw]],adjlikeAinciw*cph[[iw]]},{iw,nd}];
tvalnd=Total[valnd];
     ff=1/tvalnd[[1]];
     logprior=Log[(c/((s+mJs)))];logdterm=Log[m*tvalnd[[1]]]+maxloglikeA;
(* the factor of m multiplying tvalnd[[1]] allows for the phase integration *) (* over a single bin to be extended to a whole period, the + maxloglikeA *)
    (* corrects for the - maxloglikeA factor used above *)
  loglike=loglikeoffset-m*Log[rmax-rmin]+logfact+logprodsqrtwtvec+(m/2)*Log[(π/2)]+logdterm; ϕ=ff*tvalnd[[5]];ffwj=Round[ff*tvalnd[[4]]];
pvec={s,m,ϕ};
  pvecA={ff*tvalnd[[2]],ff*tvalnd[[3]],ffwj}]

Setup

Remove["Global`*"]

Off[General::"spell"]

Off[General::"spell1"]

Needs["ComputationalGeometry`"]

Needs["ErrorBarPlots`"]

List and plot the data for LSI 6(1^o)303

Each line of the data, named dat, consists of (Julian day - 2,451,000, Flux Density (mJy),  
uncertainty ( mJy).

dat1={{0.00,284.,33.},{718.03,100.,33.},{1096.99,66.,33.},{1457.09,309.,33.},{2524.06,84.,33.},{3607.69,184.,33.},{3630.08,164.,33.},{4033.06,64.,33.},{4161.26,112.,33.},{5355.86,198.,33.},{5469.07,148.,50.},{6012.44,138.,33.},{6038.33,200.,33.},{6063.17,116.,33.},{6089.25,227.,33.},{6117.15,214.,33.},{6147.25,167.,33.},{6172.11,262.,33.},{6198.04,170.,33.},{6224.82,186.,33.},{6251.98,294.,33.},{6276.75,265.,33.},{6306.77,296.,33.},{6361.43,166.,50.},{6411.38,283.,33.},{6440.47,245.,33.},{6467.07,169.,33.},{6492.31,232.,33.},{6519.10,300.,33.},{6543.92,306.,33.},{6572.00,244.,33.},{6597.80,320.,33.},{6623.64,236.,33.},{6651.89,254.,50.},{6677.78,242.,33.},{6705.78,269.,33.},{6731.41,229.,33.},{7048.72,216.,33.},{7075.66,62.,33.},{7103.53,117.,33.},{7133.61,193.,33.},{7164.37,147.,33.},{7185.31,119.,33.},{7211.18,132.,33.},{7244.19,101.,33.},{7267.13,164.,33.},{7292.06,188.,33.},{7324.94,94.,33.},{7339.89,186.,33.},{7369.88,93.,33.},{7398.69,100.,33.},{7427.77,124.,33.},{7451.70,92.,33.},{7473.64,61.,33.},{7494.61,135.,33.},{7520.46,120.,33.}};

Details concerning data manipulation and statistics.

tarr1=Transpose[dat1];

tvec1=N[tarr1[[1]]];

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

errvec1=N[tarr1[[3]]];

Average data interval

Last[tvec1-tvec1[[1]]]/(Length[tvec1]-1)

Translate tvec1 and dvec1 values by subtracting off Mean[tvec1] & Mean[dvec1], respectively.

mntvec1=Mean[tvec1];

dat=Transpose[{tvec1-mntvec1,dvec1,errvec1}];

nd=lendat=Length[dat]

tarr=Transpose[dat];

tvec=N[tarr[[1]]]

tstart=tvec[[1]];tend=tvec[[nd]];

dur=(tend-tstart)

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

errvec=N[tarr[[3]]]

Mean[errvec]

datasigma=StandardDeviation[dvec]

data=Transpose[{tvec,dvec}];

Plot the data

tvecAve=Mean[tvec1]

tvecAve-IntegerPart[tvecAve]

tvecRef=2451000.+tvecAve

IntegerPart[tvecRef]

cmp1=IntegerPart[tvecRef/(10^6)];
cmp2=IntegerPart[(tvecRef-cmp1*(10^6))/(10^5)];cmp3=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5))/(10^4)];cmp4=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4))/(10^3)];cmp5=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3))/(10^2)];cmp6=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2))/10];cmp7=IntegerPart[(tvecRef-cmp1*(10^6)-cmp2*(10^5)-cmp3*(10^4)-cmp4*(10^3)-cmp5*(10^2)-cmp6*10)];
cmp8=IntegerPart[10*(tvecRef-IntegerPart[tvecRef])];cmp9=IntegerPart[100*(tvecRef-IntegerPart[tvecRef])-cmp8*10];cmp10=IntegerPart[1000*(tvecRef-IntegerPart[tvecRef])-cmp8*100-cmp9*10];cmp11=IntegerPart[10000*(tvecRef-IntegerPart[tvecRef])-cmp8*1000-cmp9*100-cmp10*10];timelabel=ToString[cmp1]<>","<>ToString[cmp2]<>ToString[cmp3]<>ToString[cmp4]<>","<>ToString[cmp5]<>ToString[cmp6]<>ToString[cmp7]<>"."<>ToString[cmp8]<>ToString[cmp9]<>ToString[cmp10]<>ToString[cmp11]

dataerr=Table[{data[[i]],ErrorBar[errvec[[i]]]},{i,nd}];
plshp1=ErrorListPlot[dataerr,Frame->True,PlotRange->All,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Julian day number  (-"<>timelabel<>")",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp1a=Show[plshp1,Graphics[{Text["(a)",{0,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

Parallel tempering MCMC program itself:

INITIALIZE PROGRAM VALUES

npara=10; (* number of iterations in one parallel step *)

nthin=npara; (* store MCMC iterations at a thinning interval of nthin *)

n=1000*nthin; (* number of MCMC iterations *)

By default number of iterations n is set = 1000*(npara = 10) and nβ = 1 so that it will execute quickly. 
For reasonable results need to change n >= 2000*(npara = 10).

minCS=2000; (* minimum iterations before 1st stage Control System (CS) turned off *)

maxCS=4000; (* maximum iterations before 1st stage CS turned off *)

deltaN=5000; (*iteration interval for CS to decide whether to rerun 2nd stage CS *)

loglikeoffset=400.0; (* offset to keep results within machine precision range *)

nβ=1;(* the number of choices of tempering parameter *)

(*ratioT=1.77;*) (* ratio of temperature values for different chains (temperature ∝ 1/β *)

(*βlis=Reverse[Table[(ratioT^(-(k-1))),{k,1,nβ}]];*)

βlis={1.0};(* tempering parameter values, in this example only one *)

To look for multiple periods nβ typical set >= 4   chains, each with a different 
 temperature parameter β specified by βlis.

(*βlis={0.00004,0.0005,0.001,0.002,0.005,0.01,0.02,0.032,0.08,0.11,0.17,0.25,0.3,0.35,0.4,0.45,0.51,0.57,0.63,0.69,0.75,0.82,0.90,1.0};*) 
(* useful set of tempering parameter values for Bayes factor calculation which requires many *)

n2β=nβ; (* 2nd stage CS operates only on σall for top n2β chains (don't change this) *)

ns=1*npara; (* ns is number of iterations between swap proposals *)

np=3; (* np is the number of model parameters computational explored s,m,ϕ *)

ngs=2; (* # Gaussian proposal distributions,ngs=3 for P,s,m *)

ncs=2; (* ncs = number of model parameters used in 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) *)

swg=0; (* swg=1 if gene swap included, swg = 0 otherwise *)

smp=1;(* smp=0 or 1, smp=1 better multiple peak detection, reduced acceptance rate*)

STARTING PARAMETER VALUES

avst=Table[0,{ncs}]; (* initialize table of start parameter values *)
avmin=Table[0,{ncs}];(* initialize table of parameter search lower bounds *)
avMax=Table[0,{ncs}];(* initialize table of parameter search upper bounds *)
bfmin=Table[0,{ncs}];(* parameter lower bounds for Bayes factor calulation*)
bfMax=Table[0,{ncs}];(* parameter upper bounds for Bayes factor calulation*)

avst[[1]]=1.0; (* extra noise parameter start value *)

a1name= "s"; a1unit="  (mJy)";(* name of extra noise parameter and units *)

avst[[2]]=5.0; (* parameter 3 start value *)

a2name= "m"; a2unit=" "; (* name of parameter 3 and units *)

PRIOR SEARCH RANGES

avmin[[1]]=0.0;avMax[[1]]= 100.0;(* search bounds on extra noise term s *)

avmin[[2]]=2;avMax[[2]]=12;(* limits on number of model bins, m *)

mmin=avmin[[2]];mMax=avMax[[2]];(* limits on number of model bins, m *)

rmin=-20.0;rmax= 400.0;(* lower and upper bounds on mean signal + bkgd *)

type={0,-2}; (* If type = -1, parameter is a period, reflect at boundaries *)
(* type = -2, Round to nearest integer *)
(* type = 1, angular parameter, wrap around at 0 and 1 *)
(* type = 2, angular parameter, wrap around at 0 and 2π *)
(* type = 0, all other parameters, reflect at boundaries *)

PRIOR RANGE FOR BAYES FACTOR CALCULATION

bfmin[[1]]=0.0;bfMax[[1]]= 100.;(* prior bounds on extra noise term s *)

bfmin[[2]]=2;bfMax[[2]]= 12;(* limits on number of bins, m *)

rmin=-20.0;rmax= 400.0;(* lower and upper bounds on mean signal + bkgd *)

STARTING PROPOSAL 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  *)

(* Note: parameter m has an integer values, pick new ones from random walk *)

σst[[1]]=10.0; (* sigma for noise scale parameter *)

σst[[2]]=2.0; (* sigma for m parameter *)

minσ[[1]]=Mean[errvec]/(Sqrt[nd]);

minσ[[2]]=0.6; (* empirically determined *)

GENE BOUNDARIES

ngene=1;

genst=Table[0,{ngene}]; (* initialize table of gene start boundaries *)

genend=Table[0,{ngene}]; (* initialize table of gene end boundaries *)

genst[[1]]= 1; (* start of gene 1 *)

genend[[1]]= np; (* end of gene 1 *)

CONTROL SYSTEM PARAMETERS  (user don't change this)

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.4; (* 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=If[ nβ>1,Table[0.7-(nβ-i)*0.1/(nβ-1),{i,1,nβ}],0.7](* 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=1.2 (* Empirical factor for scaling exponent, typical value for n>10 is 0.9 *)

accept=Table[((((((λ))^(1/(ncs^(kalf*alfm))))))^((βlis[[kn]])^(-0.06))),{kn,1,nβ},{kj,1,ncs}](* Calulation of accept rate for individual parameters in 2nd stage CS *)

accept[[1,1]]

NORMALIZATION FACTORS FOR MODEL PARAMETER PRIORS (user don't change this)

mJlim=1.0;(* constant for modified Jeffreys prior for P parameter*)
mJs=10.0;(* constant for modified Jeffreys prior for s *)

c=-Log[2*π*(bfMax[[2]]-bfmin[[2]])*Log[((mJs+bfMax[[1]])/mJs)]];

DEFINE STEPS TO COMPUTE LIKELIHOOD FOR CURRENT MODEL (user don't change this)

Specify a procedure for calculation of basic work = prior×likelihood for model. 
Uses the format ({{Module[{a, b, … }, proc] , a procedure with local variables a, b, …  }})

Now compute the likelihood and quantities needed in computing the lightcurve shape later on.

Version below includes extra noise parameter s.

workP:=Module[{s,m},s=avs[[1]];m=Round[avs[[2]]];binph=m*Mod[tvec/dur,1.0];
phidis=1-FractionalPart[binph];wtvec=1/((errvec^2)+(s^2));logprodsqrtwtvec=Log[Times@@(Sqrt[wtvec])];
jvec=IntegerPart[1+binph];sortnjvec=Sort[Transpose[{phidis,jvec,wtvec,wtvec*dvec,wtvec*(dvec^2)}]];
tsort=Transpose[sortnjvec];sphidis=tsort[[1]];shiftsphidis=Take[Join[{0.0},sphidis],nd];
incphi=sphidis-shiftsphidis;cph=0.5*(sphidis+shiftsphidis);
jincphvec=Transpose[{tsort[[2]],tsort[[3]],tsort[[4]],tsort[[5]]}];trjsel=Table[0,{iw,1,nd},{jm,1,m}];Do[selj=Select[jincphvec,#[[1]]==jm &];nj=Length[selj];If[nj≥1,trsel=Transpose[selj];Wj=Total[trsel[[2]]];dWj=Total[trsel[[3]]];sqdWj=Total[trsel[[4]]];If[nj≥2,wj=1,wj=0];item={jm,nj,dWj,sqdWj,Wj,wj},item={jm,0,0.0,0.0,0.0,0}
];trjsel[[1,jm]]=item,{jm,1,m}];Do[trjsel[[iw]]=trjsel[[iw-1]];njiw=tsort[[2,iw-1]];If[njiw<m,njiw2=njiw+1,njiw2=1];Wjd=tsort[[3,iw-1]];
ddWj=tsort[[4,iw-1]];
dsqdWj=tsort[[5,iw-1]];item1={0,1,ddWj,dsqdWj,Wjd,0};vec1=trjsel[[iw,njiw]]-item1;If[vec1[[2]]>1,vec1[[6]]=1;trjsel[[iw,njiw]]=vec1,vec1[[6]]=0;trjsel[[iw,njiw]]=vec1];trjsel[[iw,njiw]]=trjsel[[iw,njiw]]/.x_Real/;Abs[x]<(10^(-10))->0.0;vec2=trjsel[[iw,njiw2]]+item1;If[vec2[[2]]>1,vec2[[6]]=1;trjsel[[iw,njiw2]]=vec2,vec2[[6]]=0;trjsel[[iw,njiw2]]=vec2],{iw,2,nd}];
       valsh=Table[tt=Transpose[trjsel[[iw]]];corWj=tt[[5]]/.x_/;x==0.0->1.0;
colWj=corWj;colmeandWj=tt[[3]]/corWj;colmeansqdWj=tt[[4]]/corWj;colchi2j=colWj*(colmeansqdWj-(((colmeandWj))^2));colwj=tt[[6]];sumchi2j=m*(Total[colwj*colchi2j])/Total[colwj];
complerrfnterm=Times@@((colWj^(-1/2))*2); 
loglikeA=-0.5*sumchi2j+Log[complerrfnterm]; 
{loglikeA,colmeandWj,colWj,colwj},{iw,nd}];
valsht=Transpose[valsh];maxloglikeA=Max[valsht[[1]]];adjlikeA=Exp[valsht[[1]]-maxloglikeA];
valnd=Table[adjlikeAinciw=adjlikeA[[iw]]*incphi[[iw]];{adjlikeAinciw,adjlikeAinciw*valsht[[2,iw]],adjlikeAinciw*valsht[[3,iw]],adjlikeAinciw*valsht[[4,iw]],adjlikeAinciw*cph[[iw]]},{iw,nd}];
tvalnd=Total[valnd];
     ff=1/tvalnd[[1]];
     logprior=Log[(1/((s+mJs)))]+c;logdterm=Log[m*tvalnd[[1]]]+maxloglikeA;
     loglike=loglikeoffset-m*Log[rmax-rmin]+logfact+logprodsqrtwtvec+(m/2)*Log[(π/2)]+logdterm;ϕ=ff*tvalnd[[5]];ffwj=Round[ff*tvalnd[[4]]];
pvec={s,m,ϕ};
    pvecA={ff*tvalnd[[2]],ff*tvalnd[[3]],ffwj}]

MODULE THAT PROPOSES THE NEW PARAMETER SET (user don't change this)

Propose new parameter values uses Switch and type[[ii]]to handle different par. types. 
Update P = av[[1]] via frequency calculation.
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]]],
-2,
avm2=Round[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]]];av[[ii]]=avm2;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm2<avmint,av[[ii]]=Mod[2*avmint-avm2,(avMaxt-avmint),avmint],avm2>avMaxt,av[[ii]]=Mod[2*avMaxt-avm2,(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]]]],4π],
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]]*(((avmin[[1]]/av[[1]]))^(1/3))*(((1-((av[[2]])^2)))^(-0.5));
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]]*(((avmin[[7]]/av[[7]]))^(1/3))*(((1-((av[[8]])^2)))^(-0.5));
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]]*(((avmin[[12]]/av[[12]]))^(1/3))*(((1-((av[[13]])^2)))^(-0.5));
Which[av7<avmint,av[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,av[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]],
8,
av8=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av8;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[17]]/av[[17]]))^(1/3))*(((1-((av[[18]])^2)))^(-0.5));
Which[av8<avmint,av[[ii]]=Mod[2*avmint-av8,(avMaxt-avmint),avmint],av8>avMaxt,av[[ii]]=Mod[2*avMaxt-av8,(avMaxt-avmint),avmint]],
9,
av9=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av9;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[22]]/av[[22]]))^(1/3))*(((1-((av[[23]])^2)))^(-0.5));
Which[av9<avmint,av[[ii]]=Mod[2*avmint-av9,(avMaxt-avmint),avmint],av9>avMaxt,av[[ii]]=Mod[2*avMaxt-av9,(avMaxt-avmint),avmint]],
10,
av10=RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]];av[[ii]]=av10;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[27]]/av[[27]]))^(1/3))*(((1-((av[[28]])^2)))^(-0.5));
Which[av10<avmint,av[[ii]]=Mod[2*avmint-av10,(avMaxt-avmint),avmint],av9>avMaxt,av[[ii]]=Mod[2*avMaxt-av10,(avMaxt-avmint),avmint]]
];
]

Parallel version that proposes a change to all of the avs parameter values by embedding this in a Table command.

proposeP:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,avs[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,avs[[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*σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
-2,
avm2=Round[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]]];avs[[ii]]=avm2;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm2<avmint,avs[[ii]]=Mod[2*avmint-avm2,(avMaxt-avmint),avmint],avm2>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm2,(avMaxt-avmint),avmint]],
1,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],1],
2,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
3,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
4,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[1]]/avs[[1]]))^(1/3))*(((1-((avs[[2]])^2)))^(-0.5));
Which[av5<avmint,avs[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,avs[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[7]]/avs[[7]]))^(1/3))*(((1-((avs[[8]])^2)))^(-0.5));
Which[av6<avmint,avs[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,avs[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[12]]/avs[[12]]))^(1/3))*(((1-((avs[[13]])^2)))^(-0.5));
Which[av7<avmint,avs[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,avs[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]],
8,
av8=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av8;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[17]]/avs[[17]]))^(1/3))*(((1-((avs[[18]])^2)))^(-0.5));
Which[av8<avmint,avs[[ii]]=Mod[2*avmint-av8,(avMaxt-avmint),avmint],av8>avMaxt,avs[[ii]]=Mod[2*avMaxt-av8,(avMaxt-avmint),avmint]],
9,
av9=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av9;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[22]]/avs[[22]]))^(1/3))*(((1-((avs[[23]])^2)))^(-0.5));
Which[av9<avmint,avs[[ii]]=Mod[2*avmint-av9,(avMaxt-avmint),avmint],av9>avMaxt,avs[[ii]]=Mod[2*avMaxt-av9,(avMaxt-avmint),avmint]],
10,
av10=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av10;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[27]]/avs[[27]]))^(1/3))*(((1-((avs[[28]])^2)))^(-0.5));
Which[av10<avmint,avs[[ii]]=Mod[2*avmint-av10,(avMaxt-avmint),avmint],av10>avMaxt,avs[[ii]]=Mod[2*avMaxt-av10,(avMaxt-avmint),avmint]]
];avs[[ii]]
]

Parallel version that proposes a change to one of the avs parameter values.

proposeP1:=Module[{avmint,avMaxt},
Switch[type[[ii]],
0,
av0=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av0;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[av0<avmint,avs[[ii]]=Mod[2*avmint-av0,(avMaxt-avmint),avmint],av0>avMaxt,avs[[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*σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]],avm1=1.0/RandomReal[NormalDistribution[1.0/values[[ii]],σalln[[ii]]]];avs[[ii]]=avm1;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm1<avmint,avs[[ii]]=Mod[2*avmint-avm1,(avMaxt-avmint),avmint],avm1>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm1,(avMaxt-avmint),avmint]]],
-2,
avm2=Round[RandomReal[NormalDistribution[values[[ii]],σall[[k,ii]]]]];avs[[ii]]=avm2;avmint=avmin[[ii]];avMaxt=avMax[[ii]];Which[avm2<avmint,avs[[ii]]=Mod[2*avmint-avm2,(avMaxt-avmint),avmint],avm2>avMaxt,avs[[ii]]=Mod[2*avMaxt-avm2,(avMaxt-avmint),avmint]],
1,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],1],
2,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
3,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π],
4,
avs[[ii]]=Mod[RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]],4π,-(2π)],
5,
av5=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av5;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[1]]/avs[[1]]))^(1/3))*(((1-((avs[[2]])^2)))^(-0.5));
Which[av5<avmint,avs[[ii]]=Mod[2*avmint-av5,(avMaxt-avmint),avmint],av5>avMaxt,avs[[ii]]=Mod[2*avMaxt-av5,(avMaxt-avmint),avmint]],
6,
av6=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av6;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[7]]/avs[[7]]))^(1/3))*(((1-((avs[[8]])^2)))^(-0.5));
Which[av6<avmint,avs[[ii]]=Mod[2*avmint-av6,(avMaxt-avmint),avmint],av6>avMaxt,avs[[ii]]=Mod[2*avMaxt-av6,(avMaxt-avmint),avmint]],
7,
av7=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av7;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[12]]/avs[[12]]))^(1/3))*(((1-((avs[[13]])^2)))^(-0.5));
Which[av7<avmint,avs[[ii]]=Mod[2*avmint-av7,(avMaxt-avmint),avmint],av7>avMaxt,avs[[ii]]=Mod[2*avMaxt-av7,(avMaxt-avmint),avmint]],
8,
av8=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av8;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[17]]/avs[[17]]))^(1/3))*(((1-((avs[[18]])^2)))^(-0.5));
Which[av8<avmint,avs[[ii]]=Mod[2*avmint-av8,(avMaxt-avmint),avmint],av8>avMaxt,avs[[ii]]=Mod[2*avMaxt-av8,(avMaxt-avmint),avmint]],
9,
av9=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av9;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[22]]/avs[[22]]))^(1/3))*(((1-((avs[[23]])^2)))^(-0.5));
Which[av9<avmint,avs[[ii]]=Mod[2*avmint-av9,(avMaxt-avmint),avmint],av9>avMaxt,avs[[ii]]=Mod[2*avMaxt-av9,(avMaxt-avmint),avmint]],
10,
av10=RandomReal[NormalDistribution[values[[ii]],σalln[[ii]]]];avs[[ii]]=av10;avmint=avmin[[ii]];avMaxt=avMax[[ii]]*(((avmin[[27]]/avs[[27]]))^(1/3))*(((1-((avs[[28]])^2)))^(-0.5));
Which[av10<avmint,avs[[ii]]=Mod[2*avmint-av10,(avMaxt-avmint),avmint],av10>avMaxt,avs[[ii]]=Mod[2*avMaxt-av10,(avMaxt-avmint),avmint]]
];avs
]

MODULE THAT ACCEPTS THE NEW PARAMETER SET & store frequency changes (user don't change this)

acceptP:=Module[{pdfβi,pdfβiA},
pdfβi=logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA=logprior+loglike;
testr1=pdfβi-logpdftempk[[nl]];
If[testr1>-uflow,If[testr1<uflow,r1=Exp[testr1],r1=1.0],r1=-1.0];  (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,If[i>n0,nc2k=nc2k+1;If[nc4<1,nak=nak+1]];
pdfβiB1=Join[{β},pvec,{i},{loglike},{pdfβi},pvecA];
If[pdfβi>maxlogpdfβik[[nl]],maxlogpdfβik=pdfβiB1];If[pdfβiA>maxlogpdfAlla[[nl]],maxlogpdfAlla=Join[{β},pvec,{i},{loglike},{pdfβiA}]];
pdfβiB={{pdfβiA},{loglike},pdfβiB1,{nc2k},{nak},maxlogpdfβik,maxlogpdfAlla}
,pdfβiC=logpdftempk;pdfβiC[[n2l-1]]=i;
pdfβiB={{pdfβiA},{loglike},pdfβiC,{nc2k},{nak},maxlogpdfβik,maxlogpdfAlla}
];pdfβiB
]

For use in second stage Control System use acceptP1.

acceptP1:=Module[{pdfβi,pdfβiA},
pdfβi=logprior+β*loglike; (* factor needed to decide on tempering swap *)
pdfβiA=logprior+loglike;
testr1=pdfβi-logpdftempk[[nl]];
If[testr1>-uflow,If[testr1<uflow,r1=Exp[testr1],r1=1.0],r1=-1.0]; (* compute acceptance rule r1*)
u1=RandomReal[]; (* if uniform random ≤ r1 then accept proposal *)
If[u1≤r1,nc2k=nc2k+1;
pdfβiB1=Join[{β},pvec,{i},{loglike},{pdfβi},pvecA];
If[pdfβi>maxlogpdfβik[[nl]],maxlogpdfβik=pdfβiB1];If[pdfβiA>maxlogpdfAlla[[nl]],maxlogpdfAlla=Join[{β},pvec,{i},{loglike},{pdfβiA}]];
pdfβiB={{pdfβiA},{loglike},pdfβiB1,{nc2k},maxlogpdfβik,maxlogpdfAlla}
,pdfβiC=logpdftempk;pdfβiC[[n2l-1]]=i;
pdfβiB={{pdfβiA},{loglike},pdfβiC,{nc2k},maxlogpdfβik,maxlogpdfAlla}
];pdfβiB
]

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 *) 
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 *)
uflow=Log[$MaxNumber/10.0];(* set number to avoid underflow messages *) 
na=Table[0,{nβ}];  (* initialize acceptance array *)
nacor=Table[0,{nβ}];  (* initialize acceptance array for correlated move sampler *)
nb=Table[0,{k,1,nβ},{ncs}];  (* initialize array to store #accepted proposals in minor cycle *)(* for each parameter proposal σ *)
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}]; 
σall1=Table[0,{ncs}];  
Do[σall1[[i]]=σst[[i]],{i,1,ncs}];(*initialize σall1 array*)
σall=Table[σst[[i]],{k,1,nβ},{i,1,ncs}];  
(* initialize σall array *)
σallold={};(* record previous best σall *)
pdfβiAmax2old={};(* record previous best logprior+loglike 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 *)
cs2cnt=1;(* initialize second stage CS counter *)
cs2cnt2=0;(* initialize counter to track how often 2nd stage CS is repeated a second time in a row *)
(*nacatot=Table[0,{nβ}];*)(* initialize counter of parameter sets added to movarray[[nβ]] *)
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)*Log[2*π] ;
(*logfactA=-(nast/2)*Log[2*π];*)
kvals=Table[i,{i,1,nβ}];
(* Evaluate the probability for the i=0 sample for each tempering level*)
Do[(* iteration over β *) β=βlis[[k]];avs=avst;
 (* initiate parameter values *)
(* ******************** Basic working *********************** *)
workP;
(* ********************************************************* *)
pdf1= loglike;
pdfβ1= logprior+β*loglike; (* factor needed to decide on tempering swap *)
logpdf[[1,k]]=Join[{β},pvec,{0,pdf1,pdfβ1},pvecA],{k,1,nβ} 
];  (* close first Do loop iterating over β *)
maxlogpdfβi=logpdf[[1]];
maxlogpdfAll=Take[logpdf[[1,nβ]],nl];(* initialize this array in each processor (chain) *)
Do[ (* start calculation for ith iteration beginning at i = 1 *)
If[i>n0,nc1=nc1+npara];If[nc1<npara+1&&i>n0,logpdftemp=logpdfinow,logpdftemp=logpdf[[1]]];
iV=i+1-npara;sw6=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw6k=sw6[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[
If[sw6k<1,i=iV;logpdftempk=logpdftemp[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=nc2[[k]];nak=na[[k]];sw6k=sw6k+1,
i=i+1;logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values
];
Do[proposeP,{ii,1,ncs}];workP;acceptP,
{isub,1,npara}
];pdfβiB,
{k,1,nβ} 
];
tworkvals=Transpose[workvals];logpdf[[2]]=tworkvals[[3]];nc2=Flatten[Transpose[tworkvals[[4]]]];na=Flatten[Transpose[tworkvals[[5]]]];maxlogpdfβi=tworkvals[[6]];lastworkvals=tworkvals[[7]];
acceptvec=Sort[workvals,OrderedQ[{#2,#1}]&];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax=kbestvec[[nl]];
If[pdfβiAmax>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
(* Consider a swap between 2 tempering levels if i an integer multiple of ns *)
If[nc4>0,Goto[anneal]];
If[nβ<2,Goto[genecrossover]];
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,nl+3}];
logpdf[[2,k1,n2l]]=loglike2;logpdf[[2,k1,nl]]=p21;
Do[logpdf[[2,k2,ji]]=temp[[ji]],{ji,2,nl+3}];
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 *)
(* Gene swap/crossover between top chain(s) and values in maxlogpdfAll *)
Label[genecrossover];
If[swg>0&&IntegerQ[i/(2*nthin)],
If[nβ<2,
If[ngene<2,
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[βnow=topvalues[[3,1]];
nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avtop[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avtop[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
{kg,1,ngene} 
],(* end of ngene=1 & nβ=1 option *)
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
avs=avcurmax;βnow=topvalues[[3,1]];
Do[avs[[ii]]=avtop[[ii]],{ii,genst[[kg]],genend[[kg]]}];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
{kg,1,ngene} 
]
],(* end of ngene>1 & nβ=1 option *)
If[ngene<2,
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,ncs+1}];secvalues=acceptvec[[2]];avsec=Take[secvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
Which[kg≤ngene,βnow=topvalues[[3,1]];nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avtop[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avtop[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
kg≤2*ngene,βnow=secvalues[[3,1]];nbreak=RandomInteger[{genst[[1]]+1,genend[[1]]-1}];
If[RandomReal[]<0.5,
Do[avs[[ii]]=avcurmax[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avsec[[ii]],{ii,nbreak+1,ncs}],
Do[avs[[ii]]=avsec[[ii]],{ii,1,nbreak}];
Do[avs[[ii]]=avcurmax[[ii]],{ii,nbreak+1,ncs}]
];
workP;pdfβiA=logprior+loglike;
pdfβiB={{pdfβiA},Join[{2+βnow},pvec,{i},{loglike},{pdfβiA}]}
],
{kg,1,2*ngene} 
],(* end of ngene=1 & nβ>1 option *)
topvalues=acceptvec[[1]];avtop=Take[topvalues[[3]],{2,np+1}];secvalues=acceptvec[[2]];avsec=Take[secvalues[[3]],{2,ncs+1}];avcurmax=Take[maxlogpdfAll,{2,ncs+1}];
workvals=
Table[
If[kg≤ngene,avs=avcurmax;βnow=topvalues[[3,1]];
Do[avs[[ii]]=avtop[[ii]],{ii,genst[[kg]],genend[[kg]]}];
workP;pdfβiA=logprior+loglike; 
pdfβiB={{pdfβiA},Join[{1+βnow},pvec,{i},{loglike},{pdfβiA}]},
avs=avcurmax;βnow=secvalues[[3,1]];kgg=kg-ngene;
Do[avs[[ii]]=avsec[[ii]],{ii,genst[[kgg]],genend[[kgg]]}];
workP;pdfβiA=logprior+loglike;
pdfβiB={{pdfβiA},Join[{2+βnow},pvec,{i},{loglike},{pdfβiA}]}
],
{kg,1,2*ngene} 
]
]
];
acceptvec1=Sort[workvals,OrderedQ[{#2,#1}]&];
kbestvec=acceptvec1[[1]];pdfβiAmax=kbestvec[[1,1]];If[pdfβiAmax>Last[maxlogpdfAll],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];
maxlogpdfAll=kbestvec[[2]]];
];(* end of gene swap/crossover If statement *)
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[σallprop=scminus[[k]]*σall[[k,nc5[[ik]]]];   If[σallprop>avMax[[ik]],σall[[k,nc5[[ik]]]]=avMax[[ik]],σall[[k,nc5[[ik]]]]=σallprop]; 
              If[k==nβ&&(nbmax[[k]]-nc5)>0,swminσ[[ik]]=0,],{ik,1,lnc5}],
           Do[σallprop=σall[[k,ik]]*scminus[[k]];If[σallprop>avMax[[ik]],σall[[k,ik]]=avMax[[ik]],σ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;If[i<maxCS,sw4=1]];
σ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[maxlogpdfAll,{2,ncs+1}];
Do[(* iteration over β *) β=βlis[[k]];avs=bestvec;
 (* initiate parameter values *)
(* ******************** Basic working ********************** *)
workP;
(* ********************************************************* *)
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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
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]]>Abs[avMax[[ip2]]],σall[[k,ip2]]=Abs[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]]],
8,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
9,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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
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]]>Abs[avMax[[ip2]]],σall[[k,ip2]]=Abs[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]]],
8,If[σall[[k,ip2]]>avMax[[ip2]],σall[[k,ip2]]=avMax[[ip2]]],
9,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 *)
n2c2=Table[0,{nβ}];(* # of para. prop. acceptances in each subcycle *)
iiV=ip2;sw7=Table[0,{nβ}];
workvals=Table[β=βlis[[k]];sw7k=sw7[[k]];maxlogpdfAlla=maxlogpdfAll;
Do[If[sw7k<1,ii=iiV;logpdftempk=logpdfinow2[[k]];values=Take[logpdftempk,{2,ncs+1}];avs=values;σalln=σall[[k]];maxlogpdfβik=maxlogpdfβi[[k]];nc2k=n2c2[[k]];sw7k=sw7k+1,
logpdftempk=pdfβiB[[3]];values=Take[logpdftempk,{2,ncs+1}];avs=values];
proposeP1;workP;acceptP1,
{n1}
];pdfβiB,
{k,nβlow,nβ} 
];
tworkvals=Transpose[workvals];n2c2=Flatten[Transpose[tworkvals[[4]]]];maxlogpdfβi=tworkvals[[5]];lastworkvals=tworkvals[[6]];
kbestvec=Sort[lastworkvals,#2[[nl]]<#1[[nl]]&][[1]];
pdfβiAmax2=kbestvec[[nl]];
If[pdfβiAmax2>maxlogpdfAll[[nl]],maxlogpdfAllold=Append[maxlogpdfAllold,maxlogpdfAll];maxlogpdfAll=kbestvec];
Do[accept3[[k,ip2]]=n2c2[[k]],{k,1,nβ}]
,{ip2,1,ncs}
];(* complete parameter Do loop *)
If[Min[N[accept3[[nβ]]/n1]]<0.2||Max[N[accept3[[nβ]]/n1]]>0.9,nagain=1,nagain=0];
If[cs2cnt<2&&nagain>0,sw4=1;cs2cnt=cs2cnt+1;cs2cnt2=cs2cnt2+1,sw4=0;cs2cnt=1]
]; (* complete If statement *)
If[i>ncsys&&IntegerQ[(i-ncsys)/deltaN]&&(maxlogpdfAll[[nl]]-pdfβiAmax2)>3.0,sw4=1;ncsysold=Append[ncsysold,ncsys];σallold=Append[σallold,σall];pdfβiAmax2old=Append[pdfβiAmax2old,pdfβiAmax2];na=Table[0,{nβ}];ncsys=i,
];(* complete If statement *)
,{i,npara,n,npara} (* 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).

ncsys

Best parameter vector found.

bestvecFound=Take[maxlogpdfAll,{2,np+1}]

MemoryInUse[]

To output the whole MCMC data set. (usually not done for storage space reasons)

(*ng=Length[logpdfβi];stmp=OpenWrite["c:/Users/Philip/Documents/greg8/55Cancri/APT5planGenC55cancri.dat",PageWidth->Infinity];
Do[Write[stmp,logpdfβi[[i]]],{i,1,ng}];Close[stmp]*)

To output only the β = 1 tempering level results. Need to remove (*  *) for these commands to execute.

(*tr=Transpose[logpdfβi];tr5=tr[[nβ]];ng=Length[tr5];stmp=OpenWrite["c:/greg7/glMCMC/GausGLnonPeriodicM7.dat",PageWidth->Infinity];
Do[Write[stmp,tr5[[i]]],{i,1,ng}];Close[stmp]*)

Here is how to input results. Need to remove (*  *) for these commands to execute.

(*dataMC=ReadList["c:/greg7/glMCMC/M6APTglShp.dat"];nnt=Length[dataMC];
n=nthin*nnt;ng=nnt *)

The subsequent analysis steps assume the data for all chains are stored in an array called logpdfβi, generated when the above program steps are run. This array contains results from all the parallel MCC chains. What happens when we want to re-analyse the MCMC samples? In general we only store the samples from the top chain to minimize storage space. The next line populates the data for all chains with the values read back in for the top chain. This trick enables the subsequent analysis programs to execute properly without any changes to the input formats. Since the subsequent analysis (except for last item dealing with the Bayes factor calculation) only computes on the top chain it doesn't matter what we have in the other chains.

(*logpdfβi=Transpose[Table[dataMC,{k,1,nβ}]];*)

Analysis of evolution of control system error & 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 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 the code designer.

swminσ

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["P",FontWeight->"Bold",FontSlant->Italic]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

tmklabel=
StyleForm[StringForm["``  (d)",
StyleForm["P",FontSlant->"Italic"]],
FontFamily->Times,FontWeight->"Bold",FontSize->13]

slabel=
StyleForm[StringForm["``  (m (s^(-1)))",
StyleForm["s",FontSlant->"Italic"]],
FontFamily->Times,FontWeight->Bold,FontSize->13]

Extracting parameter samples for the β = 1 (k = nβ) MCMC chain

All the results are stored by the variable logpdfβi.
First let's look at an example of the first row of the output given by logpdfβi[[1]].
{{0.7`,959.9570426550547`,8.410472623513195`,8,0.184423242856966`,10,-359.62532691196645`,-253.1455838368756`,{156.89277789375976`,170.56510914858458`,212.06113676644097`,155.5687786722197`,172.05437469063716`,263.34566311302075`,258.14650838999955`,65.00000147130324`},{0.004798399215619782`,0.008268349917487159`,0.008175878554497472`,0.00810576171560245`,0.00991916701353707`,0.003809601030024318`,0.002065348350492186`,0.0017245290682693423`},{1,1,1,1,1,1,1,1}},{1.`,915.483426027098`,49.521858039985666`,8,0.8344017176514003`,10,-332.9801915080576`,-335.9621806242566`,{129.06270535700554`,211.6799395240604`,153.22840275420063`,188.3271444616131`,185.46990009010187`,169.0932214984301`,238.63740694566013`,148.2293410557676`},{0.0005960212853256656`,0.0016856185266010406`,0.0028603385052064904`,0.0027413014669901013`,0.0027571737729362457`,0.002828341849558241`,0.0015247096953809956`,0.0005786509307537253`},{1,1,1,1,1,1,1,1}}}
There are 2 lists one for each of the 2 parallel MCMC chains.
The first list contains the result for β = 0.01 and the last list 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 last 2 lists with the command Take[tr,-5].
{{1.`,1601.2647748555332`,27.96272168752309`,6,0.11614611831917314`,19990,-300.57441153031`,-302.4688583545684`,{187.0901230354528`,257.87722679996403`,266.64682315098946`,186.29519219451439`,130.7404519851376`,106.09893880637397`},{0.004818152199780243`,0.005105963105584811`,0.004584912790835392`,0.001864254972704946`,0.0064362393413150915`,0.0064329812603021765`},{1,1,1,1,1,1}},
{1.`,1623.6240446019028`,11.22046901066641`,6,0.1133348300401571`,20000,-301.0338046237546`,-302.13628298560104`,{186.95461941035077`,260.04777171906886`,266.4085052025349`,190.5427767088951`,125.5429661791475`,106.01884433765404`},{0.007445110430441424`,0.007955126622175377`,0.00676801242071224`,0.0032959775130001986`,0.00997081154614048`,0.009332455694764165`},{1,1,1,1,1,1}}}
Item (1) in each list is the value of β, 
Items (2-5) are the current values of the parameters P,s,m,ϕ.
Item (6) is the iteration number.
Item (7) is the Log of the likelihood, used in computing the global likelihood of the model for the 
    Bayes factor calculation.
Item (9) is the value of   prior*(((like))^β) for the particular set of parameter values.
Item (9) is a list of m values of colmeandWj = (OverBar[(Subscript[d, Wj])]), one for each bin, for signal shape calculation.
Item (10) is a list of m values of colWj = (Subscript[W, j]) , one for each bin, for signal shape calculation.
Item (11) is a list of m values of colwj = (Subscript[w, j]), one for each bin, for signal shape calculation.

Extract parameter iterations for the k = nβ member of the tempering levels. 
To obtain columns of each quantity use trn = Transpose[tr].

k=nβ;tr=Transpose[logpdfβi][[k]];trn=Transpose[tr];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=5;(* with niter = 100, plot only every 100th point *)

nburn1=100;(* skip first nburn1 iterations for 2nd (upper right) plot *)

pl=Table[0,{i,ncs+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

xiterticks={500,1000,1500,2000};

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==27,pl[[i+2]]=ListLogPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}],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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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,ncs}
];

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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}];

plIter=Show[GraphicsGrid[If[EvenQ[ncs+2],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,ncs+2,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(ncs+2)/2]*2,2}],{{pl[[IntegerPart[(ncs+2)/2]*2+1]]}}]],Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Set the burn-in value nburn.

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 *)

Examine post burn-in parameter iterations for the β = 1   MCMC chain.

k=nβ;tr=Take[Transpose[logpdfβi][[k]],{nburn,nnt}];trn=Transpose[tr];ng=Length[trn[[1]]]

Sart by choosing some display parameters.

niter=1;(* with niter = 100, plot only every 100th point *)

nburn1=100;(* skip first nburn1 iterations for 2nd (upper right) plot *)

pl=Table[0,{i,ncs+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

xiterticks={500,1000,1500,2000};

Do[ label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];If[i==27,pl[[i+1]]=ListLogPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}],pl[[i+1]]=ListPlot[Take[Transpose[{fn,trn[[i+1]]}],{1,ng,niter}],PlotRange->All,Joined->False,Frame->True,Axes->False,PlotStyle->{Black,PointSize[0.008]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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,ncs}
];

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]},FrameTicks->{xiterticks,Automatic,Automatic,Automatic},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"}];

plIter=Show[GraphicsGrid[If[EvenQ[ncs+1],Table[{pl[[ii]],pl[[ii+1]]},{ii,1,ncs+1,2}],Join[Table[{pl[[ii]],pl[[ii+1]]},{ii,1,IntegerPart[(ncs+1)/2]*2,2}],{{pl[[IntegerPart[(ncs+1)/2]*2+1]]}}]],Spacings->{Scaled[-0.0],Scaled[-0.05]}],DisplayFunction->$DisplayFunction]

Plot pairs of parameters to examine correlations for highest peak only.     
(uses a PDF cutoff and shows PDF by point size and BW)

We want to plot points at intervals of dn iterations.

dn=1;

Plot m versus s

This step generate the data needed for plotting. Only use points with period 
values between p1Low, p1Hi and p2Low, p2Hi (corresponding to to maximum peak).

trn=.;lsel=0;ncorr=0;
If[ncsys<n,tr=Table[Transpose[logpdfβi][[nβ]][[i]],{i,nburn,nnt,dn}];lsel=Length[tr];If[lsel>0,trn=Transpose[tr];a1good=trn[[2]];a2good=trn[[3]]]];lsel

Next plots individual thinned MCMC iterations proportional to marginal distribution.

ppf=Transpose[{a1good,a2good}];plms=ListPlot[ppf,Frame->True,PlotRange->All,Axes->False,FrameLabel->{Style[a1name<>a1unit,{"Helvetica-Bold",12}],
		Style[a2name<>a2unit,{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.003],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Two dimensional marginal histogram plot.

If[Length[ppf]>0,
plotsmh=Histogram3D[ppf,
AxesLabel->{a1name<>a1unit,a2name<>a2unit<>"\n","Marginal \n    PDF"},BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

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]]]

plh=Table[1,{i,ncs}];
Do[
If[i==0,lmed=Median[trnn[[i]]];loglmed=Floor[Log[10,lmed]];loglmed10=N[10^Floor[Log[10,lmed]]];trnni=trnn[[i]]/loglmed10;
sf[n_]:=ToString[HoldForm[(10^n)],StandardForm];label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>"   (×"<> sf[loglmed]<>")"<>ToExpression["a"<>ToString[i]<>"unit"]];
plh[[i]]=Histogram[trnni,PlotRange->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"}],label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];plh[[i]]=Histogram[trnn[[i]],PlotRange->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,ncs-1}
];
label=StringForm[ToExpression["a"<>ToString[ncs]<>"name"]<>ToExpression["a"<>ToString[ncs]<>"unit"]];aimarg=Take[trn[[ncs+1]],-(ng-nburn)];
ybin=BinCounts[aimarg,{mmin-0.5,mMax+0.5}];totybin=Plus@@ybin;nybin=N[ybin/totybin];y0bin=Table[0,{i,mmin,Length[ybin]+mmin-1}];xbin=Table[i,{i,mmin,Length[ybin]+mmin-1}];xAbin=Table[0.9999*i,{i,mmin,Length[ybin]+mmin-1}];xBbin=Table[1.0001*i,{i,mmin,Length[ybin]+mmin-1}];mbin=Transpose[{xbin,nybin}];mAbin=Transpose[{xAbin,y0bin}];mBbin=Transpose[{xBbin,y0bin}];mallbin=Sort[Join[mAbin,mbin,mBbin]];pbin=Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&];plh[[ncs]]=ListPlot[mallbin,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,Joined->True,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Probability",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];
plhis=Show[GraphicsGrid[If[EvenQ[ncs],Table[{plh[[ii]],plh[[ii+1]]},{ii,1,ncs,2}],Join[Table[{plh[[ii]],plh[[ii+1]]},{ii,1,IntegerPart[(ncs)/2]*2,2}],{{plh[[IntegerPart[(ncs)/2]*2+1]]}}]],Spacings->{Scaled[-0.2],Scaled[-0.02]}]]

Redo using BinCounts to compute errors and result statistics

nai=200;njump=0;plp=Table[1,{i,ncs}];meanai=Table[0,{j,1,ncs}];medianai=Table[0,{j,1,ncs}];modeai=Table[0,{j,1,ncs}];minai=Table[0,{j,1,ncs}];maxai=Table[0,{j,1,ncs}];areai=Table[0,{j,1,ncs}];Do[label=StringForm[ToExpression["a"<>ToString[i]<>"name"]<>ToExpression["a"<>ToString[i]<>"unit"]];aimarg=Take[trn[[i+1]],-(ng-nburn)];meanai[[i]]=Mean[aimarg];medianai[[i]]=Median[aimarg];low=Round[100000*Min[aimarg]]/100000;hi=Round[100000*Max[aimarg]]/100000;If[hi==low,njump=1;Break[],];dai=(hi-low)/nai;aibin=BinCounts[aimarg,{low,hi,dai}];aimidpoints=Table[N[k],{k,low+dai/2,hi-dai/2,dai}];aibintot=Total[aibin];If[aibintot<1,njump=1;Break[],];yai=(aibin/(aibintot*dai));yaisum=Plus@@yai;pbin=Sort[Transpose[{yai/yaisum,aimidpoints}],OrderedQ[{#2, #1}]&];modeai[[i]]=pbin[[1,2]];minai[[i]]=avMax[[i]];maxai[[i]]=avmin[[i]];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}];aimargbinA=Join[{{First[aimidpoints]-dai,0.0}},aimargbin,{{Last[aimidpoints]+dai,0.0}}];plp[[i]]=ListPlot[MovingAverage[aimargbinA,{(1/37),(2/37),(4/37),(4/37),(5/37),(5/37),(5/37),(4/37),(4/37),(2/37),(1/37)}],PlotRange->{{0.98*low,1.01*hi},{0,0.75*Max[yai]}},Frame->True, Axes->False,PlotStyle->PointSize[0.02],Joined->True,AspectRatio->0.5,FrameLabel->{Style[label,{"Helvetica-Bold",12}],
		Style["PDF",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],{i,1,ncs-1}
];
label=StringForm[ToExpression["a"<>ToString[ngs]<>"name"]<>ToExpression["a"<>ToString[ngs]<>"unit"]];aimarg=Take[trn[[ngs+1]],-(ng-nburn)];meanai[[ngs]]=Mean[aimarg];medianai[[ngs]]=Median[aimarg];modeai[[ngs]]=Commonest[aimarg][[1]];
ybin=BinCounts[aimarg,{mmin-0.5,mMax+0.5}];totybin=Plus@@ybin;nybin=N[ybin/totybin];y0bin=Table[0,{i,mmin,Length[ybin]+mmin-1}];xbin=Table[i,{i,mmin,Length[ybin]+mmin-1}];xAbin=Table[0.9999*i,{i,mmin,Length[ybin]+mmin-1}];xBbin=Table[1.0001*i,{i,mmin,Length[ybin]+mmin-1}];mbin=Transpose[{xbin,nybin}];mAbin=Transpose[{xAbin,y0bin}];mBbin=Transpose[{xBbin,y0bin}];mallbin=Sort[Join[mAbin,mbin,mBbin]];pbin=Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&];minai[[ngs]]=1000000000;maxai[[ngs]]=-1000000000;area=0;j=1;
While[area≤0.683,area=area+ pbin[[j,1]];
If[pbin[[j,2]]<minai[[ngs]],minai[[ngs]]=pbin[[j,2]],Null];
If[pbin[[j,2]]>maxai[[ngs]],maxai[[ngs]]=pbin[[j,2]],Null];
j=j+1];areai[[ngs]]=area;plp[[ncs]]=ListPlot[mallbin,PlotRange->All,Frame->True,Axes->False,AspectRatio->0.5,Joined->True,PlotLabel->Style["",{"Helvetica-Bold",12}],FrameLabel->{Style[label,{"Helvetica-Bold",14}],
		Style["Probability",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}];If[njump<1,plmarg=Show[GraphicsGrid[{{plp[[1]],plp[[2]]}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]],Print["Not enough iterations"]
]

Find mProbMax = m value with largest probability.

mPMax=First[Sort[Transpose[{nybin,xbin}],OrderedQ[{#2, #1}]&]][[2]]

Calculate the sum of the probabilities of the periodic models with m ≠ mPMax to prob. of model with m = mPMax.

pri=Transpose[{xbin,nybin}];priX=Select[pri,#[[1]]==mPMax&];prinotX=Select[pri,#[[1]]≠mPMax&];prnotXtoX=Plus@@(Transpose[prinotX][[2]])/priX[[1,2]]

Most probable set of parameters & 68.3% marginal credible regions

Use next command block if working from dataMC input from file.

tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5s=Sort[tr5,#1[[nl]]>#2[[nl]]&];

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5s[[1]]

Note: the second item in the list is the raw phase, for most of our calculations we need Mod[ϕ,2*π/m], which is what we display in the various plots above .

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5s[[1,i+1]],{i,1,ncs}];peakai

Make a 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,ncs}];

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,ncs}];

smj=MatrixForm[Join[l1,l2,l4,l5]]

Plot mean & median light curves and std deviation marginalizing over m.

Allows for selecting MCMC samples with m between cutoff1 and cutoff2.

cutoff1=2;cutoff2=12;tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5Ps=Select[tr5,#[[3]]⩾cutoff1&&#[[3]]≤cutoff2&];tr5Psel=Sort[tr5Ps,#1[[nl]]>#2[[nl]]&];
trn=Transpose[tr5Psel];
permarg=trn[[2]];
Length[tr5Psel]
sbar=Mean[permarg]

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5Psel[[1]]

Identify parameter values with maximum (peak) probability, e.g., peaks is the value for extra noise parameter s.

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5Psel[[1,i+1]],{i,1,ncs+1}];peaks=peakai[[1]]

Steps in computing the mean and median light curve shape and 1 sigma uncertainty

Divide the data duration into a list of  nshape time steps labelled ts.  
Recall that for each set of parameters, we computed and stored the vector: {β,,s,m,ϕ, i,Log[like],Log[prior*like],colmeandWj,colWj,colwj},
where colmeandWj,colWj,colwj each consist of a vector of m values one for each of the m bins.
For each set of parameter values convert each ts into a bin number and extract the 
 (OverBar[(Subscript[d, Wj])]) = dWjvec, Wj = Wjvec, wj (correction for no data)= wjvec  for that bin corresponding to that set of parameter values using the Extract command. Transpose those quantities to obtain shpwjt,  shpWjt,  shpt. 
 Next form wjshplistk = Transpose[{shpwjt[[k]], shpt[[k]], shpWjt[[k]]}]. 
 Next form selk=Select[wjshplistk,#[[1]]= = 1 &] which selects only shape info where shpwjt[[k]] is non zero.
 Then compute the mean shape[[k]] and mean shsig[[k]] for each k. 
 We also store shlist so we can obtain a histogram of shape values for each k.

This version below works even if there is only one data point in certain bins

Timing[interval=10;nshape=80;ts=Table[i*dur/nshape,{i,nshape}];
shp={};shpWj={};shpwj={};nused=Length[tr5Psel];datgood=Take[tr5Psel,{1,nused,interval}];nu=Length[datgood];
Do[m=datgood[[i,3]];ϕp=datgood[[i,4]]/m;dWjvec=datgood[[i,nl+1]];Wjvec=datgood[[i,nl+2]];wjvec=datgood[[i,nl+3]];jvec=IntegerPart[1+m*Mod[ts/dur+ϕp,1]];tjvec=Transpose[{jvec}];shpi=Extract[dWjvec,tjvec];Wji=Extract[Wjvec,tjvec];wji=Extract[wjvec,tjvec];shp=Append[shp,shpi];shpWj=Append[shpWj,Wji];shpwj=Append[shpwj,wji],{i,1,nu}
];
shpt=Transpose[shp];shpWjt=Transpose[shpWj];shpwjt=Transpose[shpwj];shlist=Table[0,{k,nshape}];shape=Table[0,{k,nshape}];medianshape=Table[0,{k,nshape}];shsig=Table[0,{k,nshape}];nselk=Table[0,{k,nshape}];Do[wjshplistk=Transpose[{shpwjt[[k]],shpt[[k]],shpWjt[[k]]}];If[Length[wjshplistk]<1,Print["no data for bin "<>ToString[k]];Break[],];tselk=Transpose[wjshplistk];shlist[[k]]=tselk[[2]];medianshape[[k]]=Median[shlist[[k]]];shape[[k]]=Mean[shlist[[k]]];nselk[[k]]=Length[shlist[[k]]];shsig[[k]]=Mean[(((tselk[[3]]))^(-1/2))],{k,nshape}];shape]

Plot shape = the mean shape.

ListPlot[shape]

Plot shape = the mean shape.

ListPlot[medianshape]

Plot shsig = the mean shape sigma value.

ListPlot[shsig]

Plot mean shape ± one sigma repeated for two cycles of phase

ph0=ts/dur-1;ph1=ts/dur;ph2=ts/dur+1;
shpup0=Transpose[{ph0,shape+shsig}];shpup1=Transpose[{ph1,shape+shsig}];shpup2=Transpose[{ph2,shape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,shape-shsig}];shpdn1=Transpose[{ph1,shape-shsig}];shpdn2=Transpose[{ph2,shape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot median shape ± one sigma repeated for two cycles of phase

ph0=ts/dur-1;ph1=ts/dur;ph2=ts/dur+1;
shpup0=Transpose[{ph0,medianshape+shsig}];shpup1=Transpose[{ph1,medianshape+shsig}];shpup2=Transpose[{ph2,medianshape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,medianshape-shsig}];shpdn1=Transpose[{ph1,medianshape-shsig}];shpdn2=Transpose[{ph2,medianshape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2median=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase.

The next two lines cause the data error bars to be increased by the most probable value of the extra noise term.

Do[If[StringMatchQ[ToExpression["a"<>ToString[i]<>"name"],"s"],nsi=i,],{i,1,ncs}];

meanai[[nsi]]

pserrvec=(Sqrt[(errvec^2)+((meanai[[nsi]])^2)]);

nsi

tvec

Mod[tvec,dur]/dur

phvec1=Mod[tvec,dur]/dur;phvec2=phvec1+1;phdat1=Transpose[{phvec1,dvec,pserrvec}];
phdat2=Transpose[{phvec2,dvec,pserrvec}];phdat=Join[phdat1,phdat2];
tphdat=Transpose[phdat];phd=Transpose[{tphdat[[1]],tphdat[[2]]}];phdvec=Table[{phd[[i]],ErrorBar[tphdat[[3]][[i]]]},{i,Length[phd]}];
plphdvec=ErrorListPlot[phdvec,Frame->True,PlotRange->{{-0.05,2.0},Automatic},Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase with light curve overlaid.

plshpAllm=Show[plphdvec,plphshp2]

plshpAllmb=Show[plshpAllm,Graphics[{Text["(a)",{1.,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plshpAllmMedian=Show[plphdvec,plphshp2median]

Plot individual data points versus time with overlaid Mean light curve.

pldatvst=ErrorListPlot[Transpose[{tvec,dvec,pserrvec}],Frame->True,Axes->False,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ncycle=2;shpupt={};Do[Do[shpupt=Append[shpupt,{(ph1[[i]]+(j-2))*dur,shape[[i]]+shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
shpdnt={};Do[Do[shpdnt=Append[shpdnt,{(ph1[[i]]+(j-2))*dur,shape[[i]]-shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
plshpt1=ListPlot[{shpupt,shpdnt},Frame->True,PlotRange->All,Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshpt1a=Show[plshpt1,PlotRange->{{First[tvec]-dur/30,Last[tvec]+dur/30},All}]

pltimfitdat=Show[{plshpt1a,pldatvst},Axes->False]

pltimfitdatb=Show[pltimfitdat,Graphics[{Text["(a)",{0,30}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Plot residuals for mean solution (m = all bins).

ph0=ts/dur-1;ph1=ts/dur;ph2=ts/dur+1;shperr0=Transpose[{ph0,shape,shsig}];shperr1=Transpose[{ph1,shape,shsig}];shperr2=Transpose[{ph2,shape,shsig}];shperr=Join[shperr0,shperr1,shperr2];tshperr=Transpose[shperr];phaseshp=Transpose[{tshperr[[1]],tshperr[[2]]}];phaseshp=Table[phaseshp[[i]],{i,3*nshape}];
plphshp1=ListPlot[phaseshp,Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ifnshp=Interpolation[phaseshp]

phvec1

mvec=ifnshp[phvec1];Length[mvec]

y=dvec-mvec

Computed weighted std dev.

wresmap=(Sqrt[((((y/errvec)).((y/errvec)))/((1/errvec).(1/errvec)))])

resmap=StandardDeviation[y]

resid=Transpose[{tvec,y}];

residerr=Table[{resid[[i]],ErrorBar[pserrvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Error residuals (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp2b=Show[plshp2,Graphics[{Text["(b)",{0,-150}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plMAP3=Show[GraphicsGrid[{{pltimfitdatb},{plshp2b}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]]

Plot mean & median light curves and std deviation marginalizing over upper range of m values.

Allows for selecting MCMC samples with m between cutoff1 and cutoff2.

cutoff1=7;cutoff2=12;tr=Transpose[logpdfβi][[nβ]];tr5=Take[tr,-(nnt-nburn)];tr5Ps=Select[tr5,#[[3]]⩾cutoff1&&#[[3]]≤cutoff2&];tr5Psel=Sort[tr5Ps,#1[[nl]]>#2[[nl]]&];
trn=Transpose[tr5Psel];
permarg=trn[[2]];
Length[tr5Psel]
sbar=Mean[permarg]

Here are the most probable parameter set, and the derived values need for the lightcurve shape calulation. 
See earlier section on extracting model parameter samples for the meaning of the different list items.

tr5Psel[[1]]

Identify parameter values with maximum (peak) probability, e.g., peaks is the value for extra noise parameter s.

peakai=Table[0,{i,1,ngs+1}];Do[peakai[[i]]=tr5Psel[[1,i+1]],{i,1,ncs+1}];peaks=peakai[[1]]

Steps in computing the mean and median light curve shape and 1 sigma uncertainty

Divide the data duration into a list of  nshape time steps labelled ts.  
Recall that for each set of parameters, we computed and stored the vector: {β,,s,m,ϕ, i,Log[like],Log[prior*like],colmeandWj,colWj,colwj},
where colmeandWj,colWj,colwj each consist of a vector of m values one for each of the m bins.
For each set of parameter values convert each ts into a bin number and extract the 
 (OverBar[(Subscript[d, Wj])]) = dWjvec, Wj = Wjvec, wj (correction for no data)= wjvec  for that bin corresponding to that set of parameter values using the Extract command. Transpose those quantities to obtain shpwjt,  shpWjt,  shpt. 
 Next form wjshplistk = Transpose[{shpwjt[[k]], shpt[[k]], shpWjt[[k]]}]. 
 Next form selk=Select[wjshplistk,#[[1]]= = 1 &] which selects only shape info where shpwjt[[k]] is non zero.
 Then compute the mean shape[[k]] and mean shsig[[k]] for each k. 
 We also store shlist so we can obtain a histogram of shape values for each k.

This version below works even if there is only one data point in certain bins

Timing[interval=10;nshape=80;ts=Table[i*dur/nshape,{i,nshape}];
shp={};shpWj={};shpwj={};nused=Length[tr5Psel];datgood=Take[tr5Psel,{1,nused,interval}];nu=Length[datgood];
Do[m=datgood[[i,3]];ϕp=datgood[[i,4]]/m;dWjvec=datgood[[i,nl+1]];Wjvec=datgood[[i,nl+2]];wjvec=datgood[[i,nl+3]];jvec=IntegerPart[1+m*Mod[ts/dur+ϕp,1]];tjvec=Transpose[{jvec}];shpi=Extract[dWjvec,tjvec];Wji=Extract[Wjvec,tjvec];wji=Extract[wjvec,tjvec];shp=Append[shp,shpi];shpWj=Append[shpWj,Wji];shpwj=Append[shpwj,wji],{i,1,nu}
];
shpt=Transpose[shp];shpWjt=Transpose[shpWj];shpwjt=Transpose[shpwj];shlist=Table[0,{k,nshape}];shape=Table[0,{k,nshape}];medianshape=Table[0,{k,nshape}];shsig=Table[0,{k,nshape}];nselk=Table[0,{k,nshape}];Do[wjshplistk=Transpose[{shpwjt[[k]],shpt[[k]],shpWjt[[k]]}];If[Length[wjshplistk]<1,Print["no data for bin "<>ToString[k]];Break[],];tselk=Transpose[wjshplistk];shlist[[k]]=tselk[[2]];medianshape[[k]]=Median[shlist[[k]]];shape[[k]]=Mean[shlist[[k]]];nselk[[k]]=Length[shlist[[k]]];shsig[[k]]=Mean[(((tselk[[3]]))^(-1/2))],{k,nshape}];shape]

Plot shape = the mean shape.

ListPlot[shape]

Plot shape = the mean shape.

ListPlot[medianshape]

Plot shsig = the mean shape sigma value.

ListPlot[shsig]

Plot mean shape ± one sigma repeated for two cycles of phase

ph0=ts/dur-1;ph1=ts/dur;ph2=ts/dur+1;
shpup0=Transpose[{ph0,shape+shsig}];shpup1=Transpose[{ph1,shape+shsig}];shpup2=Transpose[{ph2,shape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,shape-shsig}];shpdn1=Transpose[{ph1,shape-shsig}];shpdn2=Transpose[{ph2,shape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot median shape ± one sigma repeated for two cycles of phase

ph0=ts/dur-1;ph1=ts/dur;ph2=ts/dur+1;
shpup0=Transpose[{ph0,medianshape+shsig}];shpup1=Transpose[{ph1,medianshape+shsig}];shpup2=Transpose[{ph2,medianshape+shsig}];shpup=Join[shpup0,shpup1,shpup2];shpdn0=Transpose[{ph0,medianshape-shsig}];shpdn1=Transpose[{ph1,medianshape-shsig}];shpdn2=Transpose[{ph2,medianshape-shsig}];shpdn=Join[shpdn0,shpdn1,shpdn2];plphshp2median=ListPlot[{shpup,shpdn},Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase.

The next two lines cause the data error bars to be increased by the most probable value of the extra noise term.

Do[If[StringMatchQ[ToExpression["a"<>ToString[i]<>"name"],"s"],nsi=i,],{i,1,ncs}];

meanai[[nsi]]

pserrvec=(Sqrt[(errvec^2)+((meanai[[nsi]])^2)]);

nsi

tvec

Mod[tvec,dur]/dur

phvec1=Mod[tvec,dur]/dur;phvec2=phvec1+1;phdat1=Transpose[{phvec1,dvec,pserrvec}];
phdat2=Transpose[{phvec2,dvec,pserrvec}];phdat=Join[phdat1,phdat2];
tphdat=Transpose[phdat];phd=Transpose[{tphdat[[1]],tphdat[[2]]}];phdvec=Table[{phd[[i]],ErrorBar[tphdat[[3]][[i]]]},{i,Length[phd]}];
plphdvec=ErrorListPlot[phdvec,Frame->True,PlotRange->{{-0.05,2.0},Automatic},Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

Plot the individual data points versus phase with light curve overlaid.

plshpAllm=Show[plphdvec,plphshp2]

plshpAllmb=Show[plshpAllm,Graphics[{Text["(a)",{1.,50}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plshpAllmMedian=Show[plphdvec,plphshp2median]

Plot individual data points versus time with overlaid Mean light curve.

pldatvst=ErrorListPlot[Transpose[{tvec,dvec,pserrvec}],Frame->True,Axes->False,PlotRange->All,PlotLabel->Style["",{"Helvetica-Bold",11}],PlotStyle->Black,FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ncycle=2;shpupt={};Do[Do[shpupt=Append[shpupt,{(ph1[[i]]+(j-2))*dur,shape[[i]]+shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
shpdnt={};Do[Do[shpdnt=Append[shpdnt,{(ph1[[i]]+(j-2))*dur,shape[[i]]-shsig[[i]]}],{i,1,nshape}],{j,1,ncycle}];
plshpt1=ListPlot[{shpupt,shpdnt},Frame->True,PlotRange->All,Joined->True,Axes->False,PlotStyle->{{Thickness->0.005,Red},{Thickness->0.005,Green}},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time (days)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshpt1a=Show[plshpt1,PlotRange->{{First[tvec]-dur/30,Last[tvec]+dur/30},All}]

pltimfitdat=Show[{plshpt1a,pldatvst},Axes->False]

pltimfitdatb=Show[pltimfitdat,Graphics[{Text["(a)",{0,30}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5]

Plot residuals for mean solution (m = all bins).

ph0=ts/dur-1;ph1=ts/dur;ph2=ts/dur+1;shperr0=Transpose[{ph0,shape,shsig}];shperr1=Transpose[{ph1,shape,shsig}];shperr2=Transpose[{ph2,shape,shsig}];shperr=Join[shperr0,shperr1,shperr2];tshperr=Transpose[shperr];phaseshp=Transpose[{tshperr[[1]],tshperr[[2]]}];phaseshp=Table[phaseshp[[i]],{i,3*nshape}];
plphshp1=ListPlot[phaseshp,Frame->True,PlotRange->{{0.0,2.0},Automatic},Joined->True,Axes->False,PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Phase (2 cycles)",{"Helvetica-Bold",12}],Style["Flux density  (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

ifnshp=Interpolation[phaseshp]

phvec1

mvec=ifnshp[phvec1];Length[mvec]

y=dvec-mvec

Computed weighted std dev.

wresmap=(Sqrt[((((y/errvec)).((y/errvec)))/((1/errvec).(1/errvec)))])

resmap=StandardDeviation[y]

resid=Transpose[{tvec,y}];

residerr=Table[{resid[[i]],ErrorBar[pserrvec[[i]]]},{i,nd}];
plshp2=ErrorListPlot[residerr,Frame->True,PlotRange->All,Axes->{True,False},PlotLabel->Style["",{"Helvetica-Bold",11}],FrameLabel->{Style["Time  (days)",{"Helvetica-Bold",12}],Style["Error residuals (mJy)",{"Helvetica-Bold",12}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]

plshp2b=Show[plshp2,Graphics[{Text["(b)",{0,-170}]}],TextStyle->{FontWeight->"Bold",FontSize->12},AspectRatio->0.5,DisplayFunction->Identity]

plMAP4=Show[GraphicsGrid[{{pltimfitdatb},{plshp2b}},Spacings->{Scaled[-0.0],Scaled[-0.02]}]]

Note: the fit to the first point is not very good because of the assumed periodic boundary condition.

Compute the Bayes factor from all tempering level results

Compares model (Subscript[M, var]) to model (Subscript[M, 1]) (rejecting the first nburn samples). 
((NOTE: THIS SECTION WON'T EVALUATE IF nβ < nβmin.))
Computing the Bayes factor using this section is only sensible if a 
large number (≥ 20) of β levels are used spanning the range β = 0 to 1. 
Otherwise use the restricted Monte Carlo Bayes factor calculation in the next section.

Compute p(D|Mvar,I), the global likelihood for the periodic model

Here we compute  the log of the global likelihood of the model, which is designated by  logpMvar
                logpMvar=log[p(D|Mvar,I)]=∫ (Subscript[⟨ log[p(D|Mvar,X,I)] ⟩, β])  dβ
(Subscript[⟨ log[p(D|Mvar,X,I)] ⟩, β]) =expectation value oflog[p(D|Mvar,X,I)]  for given β
                                              =(1/n)(∑_(t=1)^n)  log[p(D|Mvar,(Subscript[X, 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 an example of the first row of the output given by logpdfβi[[1,1]].
         {1.`,1273.9726060784137`,40.803985991174834`,5,0.35303805202159366`,10,76.0136129133192`,73.543571479479`,{148.91745708656111`,194.36292184504748`,240.09863821079406`,201.68614548468776`,132.11148679054986`},{0.0065844726825486505`,0.0051319390270891255`,0.004495349418625844`,0.001429003958843216`,0.002333596595333784`},{1,1,1,1,1}}
          The quantity  log[p(D|Mvar,(Subscript[X, t,β ]) ,I)] is the (7^th) item (n2l item) in each list. 
The different list correspond to different values of the tempering parameter β.

Set nβmin, the minimum number of tempering levels before it makes any sense to compute the 
global likelihood of the model by this method.

nβmin=20;

First check that you are happy with the burn -in value, nburn.

nburn

Generate the list expect = ⟨ln p(D|(Subscript[M, var]),X,I)⟩ , one for each tempering level 
provided nβ≥nβmin and ncsys<n, i.e., the turn-off of the control system was ≤nburn.

If[ncsys<n&&nβ≥nβmin,ngood=(nnt-nburn);tr=Transpose[Take[logpdfβi,-ngood]];expect=Table[0.0,{i,1,nβ}];Do[trnb=Transpose[tr[[nb]]];tb1Num=trnb[[n2l]];logpdfβ=Total[tb1Num]/ngood;expect[[nb]]=logpdfβ,{nb,1,nβ}],];

ngood

List ⟨ln p(D|(Subscript[M, var]),PX,I)⟩ values, one for each tempering level.

If[ncsys<n&&nβ≥nβmin,expect,]

List the β tempering values.

If[ncsys<n&&nβ≥nβmin,βlis,]

Plot ⟨ln p(D|(Subscript[M, var]),X,I)⟩ values versus (Subscript[Log, 10 ])(βlis+0.000001).

If[ncsys<n&&nβ≥nβmin,pl1=ListPlot[Transpose[{Log[10,βlis],expect}],PlotStyle->PointSize[0.02],Axes->False,Frame->True,PlotRange->All,FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D|(Subscript[M, 2]),X,I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}],]

Generate an interpolating function for a LogLinearPlot.

If[ncsys<n&&nβ≥nβmin,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[ncsys<n&&nβ>nβmin,newexpect=Table[{x,spline1[x]},{x,Min[Log[10,βlis]],0.0,0.01}];Length[newexpect]]

Plot the interpolation.

If[ncsys<n&&nβ≥nβmin,pl4=ListPlot[newexpect,Frame->True,PlotRange->All,Axes->False,Joined->True,PlotStyle->{Thickness->0.004},FrameLabel->{Style["Log β",{"Helvetica-Bold",15}],
		Style["⟨ln p(D|(Subscript[M, 2]),X,I)⟩",{"Helvetica-Bold",14}]},FrameStyle->Thickness[0.006],BaseStyle->{12,FontFamily->"Helvetica-Bold"}]]

Plot the interpolation and expect values together.

If[ncsys<n&&nβ≥nβmin,plBayesFactor=Show[pl1,pl4,PlotRange->All],]

If[ncsys<n&&nβ≥nβmin,plBayesFactorA=Show[pl1,pl4,PlotRange->{{-2.1,0.01},{60,105}}]]

If[ncsys<n&&nβ≥nβmin,plBayesFactorB=Show[pl1,pl4,PlotRange->{{-1,0.01},{80,100}}]]

If[ncsys<n&&nβ≥nβmin,plBayesFactorC=Show[pl1,pl4,PlotRange->{{-0.3,0.01},{95,99}}],]

plBayesFactor2=Show[plBayesFactor,Epilog->Inset[plBayesFactorA,Scaled[{0.3,0.55}],Scaled[{0.1,0.1}],Scaled[{0.7,0.7}]]
]

Now convert to a table with linear coordinates.

If[ncsys<n&&nβ≥nβmin,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 logpMvar.

If[ncsys<n&&nβ≥nβmin,logpMvar1=Total[Table[0.5*(newexpect1[[i]][[2]]+newexpect1[[i+1]][[2]])*(newexpect1[[i+1]][[1]]-newexpect1[[i]][[1]]),{i,1,Length[newexpect1]-1}]]]

(E^logpMvar1)

Suppose we drop the first nn  β levels and redo the 
calculation of the Log of the global likelihood for M1.

nn=3;

If[ncsys<n&&nβ⩾(nβmin+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[ncsys<n&&nβ≥(nβmin+nn),newexpect2=Table[spline2[x],{x,Min[Log[10,Drop[βlis,nn]]],0.0,0.01}];Length[newexpect2]]

If[ncsys<n&&nβ≥(nβmin+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[ncsys<n&&nβ≥(nβmin+nn),logpMvar2=Total[Table[0.5*(newexpect3[[i]][[2]]+newexpect3[[i+1]][[2]])*(newexpect3[[i+1]][[1]]-newexpect3[[i]][[1]]),{i,1,Length[newexpect3]-1}]],]

(E^logpMvar2)

Compute p(D|M1,I), global likelihood of constant one bin model

Calculation details:

Assumes a model of an unknown rmin and a random Gaussian variability of unknown sigma s.

As a practical matter we need to choose suitable limits of integration of these two parameters.
If we simply use the prior limits NIntegrate may converge too slowly because of the huge dynamic 
range of the quantity to be integrated.

rmintemp=-20.0;(* lower integration limit for r parameter *)

rmaxtemp=400.0;(* upper integration limit for r parameter *)

smintemp=0.0;(* lower integration limit for s parameter *)

smaxtemp=100.0;(* upper integration limit for s parameter *)

If[ncsys<n,s=.;r=.;logfactor=Log[((((2*π))^(-nd/2))/((rmax-rmin)*Log[((mJs+bfMax[[2]])/mJs)]))];
serrvec=(Sqrt[(errvec^2)+(s^2)]);y=(((dvec-r))/serrvec);logpriorlike=loglikeoffset+logfactor-Log[(s+mJs)]+Log[Times@@((serrvec^(-1)))]-0.5*y.y;term1=Exp[logpriorlike];
pDM1=NIntegrate[term1,{r,rmintemp,rmaxtemp},{s,smintemp,smaxtemp}]
]

logpM1=Log[pDM1]

Compute Bayes factor

If[ncsys<n&&nβ≥nβmin,odds=Exp[logpMvar1-logpM1]]

App. B: Exercise on DFT, zero padding and Nyquist sampling

CleanUp:

Remove["Global`*"]

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

1. Compute the Fourier Transform (FT) of a sine wave

The FT of a function fn is defined by (∫_(-∞)^∞)fn[t] (e^(i 2 π  f  t))dt

fn=Sin[2 π (Subscript[f, 1]) t+θ];

We will be transforming  a windowed  version of the fn by multiplying the fn which is assumed to go from -∞ to +∞ by the rectangular window function w(t) , which is = 1 between -L≤ t ≤ L and zero outside this range. Compute the analytic FT of [w(t)* fn] defined as follows:
   w(t)*fn = 0                             for t<-L/2
   w(t)*fn = fn= Sin[2 π (Subscript[f, 1]) t+π/4]       for -L/2 ≤ t ≤ L/2
   w(t)*fn = 0                             for t>-L/2

In general the FT will be complex. We will want to evaluate the real and imaginary components of the FT. It is necessary to tell Mathematica that the variables f and t are real quantities. This is done by declaring these symbols to have an imaginary part of zero.

This declares the symbol f to have an imaginary part of zero.

f/:Im[f]=0;

t/:Im[t]=0;

Specify signal model and window parameters.

(Subscript[f, 1])=1; L=4;θ=π/2;

Now compute the real part of the FT

freal=Re[(∫_(-L/2)^(L/2))fn (E^(I 2 π  f  t))\[DifferentialD]t]

plrealFT=Plot[freal,{f,-2,2},PlotRange->All]

fimag=Im[(∫_(-L/2)^(L/2))fn (E^(I 2 π  f  t))\[DifferentialD]t]

Plot[fimag,{f,-2,2}]

While we are at it lets compute the absolute value of the FT

fabs=Abs[(∫_(-L/2)^(L/2))fn (E^(I 2 π  f  t))\[DifferentialD]t]

plabsFT=Plot[fabs,{f,-2,2},PlotRange->All]

2. Compute the Discrete Fourier Transform (DFT) of a sine wave

Note the location of the rectangular window function w(t) is very important.  Its width L = n T, where T is the sample interval.  If w(t) had been located so that a sample value coincided with each end point, the rectangular function would be n + 1 sample values, and would result in time domain aliasing. We will start the first sample T/2 away from the end and the last of n samples will be T/2 short of that end.

T=0.25;n=(L/T)

samples=Table[fn,{t,-L/2+T/2,L/2-T/2,T}]

Check the number of samples.

Length[samples]

Compute the discrete Fourier Transform (DFT) of the samples.

Fourier[samples]

Most of the real and imaginary terms are very small. We can set these very small values = 0 with the Chop command.

Chop[Fourier[samples]]

We see that for the sampling we have used the DFT is complex consisting of both real and imaginary parts. We can obtain the real and imaginary parts separately with the commands

Re[Chop[Fourier[samples]]]

Im[Chop[Fourier[samples]]]

We will compare the absolute value of the DFT to the absolute value of the analytic FT.

Abs[Chop[Fourier[samples]]]

To compare with the analytic transform we need to remember the relationship between the FT and the DFT. From the course text book (see sections B.7.2 & B.7.3) the relation is
       H((Subscript[f, j])) = T (∑_(k=0)^(n-1))(Subscript[h, k])(e^(i 2 π j k/n)) = T (Subscript[H, j])           -----(1)
         (analytic)                                                                             (T x  DFT)
   
   Mathematica uses the following slightly different definition of the DFT   
      (Subscript[H, j ])(Mathematica)= (1/(Sqrt[n]))(∑_(k=1)^n) (Subscript[h, k])(e^(i 2π(j-1)(k-1)/n))
We can now rewrite equation (1) above to obtain the relationship between the analytic FT on the left and the 
Mathematica DFT on the right.
      
       H((Subscript[f, j])) = T  (Sqrt[n]) (Subscript[H, j])(Mathematica)

absoluteDFT=Abs[T (Sqrt[n ]) Chop[Fourier[samples]]]

freqnDFT=Table[i,{i,0,n-1}]

pl2=ListPlot[Transpose[{freqnDFT,absoluteDFT}],Joined->True,Axes->False,PlotRange->All,PlotStyle->{Thickness[0.005],GrayLevel[0]},PlotRange->{{0,n-1},{-0.6,0.6}},
Frame->True,PlotLabel->Style["",{"Helvetica-Bold",16}],FrameLabel->{Style["Frequency  sample  number",{"Helvetica-Bold",16}],Style["ReaL[DFT]",{"Helvetica-Bold",14}]},BaseStyle -> {"Helvetica-Bold",14},FrameStyle->Thickness[0.006]]

Create some text, lines and arrows to add to plot.

pline=Show[Graphics[{Thickness[0],Text[Style["T = "<>ToString[.25]<>"\n N = 16",FontSize->14,FontWeight->"Bold",Black],{4,-0.3},{-1,0},{1,0}],Text[Style["Nyquist  f",FontSize->14,FontWeight->"Bold",Black],{8,-0.24},{-1,0},{1,0}],Line[{{8,0.55},{8,-0.2}}],Arrow[{{8,1.9},{8,-.55}}],Text[Style["Positive  f",FontSize->14,FontWeight->"Bold",Blue],{4,1.0},{-1,0},{1,0}],Text[Style["Negative  f",FontSize->14,FontWeight->"Bold",Red],{9,1.0},{-1,0},{1,0}],Arrow[{{0,0.9},{8,0.9}}],Arrow[{{15,0.9},{8,0.9}}]}],TextStyle->{FontSize->11}];

Show[pl2,pline]

Compute the actual frequencies of the samples. The end points are ± the Nyquist frequency.

x=Table[i/L,{i,-n/2,n/2}]

Reorganize the DFT output to plot positive and negative frequencies.

tabsolute=Join[Take[absoluteDFT,{n/2+1,n}],Take[absoluteDFT,{1,n/2+1}]]

dataAbsolute=Transpose[{x,tabsolute}];

plabsoluteFFT=ListPlot[dataAbsolute,PlotRange->All,Joined->True,Frame->True,Axes->False,PlotStyle->{Thickness[0.005],GrayLevel[0]},PlotRange->{{0,n-1},{-0.6,0.6}},
Frame->True,PlotLabel->Style["Absolute DFT",{"Helvetica-Bold",16}],FrameLabel->{Style["Frequency, (n/NT)",{"Helvetica-Bold",16}],Style["",{"Helvetica-Bold",14}]},BaseStyle -> {"Helvetica-Bold",14},FrameStyle->Thickness[0.006]]

3. Compare the FT and the DFT

Show[plabsFT,plabsoluteFFT]

The amplitude estimate is reasonable but the frequency coverage is very poor. We can improve that by zero padding.

4. Compute the DFT  with zero padding

Set up a table of zeros to add to the original sampled signal.

n

zeropd=Table[0.00000,{i,1,5n}];

Append these zero to the original sample of data points using the Join command.

sampleszp=Join[samples,zeropd]

Find the Length of the zero padded data set.

nzpd=Length[sampleszp]

In earlier parts of this notebook (without zero padding) the imaginary part of the DFT was equal to zero when the fn=Sin[2 π (Subscript[f, 1]) t+θ]was real and even, as it is with θ = π/2. We were able to compare the real part of the DFT to the real part of the analytic FT. This is no longer true for the zero padded version so we will have to compare the absolute value of the DFT to the absolute value of the analytic FT.

absolutezpDFT=Abs[T (Sqrt[nzpd ]) Chop[Fourier[sampleszp]]];

freqnDFT=Table[i,{i,0,nzpd-1}];Length[freqnDFT]

pl7=ListPlot[Transpose[{freqnDFT,absolutezpDFT}],Joined->True,PlotRange->All,PlotStyle->{Thickness[0.005],GrayLevel[0]},PlotRange->{{0,n-1},{-0.55,0.55}},
Frame->True,PlotLabel->Style["(c)",{"Helvetica-Bold",14}],FrameLabel->{Style["Frequency  sample  number",{"Helvetica-Bold",14}],Style["ReaL[DFT]",{"Helvetica-Bold",14}]},BaseStyle -> {"Helvetica-Bold",14},FrameStyle->Thickness[0.006]]

xzp=Table[i/(L (nzpd/n)),{i,-nzpd/2,nzpd/2}];

tabsolutezp=Join[Take[absolutezpDFT,{nzpd/2+1,nzpd,1}],
Take[absolutezpDFT,{1,nzpd/2+1}]];

dataAbsolutezp=Transpose[{xzp,tabsolutezp}];

plabsFFTzp=ListPlot[dataAbsolutezp,PlotRange->All,PlotJoined->True,PlotStyle->{Thickness[0.005],GrayLevel[0]},
	PlotLabel->"",
	AxesLabel->{"Frequency, (n/NT)",""},
	BaseStyle -> {"Helvetica", 12}]

5. Compare the FT and the zero padded DFT

Show[plabsFFTzp,plabsFT]

Now we have good definition in frequency but the amplitudes in the side lobes look different. We can get better agreement if we sample the function at a smaller interval T.

App. B: Power spectrum of a time series

CleanUp:

Remove["Global`*"]

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

Read in Data and Plot

Read in data on a Windows system (one pair of x,y values per line). The data file is assumed to called called fft.dat and located in directory temp on drive c. You will need to remove the (* and *) at the ends of each line.

(*data=ReadList["c:\\temp\\fft.dat",Number,RecordLists->True];*)

Use the next line for a Unix or Linux system to declare the infile.

(*infile=OpenRead["~gregory//fft.dat",Number,RecordLists->True];*)

The second item is the data type.

RecordLists -> True puts objects on separate lines into separate sublists.

Next line will load internal test data if you are not reading it in from a file.

data= {{1.`,0.61587`},{2.`,0.696355`},{3.`,-1.941503`},{4.`,-2.730063`},{5.`,-2.785094`},{6.`,-0.370139`},{7.`,-1.679348`},{8.`,-0.344999`},{9.`,0.754804`},{10.`,2.724899`},{11.`,1.402389`},{12.`,2.354744`},{13.`,-1.366482`},{14.`,-0.236003`},{15.`,-1.361985`},{16.`,-1.484549`},{17.`,-1.045101`},{18.`,1.289416`},{19.`,1.247861`},{20.`,0.141487`},{21.`,-0.191561`},{22.`,-0.109583`},{23.`,-1.181124`},{24.`,-0.697082`},{25.`,-0.244601`},{26.`,0.599127`},{27.`,-1.990847`},{28.`,-0.374889`},{29.`,2.480097`},{30.`,0.53906`},{31.`,0.578921`},{32.`,2.028752`},{33.`,-0.597884`},{34.`,-1.237159`},{35.`,0.061659`},{36.`,-2.873706`},{37.`,0.512077`},{38.`,-0.350339`},{39.`,-0.213686`},{40.`,2.157935`},{41.`,-0.352252`},{42.`,-0.372447`},{43.`,0.566533`},{44.`,-1.703454`},{45.`,-2.422916`},{46.`,0.071072`},{47.`,-1.187854`},{48.`,-0.705808`},{49.`,0.273768`},{50.`,1.405401`},{51.`,0.813125`},{52.`,1.547481`},{53.`,-0.727281`},{54.`,-1.14434`},{55.`,-0.058584`},{56.`,-0.861264`},{57.`,-0.428404`},{58.`,0.344731`},{59.`,0.548533`},{60.`,1.145859`},{61.`,2.489294`},{62.`,1.209608`},{63.`,-0.039609`},{64.`,1.312416`}};

no=Length[data]

tarr=Transpose[data];

tvec=tarr[[1]];

dvec=tarr[[2]];

pl2=ListPlot[dvec,Frame->True,Joined->False]

Simulating Data

Remove the (* and *) at the ends of each line if you want to simulate data.

We define the periodic signal:

(*signal[t_]:=A Cos[2 π f t]+const*)

then insert the values of the constants, which we will later try to determine
by fitting the data to a theoretical hypothesis. No represents the number of samples.

(*A=1.0;const=0.0;f=1/10;no=64;*)

(*pl1=Plot[signal[t],{t,0,no},PlotRange->All,
		Frame->True,FrameLabel->{Frequency,Signal Strength}]*)

and then generate an array of time values

(*tvec=Table[N[i],{i,no}];*)

We now simulate Gaussian random noise random values with a mean value 
mu = 0 and standard deviation sigma = 1:

(*Needs["Statistics`ContinuousDistributions`"]*)

Set the noise sigma = 1.

(*sigma=1.0;*)

(*ran=Table[RandomReal[NormalDistribution[0, sigma]],{no}];*)

We generate the simulated noisy data by adding the random noise to the signal :

(*dvec=N[signal[tvec]+ran];*)

(*pl2=ListPlot[dvec,Frame->True,Joined->False]*)

Store Simulated Data in a File

Write the data to a file with each line consisting of a time and y value.
As a first step create array tarr with the Transpose operation which takes 
the 2 separate lists (i.e. 2 rows, one of time values and one of y) and converts each list (row) into a column.
   Next open a write stream called stmp (a pointer to the file "a:spectrum.dat" that we want to write to) with OpenWrite. FormatType->OutputForm causes the o/p to the file to be without any {{ }} brackets.
   In the Write statement PaddedForm controls total number of digits and number to the right of the decimal place. Purpose of TableForm is to create a table with each line containing a time and y value but without the list brackets {} of mathematica format. We want to simulate a data table that will look like the typical data table you would expect to import from other software.
    TableSpacing ->{0,3} creates 0 extra spaces between table rows and leaves 3 spacings between each entry in each row. Finally we close the output stream.

(*tarr=Transpose[{tvec,dvec}];*)

On a Windows system (one pair of x,y values per line). Note you need to remove (* and *) from the end of line to execute this command.

(*stmp=OpenWrite["c:\\temp\\fft1.dat",FormatType->OutputForm]*)

You can also append numbers to an existing file by using OpenAppend instead.

(*Write[stmp,PaddedForm[TableForm[tarr,TableSpacing->{0,3}],{10,6}]]*)

(*Close[stmp]*)

Example of output format for UNIX

You need to remove (* and *) from the end of line to execute this command

(*stmp=OpenWrite["/home/yourID/FFT.dat", FormatType ->OutputForm]*)

You need to add the Write statement and Close[stmp] as above.

FFT of time series

Need zero  padding for Fourier  (nt = total no. of points)

nt=1024;

zpad=Table[0.00001,{i,1,nt-no}];

data1=Join[dvec,zpad];

Note Mathematica defines the Fourier transform as
(Subscript[H, n]) = (1/(Sqrt[nt]))(∑_(k=1)^no)(Subscript[A, k]) (e^(i 2 π (k-1) (n-1)/nt)),
where no = number of data points, nt = total points including zero pads.
Notice that the zero frequency term appears at position 1 in the resulting list. 
Also note that the convention for defining the Fourier transform used in Mathematica is the one common in the physical sciences. In electrical engineering, the sign of the exponent is typically reversed.
We want the (Sqrt[ ]) term to be (Sqrt[no])) not (Sqrt[nt]). Therefore need to multiply
transform by (Sqrt[(nt/no)]).

The Fourier transform has both a real and imaginary component. Here we display the absolute value of the transform.

fftabs=(Sqrt[(nt/no)]) Abs[Fourier[data1]];

ListPlot[fftabs,Joined->True,PlotRange->All,Frame->True]

Compute the one sided Power Spectral Density, psd = P1side

psd2=fftabs fftabs;

ff[j_]:=Which[j==1,psd2[[j]],
		j>1&&j≤(nt/2),psd2[[j]]+psd2[[nt+2-j]],
		j==(nt/2)+1,psd2[[(nt/2)+1]]]

p1side=Table[ff[i],{i,1,(nt/2)+1}];

maxp1side=Max[p1side]

freq=Table[((i-1)/nt),{i,1,(nt/2)+1}];

psd1=Transpose[{freq,p1side}];

Plot the one sided PSD

pl3=ListPlot[psd1,Joined->True,Frame->True,PlotRange->All]

Normalize to a peak value of one.

np1side=(p1side/(Max[p1side]));

npsd1=Transpose[{freq,np1side}];

plpsd=ListPlot[npsd1,Joined->True,Frame->True,PlotRange->{{0.05,0.15},{0.,1.}}]

App. B: Fourier image convolution & deconvolution

Clean up and load special packages

Remove["Global`*"]

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

Needs["LinearAlgebra`MatrixManipulation`"]

Import an image and display

This assumes you have GIF digital image on your computer that you want use for the exercise.Mathematica recognizes a wide variety of image formats, check out the Import command in Help for a list of these formats. If you don't have a convenient image jump down to Load Stored Image.

Set the size of the images we'll be dealing with

size=64;

To import your image.gif on a Windows system (one pair of x,y values per line). The image file is assumed to be located in directory temp  on drive c. You will need to remove the (* and *) at the ends of the line.

(*img=Import["c:\\temp\\image.gif"];
Show[img];*)

Use the next line for a Unix or Linux system to declare the infile. You will need to remove the (* and *) at the ends of the line.

(*img=Import["~gregory//image.gif"];
Show[img];*)

Load stored image: The loaded image is in the form of a graphics Raster. To perform numerical calulations on the image we want to convert the image to a two dimensional array of numbers or a List of Lists. This is down with the following command. You will need to remove the (* and *) at the ends of the line.

(*img1=img[[1,1]];*)

Shift click on the outer brace of this line will set up the two dimensional image array img1, so we can proceed with the demonstration in case you don't have your own image.

img1={{190,191,197,202,208,209,214,214,216,221,218,218,218,218,218,221,221,213,210,206,189,158,145,147,139,121,84,73,75,74,67,68,74,69,66,77,70,68,73,83,91,110,124,144,158,165,167,144,141,180,183,129,110,102,120,138,92,88,122,146,157,184,174,159},{190,191,197,195,201,202,214,214,216,221,218,218,218,218,218,224,212,182,178,132,135,155,166,168,136,103,84,73,75,74,67,73,79,72,57,60,61,63,80,90,98,117,131,144,158,172,174,160,137,139,166,147,133,138,129,120,112,124,181,208,204,202,200,211},{180,182,194,199,204,206,209,209,211,216,218,218,218,221,217,207,195,166,134,120,140,168,172,166,123,109,81,77,72,69,62,80,84,78,50,57,69,74,86,96,111,121,128,150,154,172,174,155,136,141,149,163,156,138,145,142,113,122,176,198,207,204,211,218},{173,175,187,192,197,199,209,209,211,216,218,218,218,202,190,168,149,124,112,128,139,156,165,159,123,109,88,84,79,69,62,65,87,71,54,69,76,81,100,110,118,128,135,157,161,165,167,155,136,137,132,179,179,175,181,177,159,145,163,186,195,197,204,211},{162,164,183,190,195,197,204,204,211,216,207,218,212,191,174,145,122,114,114,124,123,142,163,159,116,102,81,81,81,70,61,54,77,66,64,75,82,88,109,117,126,125,136,151,156,164,167,160,140,138,144,192,195,192,192,190,165,158,166,191,200,202,206,199},{162,164,183,190,195,197,204,204,211,216,210,210,198,140,145,128,114,108,108,106,105,124,147,145,110,96,81,81,81,75,54,49,57,66,56,63,92,102,126,124,126,125,136,151,156,158,161,160,140,132,138,186,200,197,202,205,176,155,143,175,207,203,195,198},{162,164,183,190,195,197,204,204,211,216,211,205,188,133,136,117,109,104,104,94,93,112,118,117,106,92,81,81,81,78,49,46,43,42,56,79,99,111,137,129,126,125,136,151,156,154,157,160,140,128,134,182,185,182,190,198,183,153,128,145,194,204,188,179},{158,162,185,185,191,192,203,208,214,214,210,207,157,131,136,112,106,104,95,87,82,93,103,110,101,82,63,74,90,76,51,43,43,47,56,74,129,142,155,145,132,138,142,148,163,170,157,147,134,104,115,151,171,176,184,186,188,155,106,116,165,184,181,157},{158,162,185,185,191,192,203,208,214,214,213,200,144,121,125,112,106,94,84,75,75,95,108,115,101,82,58,69,85,76,51,43,43,47,56,74,132,144,174,164,143,141,140,138,152,167,166,142,129,113,119,147,150,155,168,174,188,155,106,104,149,174,171,149},{162,163,176,185,191,192,198,203,204,204,206,185,143,125,113,109,104,93,83,67,66,85,96,93,95,87,64,57,67,75,65,70,85,95,89,112,145,154,176,182,161,151,154,144,154,165,167,141,116,107,110,134,115,134,148,151,179,154,98,91,136,158,169,159},{162,163,176,185,191,192,198,203,204,204,209,171,146,117,109,114,109,100,82,55,55,73,79,76,83,83,64,57,67,91,126,137,167,169,170,170,163,165,182,187,180,160,158,150,160,170,173,147,114,101,104,128,109,116,136,139,171,162,90,85,130,146,167,159},{176,176,183,190,195,197,204,204,204,204,207,169,143,108,102,115,116,96,77,61,53,61,67,70,61,61,53,60,89,126,175,178,195,195,201,204,196,195,189,183,180,170,150,153,158,168,169,157,118,99,102,126,100,107,127,130,168,165,102,96,131,156,165,160},{176,176,183,190,195,197,204,204,204,204,201,163,138,111,111,119,112,96,77,61,53,61,62,64,56,56,64,70,100,143,182,183,200,200,206,210,207,205,199,194,192,171,143,122,140,159,165,162,124,99,102,126,100,107,122,125,161,164,110,106,141,156,165,165},{171,173,185,190,195,197,204,204,199,199,198,163,126,105,113,127,116,96,77,57,57,57,59,56,49,59,71,77,107,142,180,177,194,205,210,214,214,214,208,208,208,203,199,131,112,141,163,157,136,104,107,131,109,106,116,125,153,166,126,127,152,169,172,161},{171,173,185,190,195,197,204,204,199,199,198,163,126,105,113,131,120,96,77,57,57,57,59,56,49,59,75,81,111,141,171,177,194,200,206,210,214,214,213,213,212,207,203,182,128,111,135,156,141,112,115,139,116,106,120,129,157,170,130,135,160,173,176,165},{171,173,185,190,195,197,204,204,199,199,198,163,126,105,113,137,126,96,77,57,57,57,59,56,49,59,81,88,117,140,158,177,194,194,200,203,214,214,219,219,218,213,209,210,199,132,105,155,149,124,127,151,127,105,126,135,163,176,136,147,172,179,182,171},{180,181,188,195,200,202,204,204,204,204,205,169,134,109,120,141,125,98,79,71,67,62,55,51,54,69,75,81,109,135,157,174,183,195,200,204,204,204,212,212,214,214,214,207,202,191,164,131,144,132,140,150,138,126,137,142,169,177,152,158,171,179,182,172},{180,181,188,195,200,202,204,204,204,204,191,189,140,109,120,148,133,98,79,71,67,62,55,51,61,76,77,76,93,120,143,159,186,195,200,204,204,204,205,205,214,214,214,214,209,209,204,146,127,147,154,165,164,143,144,149,166,183,169,165,178,179,182,180},{176,177,190,199,199,199,204,204,204,204,212,191,144,106,114,147,132,96,82,71,63,52,44,44,70,86,76,71,85,121,152,163,188,190,197,201,204,204,207,207,205,210,213,214,214,211,208,180,141,141,159,165,174,158,151,155,177,181,168,171,184,194,187,181},{176,177,190,199,199,199,204,204,204,204,209,200,161,108,109,133,118,89,75,71,63,52,46,54,91,107,97,81,78,105,142,151,176,183,178,175,191,197,200,200,205,210,213,214,214,211,208,202,172,138,164,182,196,180,166,164,184,188,175,178,191,194,187,188},{181,182,195,195,195,195,199,199,199,199,206,190,165,109,115,121,101,84,75,69,59,46,54,64,93,106,102,85,60,107,172,191,184,193,154,128,143,160,185,190,205,210,213,214,214,214,214,201,191,142,157,183,203,196,181,172,193,195,179,182,189,193,187,190},{181,182,195,195,195,195,199,199,199,199,198,191,174,117,117,109,89,72,62,54,52,48,54,64,77,82,66,74,86,112,153,163,172,167,175,181,179,180,191,196,205,210,213,214,214,214,214,206,205,147,138,171,192,197,181,172,184,193,187,188,195,199,193,190},{181,182,195,195,195,195,199,199,199,199,192,192,179,122,117,101,81,64,54,44,46,49,54,64,85,83,84,90,98,133,158,169,188,192,203,210,192,192,195,200,205,210,213,214,214,214,214,209,214,150,125,164,185,198,181,172,179,192,193,192,199,203,197,190},{185,186,192,195,195,195,195,195,199,199,195,198,186,137,109,88,68,52,47,47,47,47,69,88,114,105,98,94,128,171,167,185,204,204,204,204,197,196,187,192,200,205,209,209,209,209,209,215,211,175,117,139,161,180,186,185,186,198,195,197,203,198,192,190},{185,186,192,195,195,195,195,195,199,199,195,198,186,138,105,77,57,47,42,47,47,47,75,100,138,132,97,88,113,159,179,196,202,204,204,204,187,185,187,192,200,205,209,209,209,209,209,215,211,182,118,132,146,165,180,184,186,198,195,197,203,198,192,190},{180,181,188,190,190,190,195,195,195,195,194,189,185,137,101,67,56,47,47,47,46,65,73,93,125,133,93,83,89,128,181,203,203,201,203,191,170,170,192,197,195,200,204,204,204,209,209,208,203,182,136,126,138,155,176,187,191,198,191,197,203,198,192,185},{180,181,188,190,190,190,195,195,195,195,194,189,185,131,95,67,56,47,47,47,46,65,77,84,99,104,88,92,116,148,179,186,186,198,190,172,171,175,192,197,195,200,204,204,204,209,209,208,203,190,138,119,131,152,176,187,191,198,191,197,203,198,192,185},{180,181,188,190,190,190,195,195,195,195,195,198,186,127,92,69,54,47,47,43,46,70,76,83,100,100,87,121,159,184,194,199,199,199,173,169,174,178,192,198,200,200,200,204,204,207,203,199,199,182,137,110,120,150,172,183,195,203,195,196,193,189,182,176},{180,181,188,190,190,190,195,195,195,195,195,198,186,125,89,69,54,47,47,48,51,75,81,88,100,100,97,115,169,192,201,199,199,192,175,177,179,183,198,203,205,205,205,204,204,207,203,199,199,187,143,115,112,148,166,181,195,203,195,196,193,189,182,181},{180,181,188,190,190,190,195,195,195,195,190,193,181,138,115,69,54,43,43,45,54,68,87,95,100,100,95,84,146,174,193,198,195,194,189,185,185,185,194,205,214,214,214,209,209,209,209,203,198,189,146,121,96,143,167,181,195,199,186,194,184,191,181,185},{180,181,188,190,190,190,195,195,195,195,190,193,181,136,118,73,58,43,43,44,57,77,95,98,100,100,93,77,132,170,189,198,195,194,189,185,185,185,190,201,210,210,210,209,209,209,209,203,198,187,149,130,97,141,167,181,195,199,186,194,184,187,177,185},{180,181,188,190,190,190,195,195,195,195,190,193,181,135,123,79,64,43,43,42,62,92,105,102,100,100,89,67,111,164,183,198,195,194,189,185,185,185,184,195,204,204,204,209,209,209,209,203,198,185,153,145,98,137,167,181,195,199,186,194,184,181,171,185},{176,176,183,185,185,185,190,190,190,190,190,193,181,135,121,83,68,51,46,43,55,73,89,95,96,91,87,80,116,161,187,195,195,190,184,180,181,181,182,188,192,196,200,204,209,209,209,206,202,184,162,148,114,143,176,187,195,192,186,189,182,177,175,177},{176,176,183,185,185,185,190,190,190,190,190,193,181,135,121,83,68,51,46,45,51,60,62,73,85,81,87,80,116,161,187,195,195,190,184,180,176,176,182,188,186,191,195,199,204,209,209,201,197,179,157,143,119,148,176,187,190,186,181,183,177,171,179,177},{176,176,183,185,185,185,190,190,190,190,190,193,181,127,115,82,67,46,42,33,41,52,49,60,78,61,79,78,103,165,189,198,190,184,160,157,152,154,165,176,182,187,191,203,208,204,204,203,184,167,149,141,127,159,177,183,189,177,180,178,172,173,185,190},{176,176,183,185,185,185,190,190,190,190,190,193,181,127,115,70,55,46,42,33,41,52,54,76,67,43,65,71,106,165,189,198,190,178,154,151,140,133,132,152,164,177,188,203,208,204,204,197,179,153,141,143,147,160,177,183,189,177,180,178,172,173,185,190},{166,166,166,169,178,178,179,183,185,185,185,185,185,130,94,63,47,42,37,35,37,60,52,55,47,37,41,60,115,161,197,197,180,179,140,162,107,91,88,120,141,173,186,198,203,203,196,187,172,157,140,154,159,154,176,187,189,177,180,176,173,181,188,190},{93,93,93,104,127,140,183,181,185,185,185,185,185,135,99,63,47,42,37,39,46,77,73,63,61,51,55,73,129,159,186,192,175,163,114,102,69,57,64,94,142,177,192,198,203,193,186,170,162,155,144,166,168,153,176,187,189,177,180,176,173,181,188,190},{48,48,55,50,47,56,161,172,180,180,180,186,190,135,96,58,43,42,37,34,48,89,106,107,92,86,90,120,145,163,183,190,176,170,153,142,107,107,130,169,183,191,196,199,189,183,173,157,157,138,153,174,182,151,180,188,179,172,179,176,176,181,188,190},{107,108,114,114,73,63,165,176,180,180,180,186,190,145,102,58,43,42,37,39,37,55,65,70,77,91,124,145,157,166,178,182,168,173,170,168,164,164,182,192,199,200,201,199,189,179,169,153,153,142,157,178,186,155,176,184,179,172,179,176,176,181,188,190},{179,180,186,186,129,104,171,182,180,180,180,186,190,160,112,58,43,42,37,38,41,65,57,70,110,119,148,156,148,171,171,170,156,152,168,180,187,187,186,193,195,188,182,199,189,173,163,147,147,148,163,184,192,161,170,178,179,172,179,176,176,181,188,190},{180,181,188,192,136,111,168,176,180,180,180,180,180,166,135,60,45,46,42,38,45,56,78,93,127,146,147,151,156,163,170,172,157,154,155,156,170,172,173,178,183,188,191,195,191,166,153,154,154,151,173,186,181,162,165,168,174,174,174,173,179,185,185,193},{180,181,188,192,136,111,168,176,180,180,180,180,180,171,148,67,52,46,42,38,45,56,73,88,122,142,147,151,156,163,170,178,181,184,180,178,181,179,182,187,190,195,199,195,191,164,144,161,161,168,182,183,174,155,158,161,167,167,167,173,179,185,185,186},{180,180,180,186,129,108,164,172,176,176,171,171,171,166,148,64,63,51,41,38,45,56,75,88,120,134,142,146,152,156,168,172,189,185,190,194,190,190,195,195,195,195,195,195,190,161,131,135,159,165,178,177,171,158,151,160,157,160,166,175,188,182,188,195},{180,180,180,186,129,108,171,179,176,176,178,178,178,179,168,76,65,58,48,38,45,56,67,81,106,120,142,146,152,149,161,165,182,178,183,187,190,190,195,195,195,195,195,188,183,153,124,120,154,168,173,160,164,151,151,160,157,160,166,175,188,189,195,195},{171,172,178,183,109,94,170,180,176,176,180,180,180,177,173,79,75,57,47,42,38,51,66,79,102,116,129,144,147,154,160,167,175,176,181,185,184,186,195,195,195,195,195,186,184,149,119,109,143,161,167,156,148,148,157,157,152,159,170,175,188,195,195,195},{171,172,178,183,109,94,171,173,176,176,180,180,180,183,179,90,76,57,47,42,38,51,66,79,108,122,129,144,147,154,160,167,175,176,181,185,184,186,195,195,195,195,195,181,170,133,108,103,107,128,141,140,136,136,151,151,152,159,170,175,188,195,195,195},{171,172,178,183,109,94,173,168,176,176,180,180,180,187,183,97,77,57,47,42,38,51,66,79,112,126,129,144,147,154,160,167,175,176,181,185,184,186,195,195,195,195,195,178,162,121,101,98,82,107,124,130,127,127,147,147,152,159,170,175,188,195,195,195},{171,172,178,185,111,103,168,172,176,176,176,176,176,181,172,104,77,51,46,43,43,43,56,68,103,122,129,137,148,150,157,158,167,172,177,181,185,187,190,190,190,185,181,164,136,96,92,78,71,98,113,116,121,129,139,145,151,158,169,179,192,199,199,199},{171,172,178,178,112,107,168,172,176,176,176,176,176,181,172,110,82,51,46,43,43,43,46,57,92,112,124,131,142,145,151,153,162,167,172,176,180,182,190,190,185,180,176,144,109,85,91,62,61,88,103,106,111,129,139,145,156,164,175,184,197,199,199,199},{176,176,176,182,99,99,168,172,176,176,176,176,176,180,175,123,77,53,42,47,43,38,41,49,80,89,108,116,127,148,154,151,159,164,170,173,178,178,182,182,178,161,136,112,98,82,68,58,61,89,96,107,111,130,140,151,154,165,181,188,198,204,204,204},{176,176,176,174,101,103,168,172,176,176,176,176,176,180,175,128,82,53,42,47,43,38,40,41,57,66,83,97,118,136,143,145,153,159,164,168,173,173,164,164,151,125,94,82,76,66,59,55,69,83,90,101,106,137,145,157,160,171,187,194,203,204,204,204},{175,175,175,170,92,101,169,168,176,176,176,176,176,180,175,142,96,56,42,38,38,38,38,38,42,48,57,69,87,104,123,128,145,142,147,151,156,154,144,127,92,77,65,65,65,56,56,54,63,78,84,93,117,144,147,159,167,178,194,204,204,204,204,199},{170,170,170,163,93,105,169,168,176,176,176,176,176,180,175,147,101,67,46,38,38,38,38,38,43,41,41,47,56,77,96,107,124,133,138,142,137,133,100,72,62,54,48,55,55,51,51,54,63,76,88,106,121,138,147,159,167,178,194,204,204,204,204,199},{166,165,159,148,104,123,169,168,171,171,171,171,171,179,183,149,119,77,63,56,44,47,42,42,43,43,43,46,52,43,53,74,91,87,87,87,80,75,53,53,38,38,38,38,38,43,43,50,64,76,91,113,123,135,149,154,172,187,190,204,204,199,199,199},{166,165,159,148,104,123,169,168,171,171,171,171,171,179,183,154,130,81,67,56,44,47,46,46,43,43,43,46,52,46,48,51,61,67,67,67,48,45,38,38,38,38,38,38,38,43,43,54,68,80,95,117,127,139,153,158,176,191,194,204,204,199,199,199},{166,165,159,148,104,123,169,168,171,171,171,171,171,179,183,161,147,87,73,56,44,47,52,52,43,43,43,46,52,51,41,42,42,36,36,36,37,38,43,43,38,38,38,38,38,43,43,60,74,86,101,123,133,145,159,164,182,197,200,204,204,199,199,199},{162,162,161,139,109,127,165,170,171,171,171,171,171,175,178,169,148,109,75,58,46,49,45,48,51,46,38,42,47,47,47,43,35,33,33,33,37,39,38,38,38,38,38,37,42,43,47,61,75,104,115,131,139,152,167,170,186,198,195,199,199,199,199,195},{172,170,155,129,111,133,165,170,171,171,171,171,171,175,178,176,155,123,89,65,53,56,45,48,51,46,38,42,47,47,47,51,42,33,33,33,37,39,38,38,38,38,38,37,42,52,63,82,96,118,129,145,146,159,167,170,186,198,195,199,199,199,199,195},{167,159,161,123,119,135,169,164,170,170,170,170,170,175,175,172,160,132,99,71,60,44,47,47,47,47,43,43,43,38,38,38,38,43,43,43,43,43,38,38,34,39,43,42,54,59,69,90,109,133,137,143,152,165,177,180,190,194,199,199,199,199,199,187},{167,159,161,123,119,135,162,157,163,163,163,163,163,168,168,166,166,146,113,78,67,51,47,47,47,47,43,43,43,38,38,38,38,43,43,43,43,43,38,38,42,46,50,44,46,54,71,104,123,141,144,150,159,172,184,187,190,194,199,199,199,192,192,182},{163,157,162,119,134,151,166,166,166,166,171,171,171,171,171,176,176,166,138,89,69,58,54,51,47,47,47,47,47,38,38,37,28,38,38,38,37,38,41,41,43,48,51,62,59,69,83,115,134,138,145,156,165,178,186,174,186,198,195,199,199,195,195,188},{163,157,162,119,134,151,166,166,166,166,171,171,171,171,171,176,176,181,171,122,95,74,66,63,53,53,47,47,47,38,38,43,34,38,38,38,43,44,47,47,49,54,58,66,72,88,101,121,140,144,151,162,177,190,185,164,186,198,195,199,199,195,195,188},{163,157,162,119,134,151,166,166,166,166,171,171,171,171,171,176,176,173,174,144,112,85,74,71,57,57,47,47,47,38,38,47,38,38,38,38,47,48,51,51,53,58,62,69,81,100,113,125,144,148,155,166,185,198,176,164,186,198,195,199,199,195,195,188}};

img = N[img1/Max[img1]];
oimg=img;
Show[Graphics[ Raster[ img ] ]]
Max[img]
Min[img]

Create the smearing point spread function (psf) and display

Create the two dimensional Gaussian (2 dim. multinormal distribution) Point Spread Function (PSF) with a mean of 0, variances of 1, and zero co-variance. The first argument {0,0} indicates the multinormal distribution is centered at 0,0.
The second argument {{1,0},{0,1}} gives the covariance of the distribution. Since the off diagonal elements are zero and the diagonal elements are equal, we have a circularly symmetric multinormal.

<<MultivariateStatistics`

ndist=MultinormalDistribution[{0,0},{{1,0},{0,1}}]

Obtain the two dimensional Gaussian's probability density function

pdf = PDF[ndist,{x,y}]

Sample the Gaussian distribution to generate a map of the PSF

psf=N[Table[Table[pdf,{x,-10,10-(20/size),20/size}],{y,-10,10-(20/size),20/size}]];
Show[ Graphics[ Raster[ psf/Max[psf] ] ] ]
Max[psf]
Min[psf]

Use the Fourier Transform to carry out the convolution

conv=InverseFourier[Fourier[img] Fourier[psf]];

Length[conv]

Look at first element of first row in the convolved image

conv[[1,1]]

To get rid of the small imaginary term use the command Chop.

nconv=Chop[conv];

Show[ Graphics[ Raster[ nconv/Max[nconv] ] ] ]

The convolved picture does not look anything like the original because of aliasing.

As a check that we are using Fourier and InverseFourier commands Okay, do the following.

convimg=InverseFourier[Fourier[img]];

convimg[[1,1]]

nconvimg=Chop[convimg];

Show[ Graphics[ Raster[nconvimg/Max[nconvimg] ] ] ]

Good, this looks like the original!

Zero pad image and psf before convolving

We now want to zero pad our image to prevent aliasing. Below we illustrate a simple way to zero pad a simple 5x5 array.

testim=Table[1,{i,1,5},{j,1,5}]

Now append zeroes to each row of the array, Transpose and append zeros to the new rows (former columns). Then Transpose padded array back.

pad=10;testim2={};testim3={};Do[testim2=Append[testim2,PadRight[testim[[i]],pad,0]],{i,1,5}];testim4=Transpose[testim2];
Do[testim3=Append[testim3,PadRight[testim4[[i]],pad,0]],{i,1,pad}];testim5=Transpose[testim3]

MatrixForm[testim5]

Show[Graphics[ Raster[ testim5 ] ]]

Take[testim5, {1, 5}, {1, 5}] //MatrixForm

Now we zero pad our original image to a 128x128 image.

pad=128;im2={};im4={};Do[im2=Append[im2,PadRight[img[[i]],pad,0]],{i,1,size}];im3=Transpose[im2];
Do[im4=Append[im4,PadRight[im3[[i]],pad,0]],{i,1,pad}];im5=Transpose[im4];

Show[Graphics[ Raster[ im5 ] ]]

Length[im5]

We also need to zero pad the smearing point spread function to a 128x128 array.

pad=128;psf2={};psf4={};Do[psf2=Append[psf2,PadRight[psf[[i]],pad,0]],{i,1,size}];psf3=Transpose[psf2];
Do[psf4=Append[psf4,PadRight[psf3[[i]],pad,0]],{i,1,pad}];psf5=Transpose[psf4];

Show[Graphics[ Raster[ psf5/Max[psf5] ] ]]

Length[psf5]

Now repeat the convolution of the zero padded image

conv5=InverseFourier[Fourier[im5] Fourier[psf5]];

Length[conv5]

conv5[[1,1]]

conv5chop=Chop[conv5];

Max[conv5chop]

convimpad=conv5chop/Max[conv5chop];

Show[ Graphics[ Raster[ convimpad ] ] ]

Now we attempt to deconvolve the convolved image

We divide the transformed convolved image by the transformed psf5. Since Fourier[psf5] will be very close to zero in some regions we add a small constant to prevent dividing by a very small number (try varying the constant). Then we InverseTransform back.

invconv5=InverseFourier[Fourier[conv5] /(Fourier[psf5]+15*(10^(-7)))];

invconv5[[1,1]]

invconv5chop=Chop[invconv5];

num=Max[invconv5chop];

invconvimpad=invconv5chop/Max[invconv5chop];

Show[ Graphics[ Raster[ invconvimpad] ] ]

Grab the submatrix containing the final deconvolved image.

restored=Take[invconvimpad, {1,size}, {1, size}];
Show[ Graphics[ Raster[restored] ] ]