FindFit with BinCounts or Histogram in Mathematica - wolfram-mathematica

daList={62.8347, 88.5806, 74.8825, 61.1739, 66.1062, 42.4912, 62.7023,
39.0254, 48.3332, 48.5521, 51.5432, 69.4951, 60.0677, 48.4408,
59.273, 30.0093, 94.6293, 43.904, 59.6066, 58.7394, 68.6183, 83.0942,
73.1526, 47.7382, 75.6227, 58.7549, 59.2727, 26.7627, 89.493,
49.3775, 79.9154, 73.2187, 49.5929, 84.4546, 28.3952, 75.7541,
72.5095, 60.5712, 53.2651, 33.5062, 80.4114, 63.7094, 90.2438,
55.2248, 44.437, 28.1884, 4.77477, 36.8398, 70.3579, 28.1913,
43.9001, 23.8907, 12.7823, 22.3473, 57.6724, 49.0148}
The above are a sample of actual data I am dealing with.
I use BinCounts, but this is just to illustrate visually histogram should do it : I would like to fit the shape of that histogram
Histogram#data
I know how to fit datapoints themselves like :
model = 0.2659615202676218` E^(-0.2222222222222222` (x - \[Mu])^2)
FindFit[data, model, \[Mu], x]
Which is far from what I wan to do : How can I fit bin-counts/histograms in Mathematica ?

If you have MMA V8 you could use the new DistributionFitTest
disFitObj = DistributionFitTest[daList, NormalDistribution[a, b],"HypothesisTestData"];
Show[
SmoothHistogram[daList],
Plot[PDF[disFitObj["FittedDistribution"], x], {x, 0, 120},
PlotStyle -> Red
],
PlotRange -> All
]
disFitObj["FittedDistributionParameters"]
(* ==> {a -> 55.8115, b -> 20.3259} *)
disFitObj["FittedDistribution"]
(* ==> NormalDistribution[55.8115, 20.3259] *)
It can fit other distributions too.
Another useful V8 function is HistogramList, which provides you with Histogram's binning data. It takes about all of Histogram's options too.
{bins, counts} = HistogramList[daList]
(* ==> {{0, 20, 40, 60, 80, 100}, {2, 10, 20, 17, 7}} *)
centers = MovingAverage[bins, 2]
(* ==> {10, 30, 50, 70, 90} *)
model = s E^(-((x - \[Mu])^2/\[Sigma]^2));
pars = FindFit[{centers, counts}\[Transpose],
model, {{\[Mu], 50}, {s, 20}, {\[Sigma], 10}}, x]
(* ==> {\[Mu] -> 56.7075, s -> 20.7153, \[Sigma] -> 31.3521} *)
Show[Histogram[daList],Plot[model /. pars // Evaluate, {x, 0, 120}]]
You could also try NonlinearModeFit for fitting. In both cases it is good to come with your own initial parameter values to have the best chances that you end up with a globally optimal fit.
In V7 there is no HistogramList but you could get the same list using this:
The function fh in Histogram[data,bspec,fh] is applied to two
arguments: a list of bins {{Subscript[b, 1],Subscript[b,
2]},{Subscript[b, 2],Subscript[b, 3]},[Ellipsis]}, and corresponding
list of counts {Subscript[c, 1],Subscript[c, 2],[Ellipsis]}. The
function should return a list of heights to be used for each of the
Subscript[c, i].
This can be used as follows (from my earlier answer):
Reap[Histogram[daList, Automatic, (Sow[{#1, #2}]; #2) &]][[2]]
(* ==> {{{{{0, 20}, {20, 40}, {40, 60}, {60, 80}, {80, 100}}, {2,
10, 20, 17, 7}}}} *)
Of course, you can still use BinCounts but the you miss MMA's automatic binning algorithms. You have to provide a binning of your own:
counts = BinCounts[daList, {0, Ceiling[Max[daList], 10], 10}]
(* ==> {1, 1, 6, 4, 11, 9, 9, 8, 5, 2} *)
centers = Table[c + 5, {c, 0, Ceiling[Max[daList] - 10, 10], 10}]
(* ==> {5, 15, 25, 35, 45, 55, 65, 75, 85, 95} *)
pars = FindFit[{centers, counts}\[Transpose],
model, {{\[Mu], 50}, {s, 20}, {\[Sigma], 10}}, x]
(* ==> \[Mu] -> 56.6575, s -> 10.0184, \[Sigma] -> 32.8779} *)
Show[
Histogram[daList, {0, Ceiling[Max[daList], 10], 10}],
Plot[model /. pars // Evaluate, {x, 0, 120}]
]
As you can see the fit parameters may depend quite a bit on your binning choice. Particularly the parameter I called s depends critically on the amount of bins. The more bins, the lower the individual bin counts and the lower the value of s will be.

Related

Warning Mathematica FittedModel: The precision of the argument function (MachinePrecision) is less than WorkingPrecision (MachinePrecision)

Fellows,
I couldn't figure why I am having the warning message from the following code in Mathematica:
data = {{0, 1}, {1, 0.02307044673005989`}, {2,
0.00784879347316981`}, {3, 0.0061305265946403195`}, {4,
0.0008550610216054799`}, {5, 0.00010928133254420425`}, {6,
0.000011431049984759768`}, {7, 1.93788101788827`*^-6}, {8,
1.6278670621771263`*^-6}, {9, 2.6661469926370584`*^-7}, {10,
3.443821224260662`*^-8}, {11, 7.413060538191399`*^-9}, {12,
1.4031525687948224`*^-9}, {13, 5.973790450062338`*^-10}, {14,
1.7434844383850214`*^-10}, {15, 2.6053424128998922`*^-11}, {16,
9.887095524831592`*^-12}, {17, 1.2318024865446659`*^-12}, {18,
2.2125640342387203`*^-13}, {19, 1.3176590670511745`*^-13}, {20,
2.7354393146500743`*^-14}};
fit = NonlinearModelFit[data, a + b Exp[-x/c], {a, b, c}, x,
MaxIterations -> \[Infinity], PrecisionGoal -> MachinePrecision,
WorkingPrecision -> MachinePrecision];
fit["BestFitParameters"] (* THE WARNING APPEARS AFTER CALLING THIS FUNCTION *)
The warning message is:
FittedModel: The precision of the argument function (MachinePrecision) is less than WorkingPrecision (MachinePrecision).
Thanks in advance.
The problem is that many of the data values are small and close to machine precision. You can try linear fitting to the Log of the data values.
data2 = {First[#], Log[Last[#]]} & /# data;
lm = LinearModelFit[data2, x, x]
Show[ListPlot[data2], Plot[lm[x], {x, 0, 20}]]
The first data point {0, 1} does not look right. Are you sure it is correct?

Plotting a 3 dimensional bar graph in Mathematica involving three axes of data

So I am fairly new to Mathematica and I have been having trouble finding a way of displaying three dimensional data in a bar structure in Mathematica. However, the best that I can do to represent my data.
My data is formatted in a way that I have a three coordinate structure for all of the points but I want to have each individual point represented. The data is as follows:
{0, 220, 0.05}, {0, 230, 0.33}, {0, 230, 0}, {0, 230, 0},
{0, 250, 1.04}, {0, 250, 0.26}, {0, 250, 1.01}, {0, 250, 4.83}, {0, 250, 0},
{0, 270, 2.69}, {10, 220, 0.6}, {10, 240, 1.28}, {10, 250, 0.97},
{15, 250, 0.25}, {15, 270, 3.52}
How can I make the graph a three dimensional graph with each coordinate point (all three axes) represented in its individual bar on the graph as opposed to a plane?
not sure what you are after -- note ListPlot3D doesn't work really right because some of your points are on top of each other..
Show[{ListPlot3D[data ], Graphics3D[{PointSize[.1], Point[data]}]}]
Show[Graphics3D#{Cuboid[{Append[#[[1 ;; 2]], 0] +
{2, 2, 0}, # - {2, 2, 0}}] & /# data}, Axes -> True,
AxesEdge -> {{-1, -1}, {1, -1}, {-1, -1}},
BoxRatios -> {1, 2, .5}]
ListPointPlot3D[{{0, 220, 0.05}, {0, 230, 0.33}, {0, 230, 0}, {0, 230,
0}, {0, 250, 1.04}, {0, 250, 0.26}, {0, 250, 1.01}, {0, 250,
4.83}, {0, 250, 0}, {0, 270, 2.69}, {10, 220, 0.6}, {10, 240,
1.28}, {10, 250, 0.97}, {15, 250, 0.25}, {15, 270, 3.52}},
Filling -> Bottom, DataRange -> All]
Is this what you want?

Generating Manipulate 'sliders' on the fly

Mathematica's Manipulate function takes as its final arguments separate lists of the parameters you want sliders for along with their value ranges. But why not a list of lists?
This way I could I easily generate all the sliders for this big list of transformation rules that I have, e.g.:
parms = {a -> 2, b -> 4, c -> 5};
Table[{{parms[[i]][[1]], parms[[i]][[2]]}, 0, 10}, {i, 1,Length[parms]}]
{{{a, 2}, 0, 10}, {{b, 4}, 0, 10}, {{c, 5}, 0, 10}}
What I would like to have, however, is:
{{a, 2}, 0, 10}, {{b, 4}, 0, 10}, {{c, 5}, 0, 10}
This I'm copy pasting now between cells, which is rather messy. I'm sure there's a better way to do this. Please help, thanks!
Please see this and this on similar questions.
What you need is Sequence## to get the list of lists to be treated as your desired output when used as input.
Perhaps something like:
ClearAll[a, b, c];
parms = {a -> 2, b -> 4, c -> 5};
With[{values = Table[parms[[i]][[1]], {i, 1, Length[parms]}],
controls = Sequence ##
Table[{{parms[[i]][[1]], parms[[i]][[2]],
Style[ToString[parms[[i]][[1]]], Red, Bold]}, 0, 10}, {i, 1,
Length[parms]}]},
Manipulate[values, controls]]
which gives

Overlapping strips

Suppose I have a series of strips of paper placed along an infinite ruler, with start and end points specified by pairs of numbers. I would like to create a list representing the number of layers of paper at points along the ruler.
For example:
strips =
{{-27, 20},
{ -2, -1},
{-47, -28},
{-41, 32},
{ 22, 31},
{ 2, 37},
{-28, 30},
{ -7, 39}}
Should output:
-47 -41 -27 -7 -2 -1 2 20 22 30 31 32 37 39
1 2 3 4 5 4 5 4 5 4 3 2 1 0
What is the most efficient, clean, or terse way to do this, accommodating Real and Rational strip positions?
Here's one approach:
Clear[hasPaper,nStrips]
hasPaper[y_, z_] := Piecewise[{{1, x <= z && x >= y}}, 0];
nStrips[y_, strip___] := Total#(hasPaper ### strip) /. x -> y
You can get the number of strips at any value.
Table[nStrips[i, strips], {i, Sort#Flatten#strips}]
{1, 2, 3, 3, 3, 4, 5, 5, 5, 5, 5, 5, 4, 3, 2, 1}
Also, plot it
Plot[nStrips[x, strips], {x, Min#Flatten#strips, Max#Flatten#strips}]
Here is one solution:
In[305]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[313]:= int = Interval /# strips;
In[317]:= Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}]
Out[317]= {{-47, 1}, {-41, 2}, {-28, 2}, {-27, 3}, {-7, 4}, {-2,
5}, {-1, 4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32,
2}, {37, 1}, {39, 0}}
EDIT Using SplitBy and postprocessing the following code gets the shortest list:
In[329]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[330]:= int = Interval /# strips;
In[339]:=
SplitBy[Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}],
Last] /. {b : {{_, co_} ..} :> First[b]}
Out[339]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1,
4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37,
1}, {39, 0}}
You may regard this as a silly approach, but I'll offer it anyway:
f[x_]:=Sum[UnitStep[x-strips[[k,1]]]-UnitStep[x-strips[[k,2]]],{k,Length[strips]}]
f/#Union[Flatten[strips]]
f[u_, s_] := Total[Piecewise#{{1, #1 <= x < #2}} & ### s /. x -> u]
Usage
f[#, strips] & /# {-47, -41, -27, -7, -2, -1, 2, 20, 22, 30, 31, 32, 37, 39}
->
{1, 2, 3, 4, 5, 4, 5, 4, 5, 4, 3, 2, 1, 0}
For Open/Closed ends, just use <= or <
Here's my approach, similar to belisarius':
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
pw = PiecewiseExpand[Total[Boole[# <= x < #2] & ### strips]]
Grid[Transpose[
SplitBy[SortBy[Table[{x, pw}, {x, Flatten[strips]}], First],
Last][[All, 1]]], Alignment -> "."]
Here's my attempt - it works on integers, rationals and reals, but makes no claim to being terribly efficient. (I made the same mistake as Sasha, my original version did not return the shortest list. So I stole the SplitBy fix!)
layers[strips_?MatrixQ] := Module[{equals, points},
points = Union#Flatten#strips;
equals = Function[x, Evaluate[(#1 <= x < #2) & ### strips]];
points = {points, Total /# Boole /# equals /# points}\[Transpose];
SplitBy[points, Last] /. {b:{{_, co_}..} :> First[b]}]
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31},
{2, 37}, {-28, 30}, {-7, 39}};
In[3]:= layers[strips]
Out[3]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1, 4}, {2, 5},
{20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37, 1}, {39, 0}}
In[4]:= layers[strips/2]
Out[4]:= {{-(47/2), 1}, {-(41/2), 2}, {-(27/2), 3}, {-(7/2), 4},
{-1, 5}, {-(1/2), 4}, {1, 5}, {10, 4}, {11, 5}, {15, 4}, {31/2, 3},
{16, 2}, {37/2, 1}, {39/2, 0}}
In[5]:= layers[strips/3.]
Out[5]= {{-15.6667, 1}, {-13.6667, 2}, {-9., 3}, {-2.33333, 4}, {-0.666667, 5},
{-0.333333, 4}, {0.666667, 5}, {6.66667, 4}, {7.33333, 5}, {10.,4},
{10.3333, 3}, {10.6667, 2}, {12.3333, 1}, {13., 0}}
Splice together abutting strips, determine key points where number of layers
changes, and calculate how many strips each key point inhabits:
splice[s_, {}] := s
splice[s_, vals_] := Module[{h = First[vals]},
splice[(s /. {{x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j},
w, z}, {x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j}, w,
z}}), Rest[vals]]]
splicedStrips = splice[strips, Union#Flatten#strips];
keyPoints = Union#Flatten#splicedStrips;
({#, Total#(splicedStrips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
// Transpose // TableForm
EDIT
After some struggling I was able to remove splice and more directly eliminate points that did not need checking (-28, in the strips data we've been using) :
keyPoints = Complement[pts = Union#Flatten#strips,
Cases[pts, x_ /; MemberQ[strips, {x, _}] && MemberQ[strips, {_, x}]]];
({#, Total#(strips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
One approach of solving this is converting the strips
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}
,{ 22, 31}, { 2, 37}, {-28, 30}, {-7, 39}}
to a list of Delimiters, marking the beginning or end of a strip and sort them by position
StripToLimiters[{start_, end_}] := Sequence[BeginStrip[start], EndStrip[end]]
limiterlist = SortBy[StripToLimiters /# strips, First]
Now we can map the sorted limiters to increments/decrements
LimiterToDiff[BeginStrip[_]] := 1
LimiterToDiff[EndStrip[_]] := -1
and use Accumulate to get the intermediate totals of intersected strips:
In[6]:= Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[limiterlist]
Out[6]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
Or without the intermediate limiterlist:
In[7]:= StripListToCountList[strips_]:=
Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[
SortBy[StripToLimiters/#strips,First]
]
StripListToCountList[strips]
Out[8]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
The following solution assumes that the layer count function will be called a large number of times. It uses layer precomputation and Nearest in order to greatly reduce the amount of time required to compute the layer count at any given point:
layers[strips:{__}] :=
Module[{pred, changes, count}
, changes = Union # Flatten # strips /. {c_, r___} :> {c-1, c, r}
; Evaluate[pred /# changes] = {changes[[1]]} ~Join~ Drop[changes, -1]
; Do[count[x] = Total[(Boole[#[[1]] <= x < #[[2]]]) & /# strips], {x, changes}]
; With[{n = Nearest[changes]}
, (n[#] /. {m_, ___} :> count[If[m > #, pred[m], m]])&
]
]
The following example uses layers to define a new function f that will compute the layer count for the provided sample strips:
$strips={{-27,20},{-2,-1},{-47,-28},{-41,32},{22,31},{2,37},{-28,30},{-7,39}};
f = layers[$strips];
f can now be used to compute the number of layers at a point:
Union # Flatten # $strips /. s_ :> {s, f /# s} // TableForm
Plot[f[x], {x, -50, 50}, PlotPoints -> 1000]
For 1,000 layers and 10,000 points, the precomputation stage can take quite a bit of time, but individual point computation is relatively quick:

Logarithmic Slider Control in Mathematica

I'm making a small interface for calculating voltage dividers in Mathematica. I have two sliders (z1 & z2) that represent the resistor values and a couple of sliders to represent Vin as a sinusoid.
The issue is that the range of available resistor values (in the real world) is roughly logarithmic on {r, 100, 1,000,000}. If I set my slider range to r, however, it's impractical to select common low resistor values in approx. {100, 10,000}.
Is it possible to create a slider that sweeps through a logarithmic range?
Manipulate[
Grid[{{Plot[(VinRCos[t] + VinC), {t, -3, 9},
PlotRange -> {-1, VMax}, AxesLabel -> {t, Vin}]}, {Plot[
z2/(z1 + z2)(VinR*Cos[t] + VinC), {t, -3, 9},
PlotRange -> {-1, VMax}, AxesLabel -> {t, Vout}]}},
ItemSize -> 20],
{{z1, 10000}, 10, 1000000, 10}, {z1}, {{z2, 10000}, 10,
1000000}, {z2}, Delimiter, {{VinR, 2.5}, 0,
5}, {VinR}, {{VinC, 2}, -VMax, VMax}, {VinC}]
Michael's answer is probably the best, i.e. just get the user to specify the exponent. An alternate solution is to make a LogSlider type command. Here's a simple example:
LogSlider[{v:Dynamic[var_], v0_?Positive}, {min_?Positive, max_?Positive},
base_:10, options___] := DynamicModule[{ev}, Dynamic[
var = base^ev;
Slider[Dynamic[ev], Log[base, {min, max}]]]]
LogSlider[v:Dynamic[var_], {min_?Positive, max_?Positive},
base_:10, options___] := LogSlider[{v, min}, {min, max}]
The function only has a subset of the flexibility of Slider and will have to be extended if you want custom step sizes etc...
You then modify your Manipulate by specifying the variables using
{{z1, 10000}, 10, 1000000, LogSlider[##]&} etc...
A simple fix is to just make the slider manipulate the exponent, and plug in e.g. 10^z1 where you need the actual value:
Manipulate[10^z1, {{z1, 5}, 2, 6}] (* 100 to 1M *)
In your particular case, you could of course also input a list of standard resistor values to pick from:
Manipulate[z1, {z1, {100, 110, 120, 130, 150, 160, 180, 200, 220, 240, 270}}]
HTH!
Here is my final result:
Manipulate[
Evaluate[Round[10^Z2]/(Round[10^Z1] + Round[10^Z2])*Vin] "V",
{{Z1, 5}, 2, 6},
Pane["Z1 = " Dynamic[Round[10^Z1] "[CapitalOmega]"],
ImageMargins -> {{2.5, 0}, {3, 0}}],
{{Z2, 5}, 2, 6},
Pane["Z2 = " Dynamic[Round[10^Z2] "[CapitalOmega]"],
ImageMargins -> {{2.5, 0}, {0, -5}}], {{Vin, 2.5}, 0, VMax},
Pane["Vin = " Dynamic[Vin "V"], ImageMargins -> {{0, 0}, {0, -5}}]]
Here is a start to LogSlider that produces the standard two-way behavior the other controls have.
LogSlider[Dynamic[x_], max_] :=
Module[{exp},
Dynamic[exp = Log[max, x];
Slider[Dynamic[exp, (exp = #; x = max^exp) &]]]]
{LogSlider[Dynamic#x, 10^6], Dynamic#x}

Resources