Is it possible to create polar CountourPlot/ListCountourPlot/DensityPlot in Mathematica? - wolfram-mathematica

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.

Related

How do you plot multiple functions in a do loop

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.

Coloring plot in Mathematica according to labels

I have a dataset with labels which I would like to plot with points colored according to their label. Is there a simple way how to get current line numer inside plot, so that I can determine which category does the point belong to?
I understood that x,y,z are the coordinates of plotted data, but it doesn't help for the external labels.
This is quite ugly and it works just on sorted dataset with regular distribution.
data = Import["http://ftp.ics.uci.edu/pub/machine-learning-databases/iris/iris.data"];
data = Drop[data, -1]; (*there one extra line at the end*)
inData = data[[All, 1 ;; 4]];
labels = data[[All, 5]];
ListPlot3D[inData,
ColorFunction ->
Function[{x, y, z},
If[y < 0.33, RGBColor[1, 1, 0.],
If[y < 0.66, RGBColor[1, 0, 0.], RGBColor[1, 0, 1]]
]
]
]
Expected result:
Suppose that points is the lists of coordinates and labels a list of the corresponding labels so for example
points = Flatten[Table[{i, j, Sin[i j]},
{i, 0, Pi, Pi/20}, {j, 0, Pi, Pi/10}], 1];
labels = RandomChoice[{"label a", "label b", "label c"}, Length[points]];
Each label corresponds to a colour which I'm writing as a list of rules, e.g.
rules = {"label a" -> RGBColor[1, 1, 0],
"label b" -> RGBColor[1, 0, 0], "label c" -> RGBColor[1, 0, 1]};
Then the points can be plotted in the colour corresponding to their label as follows
ListPointPlot3D[Pick[points, labels, #] & /# Union[labels],
PlotStyle -> Union[labels] /. rules]
Edit
To colour individual points in a ListPlot3D you can use VertexColors, for example
ListPlot3D[points, VertexColors -> labels /. rules, Mesh -> False]
For Example:
(* Build the labeled structure and take a random permutation*)
f[x_, y_] = Sqrt[100 - x x - y y];
l = RandomSample#Flatten[{Table[{{"Lower", {x, y, f[x, y] - 5}},
{"Upper", {x, y, 5 - f[x, y]}}},
{x, -5, 5, .1}, {y, -5, 5, .1}]}, 3];
(*Plot*)
Graphics3D[
Riffle[l[[All, 1]] /. {"Lower" -> Red, "Upper" -> Green},
Point /# l[[All, 2]]], Axes -> True]

Extract contours from ContourPlot in Mathematica

I have a function f(x,y) of two variables, of which I need to know the location of the curves at which it crosses zero. ContourPlot does that very efficiently (that is: it uses clever multi-grid methods, not just a brute force fine-grained scan) but just gives me a plot. I would like to have a set of values {x,y} (with some specified resolution) or perhaps some interpolating function which allows me to get access to the location of these contours.
Have thought of extracting this from the FullForm of ContourPlot but this seems to be a bit of a hack. Any better way to do this?
If you end up extracting points from ContourPlot, this is one easy way to do it:
points = Cases[
Normal#ContourPlot[Sin[x] Sin[y] == 1/2, {x, -3, 3}, {y, -3, 3}],
Line[pts_] -> pts,
Infinity
]
Join ## points (* if you don't want disjoint components to be separate *)
EDIT
It appears that ContourPlot does not produce very precise contours. They're of course meant for plotting and are good enough for that, but the points don't lie precisely on the contours:
In[78]:= Take[Join ## points /. {x_, y_} -> Sin[x] Sin[y] - 1/2, 10]
Out[78]= {0.000163608, 0.0000781187, 0.000522698, 0.000516078,
0.000282781, 0.000659909, 0.000626086, 0.0000917416, 0.000470424,
0.0000545409}
We can try to come up with our own method to trace the contour, but it's a lot of trouble to do it in a general way. Here's a concept that works for smoothly varying functions that have smooth contours:
Start from some point (pt0), and find the intersection with the contour along the gradient of f.
Now we have a point on the contour. Move along the tangent of the contour by a fixed step (resolution), then repeat from step 1.
Here's a basic implementation that only works with functions that can be differentiated symbolically:
rot90[{x_, y_}] := {y, -x}
step[f_, pt : {x_, y_}, pt0 : {x0_, y0_}, resolution_] :=
Module[
{grad, grad0, t, contourPoint},
grad = D[f, {pt}];
grad0 = grad /. Thread[pt -> pt0];
contourPoint =
grad0 t + pt0 /. First#FindRoot[f /. Thread[pt -> grad0 t + pt0], {t, 0}];
Sow[contourPoint];
grad = grad /. Thread[pt -> contourPoint];
contourPoint + rot90[grad] resolution
]
result = Reap[
NestList[step[Sin[x] Sin[y] - 1/2, {x, y}, #, .5] &, {1, 1}, 20]
];
ListPlot[{result[[1]], result[[-1, 1]]}, PlotStyle -> {Red, Black},
Joined -> True, AspectRatio -> Automatic, PlotMarkers -> Automatic]
The red points are the "starting points", while the black points are the trace of the contour.
EDIT 2
Perhaps it's an easier and better solution to use a similar technique to make the points that we get from ContourPlot more precise. Start from the initial point, then move along the gradient until we intersect the contour.
Note that this implementation will also work with functions that can't be differentiated symbolically. Just define the function as f[x_?NumericQ, y_?NumericQ] := ... if this is the case.
f[x_, y_] := Sin[x] Sin[y] - 1/2
refine[f_, pt0 : {x_, y_}] :=
Module[{grad, t},
grad = N[{Derivative[1, 0][f][x, y], Derivative[0, 1][f][x, y]}];
pt0 + grad*t /. FindRoot[f ## (pt0 + grad*t), {t, 0}]
]
points = Join ## Cases[
Normal#ContourPlot[f[x, y] == 0, {x, -3, 3}, {y, -3, 3}],
Line[pts_] -> pts,
Infinity
]
refine[f, #] & /# points
A slight variation for extracting points from ContourPlot (possibly due to David Park):
pts = Cases[
ContourPlot[Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}],
x_GraphicsComplex :> First#x, Infinity];
or (as a list of {x,y} points)
ptsXY = Cases[
Cases[ContourPlot[
Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}],
x_GraphicsComplex :> First#x, Infinity], {x_, y_}, Infinity];
Edit
As discussed here, an article by Paul Abbott in the Mathematica Journal (Finding Roots in an Interval) gives the following two alternative methods for obtaining a list of {x,y} values from ContourPlot, including (!)
ContourPlot[...][[1, 1]]
For the above example
ptsXY2 = ContourPlot[
Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}][[1, 1]];
and
ptsXY3 = Cases[
Normal#ContourPlot[
Cos[x] + Cos[y] == 1/2, {x, 0, 4 Pi}, {y, 0, 4 Pi}],
Line[{x__}] :> x, Infinity];
where
ptsXY2 == ptsXY == ptsXY3

plot a multiple rule function in mathematica

How can I write the code for a function (complex contour) similar to this in Mathematica:
I am not exactly sure what c is, but I assumed it was a number between 0 and 1 meaning the height of the incoming straight line. So maybe somehting like this would suit your needs?
c = 0.7;
t0 = ArcSin[c];
PolarPlot[If[Abs[t] < t0, Abs[Sin[t0]/Sin[t]], 1], {t, -\[Pi], \[Pi]}]
The most direct way is to use graphics primatives
(although I think I prefer Felix's PolarPlot solution)
With[{q = Pi/6},
Graphics[{Circle[{0, 0}, 1, {q, 2 Pi - q}],
Arrowheads[{{.05, .8}}],
Arrow[{{Cos[q] + 2, Sin[q]}, {Cos[q], Sin[q]}}],
Arrow[{{Cos[q], Sin[-q]}, {Cos[q] + 2, Sin[-q]}}],
FontSize -> Medium, Text["\[ScriptCapitalC]", {2, Sin[q]}, {0, -2}]},
Axes -> True, PlotRange -> {{-4, 6}, {-4, 4}}]]
I guess if you want the actual function for contour, then maybe something like
contour[t_, t0_: (5 Pi/6)] := Piecewise[{
{Exp[I (t + Pi)], -t0 < t < t0},
{t - t0 + Exp[I (t0 + Pi)], t >= t0},
{-t - t0 + Exp[-I (t0 + Pi)], t <= -t0}}]
ParametricPlot[Through[{Re, Im}[contour[t]]], {t, -8, 8}, PlotPoints -> 30]
And to add arrows to this plot, I guess you'd have to add them in manually (using Epilog or the drawing tools) or use one of the packages that modifies the built-in plots.

Mathematica: How to obtain data points plotted by plot command?

When plotting a function using Plot, I would like to obtain the set of data points plotted by the Plot command.
For instance, how can I obtain the list of points {t,f} Plot uses in the following simple example?
f = Sin[t]
Plot[f, {t, 0, 10}]
I tried using a method of appending values to a list, shown on page 4 of Numerical1.ps (Numerical Computation in Mathematica) by Jerry B. Keiper, http://library.wolfram.com/infocenter/Conferences/4687/ as follows:
f = Sin[t]
flist={}
Plot[f, {t, 0, 10}, AppendTo[flist,{t,f[t]}]]
but generate error messages no matter what I try.
Any suggestions would be greatly appreciated.
f = Sin[t];
plot = Plot[f, {t, 0, 10}]
One way to extract points is as follows:
points = Cases[
Cases[InputForm[plot], Line[___],
Infinity], {_?NumericQ, _?NumericQ}, Infinity];
ListPlot to 'take a look'
ListPlot[points]
giving the following:
EDIT
Brett Champion has pointed out that InputForm is superfluous.
ListPlot#Cases[
Cases[plot, Line[___], Infinity], {_?NumericQ, _?NumericQ},
Infinity]
will work.
It is also possible to paste in the plot graphic, and this is sometimes useful. If,say, I create a ListPlot of external data and then mislay the data file (so that I only have access to the generated graphic), I may regenerate the data by selecting the graphic cell bracket,copy and paste:
ListPlot#Transpose[{Range[10], 4 Range[10]}]
points = Cases[
Cases[** Paste_Grphic _Here **, Point[___],
Infinity], {_?NumericQ, _?NumericQ}, Infinity]
Edit 2.
I should also have cross-referenced and acknowledged this very nice answer by Yaroslav Bulatov.
Edit 3
Brett Champion has not only pointed out that FullForm is superfluous, but that in cases where a GraphicsComplex is generated, applying Normal will convert the complex into primitives. This can be very useful.
For example:
lp = ListPlot[Transpose[{Range[10], Range[10]}],
Filling -> Bottom]; Cases[
Cases[Normal#lp, Point[___],
Infinity], {_?NumericQ, _?NumericQ}, Infinity]
gives (correctly)
{{1., 1.}, {2., 2.}, {3., 3.}, {4., 4.}, {5., 5.}, {6., 6.}, {7.,
7.}, {8., 8.}, {9., 9.}, {10., 10.}}
Thanks to Brett Champion.
Finally, a neater way of using the general approach given in this answer, which I found here
The OP problem, in terms of a ListPlot, may be obtained as follows:
ListPlot#Cases[g, x_Line :> First#x, Infinity]
Edit 4
Even simpler
ListPlot#Cases[plot, Line[{x__}] -> x, Infinity]
or
ListPlot#Cases[** Paste_Grphic _Here **, Line[{x__}] -> x, Infinity]
or
ListPlot#plot[[1, 1, 3, 2, 1]]
This evaluates to True
plot[[1, 1, 3, 2, 1]] == Cases[plot, Line[{x__}] -> x, Infinity]
One way is to use EvaluationMonitor option with Reap and Sow, for example
In[4]:=
(points = Reap[Plot[Sin[x],{x,0,4Pi},EvaluationMonitor:>Sow[{x,Sin[x]}]]][[2,1]])//Short
Out[4]//Short= {{2.56457*10^-7,2.56457*10^-7},<<699>>,{12.5621,-<<21>>}}
In addition to the methods mentioned in Leonid's answer and my follow-up comment, to track plotting progress of slow functions in real time to see what's happening you could do the following (using the example of this recent question):
(* CPU intensive function *)
LogNormalStableCDF[{alpha_, beta_, gamma_, sigma_, delta_}, x_] :=
Block[{u},
NExpectation[
CDF[StableDistribution[alpha, beta, gamma, sigma], (x - delta)/u],
u \[Distributed] LogNormalDistribution[Log[gamma], sigma]]]
(* real time tracking of plot process *)
res = {};
ListLinePlot[res // Sort, Mesh -> All] // Dynamic
Plot[(AppendTo[res, {x, #}]; #) &#
LogNormalStableCDF[{1.5, 1, 1, 0.5, 1}, x], {x, -4, 6},
PlotRange -> All, PlotPoints -> 10, MaxRecursion -> 4]
etc.
Here is a very efficient way to get all the data points:
{plot, {points}} = Reap # Plot[Last#Sow#{x, Sin[x]}, {x, 0, 4 Pi}]
Based on the answer of Sjoerd C. de Vries, I've now written the following code which automates a plot preview (tested on Mathematica 8):
pairs[x_, y_List]:={x, #}& /# y
pairs[x_, y_]:={x, y}
condtranspose[x:{{_List ..}..}]:=Transpose # x
condtranspose[x_]:=x
Protect[SaveData]
MonitorPlot[f_, range_, options: OptionsPattern[]]:=
Module[{data={}, plot},
Module[{tmp=#},
If[FilterRules[{options},SaveData]!={},
ReleaseHold[Hold[SaveData=condtranspose[data]]/.FilterRules[{options},SaveData]];tmp]]&#
Monitor[Plot[(data=Union[data, {pairs[range[[1]], #]}]; #)& # f, range,
Evaluate[FilterRules[{options}, Options[Plot]]]],
plot=ListLinePlot[condtranspose[data], Mesh->All,
FilterRules[{options}, Options[ListLinePlot]]];
Show[plot, Module[{yrange=Options[plot, PlotRange][[1,2,2]]},
Graphics[Line[{{range[[1]], yrange[[1]]}, {range[[1]], yrange[[2]]}}]]]]]]
SetAttributes[MonitorPlot, HoldAll]
In addition to showing the progress of the plot, it also marks the x position where it currently calculates.
The main problem is that for multiple plots, Mathematica applies the same plot style for all curves in the final plot (interestingly, it doesn't on the temporary plots).
To get the data produced into the variable dest, use the option SaveData:>dest
Just another way, possibly implementation dependent:
ListPlot#Flatten[
Plot[Tan#t, {t, 0, 10}] /. Graphics[{{___, {_, y__}}}, ___] -> {y} /. Line -> List
, 2]
Just look into structure of plot (for different type of plots there would be a little bit different structure) and use something like that:
plt = Plot[Sin[x], {x, 0, 1}];
lstpoint = plt[[1, 1, 3, 2, 1]];

Resources