4
$\begingroup$

I have a list that consists of certain number of coordinates sub-lists (here 8).

(The following data are only an example to describe my problem.)

list={
{1,{{1.00,1.00},{2.00,2.00},{3.00,3.00},{4.00,4.00},{5.00,5.00}}},
{2,{{2.01,2.01},{3.01,3.01},{1.01,1.01},{5.01,5.01},{4.01,4.01}}},
{3,{{1.02,1.02},{3.02,3.02},{4.02,4.02},{6.02,6.02},{5.02,5.02}}},
{4,{{7.00,7.00},{1.03,1.03},{6.03,6.03}}},
{5,{{1.50,1.50},{4.04,4.04},{6.04,6.04},{7.04,7.04}}},
{6,{{1.51,1.51},{4.05,4.05},{7.03,7.03},{6.05,6.05}}},
{7,{{2.50,2.50},{7.00,7.00},{5.01,5.01},{4.03,4.03},{8.01,8.01}}},
{8,{{2.51,2.51},{6.00,6.00},{7.01,7.01},{4.04,4.04},{8.02,8.02}}}
};

Each coordinate sub-list can have a different length.

Depending on the next-neareast coordinate between neighboured sub-lists (which should be below a certain threshold distance, here I assume 0.2) the list should be reformed, so that tracks is obtained.

tracks={
{{1,{1.,1.}},{2,{1.01,1.01}},{3,{1.02,1.02}},{4,{1.03,1.03}}},
{{1,{2.,2.}},{2,{2.01,2.01}}},{{1,{3.,3.}},{2,{3.01,3.01}},{3,{3.02,3.02}}},
{{1,{4.,4.}},{2,{4.01,4.01}},{3,{4.02,4.02}}},
{{1,{5.,5.}},{2,{5.01,5.01}},{3,{5.02,5.02}}},
{{3,{6.02,6.02}},{4,{6.03,6.03}},{5,{6.04,6.04}},{6,{6.05,6.05}}},
{{4,{7.,7.}},{5,{7.04,7.04}},{6,{7.03,7.03}},{7,{7.,7.}},{8,{7.01,7.01}}},
{{5,{1.5,1.5}},{6,{1.51,1.51}}},
{{5,{4.04,4.04}},{6,{4.05,4.05}},{7,{4.03,4.03}},{8,{4.04,4.04}}},
{{7,{2.5,2.5}},{8,{2.51,2.51}}},
{{7,{5.01,5.01}}},
{{7,{8.01,8.01}},{8,{8.02,8.02}}},
{{8,{6.,6.}}}
}

Please use (also for speed testing) a set of some real data which are available here: https://pastebin.com/rEzbC1kH.

Since I am not experienced enough with mathematica the only way what I can do is to use a do loop and then compare each coordinate of sub-list i (1=<i<=8) with the coordinates of sub-list i+1, determine the corresponding nearest neighbour (always only one is existing) and then continute this way ...

How would you solve this?

Background information:

I am using a high speed camera and recording laser illuminated dust-like particles in a plasma. They all usually have a nearly constant spacing whereby they randomly move in small steps around their mean positions (step width << mean particle distance). During the observation time some can be lost since they move out of the laser beam and others can appear. One main part after finding the objects coordinates is to track them in time. The problem (“object/particle detection and tracking”) is very important e.g. in physics, biology and medicine.

In Matlab, Python (here trackpy is very famous) and IDL there are many (sophisticated) solutions for this problem, but until now I did not find anything in mathematica which solves this problem. I am surprised about that because mathematica is very strong in images analysis as well in list operations.

Example movie:

enter image description here

|improve this question
$\endgroup$
  • 1
    $\begingroup$ Is there a typo in line 3 of list where 6.01 should be 6.02? Also, in tracks, shouldn't {7,{7.00,7.00} and {8,{7.01,7.01}} be on the line starting with {4,{7.00,7.00}}? $\endgroup$ – Edmund Sep 16 '17 at 11:33
  • $\begingroup$ @Edmund: thanks, absolutely true ... and this corresponds then to the correct track which m_goldberg obtained in the list clusters ... $\endgroup$ – mrz Sep 16 '17 at 20:40
  • 2
    $\begingroup$ What happened to the two entries of {4.04, 4.04} in line 5? $\endgroup$ – Carl Woll Sep 16 '17 at 21:39
  • $\begingroup$ @Carl Woll: this is an error, one of them should be deleted (I removed the last one) ... and corrected the tracks $\endgroup$ – mrz Sep 17 '17 at 6:48
4
$\begingroup$

Here is a possibility:

getTracks[list_, threshold_] := Block[{ind, next},
    ind = Range @ Length[list[[1, 2]]];
    next = Length[ind] + 1;
    Last @ Reap[
        MapIndexed[Sow[{1, list[[1, 2, First@#2]]}, #]&, ind];

        Do[
            n = newIndex @ Nearest[
                list[[i-1, 2]] -> {"Index","Distance"},
                list[[i,2]],
                {1, threshold}
            ];
            MapIndexed[Sow[{i, list[[i, 2, First@#2]]}, #]&, n],
            {i, 2, Length[list]}
        ],
        _,
        #2&
    ]
]

toIndex[{}] := next++
toIndex[{{a_Integer,_}}] := toIndex[a]
toIndex[a_Integer] := ind[[a]]

newIndex[list_] := With[{old=toIndex/@list}, ind = old]

Basically, I use Reap/Sow to collect points, and I use Nearest between neighboring sublists to figure out which index the new point should be sown to. Here is getTracks applied to your dataset:

getTracks[list, .2]

{
{{1, {1., 1.}}, {2, {1.01, 1.01}}, {3, {1.02, 1.02}}, {4, {1.03, 1.03}}},
{{1, {2., 2.}}, {2, {2.01, 2.01}}},
{{1, {3., 3.}}, {2, {3.01, 3.01}}, {3, {3.02, 3.02}}},
{{1, {4., 4.}}, {2, {4.01, 4.01}}, {3, {4.02, 4.02}}},
{{1, {5., 5.}}, {2, {5.01, 5.01}}, {3, {5.02, 5.02}}},
{{3, {6.02, 6.02}}, {4, {6.03, 6.03}}, {5, {6.04, 6.04}}, {6, {6.05, 6.05}}},
{{4, {7., 7.}}, {5, {7.04, 7.04}}, {6, {7.03, 7.03}}, {7, {7., 7.}}, {8, {7.01, 7.01}}},
{{5, {1.5, 1.5}}, {6, {1.51, 1.51}}},
{{5, {4.04, 4.04}}, {6, {4.05, 4.05}}, {7, {4.03, 4.03}}, {8, {4.04, 4.04}}},
{{5, {4.04, 4.04}}},
{{7, {2.5, 2.5}}, {8, {2.51, 2.51}}},
{{7, {5.01, 5.01}}},
{{7, {8.01, 8.01}}, {8, {8.02, 8.02}}},
{{8, {6., 6.}}}
}

Notice that the one issue is what to do with repeated points, like happens in line 5 of list. The above code creates two tracks, one for each duplicated point.

|improve this answer
$\endgroup$
  • $\begingroup$ This is great ... thanks. I have removed the (wrong) double coordinate in line 5 and have corrected the output according to the result of your code i.imgur.com/Cli8Mqf.png. $\endgroup$ – mrz Sep 17 '17 at 14:34
  • $\begingroup$ Very fast solution: about 0.01 sec for my real data example: pastebin.com/rEzbC1kH) ... I successively increased the threshold from 0.1 to 50 and the number of tracks converges to the mean number of available coordinates per sub-set (443, see first comment to m_goldbergs solution), which is what I expected. For checking of the tracks I plotted them with tracks=getTracks[list, threshold]; ListLinePlot[tracks[[#, All, 2]] & /@ Range@Length@tracks] and they look very good. $\endgroup$ – mrz Sep 17 '17 at 20:36
  • $\begingroup$ I have tested the code with data consisting of 10 000 images and 1600 particles per image. The duration for finding the longest tracks is 94 sec (resulting in 1600 tracks, each 10 000 images long) - this is perfect. Thanks again a lot for your help. May be you can trigger a talk about this in one of the next Wolfram Technology Conferences. $\endgroup$ – mrz Sep 18 '17 at 14:48
  • $\begingroup$ Could you please have a look on that question: mathematica.stackexchange.com/questions/189592/… $\endgroup$ – mrz Jan 17 at 11:52
4
$\begingroup$

You might try ClusterClassify. It seems to work well for your example data. It gives a somewhat different clustering than you give, but its clustering actually looks better to me.

rawData = 
  {{1, {{1.00, 1.00}, {2.00, 2.00}, {3.00, 3.00}, {4.00, 4.00}, {5.00, 5.00}}}, 
   {2, {{2.01, 2.01}, {3.01, 3.01}, {1.01, 1.01}, {5.01, 5.01}, {4.01, 4.01}}}, 
   {3, {{1.02, 1.02}, {3.02, 3.02}, {4.02, 4.02}, {6.02, 6.01}, {5.02, 5.02}}}, 
   {4, {{7.00, 7.00}, {1.03, 1.03}, {6.03, 6.03}}}, 
   {5, {{1.50, 1.50}, {4.04, 4.04}, {6.04, 6.04}, {7.04, 7.04}, {4.04, 4.04}}}, 
   {6, {{1.51, 1.51}, {4.05, 4.05}, {7.03, 7.03}, {6.05, 6.05}}}, 
   {7, {{2.50, 2.50}, {7.00, 7.00}, {5.01, 5.01}, {4.03, 4.03}, {8.01, 8.01}}}, 
   {8, {{2.51, 2.51}, {6.00, 6.00}, {7.01, 7.01}, {4.04, 4.04}, {8.02, 8.02}}}};

data = 
  Catenate[Transpose[{ConstantArray[#[[1]], Length[#[[2]]]], #[[2]]}] & /@ rawData]

{{1, {1., 1.}}, {1, {2., 2.}}, {1, {3., 3.}}, {1, {4., 4.}}, {1, {5., 5.}}, 
 {2, {2.01, 2.01}}, {2, {3.01, 3.01}}, {2, {1.01, 1.01}}, {2, {5.01, 5.01}}, 
 {2, {4.01, 4.01}}, 
 {3, {1.02, 1.02}}, {3, {3.02, 3.02}}, {3, {4.02, 4.02}}, {3, {6.02, 6.01}}, 
 {3, {5.02, 5.02}}, 
 {4, {7., 7.}}, {4, {1.03, 1.03}}, {4, {6.03, 6.03}}, 
 {5, {1.5, 1.5}}, {5, {4.04, 4.04}}, {5, {6.04, 6.04}}, {5, {7.04, 7.04}}, 
 {5, {4.04, 4.04}}, 
 {6, {1.51, 1.51}}, {6, {4.05, 4.05}}, {6, {7.03, 7.03}}, {6, {6.05, 6.05}}, 
 {7, {2.5, 2.5}}, {7, {7., 7.}}, {7, {5.01, 5.01}}, {7, {4.03, 4.03}}, 
 {7, {8.01, 8.01}}, 
 {8, {2.51, 2.51}}, {8, {6., 6.}}, {8, {7.01, 7.01}}, {8, {4.04, 4.04}}, 
 {8, {8.02, 8.02}}}

c =
  ClusterClassify[data, 
    DistanceFunction -> (EuclideanDistance[Last[#1], Last[#2]] &)]

enter image description here

clusters = GatherBy[data, c]

{{{1, {1., 1.}}, {2, {1.01, 1.01}}, {3, {1.02, 1.02}}, {4, {1.03, 1.03}}}, 
 {{1, {2., 2.}}, {2, {2.01, 2.01}}}, 
 {{1, {3., 3.}}, {2, {3.01, 3.01}}, {3, {3.02, 3.02}}}, 
 {{1, {4., 4.}}, {2, {4.01, 4.01}}, {3, {4.02, 4.02}}, {5, {4.04, 4.04}}, 
  {5, {4.04, 4.04}}, {6, {4.05, 4.05}}, {7, {4.03, 4.03}}, {8, {4.04, 4.04}}}, 
 {{1, {5., 5.}}, {2, {5.01, 5.01}}, {3, {5.02, 5.02}}, {7, {5.01, 5.01}}}, 
 {{3, {6.02, 6.01}}, {4, {6.03, 6.03}}, {5, {6.04, 6.04}}, {6, 6.05, 6.05}}, 
  {8, {6., 6.}}}, 
 {{4, {7., 7.}}, {5, {7.04, 7.04}}, {6, {7.03, 7.03}}, {7, {7., 7.}}, 
  {8, {7.01, 7.01}}}, 
 {{5, {1.5, 1.5}}, {6, {1.51, 1.51}}}, 
 {{7, {2.5, 2.5}}, {8, {2.51, 2.51}}}, 
 {{7, {8.01, 8.01}}, {8, {8.02, 8.02}}}}
|improve this answer
$\endgroup$
  • $\begingroup$ I tried your code with the following data pastebin.com/rEzbC1kH. Here I have 5 sub-lists, whereby: Length@rawData[[#, 2, All]] & /@ Range@Length@rawData = {443, 443, 444, 442, 443}. For this clusters = GatherBy[data, c] took very long (90 min, macbook pro, 2,7 GHz i7, 16GB Ram). The line c =ClusterClassify ... needs about 1 min. The calculated clusters are here: pastebin.com/XBiRQcWW and they look excellent. My problem: In reality where I have about 500 coordinates per sub-set and about 1000 sub-sets GatherBy would last for many days. What can I do? $\endgroup$ – mrz Sep 16 '17 at 8:39
  • $\begingroup$ @mrz. It might go faster with a training set that is only fractional sample of the complete data. Of course, a smaller sample risks less accuracy in the clustering. That is a trade-off that must be made when machine learning brought into play. $\endgroup$ – m_goldberg Sep 16 '17 at 8:58
  • 1
    $\begingroup$ @mrz. I can't act as your personal tutor. Read the docs on ClusterClassify and GatherBy do. If you can't reach an understanding that make you confident in their use, seek another method. $\endgroup$ – m_goldberg Sep 16 '17 at 9:40
  • $\begingroup$ I will do that ... thank you very much for your help and this solution. $\endgroup$ – mrz Sep 16 '17 at 20:54
3
$\begingroup$

You may use GatherBy with Floor to collect the coordinates into nearest sets. Then Split these into consecutive runs.

With list as defined in OP and

coords = Flatten[Function[{i, v}, Join[{i}, {#}] & /@ v] @@@ list, 1];

Then

Sequence @@ Split[#, First@#2 - First@#1 <= 1 &] & /@
  GatherBy[coords, Floor[#[[-1]], .2] &] //
 SortBy[First]

{{{1,{1.,1.}},{2,{1.01,1.01}},{3,{1.02,1.02}},{4,{1.03,1.03}}},
 {{1,{2.,2.}},{2,{2.01,2.01}}},
 {{1,{3.,3.}},{2,{3.01,3.01}},{3,{3.02,3.02}}},
 {{1,{4.,4.}},{2,{4.01,4.01}},{3,{4.02,4.02}}},
 {{1,{5.,5.}},{2,{5.01,5.01}},{3,{5.02,5.02}}},
 {{3,{6.02,6.02}},{4,{6.03,6.03}},{5,{6.04,6.04}},{6,{6.05,6.05}}},
 {{4,{7.,7.}},{5,{7.04,7.04}},{6,{7.03,7.03}},{7,{7.,7.}},{8,{7.01,7.01}}},
 {{5,{1.5,1.5}},{6,{1.51,1.51}}},
 {{5,{4.04,4.04}},{5,{4.04,4.04}},{6,{4.05,4.05}},{7,{4.03,4.03}},{8,{4.04,4.04}}},
 {{7,{2.5,2.5}},{8,{2.51,2.51}}},
 {{7,{5.01,5.01}}},
 {{7,{8.01,8.01}},{8,{8.02,8.02}}}}

Hope this helps.

|improve this answer
$\endgroup$
  • $\begingroup$ I think Thread /@ list is simpler than your Function[{i, v}, Join[{i}, {#}]& /@ v] @@@ list. As for your algorithm, it works well if all points on the track have the same floor, but if the track extends far enough that they don't all have the same floor, then it doesn't work. For instance, try using a threshold of .03 instead of .2. $\endgroup$ – Carl Woll Sep 17 '17 at 4:22
  • $\begingroup$ Thank you very much for your help ... I corrected an error in list which affects the tracks. Please see the short paragraph "Background information" which I added to the question. $\endgroup$ – mrz Sep 17 '17 at 14:36
2
$\begingroup$

Using RelationGraph:

rg = RelationGraph[
  Abs[#1[[1]] - #2[[1]]] == 1 && 
    Abs[#1[[2, 2]] - #2[[2, 2]]] <= 0.2 &, Join @@ (Thread /@ list)]
SortBy[ConnectedComponents[rg], {#[[1, 1]], #[[1, 2, 1]]} &] // Column

enter image description here

|improve this answer
$\endgroup$
  • $\begingroup$ Such a short code for I thought a complicated question, incredible ... thank you very much. $\endgroup$ – mrz Sep 17 '17 at 10:29
  • $\begingroup$ I haven't used RelationGraph before ... thank you very much for the solution. $\endgroup$ – mrz Sep 17 '17 at 11:27
  • $\begingroup$ @mrz i may not have completely understood your aim but RelationGraph seemed a useful start. It may be ok for modest size problem. $\endgroup$ – ubpdqn Sep 17 '17 at 11:31

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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