Labeling vertices of a polygon in Mathematica - wolfram-mathematica

Given a set of points in the plane T={a1,a2,...,an} then Graphics[Polygon[T]] will plot the polygon generated by the points. How can I add labels to the polygon's vertices? Have merely the index as a label would be better then nothing. Any ideas?

pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{{LightGray, Polygon[pts]},
{pts /. {x_, y_} :> Text[Style[{x, y}, Red], {x, y}]}}
]
To add point also
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{{LightGray, Polygon[pts]},
{pts /. {x_, y_} :> Text[Style[{x, y}, Red], {x, y}, {0, -1}]},
{pts /. {x_, y_} :> {Blue, PointSize[0.02], Point[{x, y}]}}
}
]
update:
Use the index:
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{{LightGray, Polygon[pts]},
{pts /. {x_, y_} :>
Text[Style[Position[pts, {x, y}], Red], {x, y}, {0, -1}]}
}
]

Nasser's version (update) uses pattern matching. This one uses functional programming. MapIndexed gives you both the coordinates and their index without the need for Position to find it.
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
Graphics[
{
{LightGray, Polygon[pts]},
MapIndexed[Text[Style[#2[[1]], Red], #1, {0, -1}] &, pts]
}
]
or, if you don't like MapIndexed, here's a version with Apply (at level 1, infix notation ###).
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
idx = Range[Length[pts]];
Graphics[
{
{LightGray, Polygon[pts]},
Text[Style[#2, Red], #1, {0, -1}] & ### ({pts, idx}\[Transpose])
}
]
This can be expanded to arbitrary labels as follows:
pts = {{1, 0}, {0, Sqrt[3]}, {-1, 0}};
idx = {"One", "Two", "Three"};
Graphics[
{
{LightGray, Polygon[pts]},
Text[Style[#2, Red], #1, {0, -1}] & ### ({pts, idx}\[Transpose])
}
]

You can leverage the options of GraphPlot for this. Example:
c = RandomReal[1, {3, 2}]
g = GraphPlot[c, VertexLabeling -> True, VertexCoordinateRules -> c];
Graphics[{Polygon#c, g[[1]]}]
This way you can also make use of VertexLabeling -> Tooltip, or VertexRenderingFunction if you want to. If you do not want the edges overlaid, you may add EdgeRenderingFunction -> None to the GraphPlot function. Example:
c = RandomReal[1, {3, 2}]
g = GraphPlot[c, VertexLabeling -> All, VertexCoordinateRules -> c,
EdgeRenderingFunction -> None,
VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .02],
Black, Text[#2, #1]} &)];
Graphics[{Brown, Polygon#c, g[[1]]}]

Related

Mathematica re-use the ColorFunction of another plot

I would very much appreciate your help on my problem.
I would like to use the same color function that applies to the plot of data1 when plotting data2.
For example:
data1 = {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}};
ListPointPlot3D[data1, PlotStyle -> PointSize[0.02],
ColorFunction -> Function[{x, y, z}, RGBColor[x, y, z]]]
and next I wish to plot another data (of same dimensions) using the previous colors in the same exact order (there is an unknown function transforming data1 to data2):
data2 = {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}};
ListPointPlot3D[data2, PlotStyle -> PointSize[0.02],
ColorFunction -> Function[{x, y, z}, fun[x, y, z]]]
but for example a straightforward trial as follows will not work (although fun[] as such does work):
fun[r_, g_, b_] :=Table[RGBColor[data1[[i]]], {i,
Length[data1]}][[Position[data2, {r, g, b}][[1, 1]]]]
The gotcha in this is that ListPointPlot3D takes your integer data and converts to floats which it passes to your ColorFunction, so if you define your color function for discrete integers it fails to match the floats. Try this.. (Your approach may work as well if you work with real data )
data1 = N#{{1, 0, 0}, {0, 1, 0}, {0, 0, 1}};
cfun1[x_, y_, z_] := RGBColor[x, y, z]
ListPointPlot3D[data1, PlotStyle -> PointSize[0.02],
ColorFunction -> cfun1]
data2 = N#{{1, 1, 0}, {1, 0, 1}, {0, 1, 1}};
MapThread[ (cfun2[#2[[1]], #2[[2]], #2[[3]]] = cfun1 ## #1) & ,
{data1, data2}]
ListPointPlot3D[data2, PlotStyle -> PointSize[0.02],
ColorFunction -> cfun2]
A bit of an aside, but you likely would be better off working with graphics primitives, which would look something like this:
colors = cfun1 /# data1;
Graphics3D#MapThread[ {#1, Point##2} & , {colors, data1} ]
Graphics3D#MapThread[ {#1, Point##2} & , {colors, data2} ]
Use the colours from data1 in the PlotStyle option of the data2 plot. The list of directives in the PlotStyle refer to each data series so you have to make each point its own data series. I also take it that the values may not be between zero and one so rescale them for data2's use of RGBColor.
ListPointPlot3D[data1, PlotStyle -> PointSize[0.02],
ColorFunction -> Function[{x, y, z}, RGBColor[x, y, z]]]
rs = MinMax /# Transpose#data1;
ListPointPlot3D[List /# data2,
PlotStyle -> ({PointSize[0.02], RGBColor[Quiet#Thread[Rescale[#, rs]]]} & /# data1)]
Hope this helps.

Catenary with Manipulate

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}]

Combining Plots in Mathematica is not giving the expected result

I'm trying to combine 3 functions graphed on a Plot[] and 1 function graphed on a ParametricPlot[]. My equations are as follows:
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1}, PlotLegend -> {"-2 x", "-2 \!\(\*SqrtBox[\(x\)]\)", "-2 \!\(\*SuperscriptBox[\(x\), \(3/5\)]\)"}]
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,0, 1.40138}, PlotLegend -> {"Problem 3"}]
Show[plota, plotb]
This is the image it gives:
As yoda said, PlotLegends is terrible. However, if you don't mind setting the plot styles manually and repeating them lateron, ShowLegend can help.
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1},
PlotStyle -> {{Red}, {Blue}, {Orange}}];
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u, 0, 1.40138},
PlotStyle -> {{Black}}];
And now
ShowLegend[Show[plota, plotb],
{{{Graphics[{Red, Line[{{0, 0}, {1, 0}}]}], Label1},
{Graphics[{Blue, Line[{{0, 0}, {1, 0}}]}], Label2},
{Graphics[{Orange, Line[{{0, 0}, {1, 0}}]}], Label3},
{Graphics[{Black, Line[{{0, 0}, {1, 0}}]}], Label4}},
LegendSize -> {0.5, 0.5}, LegendPosition -> {0.5, -0.2}}]
which will give you this:
You can also write some simple functions to make this a little less cumbersome, if you deal with this problem often.
Well, the root cause of the error is the PlotLegends package, which is a terrible, buggy package. Removing that, Show combines them correctly:
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1}]
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,
0, 1.40138}]
Show[plota, plotb]
You can see Simon's solution here for ideas to label your different curves without using PlotLegends. This answer by James also demonstrates why PlotLegends has the reputation it has...
You can still salvage something with the PlotLegends package. Here's an example using ShowLegends that you can modify to your tastes
colors = {Red, Green, Blue, Pink};
legends = {-2 x, -2 Sqrt[x], -2 x^(3/5), "Problem 3"};
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1},
PlotStyle -> colors[[1 ;; 3]]];
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,
0, 1.40138}, PlotStyle -> colors[[4]]];
ShowLegend[
Show[plota,
plotb], {Table[{Graphics[{colors[[i]], Thick,
Line[{{0, 0}, {1, 0}}]}], legends[[i]]}, {i, 4}],
LegendPosition -> {0.4, -0.15}, LegendSpacing -> 0,
LegendShadow -> None, LegendSize -> 0.6}]
As the other answers pointed out, the culprit is PlotLegend. So, sometimes is useful to be able to roll your own plot legends:
plotStyle = {Red, Green, Blue};
labls = {"a", "b", "Let's go"};
f[i_, s_] := {Graphics[{plotStyle[[i]], Line[{{0, 0}, {1, 0}}]},
ImageSize -> {15, 10}], Style[labls[[i]], s]};
Plot[{Sin[x], Sin[2 x], Sin[3 x]}, {x, 0, 2 Pi},
PlotStyle -> plotStyle,
Epilog ->
Inset[Framed[Style#Column[{Grid[Table[f[i, 15], {i, 1, 3}]]}]],
Offset[{-2, -2}, Scaled[{1, 1}]], {Right, Top}],
PlotRangePadding -> 1
]

Plotting points in Mathematica

I am trying to plot a few points on the following picture in Mathematica:
ParametricPlot3D[
{{u, v, (Cos[u] + Cos[v])/3}, {u, -1, (Cos[u] + Cos[0])/3},
{5, v, (Cos[4] + Cos[v])/3}}, {u, -4, 4}, {v, 0, 8}, Axes -> False,
Boxed -> False, BoxRatios -> {8, 8, 1.5}]
(they should just look like dots on the surface)
What I was trying to do is enter the coordinates of the points manually on another graph using ListPointPlot3D, and then combine them using Show. But for some reason that isn't working. Suggestions?
Also, I would like to add small vectors tangent to the surface in the x directions for the points I have plotted, but I have no idea on how to do that, so suggestions would be very much appreciated!
Perhaps this will help you get started on a solution. It plots 3 random points on the surface. You can change the number of points by setting nPoints. I don't know how to plot tangents along x. But when you figure that out you can use Arrows, as suggested by #Verbeia.
nPoints = 3;
Show[ParametricPlot3D[{
{u, v, (Cos[u] + Cos[v])/3},
{u, -1, (Cos[u] + Cos[0])/3}, {5, v, (Cos[4] + Cos[v])/3}},
{u, -4, 4}, {v, 0, 8}, Axes -> False,
Boxed -> False, BoxRatios -> {8, 8, 1.5},
PlotStyle -> Directive[Opacity[0.5]]],
Graphics3D[{Red, PointSize[.025],
Point[Table[{u1 = RandomReal[{-3, 3}], v1 = RandomReal[{1, 7}],
(Cos[u1] + Cos[v1])/3}, {nPoints}]]}]]
Edit
The following dynamic variation makes use of #belisarius 's contribution:
Manipulate[
Show[ParametricPlot3D[{{u, v, (Cos[u] + Cos[v])/3} },
{u, -4, 4}, {v, 0, 8}, Axes -> False, Boxed -> False,
BoxRatios -> {8, 8, 1.5},
Mesh -> None,
ImageSize -> {400, 300},
PlotRange -> {{-4, 4}, {0, 8}},
PlotRangePadding -> {{0, 1.4}, {0, 0}},
PlotStyle -> Directive[Opacity[0.5]]],
Graphics3D[({Red, PointSize[.025],
Point#f[pt[[1, 1]], pt[[1, 2]]], Black,
Arrow[{f[pt[[1, 1]], pt[[1, 2]]],
f[pt[[1, 1]], pt[[1, 2]]] + D[f[t, pt[[1, 2]]], t] /.
t -> pt[[1, 1]]}]}]],
Grid[{{
LocatorPane[Dynamic[pt],
Dynamic[Graphics[{},
PlotRange -> {{-4, 4}, {0, 8}},
Frame -> True,
ImageSize -> 160,
FrameTicks -> {Range[-4, 4], Range[0, 8], None, None},
FrameLabel -> {"u", "v"},
GridLines -> {Range[-4, 4], Range[0, 8]},
GridLinesStyle -> Directive[LightGray]]],
{{-4, 0}, {4, 8}}]}}],
{{pt, {{1, 2}}}, ControlType -> None},
Initialization :> {f[u_, v_] := {u, v, (Cos[u] + Cos[v])/3};}]
For the Arrows
f[u_, v_] := {u, v, (Cos[u] + Cos[v])/3};
Show[ParametricPlot3D[{f[u, v]}, {u, -4, 4}, {v, 0, 8},
Axes -> False, Mesh -> None, Boxed -> False, BoxRatios -> {8, 8, 1.5},
PlotStyle -> Directive[Opacity[0.5]]],
Graphics3D#
Table[{Red, PointSize[.025], Point#f[u, v],
Black, Arrow[{f[u, v], f[u, v] + D[f[t, v], t] /. t -> u}]},
{u, -4, 4, 2}, {v, 0, 8, 2}]]
For getting the arrows in any direction a = { a1, a2 } instead of x, you may do:
Dot[{a1,a2}.#] & /# D[f[u, v], {{u, v}}]
(*
-> {a1, a2, -(1/3) a1 Sin[u] - 1/3 a2 Sin[v]}
*)
Edit
Both derivatives and normal:
f[u_, v_] := {u, v, (Cos[u] + Cos[v])/3};
Show[
Graphics3D#
Table[{Red, PointSize[.025], Point#f[u, v], Black, Arrowheads[.02],
Arrow[{f[u, v], f[u, v] + D[f[t, v], t] /. t -> u}],
Arrow[{f[u, v], f[u, v] + D[f[u, t], t] /. t -> v}],
Arrow[{f[u, v], f[u, v] +
Cross[D[f[t, v], t] /. t -> u,
D[f[u, t], t] /. t -> v]}]},
{u, -4, 4, 2}, {v, 0, 8, 2}],
ParametricPlot3D[{f[u, v]}, {u, -4, 4}, {v, 0, 8},
Axes -> False, Mesh -> 3, MeshStyle -> {{Opacity[0.1], LightBlue}},
Boxed -> False, BoxRatios -> {8, 8, 1.5},
PlotStyle -> Directive[Opacity[0.5]]]]
You can combine the plot with points using Graphics3D[listofpoints], where listofpoints is a T*3 matrix list, and the arrows using constructs like Graphics3D[Arrow[{{1, 1, -1}, {2, 2, 0}, {3, 3, -1}, {4, 4, 0}}]]. If they are all Graphics3D objects, you should be able to combine them with Show.
Sorry, I am not near a Mathematica installation to provide you with an example just now.

Graphical Representation of Lists

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}]

Resources