Related
I'm very new to Mathematica, so sorry if this has an obvious answer, but:
I'm trying to use NSolve to find the point of intersection between two functions, one of which was made using Interpolation, but it won't give me a solution.
Here is the input:
data = Table[x, {x, 1, 25, 1}];
data2 = Table[x^.5, {x, 1, 25, 1}];
a1 = Interpolation[Transpose[{data, data2}]];
NSolve[a1[z] == 5 - z^.5, z]
And the output:
NSolve[InterpolatingFunction[][z] == 5 - z^0.5, z, Reals]
Thanks for the help!
In[1]:= data = Table[x, {x, 1, 25, 1}];
data2 = Table[x^.5, {x, 1, 25, 1}];
a1 = Interpolation[Transpose[{data, data2}]];
r = z /. FindRoot[a1[z] - (5 - z^.5), {z, 1}];
{r, a1[r], 5 - r^.5}
Out[5]= {6.24994, 2.50001, 2.50001}
I am currently writing a module that's supposed to take some data points of 2-dimensional function (a 3 x N matrix) and draw contour plot of approximation based on those points (functions and variables for fitting are provided by user).
The "header" looks like this:
project4[dataPoints_, functionList_, fittingVarsList_, plotArgs___] :=
Module[{fitFunc, functionContourPlot, dataPointsXY, pointsPlot,
xList, yList},
Example of usage:
project4[data, {1, x, y, x y, x^2, y^2}, {x, y}]
(where data = {{x1,y1,f1}...})
After checking if the arguments are valid I do:
fitFunc = Fit[dataPoints, functionList, fittingVarsList];
To obtain the approximation.
Then I want to obtain plot of it by doing:
functionContourPlot = ContourPlot[fitFunc, {fittingVarsList[[1]], xMin, xMax},{fittingVarsList[[2]],yMin, yMax};
Which leads to an errors:
ContourPlot::write: Tag Part in {x,y}[[1]] is Protected. Show::gcomb:
"Could not combine the graphics objects in
Show[ContourPlot[fitFunc$2187,{{x,y}[[1]],xMin,xMax},{{x,y}[[2]],yMin,yMax}],"
What am I doing wrong?
The problem is ContourPlot having attribute HoldAll, which prevents Part evaluating.
Attributes#ContourPlot
You can fix it like this.
data = {{6, 4, 7.92}, {6, 5, 9.31}, {6, 6, 9.74},
{7, 4, 11.24}, {7, 5, 12.09}, {7, 6, 12.62},
{8, 4, 14.31}, {8, 5, 14.58}, {8, 6, 16.16}};
fittingVarsList = {x, y};
{xMin, xMax} = Through[{Min, Max}#data[[All, 1]]];
{yMin, yMax} = Through[{Min, Max}#data[[All, 2]]];
fitFunc = Fit[data, {1, x, y}, {x, y}]
This reproduces the problem :-
functionContourPlot = ContourPlot[fitFunc,
{fittingVarsList[[1]], xMin, xMax},
{fittingVarsList[[2]], yMin, yMax}];
The problem can be fixed by using With to create local variables :-
functionContourPlot =
With[{a = fittingVarsList[[1]], b = fittingVarsList[[2]]},
ContourPlot[fitFunc, {a, xMin, xMax}, {b, yMin, yMax}]]
If you remove HoldAll from the attributes of ContourPlot the first version works ...
Unprotect#ContourPlot;
ClearAttributes[ContourPlot, HoldAll]
... but that would be reckless programming.
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"]
]
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.
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.