How to export GraphicsRow with anti-aliasing? - wolfram-mathematica

When I put two objects below inside GraphicsRow, it seems to turn off their antialiasing. Can anyone see some way to Export graphics row in example below with antialiasing?
(source: yaroslavvb.com)
I tried various combination of Style[#,Antialiasing->True] and Preferences with no luck.
The closest work-around I is to Rasterize them at 4 times the resolution, but that has a side effect of changing appearance of objects with AbsoluteThickness, for instance, Box around each object becomes faded out.
picA = Graphics3D[{Opacity[0.5],
GraphicsComplex[{{-1., 0., 0.}, {0., -1., 0.}, {0., 0., -1.}, {0.,
0., 1.}, {0., 1., 0.}, {1., 0.,
0.}}, {{{EdgeForm[GrayLevel[0.]],
GraphicsGroup[{Polygon[{{4, 5, 1}, {1, 5, 3}, {1, 3, 2}, {4,
1, 2}, {3, 5, 6}, {5, 4, 6}, {4, 2, 6}, {2, 3,
6}}]}]}, {}, {}, {}, {}}}]}];
picB = Graphics3D[{Opacity[0.5],
GraphicsComplex[{{-1., 0., 0.}, {-0.5, -0.8660254037844386,
0.}, {-0.5, 0.8660254037844386, 1.}, {0.,
0., -1.}, {0.5, -0.8660254037844386, 1.}, {0.5,
0.8660254037844386, 0.}, {1., 0.,
0.}}, {{{EdgeForm[GrayLevel[0.]],
GraphicsGroup[{Polygon[{{6, 7, 4}, {2, 1, 4}}],
Polygon[{{1, 2, 5, 3}, {6, 3, 5, 7}, {5, 2, 4, 7}, {3, 6, 4,
1}}]}]}, {}, {}, {}, {}}}]}];
GraphicsRow[{picA, picB}]

just a quick comment: have you enabled anti-aliasing in the Preferences dialog?

Related

Multiple grids in Panel

I have MainTable and SecondTable what I want to do:
MainTable and SecondTable are mostly same (example):
{{1, 1, 0}, {2, 1, 0}, {3, 1, 0}}
All this is in function:
function[] := Module[{}, Panel[Manipulate[
All is working smoothly but I can't get those grids to their position. It's always print only one. I was searching and spent many hours without any result. I appreciates any help.
Example:
function[] := Module[{}, Panel[Manipulate[
MainTable = {{x, 1, 0}, {2, 1, 0}, {3, 1, 0}};
SecondTable = {{y, 1, 0}, {2, 1, 5}, {5, 5, 5}};
Grid[{MainTable, SecondTable}, Frame -> All],
{{x, 1, "Input 1"}, ControlType -> InputField},
{{y, 1, "Input 2"}, ControlType -> InputField}],
FrameMargins -> Automatic]]
Solution:
function[] :=
Module[{},
Panel[Manipulate[
MainTable = {{x, 1, 0}, {2, 1, 0}, {3, 1, 0}};
SecondTable = {{y, 1, 0}, {2, 1, 5}, {5, 5, 5}};
Grid[{{Grid[MainTable, Frame -> All]}, {Grid[SecondTable, Frame -> All]}}],
{{x, 1, "Input 1"}, ControlType -> InputField},
{{y, 1, "Input 2"}, ControlType -> InputField}, Alignment -> Center]]]

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.

Searching for certain triples in a list

Let’s assume we have a list of elements of the type {x,y,z} for x, y
and z integers. And, if needed x < y < z.
We also assume that the list contains at least 3 such triples.
Can Mathematica easily solve the following problem?
To detect at least one triple of the type {a,b,.}, {b,c,.} and {a,c,.}?
I am more intereseted in an elegant 1-liner than computational efficient solutions.
If I understood the problem, you want to detect triples not necessarily following one another, but generally present somewhere in the list. Here is one way to detect all such triples. First, some test list:
In[71]:= tst = RandomInteger[5,{10,3}]
Out[71]= {{1,1,0},{1,3,5},{3,3,4},{1,2,1},{2,0,3},{2,5,1},{4,2,2},
{4,3,4},{1,4,2},{4,4,3}}
Here is the code:
In[73]:=
Apply[Join,ReplaceList[tst,{___,#1,___,#2,___,#3,___}:>{fst,sec,th}]&###
Permutations[{fst:{a_,b_,_},sec:{b_,c_,_},th:{a_,c_,_}}]]
Out[73]= {{{1,4,2},{4,3,4},{1,3,5}},{{1,4,2},{4,2,2},{1,2,1}}}
This may perhaps satisfy your "one-liner" requirement, but is not very efficient. If you need only triples following one another, then, as an alternative to solution given by #Chris, you can do
ReplaceList[list,
{___, seq : PatternSequence[{a_, b_, _}, {b_, c_, _}, {a_,c_, _}], ___} :> {seq}]
I don't know if I interpreted your question correctly but suppose your list is something like
list = Sort /# RandomInteger[10, {20, 3}]
(*
{{3, 9, 9}, {0, 5, 6}, {3, 4, 8}, {4, 6, 10}, {3, 6, 9}, {1, 4, 8},
{0, 6, 10}, {2, 9, 10}, {3, 5, 9}, {6, 7, 9}, {0, 9, 10}, {1, 7, 10},
{4, 5, 10}, {0, 2, 5}, {0, 6, 7}, {1, 8, 10}, {1, 8, 10}}
*)
then you could do something like
ReplaceList[Sort[list],
{___, p:{a_, b_, _}, ___, q:{a_, c_, _}, ___, r:{b_, c_, _}, ___} :> {p, q, r}]
(* Output:
{{{0, 2, 5}, {0, 9, 10}, {2, 9, 10}}, {{3, 4, 8}, {3, 5, 9},
{4, 5, 10}}, {{3, 4, 8}, {3, 6, 9}, {4, 6, 10}}}
*)
Note that this works since it is given that for any element {x,y,z} in the original list we have x<=y. Therefore, for a triple {{a,b,_}, {a,c,_}, {b,c,_}} \[Subset] list we know that a<=b<=c. This means that the three elements {a,b,_}, {a,c,_}, and {b,c,_} will appear in that order in Sort[list].
To match triples "of the type {a,b,.}, {b,c,.} and {a,c,.}":
list = {{34, 37, 8}, {74, 32, 65}, {48, 77, 18}, {77, 100, 30},
{48, 100, 13}, {100, 94, 55}, {48, 94, 73}, {77, 28, 12},
{90, 91, 51}, {34, 5, 32}};
Cases[Partition[list, 3, 1], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}]
(Edited)
(Tuples was not the way to go)
Do you require something like:
list = RandomInteger[10, {50, 3}];
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}} /; a < b < c]
giving
{{{0, 1, 2}, {1, 5, 2}, {0, 5, 4}},
{{2, 3, 5},{3, 4, 10}, {2, 4, 5}},
{{6, 8, 10}, {8, 10, 10},{6, 10, 0}},
{{2, 4, 5}, {4, 8, 2}, {2, 8, 5}},
{{2, 4, 5}, {4, 7, 7}, {2, 7, 3}},
{{0, 2, 2}, {2, 7, 3}, {0, 7, 2}},
{{0, 2, 1}, {2, 7, 3}, {0, 7, 2}}}
or perhaps (as other have interpreted the question):
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}];

Resources