Mathematica List Selection

Question

I have a list which contains these elements :

{{{206.314, 4135.81}, {95.84, 0.}},
{{306.314, 4135.81}, {195.84, 0.}},
{{407.704, 4135.81}, {645.716, 0.}}, 
{{966.432, 4135.81}, {919.94, 0.}}, 
{{1116.14, 4135.81}, {1323.13, 0.}},
 {{1711.13, 4135.81}, {1697.04,0.}},
 {{1785.57, 4135.81}, {2152.23, 0.}}, 
{{2422.57, 4135.81}, {2314.23, 0.}},
 {{2713.03, 4135.81}, {2604.99, 0.}}}

The format of the list is {{{ Point 1, Point 2}, {Point 3, Point 4}}, {{Point 1, Point 2}, {Point 3, Point 4}},.......}

Now I want to make a new list which contains only those elements whose Point 1 elements are at a difference of nearly 580-720 to Point 1 points. So my new list should be:

{ {{407.704, 4135.81}, {645.716, 0.}}, , 
{{1116.14, 4135.81}, {1323.13, 0.}} 
{{1711.13, 4135.81}, {1697.04,0.}},
{{2422.57, 4135.81}, {2314.23, 0.}}

How do I do this?

UPDATE

More explanation about the question:-

Suppose we start from 206.314 and find out that there is no other point which is 580-710 more than this. So we now choose 306.314 and now we see that we have 966.432, which is 660 points from 306.314. So we add the two full points {{{306.314, 4135.81}, {195.84, 0.}}, {{966.432, 4135.81}, {919.94, 0.}}} in a new list. Then we find that there is no other point which is 580-710 points more than 966.432. So we drop these two points since we should have a list of minimum 4-5 point set.

So if we take 407 as start we get 4 points:- 1116- 407 = 709 1711- 1116= 595 2422-1711= 711

On the other hand if we take 407 and take 1785 instead of 1711, that is also correct since we will again get 4 points (including 407). So both answers will work in this.

Answer 1

First, I would like to give a very simple example to illustrate what kind of problem I think you want to solve.

Let's have this list of points :

mylist = {21, 23, 26, 31, 31.5, 33, 35, 40.1, 40.4, 42.2, 52.}; 

The problem is : find all the subsets of points such that the distance between 2 consecutive points in each subset is min<d=(xj-xi)<max.

Here, if min=9 and max=11, these subgroups are :

{21, 31, 40.1}
{21, 31, 40.4}
{21, 31.5, 42.2, 52.}
{23, 33, 42.2, 52.}

For example, if we start from 21, the next points within distance [9,11] from it are 31 and 31.5. In the next move you see that 42.2 is at the required distance from 31.5 (9 < 42.2-31.5= 10.7 <11) but not from 31. (22.2-31=11.2 >11). So we know that {21,31.5} will belong to a different subset than {21,31}. And so on. As each subset grows, it can split to form new subsets as it is the case again here for {21,31}.

So, the problem is more complicated than it seems, because there are a lot of combinations to track.

1. First step : for each point find all the points at the given distance min<d<max

Let's do it for the first point of the list :

testpoint = mylist[[1]]
(*21*)

.

Position[mylist, x_?(9 < # - testpoint < 11 & )]
(*{{4}, {5}}*)

.

mylist[[4]]
mylist[[5]]

(* 31 *)
(* 31.5 *)

As expected 31 and 31.5 were found. Let's do it for all the points, and have the result in a friendly and useful way :

closePointsPositions = Table[i -> 
Flatten[Position[mylist, x_?(9 < # - mylist[[i]] < 11 & )]],
{i, Length[mylist]}] // DeleteCases[#, _ -> {}] &

(*{1 -> {4, 5}, 2 -> {6}, 4 -> {8, 9}, 5 -> {10}, 6 -> {10}, 10 -> {11}}*)

This is actually the solution of the problem but in a condensed form. It shows all the connections found, from which you can build the corresponding paths.

For example here : point 1 (21) of the list is within the required distance from point 4 (31.) and from point 5 (31.5). Next, you see that point 4 (31.) is "connected" to the points 8 (40.1) and 9 (40.4). And so on.

How to extract from this result, the corresponding subsets of "connected" points ?

2. Graph approach

The problem really looks like a network problem so it is suitable to be examined with Graph-tools that Mathematica actually has built-in.

(Actually I am very bad at graph theory but this was time to explore)

Let's slightly modify the previous result so it is compatible with graph tools :

edges = Flatten[Thread /@ closePointsPositions]
{1 -> 4, 1 -> 5, 2 -> 6, 4 -> 8, 4 -> 9, 5 -> 10, 6 -> 10, 10 -> 11}

Let's visualize this as a graph :

mygraph = Graph[edges, VertexLabels -> "Name"]

For the labels, if instead of the positions of the points you want the positions values then :

vertexlist = Union[Flatten[edges /. Rule -> List]]
(*{1, 2, 4, 5, 6, 8, 9, 10, 11}*)

.

mygraph = Graph[edges,
VertexLabels -> (# -> NumberForm[mylist[[#]], {20, 1}] & ) /@ vertexlist]

This graphic shows immediatly the different solutions of the problem (when there are more points it is probably less friendly however.)

But how to automatically extract the best solutions from this ?

I did not find in the documentation a function which is able to answer diretcly the question : "give me the longest path(s) in the graph". (As I said before my knowledge in graph tools is very low so maybe this exists ?).

But I found a function GraphDistanceMatrix to list all the path lengths in the network as a function of the starting and ending points(vertex).

TableForm[GraphDistanceMatrix[mygraph], TableHeadings -> 
{c = (Style[#1, Bold, Red] & ) /@ VertexList[mygraph], c}]

You see here that the longest paths are size 3, and correspond to the starting/ending points position {1,11}, and {2,11}

Then to extract the corresponding path, for example :

FindPath[mygraph, 1, 11]
(*{{1, 5, 10, 11}}*)

.

mylist[[FindPath[mygraph, 1, 11][[1]]]]
(*{21, 31.5, 42.2, 52.}*)

You can automatize the results :

maxpathlength = Max[GraphDistanceMatrix[mygraph] /. Infinity -> -1]
(*3*)

For example, we'll be looking for all the path with maximum lengths maxpathlength:

bestpos = Position[GraphDistanceMatrix[mygraph] /. Infinity -> -1,
_?(# >= maxpathlength & )]
(*{{1, 9}, {4, 9}}*)

.

bestvertex = VertexList[mygraph][[#]]& /@ bestpos
(*{{1, 11}, {2, 11}}*)

.

bestpaths = Flatten[FindPath[mygraph, Sequence @@ #]& /@ bestvertex, 1]
(*{{1, 5, 10, 11}, {2, 6, 10, 11}}*)

And finally, as expected, the subsets containing the maximum number of points are :

mylist[[#]]& /@ bestpaths
(*{{21, 31.5, 42.2, 52.}, {23, 33, 42.2, 52.}}*)

3. Approach without graph tools

Actually, before testing the graph tools, I also solved the problem using some common Mathematica functions :

I "just" had to define this nice function :

coolRule[x_ -> y_] := path : {___, x} :>
Sequence @@ (path /. x -> Sequence @@ ## & ) /@ Thread[{x, y}]

Then using the already defined closePointsPositions

closePointsPositions
(*{1 -> {4, 5}, 2 -> {6}, 4 -> {8, 9}, 5 -> {10}, 6 -> {10}, 10 -> {11}}*)

this gives all the starting points of all possible paths :

startpath = Complement[closePointsPositions[[All, 1]],
Flatten[closePointsPositions[[All, 2]]]]
(*{1, 2}*)

this reconstructs the entire paths starting from the previous points :

allpaths = Fold[#1 /. coolRule[#2] & , List /@ startpath, closePointsPositions]
{{1, 4, 8}, {1, 4, 9}, {1, 5, 10, 11}, {2, 6, 10, 11}}

Now, for example I want the paths with more than 3 points :

bestpaths = Select[allpaths, Length[#] > 3 & ]
(*{{1, 5, 10, 11}, {2, 6, 10, 11}}*)

The corresponding positions are as expected :

mylist[[#]]&  /@ bestpaths
(*{{21, 31.5, 42.2, 52.}, {23, 33, 42.2, 52.}}*)

4. Application to your problem

I recommend you to start a fresh kernel :

Quit

then as before :

coolRule[x_ -> y_] := path : {___, x} :>
Sequence @@ (path /. x -> Sequence @@ ## & ) /@ Thread[{x, y}]

Your initial group of points :

allgrouppoints = {{{206.314, 4135.81}, {95.84, 0.}}, {{306.314, 4135.81}, 
{195.84, 0.}}, {{407.704, 4135.81}, {645.716, 0.}}, 
{{966.432, 4135.81}, {919.94, 0.}}, {{1116.14, 4135.81}, {1323.13, 0.}},
 {{1711.13, 4135.81}, {1697.04, 0.}}, {{1785.57, 4135.81}, {2152.23, 0.}},
 {{2422.57, 4135.81}, {2314.23, 0.}}, {{2713.03, 4135.81}, {2604.99, 0.}}}; 

Let's take all the p1 points (as you you defined them in your question) :

mylist = allgrouppoints[[All, 1, 1]]
(*{206.314, 306.314, 407.704, 966.432, 1116.14, 1711.13, 1785.57, 2422.57,
2713.03}*)

Define your distance interval :

min = 580; 
max = 710; 

then

closePointsPositions = Table[i -> Flatten[
Position[mylist, (x_)?(min < # - mylist[[i]] < max & )]], 
{i, Length[mylist]}] // DeleteCases[#, _ -> {}] &;
edges = Flatten[Thread /@ closePointsPositions]; 
vertexlist = Union[Flatten[edges /. Rule -> List]]; 
mygraph = Graph[edges, VertexLabels ->
(# -> NumberForm[mylist[[#]], {20, 1}] & ) /@ vertexlist]

startpath = Complement[closePointsPositions[[All, 1]],
Flatten[closePointsPositions[[All, 2]]]]; 
allpaths = Fold[#1 /. coolRule[#2] & , List /@ startpath, closePointsPositions]; 
maxpoints = Max[Length /@ allpaths]; 
Print["The maximum number of points given the distance interval ", {min, max},
" is :  ", maxpoints];
(*The maximum number of points given the distance interval {580,710} is :  4*)

Get the points subsets containing more than 3 points :

bestpaths = Select[allpaths, Length[#] > 3 & ]; 
mylist[[#]]& /@ bestpaths

gives

{{407.704, 1116.14, 1785.57, 2422.57}}

In your case, to extract the corresponding groups points you just input :

allgrouppoints[[#]]& /@ bestpaths

which gives

{{{{407.704, 4135.81}, {645.716, 0.}}, {{1116.14, 4135.81}, {1323.13, 0.}},
 {{1785.57, 4135.81}, {2152.23, 0.}}, {{2422.57, 4135.81}, {2314.23, 0.}}}}