Related
I would like to represent a Catenary-curve in Mathematica, and then allow the user to Manipulate each of the parameters, like the Hanging-Points' position (A,B), the cable's weight, the force of gravity etc.?
I would do it like this:
First, define the catenary:
catenary[x_] := a*Cosh[(x - c)/a] + y
Now I can either find the parameters a, c and y of this curve numerically, using FindRoot:
Manipulate[
Module[{root},
(
root = FindRoot[
{
catenary[x1] == y1,
catenary[x2] == y2
} /. {x1 -> pt[[1, 1]], y1 -> pt[[1, 2]], x2 -> pt[[2, 1]], y2 -> pt[[2, 2]], a -> \[Alpha]},
{{y, 0}, {c, 0}}];
Show[
Plot[catenary[x] /. root /. a -> \[Alpha], {x, -2, 2},
PlotRange -> {-3, 3}, AspectRatio -> 3/2],
Graphics[{Red, Point[pt]}]]
)], {{\[Alpha], 1}, 0.001, 10}, {{pt, {{-1, 1}, {1, 1}}}, Locator}]
Alternatively, you could solve for the parameters exactly:
solution = Simplify[Solve[{catenary[x1] == y1, catenary[x2] == y2}, {y, c}]]
and then use this solution in the Manipulate:
Manipulate[
(
s = (solution /. {x1 -> pt[[1, 1]], y1 -> pt[[1, 2]],
x2 -> pt[[2, 1]], y2 -> pt[[2, 2]], a -> \[Alpha]});
s = Select[s,
Im[c /. #] == 0 &&
Abs[pt[[1, 2]] - catenary[pt[[1, 1]]] /. # /. a -> \[Alpha]] <
10^-3 &];
Show[
Plot[catenary[x] /. s /. a -> \[Alpha], {x, -2, 2},
PlotRange -> {-3, 3}, AspectRatio -> 3/2],
Graphics[{Red, Point[pt]}]]
), {{\[Alpha], 1}, 0.001, 10}, {{pt, {{-1., 1.}, {1., 0.5}}},
Locator}]
The FindRoot version is faster and more stable, though. Result looks like this:
For completeness' sake: It's also possible to find a catenary through 3 points:
m = Manipulate[
Module[{root},
(
root =
FindRoot[
catenary[#[[1]]] == #[[2]] & /# pt, {{y, 0}, {c, 0}, {a, 1}}];
Show[
Plot[catenary[x] /. root, {x, -2, 2}, PlotRange -> {-3, 3},
AspectRatio -> 3/2],
Graphics[{Red, Point[pt]}]]
)], {{pt, {{-1, 1}, {1, 1}, {0, 0}}}, Locator}]
I am plotting a table of data using ListPlot in Mathematica. I notice that there are a few asymptotes on the graph which I do not want it to be plotted (i.e. the straight lines between the curves). What should I do to remove the straight lines?
A method from Mark McClure's post here: How to annotate multiple datasets in ListPlots
t = Table[Tan[i], {i, -Pi, Pi, .01}];
plot = ListLinePlot[t];
DeleteCases[plot, Line[_?(Length[#] < 4 &)], Infinity]
Perhaps:
t = Table[Tan[i], {i, -Pi, Pi, .01}];
ListPlot[#, Joined -> True] & /# {t, t /. x_ /; Abs#x > 10 -> None}
Edit
More robust:
t = Table[Tan[i], {i, -Pi, Pi, .01}];
ao = AbsoluteOptions[ListPlot[t, Joined -> True],PlotRange]/. {_ -> {_,x_}} ->x;
ListPlot[t /. x_ /; (x < ao[[1]] || x > ao[[2]]) -> None, Joined -> True]
t = Table[Tan[i], {i, -Pi, Pi, .01}];
plot = ListLinePlot[t];
Using Position
Position[plot, Line[___], Infinity]
{{1, 1, 3, 2}, {1, 1, 3, 3}, {1, 1, 3, 4}, {1, 1, 3, 5}, {1, 1, 3, 6}}
Using Part:
plot[[1, 1, 3, 5 ;; 6]] = Sequence[]; Show[plot]
Say I have three lists: a={1,5,10,15} b={2,4,6,8} and c={1,1,0,1,0}. I want a plot which has a as the x axis, b as the y axis and a red/black dot to mark 1/0. For. e.g. The coordinate (5,4) will have a red dot.
In other words the coordinate (a[i],b[i]) will have a red/black dot depending on whether c[i] is 1 or 0.
I have been trying my hand with ListPlot but can't figure out the options.
I suggest this.
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
Graphics[
{#, Point#{##2}} & ###
Thread#{c /. {1 -> Red, 0 -> Black}, a, b},
Axes -> True, AxesOrigin -> 0
]
Or shorter but more obfuscated
Graphics[
{Hue[1, 1, #], Point#{##2}} & ### Thread#{c, a, b},
Axes -> True, AxesOrigin -> 0
]
Leonid's idea, perhaps more naive.
f[a_, b_, c_] :=
ListPlot[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}]
f[a, b, c]
Edit: Just for fun
f[h_, a_, b_, c_, opt___] :=
h[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}, opt]
f[ ListPlot,
Sort#RandomReal[1, 100],
Sin[(2 \[Pi] #)/100] + RandomReal[#/100] & /# Range[100],
RandomInteger[1, 100],
Joined -> True,
InterpolationOrder -> 2,
Filling -> Axis]
Here are your points:
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
(I deleted the last element from c to make it the same length as a and b). What I'd suggest is to separately make images for points with zeros and ones and then combine them - this seems easiest in this situation:
showPoints[a_, b_, c_] :=
With[{coords = Transpose[{a, b}]},
With[{plotF = ListPlot[Pick[coords, c, #], PlotMarkers -> Automatic, PlotStyle -> #2] &},
Show[MapThread[plotF, {{0, 1}, {Black, Red}}]]]]
Here is the usage:
showPoints[a, b, c]
One possibility:
ListPlot[List /# Transpose[{a, b}],
PlotMarkers -> {1, 1, 0, 1} /. {1 -> { Style[\[FilledCircle], Red], 10},
0 -> { { Style[\[FilledCircle], Black], 10}}},
AxesOrigin -> {0, 0}]
Giving as output:
You could obtain similar results (to those of Leonid) using Graphics:
Graphics[{PointSize[.02], Transpose[{(c/. {1 -> Red, 0 -> Black}),
Point /# Transpose[{a, b}]}]},
Axes -> True, AxesOrigin -> {0, 0}]
I found this from a Cellular Automata Mathematica file, what is pattern and alternatives?
In this block of code, what does Pattern mean:
CellularAutomaton[{ { 0, Blank[], 3} -> 0,
{ Blank[], 2, 3} -> 3,
{ 1, 1, 3 } -> 4,
{ Blank[], 1, 4} -> 4,
{ Alternatives[1, 2] << 1 or 2 >>, 3, Blank[]} -> 5,
{ Pattern[$CellContext`p, Alternatives[0, 1]], 4, Blank[]} -> 7 - $CellContext`p,
{ 7, 2, 6} -> 3,
{ 7, Blank[], Blank[]} -> 7,
{ Blank[], 7, Pattern[$CellContext`p, Alternatives[1, 2]]} -> $CellContext`p,
{ Blank[], Pattern[$CellContext`p, Alternatives[5, 6]], Blank[]} -> 7 - $CellContext`p,
{ Alternatives[5, 6], Pattern[$CellContext`p, Alternatives[1, 2]], Blank[]} -> 7 - $CellContext`p,
{ Alternatives[5, 6], 0, 0} -> 1,
{ Blank[], Pattern[$CellContext`p, Alternatives[1, 2]], Blank[]} -> $CellContext`p,
{ Blank[], Blank[], Blank[]} -> 0}, {
You are defining a Cellular Automaton explicitly.
Each row defines an evolution rule.
You may find the relevant information here.
A few hints for reading your code:
Blank[] is the blank pattern "_" that matches any expression
Pattern[] is Mathematica construct for pattern matching
Alternatives[a,b,c] is the full form for a | b| c ... any of "a, b or c"
Pattern[p, Alternatives[a, b]] names as p the matched expr (a or b)
Edit
So, as an example, the following Automatons are made equivalent:
CellularAutomaton[{
{1, 0} -> 1,
{1, 1} -> 0,
{0, 1} -> 1,
{0, 0} -> 1},
{0, 1, 0}, 10]
CellularAutomaton[{
{1, Pattern[t, Alternatives[1, 0]]} -> Abs[1 - t],
{0, 1} -> 1,
{0, 0} -> 1
}, {0, 1, 0}, 10]
Note: The example is just for you to ease the understanding of the code you posted. There are better ways to define this Automaton.
What is a good way to draw a smooth curve with specified starting and ending point and restricted to be inside of a piecewise linear tube like below?
(source: yaroslavvb.com)
coords = {1 -> {0, 2}, 2 -> {1/3, 1}, 3 -> {0, 0},
4 -> {(1/3 + 2)/2, 1}, 5 -> {2, 1}, 6 -> {2 + 1/3, 0},
7 -> {2 + 1/3, 2}};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 3 -> 2, 2 -> 4, 4 -> 5, 5 -> 6, 5 -> 7};
path = {3, 2, 4, 5, 7};
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[lp, gp, PlotRange -> pr, ImageSize -> is]
Perhaps something like this:
coords = {2 -> {1/3, 1}, 1 -> {0, 0}, 3 -> {(1/3 + 2)/2, 1},
4 -> {2, 1}, 5 -> {2 + 1/3, 2}};
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
path = {1, 2, 3, 4, 5};
f = BezierFunction[
SortBy[coords /. Rule[x_, List[a_, b_]] -> List[a, b], First]];
pp = ParametricPlot[f[t], {t, 0, 1}];
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[pp, lp, gp, PlotRange -> pr, ImageSize -> is]
You may gain a better control over the path by adding/removing control points for the Bezier. As I remember "A Bspline is contained in the convex hull of its control points", so you can add control points inside your thick lines (up and down the middlepoints in actual point set, for example) to bound the Bezier more and more.
Edit
The following is a first try to bound the curve. Bad programming, just to get the feeling of what can be done:
coords = {2 -> {1/3, 1}, 1 -> {0, 0}, 3 -> {(1/3 + 2)/2, 1},
4 -> {2, 1}, 5 -> {2 + 1/3, 2}};
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
path = {1, 2, 3, 4, 5};
kk = SortBy[coords /. Rule[x_, List[y_, z_]] -> List[y, z],
First]; f = BezierFunction[kk];
pp = ParametricPlot[f[t], {t, 0, 1}, Axes -> False];
mp = Table[{a = (kk[[i + 1, 1]] - kk[[i, 1]])/2 + kk[[i, 1]],
Interpolation[{kk[[i]], kk[[i + 1]]}, InterpolationOrder -> 1][
a] + lineThickness/2}, {i, 1, Length[kk] - 1}];
mp2 = mp /. {x_, y_} -> {x, y - lineThickness};
kk1 = SortBy[Union[kk, mp, mp2], First]
g = BezierFunction[kk1];
pp2 = ParametricPlot[g[t], {t, 0, 1}, Axes -> False];
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[pp, pp2, lp, gp, PlotRange -> pr, ImageSize -> is]
Edit 2
Or perhaps better yet:
g1 = Graphics[BSplineCurve[kk1]];
Show[lp, g1, PlotRange -> pr, ImageSize -> is]
This one scales quite well when you enlarge the image (the previous ones don't)