8
$\begingroup$

I am trying to write a function f that returns the overlapped sublist where A ends with this sublist while B starts with it. For examples, suppose I have two lists

A = {1, 2, 1, 3, 1, 3};    
B = {1, 3, 1, 3, 2, 1, 2};
f[A,B] == {1, 3, 1, 3}

The question is to find the common sublist where A should end with the result and B should start with it. (If there are many candidates, it should return the longest such sublist).

I could not come up with elegant solutions for this problem so far. Please give me some advice.

$\endgroup$
  • 1
    $\begingroup$ LongestCommonSubsequence[a,b]? $\endgroup$ – kglr Mar 21 '15 at 20:37
  • $\begingroup$ @kguler I am not sure LongestCommonSubseqeunce solve this problem. As far as I understand, this function does not have the constraint that the common sequence should end (and start) with the arguments. $\endgroup$ – Sungmin Mar 21 '15 at 20:43
  • $\begingroup$ sungmin, you are right; totally missed the end/start thing. $\endgroup$ – kglr Mar 21 '15 at 20:57
  • $\begingroup$ I have the strong suspicion this is a duplicate, I seem to recall a question re: overlap position with some very clever answers. Still looking for it... $\endgroup$ – ciao Mar 21 '15 at 21:11
6
$\begingroup$

Maybe

aA = {1, 2, 1, 3, 1, 3};
bB = {1, 3, 1, 3, 2, 1, 2};

k = Length[aA]; 
While[(cs = bB[[;; k]]) != aA[[1 + Length[aA] - k ;;]], k--]; 
cs
(* {1, 3, 1, 3} *

Also

NestWhile[{Most[#[[1]]], Rest[#[[2]]]} &, 
          {bB[[;; Length[aA]]],  aA}, #[[1]] != #[[2]] &][[1]]
(* or  NestWhile[{Drop[#[[1]], -1], Drop[#[[2]], 1]} &,
             {bB[[;; Length[aA]]], aA}, #[[1]] != #[[2]] &][[1]] *)
(* {1, 3, 1, 3} *

And

Replace[{bB[[;; Length[aA]]], aA}, {{Longest[x__], ___}, {___, x__}} :> {x}]
(* {1, 3, 1, 3} *

Much cleaner version of the last one (thanks: @Martin Buttner):

Replace[{aA, bB}, {{___, x__}, {x__, ___}} :> {x}]
$\endgroup$
  • $\begingroup$ ... need to add checks for list lengths. $\endgroup$ – kglr Mar 21 '15 at 20:58
  • $\begingroup$ These will be slow for large lists, but since OP does not specify that as a need, +1 $\endgroup$ – ciao Mar 21 '15 at 22:27
12
$\begingroup$

As noted in the comments, for large lists one might want something faster. This is the routine I use for such things:

overlap[a_, b_] := 
 Module[{ml = Min[Length@a, Length@b], at, bt, len = 1, sp, f, x = 0},
  sp[t_, s_] := 
   Module[{z = Replace[t, {p___, Sequence @@ s, ___} :> Length@{p}]},
    If[z === t, -1, z]];
  at = a[[-ml ;;]];
  bt = b[[;; ml]];
  at[[-Catch[
       If[at == bt, Throw[Length@at]];
       While[True,
        If[(f = sp[bt, at[[-len ;;]]]) == -1, Throw[x], len += f];
        If[at[[-len ;;]] == bt[[;; len]], x = len];
        len++;]] ;;]]]

Here's a quick performance comparison between the While and NestWhile solutions (I did not test the third Replace based solutions, as these become unusably slow very quickly).

50 runs of three types were averaged for the tested solutions - a binary list with varying overlaps from 0-100%, a random integer list with at least 10% overlap, and a random integer list with at least 50% overlap. Lists were of same length since compared solutions do not account for differing lengths as noted by responder. Lists ranged from 500 to 10K elements, timings on the loungebook.

enter image description here

The advantage grows with problem size - by the time one is at lists of 200K length, this was 1100-1300X faster on integer lists with 50% overlap, and 1900-2100X faster on same with 10% overlap.

Like many algorithms, it has an Achilles heel: completely pathological lists (100% overhang or near) degrade performance. The 100% case is accounted for, I've done no optimization for near-pathological cases - a better solution if lists are of that type is to adapt the Knuth-Morris-Pratt algorithm to overlap duty. In any case, for anything less than seriously bad cases, the above will handily outrun even KMP, often by orders of magnitude.

An ideal solution might combine the above and KMP, spinning off competing jobs to the kernel in parallel and taking the fastest answer.

$\endgroup$
  • $\begingroup$ +1 of course, but since you seem to enjoy the competition please see my answer. Our methods appear complementary. $\endgroup$ – Mr.Wizard Mar 22 '15 at 11:51
8
$\begingroup$

Maybe I'm misreading the question but why not just this?

aA = {1, 2, 1, 3, 1, 3};
bB = {1, 3, 1, 3, 2, 1, 2};

Clear[commonFind]
commonFind[{___, common__}, {common__, ___}] := {common}
commonFind[aA, bB]
$\endgroup$
  • 1
    $\begingroup$ No, you read it right - that's a prettier (IMO) version of the Replace solutions - so it suffers from the same horrible scaling, but +1 for small list use. $\endgroup$ – ciao Mar 22 '15 at 6:56
5
$\begingroup$

Here is solution based on using LongestCommonSubsequence. Since this commands finds all common longest subsequences, the results is filtered to remove those that do not start at b. From these, those that end at a are picked.

findIt[a_, b_] := Module[{r},
   r = Reap[Sow @ LongestCommonSubsequence[Take[a, -#], b] & /@ Range[Length@a, 1, -1]];
   r = Union@First@r;
   r = Pick[r, SameQ[#, Take[b, Length[#]]] & /@ r];
   r = Pick[r, SameQ[#, Take[a, -Length[#]]] & /@ r];
   If[Length[r] >= 1, r[[Ordering[r, -1]]], {}]
   ];

Test

a = {1, 2, 1, 3, 1, 3};
b = {1, 3, 1, 3, 2, 1, 2};
findIt[a, b]

Mathematica graphics

a = {1, 2, 1, 3, 1, 3, 4, 4, 4, 4, 4, 4};
b = {4, 4, 4, 4, 4, 1, 3, 1, 3, 2, 1, 2};
findIt[a, b]

Mathematica graphics

a = {1, 2, 1, 3, 1, 3, 4, 4, 4, 4, 4, 5};
b = {4, 4, 4, 4, 4, 1, 3, 1, 3, 2, 1, 2};
findIt[a, b]

Mathematica graphics

a = {568, 926, 487, 487, 184, 925, 381, 94, 452, 110};
b = {184, 925, 381, 94, 452, 110, 568, 466, 645, 415}
findIt[a, b]

Mathematica graphics

a = {4, 4, 4, 4, 4, 4, 1, 2, 1, 3};
b = {1, 2, 1, 3, 4, 4, 4, 4, 4, 4};

Mathematica graphics

$\endgroup$
  • $\begingroup$ Neat, but it seems to go wrong occasionally, returning empty result. I'll try and find a small case and post lists. Try, e.g. {{568, 926, 487, 487, 184, 925, 381, 94, 452, 110}, {184, 925, 381, 94, 452, 110, 568, 466, 645, 415}} $\endgroup$ – ciao Mar 22 '15 at 7:31
  • $\begingroup$ @rasher I fixed it, thanks. I needed >= instead of > in last line $\endgroup$ – Nasser Mar 22 '15 at 7:53
  • $\begingroup$ Well done, pretty quick, +1 $\endgroup$ – ciao Mar 22 '15 at 8:02
  • $\begingroup$ I couldn't find a way for your function to work with lists whose end-start common sequence is not the longest sequence, like so a = {4, 4, 4, 4, 4, 4, 1, 2, 1, 3}; b = {1, 2, 1, 3, 4, 4, 4, 4, 4, 4}; $\endgroup$ – seismatica Mar 22 '15 at 8:48
  • $\begingroup$ @seismatica fixed. Thanks,. I needed Take[a, -#], b] instead of [Take[a, #], b] $\endgroup$ – Nasser Mar 22 '15 at 9:00
5
$\begingroup$

My proposal:

f2[a_List, b_List, flt_: 5] :=
  Module[{pos, i = 0, n, A, B},
    n = Min[Length /@ {a, b}];
    A = Take[a, -n]; B = Take[b, n];
    pos = SparseArray[Unitize @ Subtract[A, First@B], Automatic, 1]["AdjacencyLists"];
    pos =
      NestWhile[
        Select[# + i <= n && A[[# + i]] === B[[1 + i]] &], 
        pos, (i++; Length@# > 1) &, 1, flt
      ];
    FirstCase[pos, x_ /; A[[x ;;]] === B[[;; -x]] :> A[[x ;;]]]
  ]
  • The Min and following line are used to clip the longer list to the length of the shorter one.

  • The long SparseArray line is a faster form of Position for packed arrays. The idea is to only check alignments that start with the same first element.

  • The NestWhile line checks additional elements up to the value specified by the flt parameter, default 5. This is a tunable parameter.

  • The FirstCase line find the first, and therefore longest, overlap candidate that matches.

This may be more than an order of magnitude faster than rasher's overlap:

n = 1*^6; m = 999;

x = RandomInteger[m, n];
a = RandomInteger[m, n] ~Join~ x;
b = x ~Join~ RandomInteger[m, n];

f2[a, b]       // Timing // First
overlap[a, b]  // Timing // First

0.0162

0.196

If elements are more rare, e.g. m is larger, f2 gains further advantage:

n = 1*^6; m = 99999;  (* other code as above *)

0.0116

0.421

However if elements are very common the performance reverses. A higher flt helps a little but not enough:

n = 1*^6; m = 3;

x = RandomInteger[m, n];
a = RandomInteger[m, n] ~Join~ x;
b = x ~Join~ RandomInteger[m, n];

f2[a, b]       // Timing // First
f2[a, b, 10]   // Timing // First
overlap[a, b]  // Timing // First

2.51

1.76

0.225

$\endgroup$
  • 1
    $\begingroup$ Nice. I did not intend mine for integer lists only (though that appears to be op needs) - it works with anything. I''ll ponder a more limited-scope speed demon, though yours may be tough to beat... +1 o/c! $\endgroup$ – ciao Mar 22 '15 at 17:16
  • $\begingroup$ OK, cobbled together a hare-brained concept, using your n= 1*^6 and m of 3, 999, 99999, and 999999 was ~3, 25, 50 and 70X faster than my above, so I'd guess ~20, 2.5, 5, and 7X faster for same than yours above (guess, since I uninstalled 10 - too many bugs for now). Going to flesh out code and see if it can be compiled (to VM - my feeling is if it's C, I'm just doing it in C in the first place.). Bonus is that it is agnostic like mine above - works with any kind of list... Will update my OP if/when it gets fleshed out and proofed. Fun puzzle... $\endgroup$ – ciao Mar 23 '15 at 4:18
  • $\begingroup$ @rasher I'm not surprised, and I look forward to your update or new answer. I agree regarding C. Frankly while this is a fun puzzle I really feel that it shouldn't be necessary; if we had JIT compilation of pattern code, which should be possible in many cases IMO, the clean and direct method from seismatica should be fast. I really wish effort would be put into a tight and fast core language update rather than simply ballooning the number of functions with each release. I surmise that you may have similar feeling given your uninstallation of v10. $\endgroup$ – Mr.Wizard Mar 23 '15 at 4:37

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.