Related
I am having trouble plotting multiple functions on separate graph by using the Do loop. I have already figured out how to do it for just one fit function, but now I have to do it for 9 more fit functions.
m = 10;
t0IGList = {0.01, 0.01, 0.012, 0.015, 0.018, 0.022, 0.028, 0.035,
0.042, 0.05};
SubDataFit =
NonlinearModelFit[SubDataList[[1]],
A/(1 + (2 (t - t0)/\[Sigma])^2) +
B0, {{A, 0.7}, {t0, t0IGList[[1]]}, {\[Sigma], 0.006}, {B0, 7.0}},
t];
SubFitPlot =
Plot[SubDataFit[t], {t, 0, 0.07}, ImageSize -> 500,
FrameLabel -> {"Time (s)", "Voltage (V)"}, PlotStyle -> Red,
PlotRange -> {7, 7.8}];
Do[{
SubDataFit[[i]] =
NonlinearModelFit[SubDataList[[i]],
A/(1 + (2 (t - t0)/\[Sigma])^2) +
B0, {{A, 0.7}, {t0, t0IGList[[i]]}, {\[Sigma], 0.006}, {B0,
7.0}}, t];
SubFitPlot =
Plot[SubDataFit[t], {t, 0, 0.07}, ImageSize -> 500,
FrameLabel -> {"Time (s)", "Voltage (V)"}, PlotStyle -> Red];
Print["B = ", i, "Volts"];
Print[SubDataPlot];}, {i, 1, m}];
You say you want to plot "multiple functions on separate graph", which seems to mean you want 10 separate graphs. If that right. If so, you can separate out the two pieces of what you want: producing the fits in a loop and collecting them into a list, and then plotting the fitted functions. You can make your plotting function as complicated as you wish. Simple example:
flst = {x, x^2, x^3, Log[x]}
Plot[#, {x, 0.01, 2}] & /# flst
Once you have this list of plots you can do anything your want with them (e.g., make a GraphicsGrid, or Export them, etc.)
Try using Module. Create a function
plot[i_]:=Module[{local variables for module},
Any actions you want: fits, calculations etc. Separate them with ";";
Plot[i-th function]].
Then you could use this function with different i from you range to create plots you want.
I have written code which draws the Sierpinski fractal. It is really slow since it uses recursion. Do any of you know how I could write the same code without recursion in order for it to be quicker? Here is my code:
midpoint[p1_, p2_] := Mean[{p1, p2}]
trianglesurface[A_, B_, C_] := Graphics[Polygon[{A, B, C}]]
sierpinski[A_, B_, C_, 0] := trianglesurface[A, B, C]
sierpinski[A_, B_, C_, n_Integer] :=
Show[
sierpinski[A, midpoint[A, B], midpoint[C, A], n - 1],
sierpinski[B, midpoint[A, B], midpoint[B, C], n - 1],
sierpinski[C, midpoint[C, A], midpoint[C, B], n - 1]
]
edit:
I have written it with the Chaos Game approach in case someone is interested. Thank you for your great answers!
Here is the code:
random[A_, B_, C_] := Module[{a, result},
a = RandomInteger[2];
Which[a == 0, result = A,
a == 1, result = B,
a == 2, result = C]]
Chaos[A_List, B_List, C_List, S_List, n_Integer] :=
Module[{list},
list = NestList[Mean[{random[A, B, C], #}] &,
Mean[{random[A, B, C], S}], n];
ListPlot[list, Axes -> False, PlotStyle -> PointSize[0.001]]]
This uses Scale and Translate in combination with Nest to create the list of triangles.
Manipulate[
Graphics[{Nest[
Translate[Scale[#, 1/2, {0, 0}], pts/2] &, {Polygon[pts]}, depth]},
PlotRange -> {{0, 1}, {0, 1}}, PlotRangePadding -> .2],
{{pts, {{0, 0}, {1, 0}, {1/2, 1}}}, Locator},
{{depth, 4}, Range[7]}]
If you would like a high-quality approximation of the Sierpinski triangle, you can use an approach called the chaos game. The idea is as follows - pick three points that you wish to define as the vertices of the Sierpinski triangle and choose one of those points randomly. Then, repeat the following procedure as long as you'd like:
Choose a random vertex of the trangle.
Move from the current point to the halfway point between its current location and that vertex of the triangle.
Plot a pixel at that point.
As you can see at this animation, this procedure will eventually trace out a high-resolution version of the triangle. If you'd like, you can multithread it to have multiple processes plotting pixels at once, which will end up drawing the triangle more quickly.
Alternatively, if you just want to translate your recursive code into iterative code, one option would be to use a worklist approach. Maintain a stack (or queue) that contains a collection of records, each of which holds the vertices of the triangle and the number n. Initially put into this worklist the vertices of the main triangle and the fractal depth. Then:
While the worklist is not empty:
Remove the first element from the worklist.
If its n value is not zero:
Draw the triangle connecting the midpoints of the triangle.
For each subtriangle, add that triangle with n-value n - 1 to the worklist.
This essentially simulates the recursion iteratively.
Hope this helps!
You may try
l = {{{{0, 1}, {1, 0}, {0, 0}}, 8}};
g = {};
While [l != {},
k = l[[1, 1]];
n = l[[1, 2]];
l = Rest[l];
If[n != 0,
AppendTo[g, k];
(AppendTo[l, {{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1}] & ## #) & /#
NestList[RotateLeft, k, 2]
]]
Show#Graphics[{EdgeForm[Thin], Pink,Polygon#g}]
And then replace the AppendTo by something more efficient. See for example https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile
Edit
Faster:
f[1] = {{{0, 1}, {1, 0}, {0, 0}}, 8};
i = 1;
g = {};
While[i != 0,
k = f[i][[1]];
n = f[i][[2]];
i--;
If[n != 0,
g = Join[g, k];
{f[i + 1], f[i + 2], f[i + 3]} =
({{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1} & ## #) & /#
NestList[RotateLeft, k, 2];
i = i + 3
]]
Show#Graphics[{EdgeForm[Thin], Pink, Polygon#g}]
Since the triangle-based functions have already been well covered, here is a raster based approach.
This iteratively constructs pascal's triangle, then takes modulo 2 and plots the result.
NestList[{0, ##} + {##, 0} & ## # &, {1}, 511] ~Mod~ 2 // ArrayPlot
Clear["`*"];
sierpinski[{a_, b_, c_}] :=
With[{ab = (a + b)/2, bc = (b + c)/2, ca = (a + c)/2},
{{a, ab, ca}, {ab, b, bc}, {ca, bc, c}}];
pts = {{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}} // N;
n = 5;
d = Nest[Join ## sierpinski /# # &, {pts}, n]; // AbsoluteTiming
Graphics[{EdgeForm#Black, Polygon#d}]
(*sierpinski=Map[Mean, Tuples[#,2]~Partition~3 ,{2}]&;*)
Here is a 3D version,https://mathematica.stackexchange.com/questions/22256/how-can-i-compile-this-function
ListPlot#NestList[(# + RandomChoice[{{0, 0}, {2, 0}, {1, 2}}])/2 &,
N#{0, 0}, 10^4]
With[{data =
NestList[(# + RandomChoice#{{0, 0}, {1, 0}, {.5, .8}})/2 &,
N#{0, 0}, 10^4]},
Graphics[Point[data,
VertexColors -> ({1, #[[1]], #[[2]]} & /# Rescale#data)]]
]
With[{v = {{0, 0, 0.6}, {-0.3, -0.5, -0.2}, {-0.3, 0.5, -0.2}, {0.6,
0, -0.2}}},
ListPointPlot3D[
NestList[(# + RandomChoice[v])/2 &, N#{0, 0, 0}, 10^4],
BoxRatios -> 1, ColorFunction -> "Pastel"]
]
I'd like to ask if the following way I manage plotting result of simulation is efficient use of Mathematica and if there is a more 'functional' way to do it. (may be using Sow, Reap and such).
The problem is basic one. Suppose you want to simulate a physical process, say a pendulum, and want to plot the time-series of the solution (i.e. time vs. angle) as it runs (or any other type of result).
To be able to show the plot, one needs to keep the data points as it runs.
The following is a simple example, that plots the solution, but only the current point, and not the full time-series:
Manipulate[
sol = First#NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == Pi/4, y'[0] == 0},
y, {t, time, time + 1}];
With[{angle = y /. sol},
(
ListPlot[{{time, angle[time]}}, AxesLabel -> {"time", "angle"},
PlotRange -> {{0, max}, {-Pi, Pi}}]
)
],
{{time, 0, "run"}, 0, max, Dynamic#delT, ControlType -> Trigger},
{{delT, 0.1, "delT"}, 0.1, 1, 0.1, Appearance -> "Labeled"},
TrackedSymbols :> {time},
Initialization :> (max = 10)
]
The above is not interesting, as one only sees a point moving, and not the full solution path.
The way currently I handle this, is allocate, using Table[], a buffer large enough to hold the largest possible time-series size that can be generated.
The issue is that the time-step can change, and the smaller it is, the more data will be generated.
But since I know the smallest possible time-step (which is 0.1 seconds in this example), and I know the total time to run (which is 10 seconds here), then I know how much to allocate.
I also need an 'index' to keep track of the buffer. Using this method, here is a way to do it:
Manipulate[
If[time == 0, index = 0];
sol = First#NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == Pi/4,y'[0] == 0},
y, {t, time, time + 1}];
With[{angle = y /. sol},
(
index += 1;
buffer[[index]] = {time, angle[time]};
ListPlot[buffer[[1 ;; index]], Joined -> True, AxesLabel -> {"time", "angle"},
PlotRange -> {{0, 10}, {-Pi, Pi}}]
)
],
{{time, 0, "run"}, 0, 10, Dynamic#delT, AnimationRate -> 1, ControlType -> Trigger},
{{delT, 0.1, "delT"}, 0.1, 1, 0.1, Appearance -> "Labeled"},
{{buffer, Table[{0, 0}, {(max + 1)*10}]}, None},
{{index, 0}, None},
TrackedSymbols :> {time},
Initialization :> (max = 10)
]
For reference, when I do something like the above in Matlab, it has a nice facility for plotting, called 'hold on'. So that one can plot a point, then say 'hold on' which means that the next plot will not erase what is already on the plot, but will add it.
I did not find something like this in Mathematica, i.e. update a current plot on the fly.
I also did not want to use Append[] and AppendTo[] to build the buffer as it runs, as that will be slow and not efficient.
My question: Is there a more efficient, Mathematica way (which can be faster and more elegent) to do a typical task such as the above, other than what I am doing?
thanks,
UPDATE:
On the question on why not solving the ODE all at once.
Yes, it is possible, but it simplifies things alot to do it in pieces, also for performance reasons.
Here is an example with ode with initial conditions:
Manipulate[
If[time == 0, index = 0];
sol = First#
NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == y0,
y'[0] == yder0}, y, {t, time, time + 1}];
With[{angle = (y /. sol)[time]},
(
index += 1;
buffer[[index]] = {time, angle};
ListPlot[buffer[[1 ;; index]], Joined -> True,
AxesLabel -> {"time", "angle"},
PlotRange -> {{0, 10}, {-Pi, Pi}}])],
{{time, 0, "run"}, 0, 10, Dynamic#delT, AnimationRate -> 1,
ControlType -> Trigger}, {{delT, 0.1, "delT"}, 0.1, 1, 0.1,
Appearance -> "Labeled"},
{{y0, Pi/4, "y(0)"}, -Pi, Pi, Pi/100, Appearance -> "Labeled"},
{{yder0, 0, "y'(0)"}, -1, 1, .1, Appearance -> "Labeled"},
{{buffer, Table[{0, 0}, {(max + 1)*10}]}, None},
{{index, 0}, None},
TrackedSymbols :> {time},
Initialization :> (max = 10)
]
Now, in one were to solve the system once before, then they need to watch out if the IC changes. This can be done, but need extra logic and I have done this before many times, but it does complicate things a bit. I wrote a small note on this here.
Also, I noticed that I can get much better speed by solving the system for smaller time segments as time marches on, than the whole thing at once. NDSolve call overhead is very small. But when the time duration to NDsolve for is large, problems can result when one ask for higher accuracy from NDSolve, as in options AccuracyGoal ->, PrecisionGoal ->, which I could not when time interval is very large.
Overall, the overhead of calling NDSolve for smaller segments seems to much less compare to the advantages it makes in simplifing the logic, and speed (may be more accurate, but I have not checked on this more). I know it seems a bit strange to keep calling NDSolve, but after trying both methods (all at once, but add logic to check for other control variables) vs. this method, I am now leaning towards this one.
UPDATE 2
I compared the following 4 methods for 2 test cases:
tangle[j][j] method (Belisarius)
AppendTo (suggested by Sjoerd)
Dynamic linked list (Leonid) (with and without SetAttributes[linkedList, HoldAllComplete])
preallocate buffer (Nasser)
The way I did this, is by running it over 2 cases, one for 10,000 points, and the second for 20,000 points. I did leave the Plot[[] command there, but do not display it on the screen, this is to eliminate any overhead of the actual rendering.
I used Timing[] around a Do loop which iterate over the core logic which called NDSolve and iterate over the time span using delT increments as above. No Manipulate was used.
I used Quit[] before each run.
For Leonid method, I changed the Column[] he had by the Do loop. I verified at the end, but plotting the data using his getData[] method, that the result is ok.
All the code I used is below. I made a table which shows the results for the 10,000 points and 20,000. Timing is per seconds:
result = Grid[{
{Text[Style["method", Bold]],
Text[Style["number of elements", Bold]], SpanFromLeft},
{"", 10000, 20000},
{"", SpanFromLeft},
{"buffer", 129, 571},
{"AppendTo", 128, 574},
{"tangle[j][j]", 612, 2459},
{"linkedList with SetAttribute", 25, 81},
{"linkedList w/o SetAttribute", 27, 90}}
]
Clearly, unless I did something wrong, but code is below for anyone to verify, Leonid method wins easily here. I was also surprised that AppendTo did just as well as the buffer method which pre-allocated data.
Here are the slightly modified code I used to generate the above results.
buffer method
delT = 0.01; max = 100; index = 0;
buffer = Table[{0, 0}, {(max + 1)*1/delT}];
Timing[
Do[
sol = First#
NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == Pi/4,
y'[0] == 0}, y, {t, time, time + 1}];
With[{angle = y /. sol},
(index += 1;
buffer[[index]] = {time, angle[time]};
foo =
ListPlot[buffer[[1 ;; index]], Joined -> True,
AxesLabel -> {"time", "angle"},
PlotRange -> {{0, 10}, {-Pi, Pi}}]
)
], {time, 0, max, delT}
]
]
AppendTo method
Clear[y, t];
delT = 0.01; max = 200;
buffer = {{0, 0}}; (*just a hack to get ball rolling, would not do this in real code*)
Timing[
Do[
sol = First#
NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == Pi/4,
y'[0] == 0}, y, {t, time, time + 1}];
With[{angle = y /. sol},
(AppendTo[buffer, {time, angle[time]}];
foo =
ListPlot[buffer, Joined -> True, AxesLabel -> {"time", "angle"},
PlotRange -> {{0, 10}, {-Pi, Pi}}]
)
], {time, 0, max, delT}
]
]
tangle[j][j] method
Clear[y, t];
delT = 0.01; max = 200;
Timing[
Do[
sol = First#
NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == Pi/4,
y'[0] == 0}, y, {t, time, time + 1}];
tangle[time] = y /. sol;
foo = ListPlot[
Table[{j, tangle[j][j]}, {j, .1, max, delT}],
AxesLabel -> {"time", "angle"},
PlotRange -> {{0, max}, {-Pi, Pi}}
]
, {time, 0, max, delT}
]
]
dynamic linked list method
Timing[
max = 200;
ClearAll[linkedList, toLinkedList, fromLinkedList, addToList, pop,
emptyList];
SetAttributes[linkedList, HoldAllComplete];
toLinkedList[data_List] := Fold[linkedList, linkedList[], data];
fromLinkedList[ll_linkedList] :=
List ## Flatten[ll, Infinity, linkedList];
addToList[ll_, value_] := linkedList[ll, value];
pop[ll_] := Last#ll;
emptyList[] := linkedList[];
Clear[getData];
Module[{ll = emptyList[], time = 0, restart, plot, y},
getData[] := fromLinkedList[ll];
plot[] := Graphics[
{
Hue[0.67`, 0.6`, 0.6`],
Line[fromLinkedList[ll]]
},
AspectRatio -> 1/GoldenRatio,
Axes -> True,
AxesLabel -> {"time", "angle"},
PlotRange -> {{0, 10}, {-Pi, Pi}},
PlotRangeClipping -> True
];
DynamicModule[{sol, angle, llaux, delT = 0.01},
restart[] := (time = 0; llaux = emptyList[]);
llaux = ll;
sol :=
First#NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == Pi/4,
y'[0] == 0}, y, {t, time, time + 1}];
angle := y /. sol;
ll := With[{res =
If[llaux === emptyList[] || pop[llaux][[1]] != time,
addToList[llaux, {time, angle[time]}],
(*else*)llaux]
},
llaux = res
];
Do[
time += delT;
plot[]
, {i, 0, max, delT}
]
]
]
]
thanks for everyone help.
I don't know how to get what you want with Manipulate, but I seem to have managed getting something close with a custom Dynamic. The following code will: use linked lists to be reasonably efficient, stop / resume your plot with a button, and have the data collected so far available on demand at any given time:
ClearAll[linkedList, toLinkedList, fromLinkedList, addToList, pop, emptyList];
SetAttributes[linkedList, HoldAllComplete];
toLinkedList[data_List] := Fold[linkedList, linkedList[], data];
fromLinkedList[ll_linkedList] := List ## Flatten[ll, Infinity, linkedList];
addToList[ll_, value_] := linkedList[ll, value];
pop[ll_] := Last#ll;
emptyList[] := linkedList[];
Clear[getData];
Module[{ll = emptyList[], time = 0, restart, plot, y},
getData[] := fromLinkedList[ll];
plot[] :=
Graphics[{Hue[0.67`, 0.6`, 0.6`], Line[fromLinkedList[ll]]},
AspectRatio -> 1/GoldenRatio, Axes -> True,
AxesLabel -> {"time", "angle"}, PlotRange -> {{0, 10}, {-Pi, Pi}},
PlotRangeClipping -> True];
DynamicModule[{sol, angle, llaux, delT = 0.1},
restart[] := (time = 0; llaux = emptyList[]);
llaux = ll;
sol := First#
NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0, y[0] == Pi/4, y'[0] == 0},
y, {t, time, time + 1}];
angle := y /. sol;
ll := With[{res =
If[llaux === emptyList[] || pop[llaux][[1]] != time,
addToList[llaux, {time, angle[time]}],
(* else *)
llaux]},
llaux = res];
Column[{
Row[{Dynamic#delT, Slider[Dynamic[delT], {0.1, 1., 0.1}]}],
Dynamic[time, {None, Automatic, None}],
Row[{
Trigger[Dynamic[time], {0, 10, Dynamic#delT},
AppearanceElements -> { "PlayPauseButton"}],
Button[Style["Restart", Small], restart[]]
}],
Dynamic[plot[]]
}, Frame -> True]
]
]
Linked lists here replace your buffer and you don't need to pre-allocate and to know in advance how many data points you will have. The plot[] is a custom low-level plotting function, although we probably could just as well use ListPlot. You use the "Play" button to both stop and resume plotting, and you use the custom "Restart" button to reset the parameters.
You can call getData[] at any given time to get a list of data accumulated so far, like so:
In[218]:= getData[]
Out[218]= {{0,0.785398},{0.2,0.771383},{0.3,0.754062},{0.4,0.730105},{0.5,0.699755},
{0.6,0.663304},{0.7,0.621093},{0.8,0.573517},{0.9,0.521021},{1.,0.464099},
{1.1,0.403294},{1.2,0.339193},{1.3,0.272424}}
I just wonder why you want to solve the DE in pieces. It can be solved for the whole interval at once. There is also no need to place the NDSolve in the Manipulate then. It doesn't need to be solved time and again when the body of the Manipulateis triggered. Plot itself is sufficiently fast to plot the growing graph at each time step. The following code does what you want without the need for any storage.
sol = First#
NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]]==0,y[0] == Pi/4,y'[0] == 0}, y, {t, 0, 10}];
eps = 0.000001;
Manipulate[
With[{angle = y /. sol},
Plot[angle[t], {t, 0, time + eps},
AxesLabel -> {"time", "angle"},
PlotRange -> {{0, max}, {-Pi, Pi}}
]
],
{{time, 0, "run"}, 0, max,Dynamic#delT, ControlType -> Trigger},
{{delT, 0.1, "delT"}, 0.1, 1, 0.1, Appearance -> "Labeled"}, TrackedSymbols :> {time},
Initialization :> (max = 10)
]
BTW: AppendTo may be vilified as slow, but it is not that slow. On a typical list suitable for plotting it takes less than a milisecond, so it shouldn't slow plotting at all.
Not memory efficient at all, but its virtue is that it only needs a slight modification of your first code:
Clear[tangle];
Manipulate[
sol = First#NDSolve[{y''[t] + 0.1 y'[t] + Sin[y[t]] == 0,
y[0] == Pi/4,
y'[0] == 0},
y, {t, time, time + 1}];
(tangle[time] = y /. sol;
ListPlot[Table[{j, tangle[j][j]}, {j, .1, max, delT}],
AxesLabel -> {"time", "angle"},
PlotRange -> {{0, max}, {-Pi, Pi}}]),
{{time, 0, "run"}, 0, max, Dynamic#delT, ControlType -> Trigger},
{{delT, 0.1, "delT"}, 0.1, 1, 0.1, Appearance -> "Labeled"},
TrackedSymbols :> {time},
Initialization :> {(max = 10); i = 0}]
I'm reverse-engineering how Mathematica does list interpolation:
(* Fortunately, Mathematica WILL interpolate an arbitrary list *)
tab = Table[a[i], {i,1,100}]
f = Interpolation[tab]
(* get the coefficient of each term by setting others to zero *)
Plot[{f[42+x] /. {a[42] -> 0, a[43] ->0, a[44] -> 0, a[41] -> 1}},
{x,0,1}]
Plot[{f[42+x] /. {a[41] -> 0, a[43] ->0, a[44] -> 0, a[42] -> 1}},
{x,0,1}]
Plot[{f[42+x] /. {a[42] -> 0, a[41] ->0, a[44] -> 0, a[43] -> 1}},
{x,0,1}]
Plot[{f[42+x] /. {a[42] -> 0, a[43] ->0, a[41] -> 0, a[44] -> 1}},
{x,0,1}]
(* above is neither Hermite, nor linear, though some look close *)
(* these are available at oneoff.barrycarter.info/STACK/ *)
Table[f[42+x] /. {a[42] -> 0, a[43] ->0, a[44] -> 0, a[41] -> 1},
{x,0,1, 1/100}] >> /home/barrycarter/BCINFO/ONEOFF/STACK/coeff41.txt
Table[f[42+x] /. {a[41] -> 0, a[43] ->0, a[44] -> 0, a[42] -> 1},
{x,0,1, 1/100}] >> /home/barrycarter/BCINFO/ONEOFF/STACK/coeff42.txt
Table[f[42+x] /. {a[41] -> 0, a[42] ->0, a[44] -> 0, a[43] -> 1},
{x,0,1, 1/100}] >> /home/barrycarter/BCINFO/ONEOFF/STACK/coeff43.txt
Table[f[42+x] /. {a[41] -> 0, a[42] ->0, a[43] -> 0, a[44] -> 1},
{x,0,1, 1/100}] >> /home/barrycarter/BCINFO/ONEOFF/STACK/coeff44.txt
EDIT: Thanks, whuber! That did exactly what I wanted. For reference, the coefficients are (in order):
(x-2)*(x-1)*x/-6
(x-2)*(x-1)*(x+1)/2
x*(x+1)*(x-2)/-2
(x-1)*x*(x+1)/6
According to the documentation the interpolator is piecewise polynomial. That's a little vague, so there is something to be investigated here.
You can establish experimentally that the interpolator is a linear function of the data. A nice basis for all possible data consists of vectors of the form {1,0,...,0}, {0,1,0,...,0}, ..., {0,...,0,1}. To this end, let's build a tiny function to produce these vectors of length $n$:
test[n_, i_] := Module[{x = ConstantArray[0,n]},x[[i]] = 1; x]
You can confirm the linearity by trying some examples like this one, with coefficients $a$ and $b$ acting on the $i^\text{th}$ and $j^\text{th}$ basis vectors of length $n$:
With[{a=1, b=2.5, n=5, i=2, j=3},
Plot[{Interpolation[a test[n,i] + b test[n,j]][x],
a Interpolation[test[n,i]][x] + b Interpolation[test[n,j]][x]}, {x, 1, n}]
]
There will be but a single curve because the two functions are superimposed.
Having established the linearity, it will suffice to analyze the interpolator's values on the $n$ basis vectors. You can determine the degrees of the polynomials by differentiation. By default the degree is 3, but you can modify that with the "InterpolatingOrder" parameter. The following code will plot a table of obviously piecewise constant curves resulting from the derivatives of the interpolator for interpolating orders 1 through ioMax, using all the basis vectors for data of length $n$:
With[{n=7, ioMax = 5},
Table[
Module[{fns},
fns = Table[Interpolation[test[n,i], InterpolationOrder->io], {i,1,n}];
Table[Plot[Evaluate#D[f[#], {#,io}]&[x], {x,1,n},
PlotRange->Full, PlotStyle->Thick, ImageSize->150], {f, fns}]
], {io, 1, ioMax}
]
] // TableForm
The output shows that the breaks occur at the integer values of the argument and that there are at most $n-d$ distinct segments for data of length $n$ and an interpolator of degree $d$. This information should get you most of the way there.
I am looking to plot something like the whispering gallery modes -- a 2D cylindrically symmetric plot in polar coordinates. Something like this:
I found the following code snippet in Trott's symbolics guidebook. Tried running it on a very small data set; it ate 4 GB of memory and hosed my kernel:
(* add points to get smooth curves *)
addPoints[lp_][points_, \[Delta]\[CurlyEpsilon]_] :=
Module[{n, l}, Join ## (Function[pair,
If[(* additional points needed? *)
(l = Sqrt[#. #]&[Subtract ## pair]) < \[Delta]\[CurlyEpsilon], pair,
n = Floor[l/\[Delta]\[CurlyEpsilon]] + 1;
Table[# + i/n (#2 - #1), {i, 0, n - 1}]& ## pair]] /#
Partition[If[lp === Polygon,
Append[#, First[#]], #]&[points], 2, 1])]
(* Make the plot circular *)
With[{\[Delta]\[CurlyEpsilon] = 0.1, R = 10},
Show[{gr /. (lp : (Polygon | Line))[l_] :>
lp[{#2 Cos[#1], #2 Sin[#1]} & ###(* add points *)
addPoints[lp][l, \[Delta]\[CurlyEpsilon]]],
Graphics[{Thickness[0.01], GrayLevel[0], Circle[{0, 0}, R]}]},
DisplayFunction -> $DisplayFunction, Frame -> False]]
Here, gr is a rectangular 2D ListContourPlot, generated using something like this (for example):
data = With[{eth = 2, er = 2, wc = 1, m = 4},
Table[Re[
BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[
I m phi]], {r, 0, 10, .2}, {phi, 0, 2 Pi, 0.1}]];
gr = ListContourPlot[data, Contours -> 50, ContourLines -> False,
DataRange -> {{0, 2 Pi}, {0, 10}}, DisplayFunction -> Identity,
ContourStyle -> {Thickness[0.002]}, PlotRange -> All,
ColorFunctionScaling -> False]
Is there a straightforward way to do cylindrical plots like this?.. I find it hard to believe that I would have to turn to Matlab for my curvilinear coordinate needs :)
Previous snippets deleted, since this is clearly the best answer I came up with:
With[{eth = 2, er = 2, wc = 1, m = 4},
ContourPlot[
Re[BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[I phi m]]/.
{r ->Norm[{x, y}], phi ->ArcTan[x, y]},
{x, -10, 10}, {y, -10, 10},
Contours -> 50, ContourLines -> False,
RegionFunction -> (#1^2 + #2^2 < 100 &),
ColorFunction -> "SunsetColors"
]
]
Edit
Replacing ContourPlot by Plot3D and removing the unsupported options you get:
This is a relatively straightforward problem. The key is that if you can parametrize it, you can plot it. According to the documentation both ListContourPlot and ListDensityPlot accept data in two forms: an array of height values or a list of coordinates plus function value ({{x, y, f} ..}). The second form is easier to deal with, such that even if your data is in the first form, we'll transform it into the second form.
Simply, to transform data of the form {{r, t, f} ..} into data of the form {{x, y, f} ..} you doN[{#[[1]] Cos[ #[[2]] ], #[[1]] Sin[ #[[2]] ], #[[3]]}]& /# data, when applied to data taken from BesselJ[1, r/2] Cos[3 t] you get
What about when you just have an array of data, like this guy? In that case, you have a 2D array where each point in the array has known location, and in order to plot it, you have to turn it into the second form. I'm partial to MapIndexed, but there are other ways of doing it. Let's say your data is stored in an array where the rows correspond to the radial coordinate and the columns are the angular coordinate. Then to transform it, I'd use
R = 0.01; (*radial increment*)
T = 0.05 Pi; (*angular increment*)
xformed = MapIndexed[
With[{r = #2[[1]]*R, t = #2[[1]]*t, f = #1},
{r Cos[t], r Sin[t], f}]&, data, {2}]//Flatten[#,1]&
which gives the same result.
If you have an analytic solution, then you need to transform it to Cartesian coordinates, like above, but you use replacement rules, instead. For instance,
ContourPlot[ Evaluate[
BesselJ[1, r/2]*Cos[3 t ] /. {r -> Sqrt[x^2 + y^2], t -> ArcTan[x, y]}],
{x, -5, 5}, {y, -5, 5}, PlotPoints -> 50,
ColorFunction -> ColorData["DarkRainbow"], Contours -> 25]
gives
Two things to note: 1) Evaluate is needed to ensure that the replacement is performed correctly, and 2) ArcTan[x, y] takes into account the quadrant that the point {x,y} is found in.