Is there a way to draw a set of lines in mathematica all with the same origin point? - wolfram-mathematica

I have a set of points given by this list:
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
I would like Mathematica to draw a line from the origin to all the points above. In other words draw vectors from the origin (0,0) to all the individual points in the above set. Is there a way to do this? So far I've tried the Filling option, PlotPoints and VectorPlot but they don't seem to be able to do what I want.

Starting easy, and then increasing difficulty:
Graphics[{Arrow[{{0, 0}, #}] & /# list1}]
Graphics[{Arrow[{{0, 0}, #}] & /# list1}, Axes -> True]
Needs["PlotLegends`"];
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
k = ColorData[22, "ColorList"][[;; Length#list1]];
GraphicsRow[{
Graphics[Riffle[k, Arrow[{{0, 0}, #}] & /# #], Axes -> True],
Graphics#Legend[Table[{k[[i]], #[[i]]}, {i, Length##}]]}] &#list1
Needs["PlotLegends`"];
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
k = ColorData[22, "ColorList"][[;; Length#list1]];
ls = Sequence[Thick, Line[{{0, 0}, {1, 0}}]];
GraphicsRow[{
Graphics[Riffle[k, Arrow[{{0, 0}, #}] & /# #], Axes -> True],
Graphics#Legend[MapThread[{Graphics[{#1, ls}], #2} &, {k, #}]]}] &#list1
Needs["PlotLegends`"];
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
pr = {Min##, Max##} & /# Transpose#list1;
k = ColorData[22, "ColorList"][[;; Length#list1]];
GraphicsRow[{
Graphics[r = Riffle[k, {Thick,Arrow[{{0, 0}, #}]} & /# #], Axes -> True],
Graphics#
Legend[MapThread[
{Graphics[#1, Axes -> True, Ticks -> None, PlotRange -> pr],
Text#Style[#2, 20]} &,
{Partition[r, 2], #}]]}] &#list1
You could also tweak ListVectorPlot, although I don't see why you should do it, as it is not intended to use like this:
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
data = Table[{i/2, -i/Norm[i]}, {i, list1}];
ListVectorPlot[data, VectorPoints -> All,
VectorScale -> {1, 1, Norm[{#1, #2}] &},
VectorStyle -> {Arrowheads[{-.05, 0}]}]

Graphics[
{
Line[{{0, 0}, #}] & /# list1
}
]
where /# is the shorthand infix notation for the function Map.
I wonder why you tried Filling, Plotpoints and VectorPlot. I must assume you haven't read the documentation at all, because even a superficial reading would tell you that those commands and options have nothing to do with the functionality you're looking for.

Related

Combinations between two lists

I edited the post. I am sorry, I thought that it would appear in the Mathematica section. This question is regarding to the mathematica software.
I would like to make all the possible combinations between two lists with some restrictions. For example, let's say that I have the following lists:
list1=Flatten[Table[{i, j}, {j, 0, 1}, {i, 0, 1}], 1]
{{0, 0}, {1, 0}, {0, 1}, {1, 1}}
list2={a,b}
What I would like to get is a list that makes all the possible combinations between each sublist in list1 and each one in list2, if possible without the elements in list2 taking the same sublist in list1. The solution that I want is:
{{{0, 0, a}, {1, 0, b}}, {{0, 0, a}, {0, 1, b}}, {{0, 0, a}, {1, 1, b}}, {{1, 0, a}, {0, 0, b}}, {{1, 0, a}, {0, 1, b}}, {{1, 0, a}, {1, 1, b}}, {{0, 1, a}, {0, 0, b}}, {{0, 1, a}, {1, 0, b}}, {{0, 1, a}, {1, 1, b}}, {{1, 1, a}, {0, 0, b}}, {{1, 1, a}, {1, 0, b}}, {{1, 1, a}, {0, 1, b}}}
Is there an easy way of doing it?
I would like to do it for larger lists such as the following:
list1=Flatten[Table[{i, j, z}, {z, -2, 2}, {j, -2, 2}, {i, -2, 2}], 2]
{{-2, -2, -2}, {-1, -2, -2}, {0, -2, -2}, {1, -2, -2}, {2, -2, -2},
{-2, -1, -2}, {-1, -1, -2}, {0, -1, -2}, {1, -1, -2}, {2, -1, -2},
{-2, 0, -2}, {-1, 0, -2}, {0, 0, -2}, {1, 0, -2}, {2, 0, -2}, {-2, 1,
-2}, {-1, 1, -2}, {0, 1, -2}, {1, 1, -2}, {2, 1, -2}, {-2, 2, -2}, {-1, 2, -2}, {0, 2, -2}, {1, 2, -2}, {2, 2, -2}, {-2, -2, -1}, {-1,
-2, -1}, {0, -2, -1}, {1, -2, -1}, {2, -2, -1}, {-2, -1, -1}, {-1, -1, -1}, {0, -1, -1}, {1, -1, -1}, {2, -1, -1}, {-2, 0, -1}, {-1, 0, -1}, {0, 0, -1}, {1, 0, -1}, {2, 0, -1}, {-2, 1, -1}, {-1, 1, -1}, {0, 1,
-1}, {1, 1, -1}, {2, 1, -1}, {-2, 2, -1}, {-1, 2, -1}, {0, 2, -1}, {1, 2, -1}, {2, 2, -1}, {-2, -2, 0}, {-1, -2, 0}, {0, -2, 0}, {1, -2, 0},
{2, -2, 0}, {-2, -1, 0}, {-1, -1, 0}, {0, -1, 0}, {1, -1, 0}, {2, -1,
0}, {-2, 0, 0}, {-1, 0, 0}, {0, 0, 0}, {1, 0, 0}, {2, 0, 0}, {-2, 1,
0}, {-1, 1, 0}, {0, 1, 0}, {1, 1, 0}, {2, 1, 0}, {-2, 2, 0}, {-1, 2,
0}, {0, 2, 0}, {1, 2, 0}, {2, 2, 0}, {-2, -2, 1}, {-1, -2, 1}, {0, -2,
1}, {1, -2, 1}, {2, -2, 1}, {-2, -1, 1}, {-1, -1, 1}, {0, -1, 1}, {1,
-1, 1}, {2, -1, 1}, {-2, 0, 1}, {-1, 0, 1}, {0, 0, 1}, {1, 0, 1}, {2, 0, 1}, {-2, 1, 1}, {-1, 1, 1}, {0, 1, 1}, {1, 1, 1}, {2, 1, 1}, {-2,
2, 1}, {-1, 2, 1}, {0, 2, 1}, {1, 2, 1}, {2, 2, 1}, {-2, -2, 2}, {-1,
-2, 2}, {0, -2, 2}, {1, -2, 2}, {2, -2, 2}, {-2, -1, 2}, {-1, -1, 2}, {0, -1, 2}, {1, -1, 2}, {2, -1, 2}, {-2, 0, 2}, {-1, 0, 2}, {0, 0, 2},
{1, 0, 2}, {2, 0, 2}, {-2, 1,2}, {-1, 1, 2}, {0, 1, 2}, {1, 1, 2}, {2,
1, 2}, {-2, 2, 2}, {-1, 2, 2}, {0, 2, 2}, {1, 2, 2}, {2, 2, 2}}
list2={a,b,c,d}
so that the solutions looks like:
{{{-2, -2, -2, a}, {-1, -2, -2, b}, {0, -2, -2, c}, {2, -2, -2, d}},....., {{-2, -2, -2, a}, {-1, -1, -1, b}, {0, 0, 0, c}, {2, 2, 2, d}}
note that the following should not be in the list
{{-2, -2, -2, a},{-2, -2, -2, b},{-2, -2, -2, c},{-2, -2, -2, d}}
Thank you very much.
I am assuming that the specific order of the pairs of triplets is not important.
Your Table construct will be shorter using Tuples.
You can get pairs without duplication using Subsets.
Permutations is used to get all orderings of subsets.
Join and Apply (##) are used to flatten one level of the nested list.
list2 is transformed with List /# {a, b} into {{a}, {b}} for use in:
The final step is to Map the Function Join[#, list2, 2] & onto these subsets.
All together:
list1 = Tuples[{0, 1}, 2]
list2 = List /# {a, b};
Join[#, list2, 2] & /# Join ## Permutations /# Subsets[list1, {2}]
{{{0, 0, a}, {0, 1, b}}, {{0, 1, a}, {0, 0, b}}, {{0, 0, a}, {1, 0, b}},
{{1, 0, a}, {0, 0, b}}, {{0, 0, a}, {1, 1, b}}, {{1, 1, a}, {0, 0, b}},
{{0, 1, a}, {1, 0, b}}, {{1, 0, a}, {0, 1, b}}, {{0, 1, a}, {1, 1, b}},
{{1, 1, a}, {0, 1, b}}, {{1, 0, a}, {1, 1, b}}, {{1, 1, a}, {1, 0, b}}}

How to trace a path graphically in a matrix in mathematica

I have a matrix, i.e., a non-ragged list of lists, and given a list of coordinates, for example in form of {{0,0},{1,1},{2,2},...{5,5}}, I want to trace a path in that matrix and show the results graphically. A colored band for the path is good enough.
Please help me to write such a function in Mathematica. Thanks a lot!
Here's one possibility.
pos = {{1, 1}, {1, 2}, {2, 2}, {3, 3},
{3, 4}, {3, 5}, {4, 5}, {5, 5}};
mat = HankelMatrix[8];
display = Map[Pane[#,{16,20},Alignment->Center]&, mat, {2}];
display = MapAt[Style[#, Background -> Yellow]&, display, pos];
Grid[display, Spacings->{0,0}]
Outlining the entries with a tube, as you describe, is harder. It can be done, though, if we are willing to step down to graphics primitives.
mat = IdentityMatrix[8];
pos = {{1, 1}, {1, 2}, {2, 2}, {3, 3},
{3, 4}, {3, 5}, {4, 5}, {5, 5}};
pos = Map[{#[[1]], -#[[2]]} &, pos];
outline = {CapForm["Round"], JoinForm["Round"],
{AbsoluteThickness[30], Line[pos]},
{AbsoluteThickness[28], White, Line[pos]}};
disks = Table[{Darker[Yellow, 0.07], Disk[p, 0.25]},
{p, pos}];
numbers = MapIndexed[Style[Text[#, {#2[[1]], -#2[[2]]},
{-0.2, 0.2}], FontSize -> 12] &, mat, {2}];
Graphics[{outline, disks, numbers}, ImageSize -> 300]
Another possibility, using ItemStyle:
m = RandomInteger[10, {10, 10}];
c = {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {5, 5}, {5, 6}, {5, 7}, {4, 8}};
Grid[m, ItemStyle -> {Automatic, Automatic, Table[i -> {16, Red}, {i, c}]}]
Which ends up looking like this:
I may have misunderstood the question but this is what I thought you were asking for:
coords = Join ## Array[List, {3, 4}]
{{1, 1}, {1, 2}, {1, 3}, {1, 4}, {2, 1}, {2, 2}, {2, 3}, {2, 4}, {3,
1}, {3, 2}, {3, 3}, {3, 4}}
path = RandomSample[coords, Length[coords]]
{{1, 2}, {3, 3}, {2, 2}, {2, 4}, {3, 1}, {1, 4}, {1, 3}, {2, 1}, {3,
4}, {3, 2}, {2, 3}, {1, 1}}
labels = Text[StyleForm[#], #] & /# coords;
Graphics[Line[path], Epilog -> labels]

PlotMarkers disappear when plotting exactly two polylines in Mathematica?

Not sure if this is a MMA bug or me doing something wrong.
Consider the following function:
plotTrace[points_] :=
ListPlot[points,
Joined -> True,
PlotMarkers -> Table[i, {i, Length#points}]]
now consider passing it values generated by RandomReal. Namely, consider
RandomReal[1, {nTraces, nPointsPerTrace, 2(*constant = nDimensions*)}].
If nTraces is 1, then PlotMarkers are displayed for all values of nPointsPerTrace that I tried:
Manipulate[
plotTrace[RandomReal[1, {1, nPointsPerTrace, 2}]],
{nPointsPerTrace, 1, 20, 1}]
If nTraces is 3 or greater, then plot markers are displayed for all values of nPointsPerTrace that I tried
Manipulate[plotTrace[RandomReal[1, {nTraces, nPointsPerTrace, 2}]],
{nTraces, 3, 20, 1}, {nPointsPerTrace, 1, 20, 1}]
But if nTraces is exactly 2, I don't see plot markers, no matter the value of nPointsPerTrace:
Manipulate[plotTrace[RandomReal[1, {2, nPointsPerTrace, 2}]],
{nPointsPerTrace, 1, 20, 1}]
Hints, clues, advice would be greatly appreciated!
It's treating PlotMarkers -> {1,2} as a marker and size, instead of as two markers:
In[137]:= ListPlot[{{1, 2, 3}, {4, 5, 6}}, PlotMarkers -> {1, 2}] // InputForm
Out[137]//InputForm=
Graphics[GraphicsComplex[{{1., 1.}, {2., 2.}, {3., 3.}, {1., 4.}, {2., 5.}, {3., 6.},
{1., 1.}, {2., 2.}, {3., 3.}, {1., 4.}, {2., 5.}, {3., 6.}},
{{{Hue[0.67, 0.6, 0.6], Inset[Style[1, FontSize -> 2], 7],
Inset[Style[1, FontSize -> 2], 8], Inset[Style[1, FontSize -> 2], 9]},
{Hue[0.9060679774997897, 0.6, 0.6], Inset[Style[1, FontSize -> 2], 10],
Inset[Style[1, FontSize -> 2], 11], Inset[Style[1, FontSize -> 2], 12]}, {}}}],
{AspectRatio -> GoldenRatio^(-1), Axes -> True, AxesOrigin -> {0, 0},
PlotRange -> {{0, 3.}, {0, 6.}}, PlotRangeClipping -> True,
PlotRangePadding -> {Scaled[0.02], Scaled[0.02]}}]
Things get even stranger when you try different things for PlotMarkers. The following does not display the plot markers, as in your examples above.
pts = RandomReal[1, {2, 10, 2}];
(* No markers *)
ListPlot[pts,
Joined -> True,
PlotMarkers -> {1, 2}
]
However, when you change the 2 to b, it does:
pts = RandomReal[1, {2, 10, 2}];
(* Has markers *)
ListPlot[pts,
Joined -> True,
PlotMarkers -> {1, b}
]
If you try to change the 1 to something, it doesn't work:
pts = RandomReal[1, {2, 10, 2}];
(* No markers *)
ListPlot[pts,
Joined -> True,
PlotMarkers -> {a, 2}
]
It does indeed sound like a bug, but I'm not sure if this is version dependent or some behavior that's not obvious.

Labeling vertices of a polygon in 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]]}]

Locator goes out of the graph region

When I run the following code
pMin = {-3, -3};
pMax = {3, 3};
range = {pMin, pMax};
Manipulate[
GraphicsGrid[
{
{Graphics[Locator[p], PlotRange -> range]},
{Graphics[Line[{{0, 0}, p}]]}
}, Frame -> All
],
{{p, {1, 1}}, Locator}
]
I expect the Locator control to be within the bounds of the first Graph, but instead it can be moved around the whole GraphicsGrid region. Is there an error in my code?
I also tried
{{p, {1, 1}}, pMin, pMax, Locator}
instead of
{{p, {1, 1}}, Locator}
But it behaves completely wrong.
UPDATE
Thanks to everyone, this is my final solution:
Manipulate[
distr1 = BinormalDistribution[p1, {1, 1}, \[Rho]1];
distr2 = BinormalDistribution[p2, {1, 1}, \[Rho]2];
Grid[
{
{Graphics[{Locator[p1], Locator[p2]},
PlotRange -> {{-5, 5}, {-5, 5}}]},
{Plot3D[{PDF[distr1, {x, y}], PDF[distr2, {x, y}]}, {x, -5, 5}, {y, -5, 5}, PlotRange -> All]}
}],
{{\[Rho]1, 0}, -0.9, 0.9}, {{\[Rho]2, 0}, -0.9, 0.9},
{{p1, {1, 1}}, Locator},
{{p2, {1, 1}}, Locator}
]
UPDATE
Now the problem is that I cannot resize and rotate the lower 3d graph. Does anyone know how to fix that?
I'm back to the solution with two Slider2D objects.
If you examine the InputForm you'll find that GraphicsGrid returns a Graphics object. Thus, the Locator indeed moves throughout the whole image.
GraphicsGrid[{{Graphics[Circle[]]}, {Graphics[Disk[]]}}] // InputForm
If you just change the GraphicsGrid to a Grid, the locator will be restricted to the first part but the result still looks a bit odd. Your PlotRange specification is a bit strange; it doesn't seem to correspond to any format specified in the Documentation center. Perhaps you want something like the following.
Manipulate[
Grid[{
{Graphics[Locator[p], Axes -> True,
PlotRange -> {{-3, 3}, {-3, 3}}]},
{Graphics[Line[{{0, 0}, p}], Axes -> True,
PlotRange -> {{-3, 3}, {-3, 3}}]}},
Frame -> All],
{{p, {1, 1}}, Locator}]
LocatorPane[] does a nice job of confining the locator to a region.
This is a variation on the method used by Mr. Wizard.
Column[{ LocatorPane[Dynamic[pt3],
Framed#Graphics[{}, ImageSize -> 150, PlotRange -> 3]],
Framed#Graphics[{Line[{{-1, 0}, Dynamic#pt3}]}, ImageSize -> {150, 150},
PlotRange -> 3]}]
I would have assumed that you'd want the locator to share the space with the line it controls. In fact, to be "attached" to the line. This turns out to be even easier to implement.
Column[{LocatorPane[Dynamic[pt3],Framed#Graphics[{Line[{{-1, 0}, Dynamic#pt3}]},
ImageSize -> 150, PlotRange -> 3]]}]
I am not sure what you are trying to achieve. There are a number of problems I see, but I don't know what to address. Perhaps you just want a simple Slider2D construction?
DynamicModule[{p = {1, 1}},
Column#{Slider2D[Dynamic[p], {{-3, -3}, {3, 3}},
ImageSize -> {200, 200}],
Graphics[Line[{{0, 0}, Dynamic[p]}],
PlotRange -> {{-3, 3}, {-3, 3}}, ImageSize -> {200, 200}]}]
This is a reply to the updated question about 3D graphic rotation.
I believe that LocatorPane as suggested by David is a good way to approach this. I just put in a generic function since your example would not run on Mathematica 7.
DynamicModule[{pt = {{-1, 3}, {1, 1}}},
Column[{
LocatorPane[Dynamic[pt],
Framed#Graphics[{}, PlotRange -> {{-5, 5}, {-5, 5}}]],
Dynamic#
Plot3D[{x^2 pt[[1, 1]] + y^2 pt[[1, 2]],
-x^2 pt[[2, 1]] - y^2 pt[[2, 1]]},
{x, -5, 5}, {y, -5, 5}]
}]
]

Resources