Related
I have a cloud of points in 3D. It is easy to plot them with Mathematica with ListPlot3D function. The coloring is a bit difficult for me. I would like to get a result like this:
SphericalPlot3D[
1 + Sin[-5 \[Phi]] Sin[-5 \[Theta]]/10, {\[Theta],
0, \[Pi]}, {\[Phi], 0, 2 \[Pi]},
ColorFunction -> (ColorData["Rainbow"][#6] &), Mesh -> None,
PlotPoints -> 30, Boxed -> False, Axes -> False]
So that color would show the radial distance from the center. Is it possible to do it? I also have very near spherical cloud of data, more precisely spherical-like cap with bulges.
You can do :
nPoints = 10^3;
SeedRandom[7];
data = CoordinateTransformData["Spherical" -> "Cartesian", "Mapping", #] & /#
Transpose[{1 + RandomReal[{-0.15, 0.15}, nPoints], RandomReal[{0, Pi}, nPoints], RandomReal[{-Pi, Pi}, nPoints]}];
ListSurfacePlot3D[data,
ColorFunction -> (ColorData["Rainbow"][EuclideanDistance[{0, 0, 0},{#1, #2, #3}]] &),
ColorFunctionScaling -> False, Mesh -> None, Boxed -> False, Axes -> False]
I'm modelling the gravity field of the eight planets and trying to export the resulting ContourPlot as a .avi file. The problem is that the .avi plays the animation both forwards and backwards, even though I explicitly tell Animate that AnimationDirection->Forward. Anyone know any solutions? Here's the offending piece of code:
gfield = Animate[
ContourPlot[
Sqrt[Fgravplanets[x, y, t][[1]]^2 + Fgravplanets[x, y, t][[2]]^2],
{x, -1.5 rp["Neptune"], 1.5 rp["Neptune"]}, {y, -1.5 rp["Neptune"],
1.5 rp["Neptune"]},
PlotRange -> {0, 10},
Mesh -> None,
ImageSize -> Medium,
AxesLabel -> {"x", "y", "Fgrav"},
ColorFunction -> Hue,
PlotPoints -> 20,
Contours -> 20
],
{t, 0, 365*24*3600*10, 365*24*3600/10},
AnimationDirection -> Forward,
AnimationRate -> 365*24*3600/5
]
Export["gfield.avi", gfield]
Just replace Animate by Table:
gfield = Table[
ContourPlot[
Sqrt[Fgravplanets[x, y, t][[1]]^2 + Fgravplanets[x, y, t][[2]]^2],
{x, -1.5 rp["Neptune"], 1.5 rp["Neptune"]}, {y, -1.5 rp["Neptune"],
1.5 rp["Neptune"]},
PlotRange -> {0, 10},
Mesh -> None,
ImageSize -> Medium,
AxesLabel -> {"x", "y", "Fgrav"},
ColorFunction -> Hue,
PlotPoints -> 20,
Contours -> 20
],
{t, 0, 365*24*3600*10, 365*24*3600/10}];
Export["gfield.avi", gfield]
Exporting to .avi works as expected for lists of graphics. You might have to adjust the step size in the Table iterator to achieve your desired framerate.
I'm trying to write a program in Mathematica that will simulate the way charged ball bearings spread out when they are charged with like charges (they repel each other). My program so far keeps the ball bearings from moving off the screen, and counts the number of times they hit the side of the box. I have the ball bearings moving randomly around the box so far, but I need to know how to make them repel each other.
Here's my code so far:
Manipulate[
(*If the number of points has been reduced, discard points*)
If[ballcount < Length[contents],
contents = Take[contents, ballcount]];
(*If the number of points has been increased, generate some random points*)
If[ballcount > Length[contents],
contents =
Join[contents,
Table[{RandomReal[{-size, size}, {2}], {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}, {ballcount - Length[contents]}]]];
Grid[{{Graphics[{PointSize[0.02],
(*Draw the container*)
Line[size {{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}],
Blend[{Blue, Red}, charge/0.3],
Point[
(*Start the main dynamic actions*)
Dynamic[
(*Reset the collision counter*)
collision = 0;
(*Check for mouse interaction and add points if there has been one*)
Refresh[
If[pt =!= lastpt, If[ballcount =!= 50, ballcount++];
AppendTo[
contents, {pt, {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}]; lastpt = pt],
TrackedSymbols -> {pt}];
(*Update the position of the points using their velocity values*)
contents = Map[{#[[1]] + #[[2]] charge, #[[2]]} &, contents];
(*Check for and fix points that have exceeded the box in Y
direction, incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 2]]] > size,
collision++; {{#[[1, 1]],
2 size Sign[#[[1, 2]]] - #[[1, 2]]}, {1, -1} #[[
2]]}, #] &,
contents];
(*Check for and fix points that have exceeded the box in X
direction, incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 1]]] > size,
collision++; {{2 size Sign[#[[1, 1]]] - #[[1, 1]], #[[1,
2]]}, {-1, 1} #[[2]]}, #] &,
contents];
hits = Take[PadLeft[Append[hits, collision/size], 200], 200];
Map[First, contents]]]},
PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}},
ImageSize -> {250, 250}],
(*Show the hits*)
Dynamic#Show
[
ListPlot
[
Take[MovingAverage[hits, smooth], -100
]
,
Joined -> True, ImageSize -> {250, 250}, AspectRatio -> 1,
PlotLabel -> "number of hits", AxesLabel -> {"time", "hits"},
PlotRange -> {0, Max[Max[hits], 1]}], Graphics[]
]
}}
]
,
{{pt, {0, 1}}, {-1, -1}, {1, 1}, Locator, Appearance -> None},
{{ballcount, 5, "number of ball bearings"}, 1, 50, 1},
{{charge, 0.05, "charge"}, 0.002, 0.3},
{smooth, 1, ControlType -> None, Appearance -> None},
{size, 1, ControlType -> None, Appearance -> None},
{hits, {{}}, ControlType -> None},
{contents, {{}}, ControlType -> None},
{lastpt, {{0, 0}}, ControlType -> None}
]
What you need for your simulation is a "collision detection algorithm". The field of those algorithms is widespread since it is as old as computer games (Pong) are and it is impossible to give a complete answer here.
Your simulation as it is now is very basic because you advance your charged balls every time step which makes them "jump" from position to position. If the movement is as simple as it is with the constant velocity and zero acceleration, you know the exact equation of the movement and could calculate all positions by simply putting the time into the equations. When a ball bounces off the wall, it gets a new equation.
With this, you could predict, when two balls will collide. You simply solve for two balls, whether they have at the same time the same position. This is called A Priori detection. When you take your simulation as it is now, you would have to check at every timestep, whether or not two balls are so close together, that they may collide.
The problem there is, that your simulation speed is not infinitely high and the faster your balls are, the bigger the jumps in your simulation. It is then not unlikely, that two balls over-jump each other and you miss a collision.
With this in mind, you could start by reading the Wikipedia article to that topic, to get an overview. Next, you could read some scientific articles about it or check out, how the cracks do it. The Chipmunk physics engine for instance is an amazing 2d-physics engine. To ensure that such stuff works, I'm pretty sure they had to put a lot thoughts in their collision detection.
I can't do the detection part since that is a project on its own. But it seems now the interaction is faster, you had few Dynamics which were not needed. (if you see the side of the cell busy all the time, this always mean a Dynamic is busy where it should not be).
I also added a STOP/START button. I could not understand everything you were doing, but enough to make the changes I made. You are also using AppendTo everything. You should try to allocate contents before hand, and use Part[] to access it, would be much faster, since you seem to know the maximum points allowed?
I like to spread the code out more, this helps me see the logic more.
Here is a screen shot, and the updated version code is below. Hope you find it faster.
Please see code below, in update (1)
Update (1)
(*updated version 12/30/11 9:40 AM*)
Manipulate[(*If the number of points has been reduced,discard points*)
\
Module[{tbl, rand, npt, ballsToAdd},
If[running,
(
tick += $MachineEpsilon;
If[ballcount < Length[contents],
contents = Take[contents, ballcount]];
(*If the number of points has been increased,
generate some random points*)
If[ballcount > Length[contents],
(
ballsToAdd = ballcount - Length[contents];
tbl =
Table[{RandomReal[{-size, size}, {2}], {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}, {ballsToAdd}];
contents = Join[contents, tbl]
)
];
image = Grid[{
{LocatorPane[Dynamic[pt], Graphics[{
PointSize[0.02],(*Draw the container*)
Line[size {{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}],
Blend[{Blue, Red}, charge/0.3],
Point[(*Start the main dynamic actions*)
(*Reset the collision counter*)
collision = 0;
(*Check for mouse interaction and add points if there has \
been one*)
If[EuclideanDistance[pt, lastpt] > 0.001, (*adjust*)
(
If[ballcount < MAXPOINTS,
ballcount++
];
rand = RandomReal[{0, 2 \[Pi]}];
npt = {Cos[rand], Sin[rand]};
AppendTo[contents, {pt, npt} ];
lastpt = pt
)
];
(*Update the position of the points using their velocity \
values*)
contents =
Map[{#[[1]] + #[[2]] charge, #[[2]]} &, contents];
(*Check for and fix points that have exceeded the box in \
Y direction,incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 2]]] > size,
(
collision++;
{{#[[1, 1]],
2 size Sign[#[[1, 2]]] - #[[1, 2]]}, {1, -1} #[[2]]}
),
(
#
)
] &, contents
];
(*Check for and fix points that have exceeded the box in \
X direction,
incrementing the collision counter for each one*)
contents =
Map[If[Abs[#[[1, 1]]] > size,
collision++; {{2 size Sign[#[[1, 1]]] - #[[1, 1]], #[[
1, 2]]}, {-1, 1} #[[2]]}, #] &, contents
];
hits = Take[PadLeft[Append[hits, collision/size], 200],
200];
Map[First, contents]
]
},
PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}},
ImageSize -> {250, 250}
], Appearance -> None
],(*Show the hits*)
Show[ListPlot[Take[MovingAverage[hits, smooth], -100],
Joined -> True, ImageSize -> {250, 250}, AspectRatio -> 1,
PlotLabel -> "number of hits", AxesLabel -> {"time", "hits"},
PlotRange -> {0, Max[Max[hits], 1]}
]
]
}
}
]
)
];
image
],
{{MAXPOINTS, 50}, None},
{pt, {{0, 1}}, None},
{{ballcount, 5, "number of ball bearings"}, 1, MAXPOINTS, 1,
Appearance -> "Labeled", ImageSize -> Small},
{{charge, 0.05, "charge"}, 0.002, 0.3, Appearance -> "Labeled",
ImageSize -> Small},
Row[{Button["START", {running = True; tick += $MachineEpsilon}],
Button["STOP", running = False]}],
{{tick, 0}, None},
{smooth, 1, None},
{size, 1, None},
{hits, {{}}, None},
{{contents, {}}, None},
{lastpt, {{0, 0}}, None},
{{collision, 0}, None},
{image, None},
{{running, True}, None},
TrackedSymbols -> { tick},
ContinuousAction -> False,
SynchronousUpdating -> True
]
Here is a set of structured 3D points. Now we can form a BSpline using these points as knots.
dat=Import["3DFoil.mat", "Data"]
fu=BSplineFunction[dat]
Here we can do a ParametricPlot3D with these points.
pic=ParametricPlot3D[fu[u,v],{u, 0, 1}, {v, 0, 1}, Mesh -> All, AspectRatio ->
Automatic,PlotPoints->10,Boxed-> False,Axes-> False]
Question
If we carefully look at the 3D geometry coming out of the spline we can see that it is a hollow structure. This hole appears in both side of the symmetric profile. How can we perfectly (not visually!) fill up this hole and create a unified Graphics3D object where holes in both sides are patched.
What I am able to get so far is the following. Holes are not fully patched.
I am asking too many questions recently and I am sorry for that. But if any of you get interested I hope you will help.
Update
Here is the problem with belisarius method.
It generates triangles with almost negligible areas.
dat = Import[NotebookDirectory[] <> "/3DFoil.mat", "Data"];
(*With your points in "dat"*)
fd = First#Dimensions#dat;
check = ParametricPlot3D[{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}][u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]}, {u, 0,
1}, {v, 0, 1}, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
output is here
Export[NotebookDirectory[]<>"myres.obj",check];
cd=Import[NotebookDirectory[]<>"myres.obj"];
middle=
check[[1]][[2]][[1]][[1(* Here are the numbers of different Graphics group*)]][[2,1,1,1]];
sidePatch1=check[[1]][[2]][[1]][[2]][[2,1,1,1]];
sidePatch2=check[[1]][[2]][[1]][[3]][[2,1,1,1]];
There are three Graphics groups rest are empty. Now lets see the area of the triangles in those groups.
polygonArea[pts_List?
(Length[#]==3&)]:=Norm[Cross[pts[[2]]-pts[[1]],pts[[3]]-pts[[1]]]]/2
TriangleMaker[{a_,b_,c_}]:={vertices[[a]],vertices[[b]],vertices[[c]]}
tring=Map[polygonArea[TriangleMaker[#]]&,middle];
tring//Min
For the middle large group output is
0.000228007
This is therefore a permissible triangulation. But for the side patches we get zero areas.
Map[polygonArea[TriangleMaker[#]] &, sidePatch1] // Min
Map[polygonArea[TriangleMaker[#]] &, sidePatch2] // Min
Any way out here belisarius ?
My partial solution
First download the package for simplifying complex polygon from Wolfram archive.
fu = BSplineFunction[dat];
pic =(*ParametricPlot3D[fu[u,v],{u,0,1},{v,0,1},Mesh->None,
AspectRatio->Automatic,PlotPoints->25,Boxed->False,Axes->False,
BoundaryStyle->Red]*)
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Black];
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity];
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1];
nf = Nearest[bound -> Automatic]; {a1, a2} =
Union#Flatten#(nf /# corners);
sets = {bound[[2 ;; a1]], bound[[a1 ;; a2]],bound[[a2 ;; a2 + a1]]};
CorrectOneNodeNumber = Polygon[sets[[{1, 3}]]][[1]][[1]] // Length;
CorrectOneNodes1 =
Polygon[sets[[{1, 3}]]][[1]][[1]]; CorrectOneNodes2 =
Take[Polygon[sets[[{1, 3}]]][[1]][[2]], CorrectOneNodeNumber];
<< PolygonTriangulation`SimplePolygonTriangulation`
ver1 = CorrectOneNodes1;
ver2 = CorrectOneNodes2;
triang1 = SimplePolygonTriangulation3D[ver1];
triang2 = SimplePolygonTriangulation3D[ver2];
Show[Graphics3D[{PointSize[Large], Point[CorrectOneNodes1]},Boxed -> False,
BoxRatios -> 1], Graphics3D[{PointSize[Large], Point[CorrectOneNodes2]},
Boxed -> False, BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver1, Polygon[triang1]], Boxed -> False,
BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver2, Polygon[triang2]], Boxed -> False,
BoxRatios -> 1]]
We get nice triangles here.
picfin=ParametricPlot3D[fu[u,v],{u,0,1}, {v,0,1},Mesh->All,AspectRatio->Automatic,PlotPoints->10,Boxed->False,Axes->False,BoundaryStyle->None];pic3D=Show[Graphics3D[GraphicsComplex[ver1,Polygon[triang1]]],picfin,Graphics3D[GraphicsComplex[ver2,Polygon[triang2]]],Boxed->False,Axes->False]
Now this has just one problem. Here irrespective of the PlotPoints there are four triangles always appearing that just shares only one edge with any other neighboring triangle. But we expect all of the triangles to share at least two edges with other trangles. That happens if we use belisarius method. But it creates too small triangles that my panel solver rejects as tingles with zero area.
One can check here the problem of my method. Here we will use the method from the solution by Sjoerd.
Export[NotebookDirectory[]<>"myres.obj",pic3D];
cd=Import[NotebookDirectory[]<>"myres.obj"];
polygons=(cd[[1]][[2]]/.GraphicsComplex-> List)[[2]][[1]][[1,1]];
pt=(cd[[1]][[2]]/.GraphicsComplex-> List)[[1]];
vertices=pt;
(*Split every triangle in 3 edges,with nodes in each edge sorted*)
triangleEdges=(Sort/#Subsets[#,{2}])&/#polygons;
(*Generate a list of edges*)
singleEdges=Union[Flatten[triangleEdges,1]];
(*Define a function which,given an edge (node number list),returns the bordering*)
(*triangle numbers.It's done by working through each of the triangles' edges*)
ClearAll[edgesNeighbors]
edgesNeighbors[_]={};
MapIndexed[(edgesNeighbors[#1[[1]]]=Flatten[{edgesNeighbors[#1[[1]]],#2[[1]]}];
edgesNeighbors[#1[[2]]]=Flatten[{edgesNeighbors[#1[[2]]],#2[[1]]}];
edgesNeighbors[#1[[3]]]=Flatten[{edgesNeighbors[#1[[3]]],#2[[1]]}];)&,triangleEdges];
(*Build a triangle relation table.Each'1' indicates a triangle relation*)
relations=ConstantArray[0,{triangleEdges//Length,triangleEdges//Length}];
Scan[(n=edgesNeighbors[##];
If[Length[n]==2,{n1,n2}=n;
relations[[n1,n2]]=1;relations[[n2,n1]]=1];)&,singleEdges]
(*Build a neighborhood list*)
triangleNeigbours=Table[Flatten[Position[relations[[i]],1]],{i,triangleEdges//Length}];
trires=Table[Flatten[{polygons[[i]],triangleNeigbours[[i]]}],{i,1,Length#polygons}];
Cases[Cases[trires,x_:>Length[x]],4]
Output shows always there are four triangles that shares only one edges with others.
{4,4,4,4}
In case of belisarius method we don't see this happening but there we get triangles with numerically zero areas.
BR
Import the data and construct the BSpline function as before:
dat = Import["Downloads/3DFoil.mat", "Data"];
fu = BSplineFunction[dat]
Generate the surface, making sure to include (only) the boundary line, which will follow the edge of the surface. Make sure to set Mesh to either All or None.
pic = ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Red]
Extract the points from the boundary line:
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity]
Find the "corners", based on your parameter space:
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1]
Find the edge points best corresponding to the corners, keeping in mind that ParametricPlot3D doesn't use the limits exactly, so we can't just use Position:
nf = Nearest[bound -> Automatic];
nf /# corners
Figure our which range of points on the boundary correspond to the areas you need to fill up. This step involved some manual inspection.
sets = {bound[[2 ;; 22]], bound[[22 ;; 52]], bound[[52 ;; 72]],
bound[[72 ;;]]}
Construct new polygons corresponding to the holes:
Graphics3D[Polygon[sets[[{1, 3}]]], Boxed -> False, BoxRatios -> 1]
Show[pic, Graphics3D[Polygon[sets[[{1, 3}]]]]]
Note that there is probably still a hole that can't be seen where the edge runs between the holes you mentioned, and I haven't tried to fill it in, but you should have enough information to do that if needed.
Your data set looks like this:
Graphics3D[Point#Flatten[dat, 1]]
It consists of 22 sections of 50 points.
Adding a mid-line in each end section (which is actually the end section flattened):
dat2 = Append[Prepend[dat,
Table[(dat[[1, i]] + dat[[1, -i]])/2, {i, Length[dat[[1]]]}]
],
Table[(dat[[-1, i]] + dat[[-1, -i]])/2, {i, Length[dat[[-1]]]}]
];
Graphics3D[{Point#Flatten[dat, 1], Red, Point#dat2[[1]], Green, Point#dat2[[-1]]}]
Now add some weights to the wingtip rim:
sw = Table[1, {24}, {50}];
sw[[2]] = 1000 sw[[1]];
sw[[-2]] = 1000 sw[[1]];
fu = BSplineFunction[dat2, SplineWeights -> sw];
Show[
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> All,
AspectRatio -> Automatic, PlotPoints -> 20, Boxed -> False,
Axes -> False, Lighting -> "Neutral"
],
Graphics3D[{PointSize -> 0.025, Green, Point#dat2[[-1]], Red,Point#dat2[[-2]]}]
]
Note that I increased the PlotPoints value to 20.
(*With your points in "dat"*)
fu = BSplineFunction[dat[[1 ;; 2]]];
Show[{ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic, PlotPoints -> 30],
ListPlot3D[dat[[1]]]}]
And with
InputForm[%]
you get the "unified" graphics object.
Edit
Another way, probably better:
(*With your points in "dat"*)
fu = BSplineFunction[dat];
Show[
{ ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False],
ParametricPlot3D[
BSplineFunction[{First#dat, Reverse#First#dat}][u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> None, PlotStyle -> Yellow],
ParametricPlot3D[
BSplineFunction[{dat[[First#Dimensions#dat]],
Reverse#dat[[First#Dimensions#dat]]}]
[u, v], {u, 0, 1}, {v, 0, 1}]}]
In just one structure:
(*With your points in "dat"*)
fd = First#Dimensions#dat;
ParametricPlot3D[
{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}] [u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]},
{u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
Edit
You can check that there are small triangles, but they are triangles indeed and not zero area polygons:
fu = BSplineFunction[dat];
check = ParametricPlot3D[{BSplineFunction[{First#dat, Reverse#dat[[1]]}][u, v]},
{u, 0, 1}, {v, 0, 1}, Mesh -> All,
PlotStyle -> Yellow, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False];
pts = check /. Graphics3D[GraphicsComplex[a_, b__], ___] -> a;
m = check[[1]][[2]][[1]][[1]] /. {___, GraphicsGroup[{Polygon[a_]}]} -> a;
t = Replace[m, {a_, b_, c_} -> {pts[[a]], pts[[b]], pts[[c]]}, {1}];
polygonArea[pts_List?(Length[#] == 3 &)] :=
Norm[Cross[pts[[2]] - pts[[1]], pts[[3]] - pts[[1]]]]/2;
t[[Position[Ordering[polygonArea /# t], 1][[1]]]]
(*
->{{{-4.93236, 0.0989696, -2.91748},
{-4.92674, 0.0990546, -2.91748},
{-4.93456, 0.100181, -2.91748}}}
*)
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}]