How to find the longest matching sublists in a list

Question

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}}

Answer 1

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}} *)

Answer 2

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)

Answer 3

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?

Answer 4

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.

Answer 5

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}}}} *)

Answer 6

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.

Answer 7

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):