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.

Given a list of 2D points, i.e.

 {p1, p2, ..., pn}

the list may contain equal points, i.e. pi = pj. In this case it may also be true that a sublist of consecutive points has an equal somewhere in the list, i.e.:

 pi=pj and p(i+1)=p(j+1).

I am looking for the longest of such sublists in the list.

For example, in

 { {0,0}, {1,0}, {1,1}, {0,1}, {2,0}, {3,0}, {3,1}, {2,1}, {1,0}, {1,1}, {4,0}}

the sublist I am looking for is

{{1,0}, {1,1}} 

has length 2 and occurs twice.

I am looking for an efficient way to ( functionally ) code this in Mathematica.

Question: How to find the longest matching sublists in a list?

Answers sofar failed on the following testcase, which I shall add for your convenience:L

 {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}, {1, 1}, {4, 0}, {0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}, {2, 2}, {4, 0}};

with as longest matching sublist

 {{0, 0},{1, 0}, {1, 1},{0, 1},{2, 0},{3, 0},{3, 1},{2, 1},{1, 0}}
share|improve this question
    
What about {{3,0},{3,1}}? –  Yves Klett Nov 16 '13 at 13:06
    
Appears only once. –  ndroock1 Nov 16 '13 at 13:07
    
But it is just as long as {{1,0},{1,1}}... –  Yves Klett Nov 16 '13 at 13:08
    
Ok, I mean {1,0}={1,0} and {1,1}={1,1} . –  ndroock1 Nov 16 '13 at 13:10
2  
You want the longest sublist that appears at least twice or the sublist of length at least two that appears the most? –  Rojo Nov 16 '13 at 15:25

7 Answers 7

up vote 7 down vote accepted

Here is my solution, based on recursion and the use of the LongestCommonSubsequence built-in function. It assumes that the common subsequences can not overlap.

ClearAll[half]
half[lst_] /; EvenQ[Length[lst]] := Through[{Take, Drop}[lst, Length[lst]/2]];

ClearAll[pickLonger];
SetAttributes[pickLonger,Orderless];
pickLonger[fst_List,sec_List] /; Length[fst] >= Length[sec]:= fst;

ClearAll[$unique,lcomm];
    lcomm[lst_] /; OddQ[Length[lst]]:=
        lcomm[Append[lst,$unique]];
lcomm[lst_]:=
    With[{result=LongestCommonSubsequence @@ half[lst]},
        result/;result=!={}
    ];
lcomm[lst_]:=
    pickLonger @@ lcomm /@ half[lst]

What it does is to split a list in two halves and test for common subsequence. If it does not occur, lcomm applies itself recursively to the two halves of the list, and picks the largest result. If the list has odd number of elements, a spurious element is added at the end, so that the list can be evenly divided.

Examples:

test={{0,0},{1,0},{1,1},{0,1},{2,0},{3,0},{3,1},{2,1},{1,0},{1,1},{4,0}};
lcomm[test]

(* {{1, 0}, {1, 1}} *)

and

 ltest = {
    {0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, 
    {2, 1}, {1, 0}, {1, 1}, {4, 0}, {0, 0}, {1, 0}, {1, 1}, 
    {0, 1}, {2,0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}, {2, 2}, {4, 0}
 };
 lcomm[ltest]

(* {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}} *)
share|improve this answer
    
Okay, in half should Length[lst]2 be Length[lst]/2? –  Mr.Wizard Nov 16 '13 at 18:36
    
@Mr.Wizard Thanks! Indeed. I was using my code formatter to post here, which has bugs for multiplication and, therefore, division. Another reason for me to fix those. –  Leonid Shifrin Nov 16 '13 at 19:10
    
@LeonidShifrin: is there a working version of this elsewhere? Searched but came up empty. –  rasher Feb 14 at 23:39
    
@rasher Working version of what? The code above does work, after having been fixed. –  Leonid Shifrin Feb 14 at 23:59
    
@LeonidShifrin: Perhaps I misunderstand the op, but, e.g., {{0, 1}, {1, 0}, {1, 1}, {0, 1}, {1, 0}, {1, 1}, {2, 2}, {2, 3}} should return {0,1},{1,0},{1,1} as I understand the OP, code returns {1,0},{1,1} –  rasher Feb 15 at 0:14

How about (assuming there is at least one list longer than 1 - else add a conditional to discard if result has length 1):

list/. {___, Longest[x___], ___, x___, ___} :> {x}

Note: is performance an issue for you?

Note2: as to @Rojo's comment above: this will return the longest subsequence that appears at least twice (and not the subsequence that appears most)

share|improve this answer

If we set

li = {{0, 0}, {1, 0}, {1, 1}, ..., {1, 1}, {4, 0}} (*your list*)

then (EDITED)

preliminary = Last@
    SortBy[
       ReplaceList[li, {___, x__, Shortest[y__], x__, ___} :> {x}],
       Length
   ];
result = If[Length[preliminary] > 1, preliminary, {}]

returns {{1, 0}, {1, 1}} and should solve also the other examples you provided.

The issue is that the match can occur in several ways, and I now explicitely select the longest among the matches. Then, a result with a single element is discarded.

Does it sound ok now?

share|improve this answer
    
This list should return {} but fails on the solution you gave: {{Sqrt[3]/2, 1/2}, {0, 1}, {-(Sqrt[3]/2), 1/ 2}, {-(Sqrt[3]/2), -(1/2)}, {0, -1}, {Sqrt[3]/ 2, -(1/2)}, {-(Sqrt[3]/2), 1/2}, {0, 1}, {-(1/2), 1/2 (2 + Sqrt[3])}, {1/2 (-1 - Sqrt[3]), 1/2 (1 + Sqrt[3])}, {-(1/2), 1/2 (2 + Sqrt[3])}, {0, 1}, {1/2, 1/2 (2 + Sqrt[3])}, {1/2, 1/2 (2 + Sqrt[3])}, {0, 1}, {Sqrt[3]/2, 1/ 2}, {1/2 (1 + Sqrt[3]), 1/2 (1 + Sqrt[3])}, {1/2 (1 + Sqrt[3]), 1/2 (1 + Sqrt[3])}, {Sqrt[3]/2, 1/2}, {1/2 (2 + Sqrt[3]), 1/2}} –  ndroock1 Nov 16 '13 at 13:22
    
It was not clear to me that a single repeated element should not be returned. In this case, we can use: li /. {, x, Shortest[y_], x__, ___} :> If[Length[{x}] > 1, {x}, {}] –  user8074 Nov 16 '13 at 13:37
    
Now it fails on this list: {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}, {1, 1}, {4, 0}, {0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}, {2, 1}, {4, 0}}; –  ndroock1 Nov 16 '13 at 14:10
    
So far, so good, thanks –  ndroock1 Nov 16 '13 at 14:34

I thought of patten matching, as user8074 did, but I don't think we need ReplaceList here.

I missed Pinguin Dirk's answer; this can be thought of as a variation of it.

I haven't tested this well but I think it should work:

longSS = Fold[Replace, #, {{___, Longest[x__], ___, x__, ___} :> {x}, {_} | # :> {}}] &

A test:

longSS /@ {{1, 2, 3, 4}, {1, 2, 3, 1, 2}, {1, 2, 3, 4, 1, 5}, {1, 2, 3, 1, 2, 3}}
{{}, {1, 2}, {}, {1, 2, 3}}

This has poor computational complexity. Leonid's approach appears to be much better once it is working.

share|improve this answer

This is for pre-7 versions (that don't have LongestCommonSubsequence). It is not especially efficient, but seems faster than solutions that use some form of replacement. Also, if there are several equal-length longest-repeated-sublists then it will return all of them.

longsub[list_] := Block[{n = Floor[Length@list/2], r, u},
While[n > 0 && (r = Max[(u = Tally@Partition[list,n,1])[[All,2]]]) == 1, n--];
{n, r, Pick[u[[All,1]],u[[All,2]],r]}]

longsub[testcase]

(* {9, 2, {{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}}}} *)
share|improve this answer
    
+1. I was too thinking along these lines, but then opted for the one I posted. –  Leonid Shifrin Nov 18 '13 at 8:35

I (embarrassingly) misunderstood this question when I first posted an answer. I post this with the following caveats about 'longest sequence':

  1. In the following overlapping sequences will also be identified (this may not be the desired functionality), e.g. {1,2,3,1,2,3,1,2,3}->{1,2,3,1,2,3}. This could be accounted for.
  2. More than one sequence could be the same longest length. Methods such as Fold[Replace, #, {{___, Longest[x__], ___, x__, ___} :> {x}, {_} | # :> {}}] & will detect first identified. e.g

longSS[{a, b, f, c, d, a, b, g, c, d}] yields {a,b} but {c,d} is also an acceptable answer.

Note also extra curly brackets in output relate to the issue of possible multiple maximal subsequences.

func[u_] :=
 Module[{v, tb, mx, mxm, ps, sb, pk, pks},
  v = Append[u, ToString[u[[-2]] u[[-1]]]];
  tb = Table[
    MapThread[Boole@SameQ[#1, #2] &, {v, RotateLeft[v, j]}], {j, 
     Length[v] - 1}];
  mx = (Max /@ Map[Total, Split /@ tb, {2}]);
  mxm = Max@mx;
  If[mxm <= 1, Return[{}]];
  ps = Position[mx, mxm];
  sb = Split /@ Extract[tb, ps];
  pk = Map[
    Function[x, Flatten[If[Total@# == Max@mx, #, 0. #] & /@ x]], sb];
  pks = Union@Map[Union@Partition[#, mxm] &, Pick[v, #, 1] & /@ pk];
  Flatten[pks, 1]
  ]

Testing cases:

test = {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 
    1}, {1, 0}, {1, 1}, {4, 0}, {0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 
    0}, {3, 0}, {3, 1}, {2, 1}, {1, 0}, {2, 2}, {4, 0}};

func[test] yields:

{{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 1}, {1, 
   0}}}


func /@ {{1, 2, 3, 4}, {1, 2, 3, 1, 2}, {1, 2, 3, 4, 1, 5}, {1, 2, 3, 
   1, 2, 3}}

yields:

{{}, {{1, 2}}, {}, {{1, 2, 3}}}

More than one maximal repeated subsequence:

func[{a, b, c, d, g, a, b, f, c, d}]

yields:

{{a, b}, {c, d}}

or

func[{a, b, c, f, g, h, a, b, c, x, f, g, h, y, f, g, h}]

yields:

{{a, b, c}, {f, g, h}}

The original test case:

func[{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {2, 0}, {3, 0}, {3, 1}, {2, 
   1}, {1, 0}, {1, 1}, {4, 0}}]

gives:

{{{1, 0}, {1, 1}}}

Excepting extra parentheses, test cases are handled. Overlap detection may not be a desired feature.

I post this, not as an ideal answer, but probably as a penance for misunderstanding question in first place. I am learning a lot looking at the other answers.

share|improve this answer

My belated answer to this interesting question (I ran across it yesterday when it popped up as "related".) The right way to do this, IMHO, is via a suffix-tree (I'm certain I saw an MMA version of Ukkonen's O(N) version, can't find it and I'd rather not reinvent the wheel). However, I pondered another way while searching for the above algorithm, and was surprised at its speed.

I tested it against all the answers, following is it timed against the two that gave correct answers (mosty - one seemed to treat overlaps rather haphazardly, both did not return complete sets). The other three answers were not timed: two give incorrect results, one was unusably slow at more than a few dozens of pairs.

Note this is just a cobbled-up work-in-progress made during a cigar binge, so it's not heavily tested, but it appears to give correct results, etc. If there's interest I'll spruce it up, or perhaps implement a suffix-tree version.

Code:

lss[list_, overlaps_: False, minlen_: 2, maxlenarg_: Infinity] := 

 Module[{reso = {}, g, p, res, 
   maxlen = If[maxlenarg == Infinity, Ceiling[Length[list]/2], maxlenarg], 
   topdown},

  topdown = Boole[maxlen < minlen];
  Map[(p = Partition[list, #, 1];
     g = GatherBy[Range@Length@p, p[[#]] &];
     g = If[! overlaps, Pick[g, UnitStep[(Max[#] - Min[#]) & /@ g - #], 1], g];
     res = p[[#]] & /@ Flatten@Select[g, Length[#] > 1 &]; 
     If[(topdown == 0 && res == {}) || (topdown == 1 && res =!= {}), 
      Return[Gather[If[topdown == 1, Union@res, reso]], Module], 
      reso = Union@res]) &, Range[minlen, maxlen, 1 - 2 topdown]]]

Timings, by number of elements (pairs), generated with RandomInteger[{0, 10}, {numEles, 2}] (caveat: on cigar-time netbook, and switched to Log plot so lss could be seen):

enter image description here

share|improve this answer

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.