Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

From an array of numbers, I would like to determine (and then colour appropriately) which points are symmetric about a given axis (here, $x = 1/2$), and which are not.

For example, form this:

ListPlot[{{1.5,1.5},{1,1},{1.5,-0.5},{-0.5,-0.5},{-0.5,1},{-0.5,1.5}}, 
PlotStyle -> Red]

I would like to achieve this:

Plot[{0}, {x, -2, 2}, PlotRange -> {-2, 2}, Epilog -> 
{PointSize[Medium], Red,Point[{{{1.5, 1.5}, {-0.5, 1.5}, {1.5, -0.5}, {-0.5, -0.5}}}],
PointSize[Medium], Blue, Point[{{-0.5, 1}, {1, 1}}]}]

(Please excuse the clumsiness with which I code: I am very new to Mathematica.)

I have looked at Symmetric in Wolfram Documentation, but it doesn't seem to cover this. I don't know of a method for selecting certain arrays and formatting them with one colour, then selecting a different set and formatting that with another colour, other than by doing it manually. Is there a way of automating this process? (My goal is to do this for arrays of over 1000 points, so sorting manually is not really an option!)

Update2

Data: array link

Update3

@Kuba, Using the code you provided in answer to my other post:

sol = Solve[N[Table[BernoulliB[n, z], {n, 1000, 1000}] == 0]];

would it be possible to find symmetric points?

(And also format the plot: AspectRatio -> Automatic, Plot Axis @ x = 1/2, etc.?)

Update4

Note: So as not to mislead, I have included a corrected plot. The strange pattern produced without precision adjustment:

enter image description here

is purely caused by numerical error (thanks to Antonio Vargas for pointing this out) - the corrected plot for n = 171 (n = 1000 is too much for my machine!), calculated to greater precision, looks like this:

enter image description here

Plotted using Kuba's code:

sol = Solve[N[Table[BernoulliB[n, z], {n, 171, 171}] == 0, 50]];
point[x_?VectorQ] := {PointSize@.01, Red, Point[x]}
point[x : (_?VectorQ ..)] := {PointSize@.01, Blue, Point /@ {x}}
axis = 1/2;
point @@@ GatherBy[{Re@z, Im@z} /. sol,(*Round added*)
Round[{Abs[#[[1]] - axis], #[[2]]}, 0.001] &] // 
Graphics[#, Frame -> True, GridLines -> {{axis}, None}] &
share|improve this question
1  
something's broken in the second section of code, can you please check again? –  Pinguin Dirk Oct 17 '13 at 6:41
    
@ Pinguin Dirk - Apologies! –  martin Oct 17 '13 at 7:09
    
Is your (x,y)-position binned (discrete) or it can be any pair of real number? Are you interested in both x and y symmetry, or only x, or only y? Could you post the function that generated the point plot? Your codef below it doesn't really help... –  István Zachar Oct 17 '13 at 7:35
    
Your points have real coordinates, is very unlikely you can find symmetric pairs. –  Kuba Oct 17 '13 at 7:49
    
@ Kuba Please see update3 –  martin Oct 17 '13 at 8:01

1 Answer 1

up vote 4 down vote accepted
list = DeleteDuplicates@RandomInteger[{-10, 10}, {155, 2}];
axis = 1/2;

First let's gather points with the same distance form your axis and the same second coordinate.

Those which have simmetric partner will appear in pair so we can gather by length to distinguish singles from pairs.

pts = Join @@@ GatherBy[
               GatherBy[list, {Abs[#[[1]] - axis], #[[2]]} &]
               , Length]

Graphics[{PointSize[0.05],
          Table[{RGBColor @@ RandomReal[1, 3], Point@pts[[ i]]}, {i, Length@pts}]
         }, GridLines -> {{axis}, None}, Frame -> True]

enter image description here


Edit respond to OP's edit. I've also included b.gatessucs suggestion to skip second GatherBy. This is slightly different method.

sol = Solve[N[Table[BernoulliB[n, z], {n, 1000, 1000}] == 0]];

point[x_?VectorQ] := {PointSize@.01, Red, Point[x]}
point[x : (_?VectorQ ..)] := {PointSize@.03, Blue, Point /@ {x}}

axis = 1/2;

point @@@ GatherBy[{Re@z, Im@z} /. sol, {Abs[#[[1]] - axis], #[[2]]} &
                  ] // Graphics[#, Frame -> True, GridLines -> {{axis}, None}] &

enter image description here

There are not so many symmetric pairs because points have real coordinates, you can add Round if you can/want, in order to make the criterium weaker:

point @@@ GatherBy[{Re@z, Im@z} /. sol, 
 (*Round added*)   Round[{Abs[#[[1]] - axis], #[[2]]}, .1] & 
                  ] // Graphics[#, Frame -> True, GridLines -> {{axis}, None}] &

enter image description here

Look out with Round to not catch nearby points as symmetric.

share|improve this answer
1  
Maybe you can avoid the double GatherBy. If you define symmetricQ[point1_, point2_, axis_] := point1[[2]] == point2[[2]] && (point1[[2]] - axis) == (axis - point1[[1]]) then this should work : Graphics[{PointSize[0.05], RGBColor @@ RandomReal[1, 3], (Thread[Point @@ #] )} & /@ Gather[pts, symmetricQ[#1, #2, 1/2] &] , GridLines -> {{axis}, None}, Frame -> True]. –  b.gatessucks Oct 17 '13 at 7:40
    
@b.gatessucks I agree it is not necessary. I was thinking about point[x:{_Integer, _Integer}]:={Red, Point[x]}; point[x:{_List, _List}]:={Blue, Point/@x} and mapping, but I left double GatherBy. –  Kuba Oct 17 '13 at 7:46
    
@ Kuba - fantastic! Thank you so much for your help on this! –  martin Oct 17 '13 at 9:31

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.