Dynamic in Mathematica without duplication of code - wolfram-mathematica

I'm trying to create three separate graphs, this code will give you the idea:
f[t_] := Sin[10 t] + Cos[15 t];
Slider[Dynamic[dx], {0.01, 1}]
var = Dynamic[Fourier[Table[f[t], {t, 0, 100, dx}]]];
ListLinePlot[Abs[var]]
ListLinePlot[Re[var]]
ListLinePlot[Im[var]]
This won't work because var hasn't been evaluated an so ListLinePlot/Abs/Re/Im does not recognize it as a list of numbers. Dynamic has to wrap ListLinePlot.
Wrapping ListLinePlot and everything else with Dynamic works. But then I would have to calculate Fourier[Table[... once for each graph. Per principle, I don't want to have this duplication of code.
This is a way that avoids duplication of code but is not as semantic as my proposed not working example above, plus it puts all series in one graph and not in three separate:
Dynamic[
ListLinePlot[
(#[Fourier[
Table[f[t], {t, 0, 100, dx}]
]]) & /# {Abs,Re,Min}, DataRange -> {0, 100}
]
]
Hopefully you can see now what I am trying to achieve. Something like my first piece of code except it should work. How can I do that?

In most cases you only need to wrap Dynamic around the expression that needs to be recomputed. As you noticed, if you wrap Dynamic around the contents of var, it will not work because ListPlot will see a Dynamic head, not the list, when you pass var to it. What needs to be recomputed in this case is the complete ListPlot.
The correct solution is to use a delayed definition for var (i.e. := instead of =) and wrap Dynamic around ListPlot:
f[t_] := Sin[10 t] + Cos[15 t];
Slider[Dynamic[dx], {0.01, 1}]
var := Fourier[Table[f[t], {t, 0, 100, dx}]];
Dynamic#ListLinePlot[Abs[var]]
Dynamic#ListLinePlot[Re[var]]
Dynamic#ListLinePlot[Im[var]]
People often get confused with Dynamic because it sometimes shows up deep within in expression, e.g. in your Slider example. But there Dynamic has a different function: setting a value.
Generally, unless used to set a value, Dynamic always needs to be the outermost head in an expression. (There are some exceptions, notably when we're handling expressions that directly correspond to what is shown on screen, and are handled by the front end, such as graphics primitives: Slider[Dynamic[x], {0, 5}], Graphics[{Disk[], Dynamic#Disk[{x, 0}]}] will work.)
Dynamic affects only the way expressions are displayed in the front end, not how the kernel sees them. Here's an example:
x=1
arr = {Dynamic[x], 2, 3}
The Front End will display arr as {1, 2, 3}, but the kernel still sees it as {Dynamic[x], 2, 3}. So if we calculate Total[arr], the front end will display it as 1 + 5 but the kernel will see if as Dynamic[x] + 5. I hope this clarifies the situation a bit.
Note: I did not want to use Manipulate in this solution because the OP didn't use it either. Manipulate is just a high level convenience function and everything it does can be achieved with Dynamic and some controls such as Slider.

You probably want something like this:
f[t_] := Sin[10 t] + Cos[15 t]
DynamicModule[{var},
Manipulate[
var = Fourier[Table[f[t], {t, 0, 100, dx}]];
{ListLinePlot[Abs[var]],
ListLinePlot[Re[var]],
ListLinePlot[Im[var]]},
{dx, 0.01, 1}
]]

Untested:
f[t_] := Sin[10 t] + Cos[15 t];
Slider[Dynamic[dx], {0.01, 1}]
Dynamic[var = Fourier[Table[f[t], {t, 0, 100, dx}]]];
Dynamic[ListLinePlot[Abs[var]]]
Dynamic[ListLinePlot[Re[var]]]
Dynamic[ListLinePlot[Im[var]]]
I think this should calculate Fourier just once. From my understanding, the ListLinePlots should be triggered by the change of var after evaluating Fourier (note that the assignment of var is inside the Dynamic).

Related

Mathematica non-linear model fitting optimization - multiple calls to a numerically integrated function that does not change

I have a main function that I am using to fit measured heat capacities to a certain model:
HeatCapacity[a_, t_] :=
If[t > 1,
t, (6*a^3/(\[Pi]^2*t)) NIntegrate[
FermiDirac[a, \[Epsilon],
t]*(1 - FermiDirac[a, \[Epsilon],
t])*(Energy[\[Epsilon], t]^(2)/t -
0.5*d\[CapitalDelta]2[t]), {\[Epsilon], 0, \[Infinity]},
AccuracyGoal -> 5]];
Implicit to this function are repeated calls to another numerically integrated function:
Delta[t_] :=
Block[{a =
Subscript[k, B]
Subscript[\[CapitalTheta], D]/Subscript[\[CapitalDelta], 0],
b = Subscript[\[Alpha], BCS]/2/t},
Return[FindRoot[
NIntegrate[(1/Sqrt[\[Epsilon]^2 + x^2]) Tanh[
b*Sqrt[\[Epsilon]^2 + x^2]], {\[Epsilon], 0, a},
AccuracyGoal -> 5] - Log[2 a], {x, 0.01, 0.1}] [[1, 2]]*1 ]]
Now, once Delta[t] has been calculated once, it doesn't change, and should in principle not need to be recalculated every time it's called - which is what my current method is doing.
My question is, how can I best optimise my code such that Delta[t] is only calculated once? Would some form of lookup table be required? If so, does this change my requirements for performing the non-linear fit routine (i.e. some kind of discrete non linear model fit?).
For completeness, I shall include my full code with all functions used. I realise the mathematica subscripts etc don't appear nicely on here so I can reformat if people prefer.
Cheers
Energy[\[Epsilon]_, t_] :=
Sqrt[\[Epsilon]^2 +
Delta[t]^2]; (* energy spectrum, \[Epsilon] measured wrt Fermi \
level *)
g[\[Epsilon]_, t_] :=
Subscript[\[Alpha], BCS] Energy[\[Epsilon], t]/(2 t);
dtop[t_] :=
NIntegrate[Sech[g[\[Epsilon], t]]^2, {\[Epsilon], 0, \[Infinity]},
AccuracyGoal -> 5];
dbottom[t_] :=
NIntegrate[
t*Sech[g[\[Epsilon], t]]^2/(2 Energy[\[Epsilon], t]^2) -
t^2 Tanh[
g[\[Epsilon], t]]/(Subscript[\[Alpha], BCS]
Energy[\[Epsilon], t]^3), {\[Epsilon], 0, \[Infinity]},
AccuracyGoal -> 5];
d\[CapitalDelta]2[t_] := dtop[t]/dbottom[t];
FermiDirac[\[Alpha]_, \[Epsilon]_,
t_] := (E^(\[Alpha] Energy[\[Epsilon], t]/t) + 1)^(-1);
HeatCapacity[a_, t_] :=
If[t > 1,
t, (6*a^3/(\[Pi]^2*t)) NIntegrate[
FermiDirac[a, \[Epsilon],
t]*(1 - FermiDirac[a, \[Epsilon],
t])*(Energy[\[Epsilon], t]^(2)/t -
0.5*d\[CapitalDelta]2[t]), {\[Epsilon], 0, \[Infinity]},
AccuracyGoal -> 5]];
ScaledHC[\[Gamma]_, Tc_, a_, t_] := \[Gamma] Tc HeatCapacity[a, t/Tc];
result = NonlinearModelFit[datain,
ScaledHC[gamma, 4.7, alpha,
t], {{gamma, Subscript[\[Gamma], fit]}, {alpha, Subscript[\[Alpha],
fit]}}, t,
Weights -> (1./err^2.), {StepMonitor :>
Print["Gamma = ", Evaluate[gamma],
" \!\(\*SubscriptBox[\(T\), \(C\)]\) = ", Evaluate[b],
" alpha = ", Evaluate[alpha]]}]
You might read a little about the difference between = and :=, sometimes called Set[] and SetDelayed[], not to be confused with == and there is even an === and they are all different. = evaluates the right hand side the moment the cell is evaluated with the current values that all variables have and saves that result under the name Delta. It shouldn't evaluate the body of Delta again when the left hand side is used or used repeatedly in the future, just as long as you don't manually evaluate that cell again. := simply stores away the form of the right hand side and will evaluate that each time in the future when the left hand side is used and with the value variables have at that future time. If your variables won't change then perhaps = will be enough for you.
If you can arrange to have all the variables except t initialized before you then evaluate
Delta[t_]=Block[...]
Then that should evaluate only once. You could verify this by including a diagnostic Print[] inside your Delta function.
You might also investigate whether you really need the Return[] in that. Return[] has been a source of perplexing problems in the past and if I understand your code correctly that can be eliminated. The *1 might also be discarded because I can't see what that is doing for you.
If you don't necessarily need to hide the values of a and b then you might even write this as
Delta[t_]=(a=...;b=...;FindRoot[...][[1,2]]);
where you replace each ... with the obvious. The ( and ) will over-ride the precedence of semicolon and allow you to have compound statements in a single function definition.
You could even do further modifications to the code, but perhaps this is enough for now.
I have not, and don't have enough information to do so, carefully tested all your code after making such modifications, so test this carefully.

Plotting a random walk using Mathematica

This is my first time posting here. I would really appreciate some help with a question from my mathematica study guide. My question is:
Suppose that a drunk randomly steps either forward, backward, left, or right one unit many times. Create a list of coordinates {{x,y}..} representing his path and then display that path as a set of line segments for each step. [Hint: use NestList to create a list of coordinates, Partition to form a list of segments, map Line onto the segment list, and Show[Graphics[list]] to display the path.]
I have managed to successfully create the function:
Clear[x, n]
Randomwalk[n_] :=
NestList[(# + (-1)^Table[Random[Integer, {0, 1}], {2}]) &, Table[0, {2}], n];
Randomwalk[50]
I, however, need help with the second part, where I need to graph it. MY attempt at the second part is as follows:
Show[Graphics[Line[Randomwalk[50]]]]
and although it gives me a graph, it does not seem to be correct. I would really appreciate some help with this.
You could try the following function
RandomWalk[n_]:=Accumulate[{{1,0},{-1,0},{0,1},{0,-1}}[[RandomInteger[{1,4},n]]]]
where n is the number of steps to take. Plotting works as you wrote
Graphics[Line[RandomWalk[200]]]
However, plotting with colour shows how the walk progressed, as in
With[{n=100},
Graphics[MapIndexed[{Hue[#2[[1]]/(n + 10)], Line[#]} &,
Partition[RandomWalk[n], 2, 1]]]]
Instead of using [[RandomInteger[{1,4},n]]] to pick out the directions, you could use RandomChoice which is designed expressly for this type of operation:
RandomWalk[n_] := Accumulate[RandomChoice[{{1, 0}, {-1, 0}, {0, 1}, {0, -1}}, n]]
This gives about the same (maybe slightly faster) speed as the approach using Part and RandomInteger. But if you are working with large walks (n > 10^6, say), then you might want to squeeze some speed out by forcing the list of directions to be a packed array:
NSEWPacked = Developer`ToPackedArray[{{1, 0}, {-1, 0}, {0, 1}, {0, -1}}]
Then use the packed array:
RandomWalkPacked[n_] := Accumulate[RandomChoice[NSEWPacked, n]]
You should see about an order of magnitude speedup with this:
Timing[RandomWalkPacked[10^7];]
For details on packed arrays, see Developer/ref/ToPackedArray or chapter 12 on optimizing Mathematica programs in Programming with Mathematica: An Introduction.

How to use indexed object inside Manipulate so that its state is saved as other dynamics?

I have a really big problem on my hands.
I spend a week rewriting a Manipulate demo to use indexed objects (to use them as emulation of a struct)
However, when I started I did not know how to define them as None control type (so that the state is saved between each Manipulate update), so, I moved them to the Initialization section for now, so that I can test the idea.
Everything works well except for one problem:
In the Initialization section, they become GLOBAL. Which means, when making a demo, and making a snap-shot of the Manipulate, which one must do, then the 2 Manipulates now will interact with each others in an undesired way. They share these global variables (the indexed objects). Which means if I change something in one Manipulate, the other Manipulate is affected.
The WRI demonstration editor do not recommend using global variables inside the Manipulate section either.
I'll explain the problem with simple examples, and hope an expert here might know a work around. Currently I have something like this, which works:
Manipulate[
p#x = 0; (*I'd like to use here *)
p#y = 99; (*etc...*)
foo,
{{foo, 0, "foo"}, 0, 10, 1},
Initialization :>
{
p[x] = 99; (*my data live here *)
p[y] = 0; (*my data live here *)
}
]
But in the above p[x] and p[y] are global. I tried the control None trick, but this does not work:
Manipulate[
p[x] = 0;
foo,
{{foo, 0, "foo"}, 0, 10, 1},
{{p[x], 99}, None} (* syntax error, what is the correct syntax? *)
]
I can't put a Module around Manipulate in order to use it to save state. Not allowed.
So, I need a way to have these indexed object preserve the state between each Manipulate update, just like a control variable, but not be global.
But the problem I do not know how to do this. The only way I knew to do this, was using the Control None trick.
I know that Manipulate is basically a DynamicModule[] itself. That is why its own variables (control variables) keep state. I need these indexed object to be like them as well. Can I use a DynamicModule[] inside Manipulate somehow to do this or is there a simple solution to this?
Btw, I found I can do the following
Manipulate[
z,
{{foo, 0, "foo"}, 0, 10, 1},
{{z, p[x]}, None}
]
But I am not sure what to make of the above. I need to use p#x and not z.
The strange thing, one can define an array of indexed objects, but not a single one?
Manipulate[
z,
{{foo, 0, "foo"}, 0, 10, 1},
{{z, Table[p[i], {i, 5}]}, None}
]
Thanks for any hints.
Update:
I am not able to get Mike answer below to work as I needed it to. For example, suppose I want to have p[x] initialized to 0, and then in each Manipulate update, I want to add one to it. How to do that? This is what I tried:
Manipulate[
DynamicModule[{p, x}, (*not working *)
p#x = p#x + 1;
p#x,
Initialization :>
{
p#x = 0;
}
],
{{n, 0, "n"}, 0, 10, 1},
TrackedSymbols :> n
]
Will keep trying things...
Update 2:30 AM
This below is more clear example of the problem in case the above is not clear
Manipulate[
p#x = p#x + 1;(*I'd like to use here*)
n;
Row[{"p#x=", p#x}],
Button["click to update p#x", n++],
{{n, 0}, None},
TrackedSymbols :> {n},
Initialization :> {
p#x = 0;
}
]
In this example, an indexed object, p[x] is global variable, hence its state is preserved. I need to do the same, but without having p[x] defined as global, but move it to be part of the Manipulate so that it becomes localized, but also have its state saved.
The problem again, is that the control None syntax does not allow me to type
{{p#x,0},None}
Hope this example makes things more clear.
With the caveat that I mostly only use DynamicModule, rarely Manipulate, so I'm not familiar with how you torture it into submission, I'm thinking this may work:
Manipulate[
DynamicModule[{p, x, y},
p#x = 0;
p#y = 99;
p[y]*foo (* or Dynamic[p[x]*foo] *)],
{{foo, 0, "foo"}, 0, 10, 1}]
If it doesn't work the way you require you may need to provide more information or wait for a Manipulate guy to respond.
Edit
Just added an alternative with a Dynamic. So in your real code if e.g. p or x or y are to be updated then you need to use Dynamic. (The example above assume x is dynamic)
FURTHER EDIT
Your most recent edit implies that you want p#x to change when the value of n changes, e.g. when the slider moves.
Manipulate[
DynamicModule[{p, x, tmp},
p#x = 0;
{Dynamic[p#x += 1; n, TrackedSymbols :> {n}], Dynamic[p#x]}],
{{n, 0, "n"}, 0, 10, 1}]
That is it for me tonight. Maybe someone else can offer some suggestions.

Finding runs of similar, not identical, elements in Mathematica

I have a list of numbers. I want to extract from the list runs of numbers that fall inside some band and have some minimum length. For instance, suppose the I want to operate on this list:
thisList = {-1.2, -1.8, 1.5, -0.6, -0.8, -0.1, 1.4, -0.3, -0.1, -0.7}
with band=1 and runLength=3. I would like to have
{{-0.6, -0.8, -0.1}, {-0.3, -0.1, -0.7}}
as the result. Right now I'm using
Cases[
Partition[thisList,runLength,1],
x_ /; Abs[Max[x] - Min[x]] < band
]
The main problem is that where runs overlap, I get many copies of the run. For instance, using
thisList = {-1.2, -1.8, 1.5, -0.6, -0.8, -0.1, -0.5, -0.3, -0.1, -0.7}
gives me
{{-0.6, -0.8, -0.1}, {-0.8, -0.1, -0.5}, {-0.1, -0.5, -0.3}, {-0.5, -0.3, -0.1}, {-0.3, -0.1, -0.7}}
where I would rather have
{-0.6, -0.8, -0.1, -0.5, -0.3, -0.1, -0.7}
without doing some hokey reduction of the overlapping result. What's the proper way? It'd be nice if it didn't involve exploding the data using Partition.
EDIT
Apparenty, my first solution has at least two serious flaws: it is dead slow and completely impractical for lists larger than 100 elements, and it contains some bug(s) which I wasn't able to identify yet - it is missing some bands sometimes. So, I will provide two (hopefuly correct) and much more efficient alternatives, and I provide the flawed one below for any one interested.
A solution based on linked lists
Here is a solution based on linked lists. It allows us to still use patterns but avoid inefficiencies caused by patterns containing __ or ___ (when repeatedly applied):
ClearAll[toLinkedList];
toLinkedList[x_List] := Fold[{#2, #1} &, {}, Reverse#x]
ClearAll[accumF];
accumF[llFull_List, acc_List, {h_, t_List}, ctr_, max_, min_, band_, rLen_] :=
With[{cmax = Max[max, h], cmin = Min[min, h]},
accumF[llFull, {acc, h}, t, ctr + 1, cmax, cmin, band, rLen] /;
Abs[cmax - cmin] < band];
accumF[llFull_List, acc_List, ll : {h_, _List}, ctr_, _, _, band_, rLen_] /; ctr >= rLen :=
accumF[ll, (Sow[acc]; {}), ll, 0, h, h, band, rLen];
accumF[llFull : {h_, t : {_, _List}}, _List, ll : {head_, _List}, _, _, _, band_, rLen_] :=
accumF[t, {}, t, 0, First#t, First#t, band, rLen];
accumF[llFull_List, acc_List, {}, ctr_, _, _, _, rLen_] /; ctr >= rLen := Sow[acc];
ClearAll[getBandsLL];
getBandsLL[lst_List, runLength_Integer, band_?NumericQ] :=
Block[{$IterationLimit = Infinity},
With[{ll = toLinkedList#lst},
Map[Flatten,
If[# === {}, #, First##] &#
Reap[
accumF[ll, {}, ll, 0, First#ll, First#ll, band,runLength]
][[2]]
]
]
];
Here are examples of use:
In[246]:= getBandsLL[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,1.4,-0.3,-0.1,-0.7},3,1]
Out[246]= {{-0.6,-0.8,-0.1},{-0.3,-0.1,-0.7}}
In[247]:= getBandsLL[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7},3,1]
Out[247]= {{-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7}}
The main idea of the function accumF is to traverse the number list (converted to a linked list prior to that), and accumulate a band in another linked list, which is passed to it as a second argument. Once the band condition fails, the accumulated band is memorized using Sow (if it was long enough), and the process starts over with the remaining part of the linked list. The ctr parameter may not be needed if we would choose to use Depth[acc] instead.
There are a few non-obvious things present in the above code. One subtle point is that an attempt to join the two middle rules for accumF into a single rule (they look very similar) and use CompoundExpression (something like (If[ctr>=rLen, Sow[acc];accumF[...])) on the r.h.s. would lead to a non-tail-recursive accumF (See this answer for a more detailed discussion of this issue. This is also why I make the (Sow[acc]; {}) line inside a function call - to avoid the top-level CompoundExpression on the r.h.s.). Another subtle point is that I have to maintain a copy of the linked list containing the remaining elements right after the last successful match was found, since in the case of unsuccessful sequence I need to roll back to that list minus its first element, and start over. This linked list is stored in the first argument of accumF.
Note that passing large linked lists does not cost much, since what is copied is only a first element (head) and a pointer to the rest (tail). This is the main reason why using linked lists vastly improves performance, as compared to the case of patterns like {___,x__,right___} - because in the latter case, a full sequences x or right are copied. With linked lists, we effectively only copy a few references, and therefore our algorithms behave roughly as we expect (linearly in the length of the data list here). In this answer, I also mentioned the use of linked lists in such cases as one of the techniques to optimize code (section 3.4).
Compile - based solution
Here is a straightforward but not too elegant function based on Compile, which finds a list of starting and ending bands positions in the list:
bandPositions =
Compile[{{lst, _Real, 1}, {runLength, _Integer}, {band, _Real}},
Module[{i = 1, j, currentMin, currentMax,
startEndPos = Table[{0, 0}, {Length[lst]}], ctr = 0},
For[i = 1, i <= Length[lst], i++,
currentMin = currentMax = lst[[i]];
For[j = i + 1, j <= Length[lst], j++,
If[lst[[j]] < currentMin,
currentMin = lst[[j]],
(* else *)
If[lst[[j]] > currentMax,
currentMax = lst[[j]]
]
];
If[Abs[currentMax - currentMin] >= band ,
If[ j - i >= runLength,
startEndPos[[++ctr]] = {i, j - 1}; i = j - 1
];
Break[],
(* else *)
If[j == Length[lst] && j - i >= runLength - 1,
startEndPos[[++ctr]] = {i, j}; i = Length[lst];
Break[];
];
]
]; (* inner For *)
]; (* outer For *)
Take[startEndPos, ctr]], CompilationTarget -> "C"];
This is used in the final function:
getBandsC[lst_List, runLength_Integer, band_?NumericQ] :=
Map[Take[lst, #] &, bandPositions[lst, runLength, band]]
Examples of use:
In[305]:= getBandsC[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,1.4,-0.3,-0.1,-0.7},3,1]
Out[305]= {{-0.6,-0.8,-0.1},{-0.3,-0.1,-0.7}}
In[306]:= getBandsC[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7},3,1]
Out[306]= {{-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7}}
Benchmarks
In[381]:=
largeTest = RandomReal[{-5,5},50000];
(res1 =getBandsLL[largeTest,3,1]);//Timing
(res2 =getBandsC[largeTest,3,1]);//Timing
res1==res2
Out[382]= {1.109,Null}
Out[383]= {0.016,Null}
Out[384]= True
Obviously, if one wants performance, Compile wins hands down. My observations for larger lists are that both solutions have approximately linear complexity with the size of the number list (as they should), with compiled one roughly 150 times faster on my machine than the one based on linked lists.
Remarks
In fact, both methods encode the same algorithm, although this may not be obvious. The one with recursion and patterns is arguably somewhat more understandable, but that is a matter of opinion.
A simple, but slow and buggy version
Here is the original code that I wrote first to solve this problem. This is based on a rather straightforward use of patterns and repeated rule application. As mentioned, one disadvantage of this method is its very bad performance. This is actually another case against using constructs like {___,x__,y___} in conjunction with repeated rule application, for anything longer than a few dozens elements. In the mentioned recommendations for code optimization techniques, this corresponds to the section 4.1.
Anyways, here is the code:
If[# === {}, #, First##] &#
Reap[thisList //. {
left___,
Longest[x__] /;Length[{x}] >= runLength && Abs[Max[{x}] - Min[{x}]] < band,
right___} :> (Sow[{x}]; {right})][[2]]
It works correctly for both of the original small test lists. It also looks generally correct, but for larger lists it often misses some bands, which can be seen by comparison with the other two methods. I wasn't so far able to localize the bug, since the code seems pretty transparent.
I'd try this instead:
thisList /. {___, Longest[a : Repeated[_, {3, Infinity}]], ___} :>
{a} /; Abs[Max#{a} - Min#{a}] < 1
where Repeated[_, {3, Infinity}] guarantees that you get at least 3 terms, and Longest ensures it gives you the longest run possible. As a function,
Clear[f]
f[list_List, band_, minlen_Integer?Positive] := f[list, band, minlen, Infinity]
f[list_List, band_,
minlen_Integer?Positive, maxlen_?Positive] /; maxlen >= minlen :=
list /. {___, Longest[a : Repeated[_, {minlen, maxlen}]], ___} :> {a} /;
Abs[Max#{a} - Min#{a}] < band
Very complex answers given. :-) I think I have a simpler approach for you. Define to yourself what similarity means to you, and use GatherBy[] to collect all similar elements, or SplitBy[] to collect "runs" of similar elements (then remove "runs" of minimal unaccepted length, say 1 or 2, via DeleteCases[]).
Harder question is establishing similarity. By your method 1.2,0.9,1.9,0.8 would group first three elements, but not last three, but 0.9 and 0.8 are just as similar, and 1.9 would kick it out of your band. What about .4,.5,.6,.7,.8,.9,1.0,1.1,1.2,1.3,1.4,1.5 - where does similarity end?
Also look into ClusteringComponents[] and FindClusters[]

Coefficient function is slow

Please consider:
Clear[x]
expr = Sum[x^i, {i, 15}]^30;
CoefficientList[expr, x]; // Timing
Coefficient[Expand#expr, x, 234]; // Timing
Coefficient[expr, x, 234]; // Timing
{0.047, Null}
{0.047, Null}
{4.93, Null}
Help states:
Coefficient works whether or not expr is explicitly given in expanded form.
Is there a reason why Coefficient needs to be so slow in the last case?
Here is a hack which may enable your code to be fast, but I don't guarantee it to always work correctly:
ClearAll[withFastCoefficient];
SetAttributes[withFastCoefficient, HoldFirst];
withFastCoefficient[code_] :=
Block[{Binomial},
Binomial[x_, y_] := 10 /; ! FreeQ[Stack[_][[-6]], Coefficient];
code]
Using it, we get:
In[58]:= withFastCoefficient[Coefficient[expr,x,234]]//Timing
Out[58]= {0.172,3116518719381876183528738595379210}
The idea is that, Coefficient is using Binomial internally to estimate the number of terms, and then expands (calls Expand) if the number of terms is less than 1000, which you can check by using Trace[..., TraceInternal->True]. And when it does not expand, it computes lots of sums of large coefficient lists dominated by zeros, and this is apparently slower than expanding, for a range of expressions. What I do is to fool Binomial into returning a small number (10), but I also tried to make it such that it will only affect the Binomial called internally by Coefficient:
In[67]:= withFastCoefficient[f[Binomial[7,4]]Coefficient[expr,x,234]]
Out[67]= 3116518719381876183528738595379210 f[35]
I can not however guarantee that there are no examples where Binomial somewhere else in the code will be computed incorrectly.
EDIT
Of course, a safer alternative that always exists is to redefine Coefficient using the Villegas - Gayley trick, expanding an expression inside it and calling it again:
Unprotect[Coefficient];
Module[{inCoefficient},
Coefficient[expr_, args__] :=
Block[{inCoefficient = True},
Coefficient[Expand[expr], args]] /; ! TrueQ[inCoefficient]
];
Protect[Coefficient];
EDIT 2
My first suggestion had an advantage that we defined a macro which modified the properties of functions locally, but disadvantage that it was unsafe. My second suggestion is safer but modifies Coefficient globally, so it will always expand until we remove that definition. We can have the best of both worlds with the help of Internal`InheritedBlock, which creates a local copy of a given function. Here is the code:
ClearAll[withExpandingCoefficient];
SetAttributes[withExpandingCoefficient, HoldFirst];
withExpandingCoefficient[code_] :=
Module[{inCoefficient},
Internal`InheritedBlock[{Coefficient},
Unprotect[Coefficient];
Coefficient[expr_, args__] :=
Block[{inCoefficient = True},
Coefficient[Expand[expr], args]] /; ! TrueQ[inCoefficient];
Protect[Coefficient];
code
]
];
The usage is similar to the first case:
In[92]:= withExpandingCoefficient[Coefficient[expr,x,234]]//Timing
Out[92]= {0.156,3116518719381876183528738595379210}
The main Coefficient function remains unaffected however:
In[93]:= DownValues[Coefficient]
Out[93]= {}
Coefficient will not expand unless it deems it absolutely necessary to do so. This does indeed avoid memory explosions. I believe it has been this way since version 3 (I think I was working on it around 1995 or so).
It can also be faster to avoid expansion. Here is a simple example.
In[28]:= expr = Sum[x^i + y^j + z^k, {i, 15}, {j, 10}, {k, 20}]^20;
In[29]:= Coefficient[expr, x, 234]; // Timing
Out[29]= {0.81, Null}
But this next appears to hang in version 8, and takes at least a half minute in the development Mathematica (where Expand was changed).
Coefficient[Expand[expr], x, 234]; // Timing
Possibly some heuristics should be added to look for univariates that will not explode. Does not seem like a high priority item though.
Daniel Lichtblau
expr = Sum[x^i, {i, 15}]^30;
scoeff[ex_, var_, n_] /; PolynomialQ[ex, var] :=
ex + O[var]^(n + 1) /.
Verbatim[SeriesData][_, 0, c_List, nmin_, nmax_, 1] :>
If[nmax - nmin != Length[c], 0, c[[-1]]];
Timing[scoeff[expr, x, 234]]
seems quite fast, too.
After some experimentation following Rolf Mertig's answer, this appears to be the fastest method on the type of expression such as Sum[x^i, {i, 15}]^30:
SeriesCoefficient[expr, {x, 0, 234}]

Resources