10
$\begingroup$

Prepare some dummy data to investigate:

alist = RandomSample[Table[ToExpression["a" <> ToString[i]], {i, 1, 10000}]];
range = Range[10000];
Do[
 len = RandomInteger[{3000, 10000}];
 select = Sort[RandomSample[range, len]];
 sublists[j] = alist[[select]];
 , {j, 1, 5000}]

we have 5000 sublists of length between 3000 and 10000 elements "ai" in a particular order. I would like to have a function that merges all 5000 sublists such that all duplicates are discarded and any "ai" appear to the left of "aj" if they do so in any of the sublists. How can one do this in Mathematica most efficiently?

A tiny example of the above would be:

alist = {a1,a3,a2,a5,a4};
sublists[1] = {a1,a5};
sublists[2] = {a3,a2,a5};
sublists[3] = {a1,a2};

so that the function merge returns:

merge[Table[sublists[i],{i,1,3}]]

{a1,a3,a2,a5}

Note that merge was not given the actual alist.

EDIT:

Investigating the Experimental'ShortestSupersequence command, let us replace the definition of alist above by

alist = Table[a[i], {i, 1, 10000}];

This creates a list of strictly increasing a[i]. Generating the sublists from this as above, we get for example

seq = Fold[Experimental`ShortestSupersequence, sublists /@ Range[5000]];
seq//Length

10984

Repeating the steps seems to consistently return a seq that is longer than 10000, while

seq // DeleteDuplicates // Length

10000

To check that all sublists contain a[i] elements in strictly increasing order, we can do:

FreeQ[
 Table[
  tmp = sublists[i] /. a[x_] -> x;
  tmp = tmp[[2 ;;]] - tmp[[;; -2]];
  FreeQ[tmp/Abs[tmp], -1]
  , {i, 1, 5000}]
 , False]

True

The only way how some of the sublists might have some elements reversed in inconsistent order with alist is if we had {...,a[i],...,a[j],...} with j<i somewhere, which is ruled out by the above test. So it seems that Experimental'ShortestSupersequence is buggy...

$\endgroup$
  • $\begingroup$ how do yo reconcile (a) any "ai" appear to the left of "aj" if they do so in alist and (b) alist is not known explicitly? (Since sublists are independently shuffled they don't contain any information on whether or not "ai" is before "aj" in the unknown alist) $\endgroup$ – kglr Jun 1 at 14:53
  • $\begingroup$ @kglr note that there is a Sort after the RandomSample of the integers in range. This picks elements from alist in an ordered way. $\endgroup$ – Kagaratsch Jun 1 at 14:55
  • $\begingroup$ oh i see... thanks! $\endgroup$ – kglr Jun 1 at 14:56
  • $\begingroup$ then.. {a3, a1, a2,a5} is also a solution, right? $\endgroup$ – kglr Jun 1 at 14:59
  • $\begingroup$ @kglr that's right, without knowing alist there are several solutions. Finding any of them should be good enough though. You are right, maybe I should describe the merging better. $\endgroup$ – Kagaratsch Jun 1 at 15:00
6
$\begingroup$

Update: You can use TopologicalSort after turning each list to a list of rules reflecting the ordering of its elements:

ClearAll[topoSort]
topoSort = TopologicalSort[Flatten[Thread[Most@# -> Rest@#] & /@ #]] &;

lists = {{a1, a5}, {a3, a2, a5}, {a1, a2}} ;
topoSort @ lists 

{a1, a3, a2, a5}

Timings: Using a scaled down version of OP's data:

SeedRandom[1]
{n, m, k} = {1000, 300, 500};
alist = RandomSample[Table[ToExpression["a" <> ToString[i]], {i, 1, n}]];
range = Range[n];
Do[
  len = RandomInteger[{m, n}];
  select = Sort[RandomSample[range, len]];
  sublists[j] = alist[[select]];
  , {j, 1, k}]

allsublists = Array[sublists, k];

f = mergeChron[allsublists]; // RepeatedTiming // First

1.14

g = merge[allsublists]; // RepeatedTiming // First

1.1

h = topoSort[allsublists]; // RepeatedTiming // First

0.313

Equal[f, g, h]

True

With {n, m, k} = {2000, 600, 1000}, the timings are 9.44, 5.69 and 1.64 for mergeChron, merge and topoSort, respectively,

Original answer: (this needs further work ...)

Fold[Experimental`ShortestSupersequence, sublists /@ Range[3]]

{a3, a1, a2, a5}

Also

Fold[Experimental`ShortestSupersequence, RotateRight[sublists /@ Range[3]]]

{a1, a3, a2, a5}

In case this produces an output with duplicates we can use

DeleteDuplicates @ Fold[Experimental`ShortestSupersequence, sublists /@ Range[5000]]
$\endgroup$
  • $\begingroup$ Somehow, when I apply this to the big example it returns an output that still has duplicates. If I apply DeleteDuplicates to it, will it give the desired ordering? $\endgroup$ – Kagaratsch Jun 1 at 15:13
  • $\begingroup$ @Kagaratsch, my rough intuition is that it should not happen if the orderings in all the sublists are consistent (ie, a and b appear in the same order in all sublists that contain both) . It could happen if a and b appear in different order in two sublists. In any case wrapping with DeleteDuplicates fixes the problem. Could you post the smallest example in which the output has duplicates? $\endgroup$ – kglr Jun 1 at 15:19
  • $\begingroup$ Hmm, I'm pretty sure the code generates all lists in consistent order due to the Sort command before the elements are picked... $\endgroup$ – Kagaratsch Jun 1 at 15:22
  • $\begingroup$ Then it is probably some glitch in theExperimentalShortestSupersequence` function. $\endgroup$ – kglr Jun 1 at 15:26
  • $\begingroup$ Seems that way, see edit of my question for some details. $\endgroup$ – Kagaratsch Jun 1 at 15:44
5
$\begingroup$

I think the following works but please give it a try with your data. I've tried quite a few random examples and it has worked for all of them.

First, construct a directed graph with edges defined by neighbors in the sublists:

allsublists = Array[sublists, 5000];  (* or whatever the max count is *)
G = Graph[Join @@ (BlockMap[Apply[Rule], #, 2, 1] & /@ allsublists)]

Next, look at the GraphDistanceMatrix and count how many times the symbol appears in each row:

infcount = Count[∞] /@ GraphDistanceMatrix[G]

Next, sort the graph vertices according to this infcount:

alist = SortBy[Transpose[{VertexList[G], infcount}], Last][[All, 1]]

All together in one function:

merge[L_] := 
  With[{G = Graph[Join @@ (BlockMap[Apply[Rule], #, 2, 1] & /@ L)]},
    SortBy[Transpose[{VertexList[G], Count[∞] /@ GraphDistanceMatrix[G]}], Last][[All, 1]]]

example

The given example is

allsublists = Array[sublists, 3]
(*    {{a1, a5}, {a3, a2, a5}, {a1, a2}}    *)

Construct the directed neighbor graph:

G = Graph[Join @@ (BlockMap[Apply[Rule], #, 2, 1] & /@ allsublists),
  VertexLabels -> Automatic]

enter image description here

Have a look at the graph distance matrix:

VertexList[G]
(*    {a1, a5, a3, a2}    *)
GraphDistanceMatrix[G]
(*    {{0, 1, ∞, 1},
       {∞, 0, ∞, ∞},
       {∞, 2, 0, 1},
       {∞, 1, ∞, 0}}    *)

count the infinities in each row, i.e., for each vertex we count how many other vertices are unreachable:

infcount = Count[∞] /@ GraphDistanceMatrix[G]
(*    {1, 3, 1, 2}    *)

sort the vertices by the number of infinities (i.e. by the number of unreachable other vertices):

alist = SortBy[Transpose[{VertexList[G], infcount}], Last][[All, 1]]
(*    {a1, a3, a2, a5}    *)
$\endgroup$
  • $\begingroup$ Nice solution with graphs! I was afraid it would be too memory demanding and/or slow, but my 32GB ram turned out to be enough and it finished in just a minute or two. Amazing! $\endgroup$ – Kagaratsch Jun 1 at 23:22
  • 1
    $\begingroup$ As @kglr points out, my solution only points out that I didn't know about TopologicalSort and computed it "manually". alist = TopologicalSort[G] replaces the calculation of infcount and alist. $\endgroup$ – Roman Jun 2 at 6:45
4
$\begingroup$

Using PositionIndex and Merge,

mergeChron[x_] := Merge[PositionIndex /@ x, Max] // Sort // Keys;

Test:

Case1:

allsublists= {{a1, a5}, {a3, a2, a5}, {a1, a2}};
mergeChron[allsublists]

{a1, a3, a2, a5}

Case2:

alist = RandomSample[Table[ToExpression["a" <> ToString[i]], {i, 1, 1000}]];
range = Range[1000];
Do[len = RandomInteger[{450, 1000}];
 select = Sort[RandomSample[range, len]];
 sublists[j] = alist[[select]];, {j, 1, 300}]

For num = 300, all three of the methods produce the same output. However, that's not the case for num = 30. It might be because of the existence of multiple solutions (as discussed in comments).

num = 300;
allsublists = Array[sublists, num];
f = mergeChron[allsublists];
g = merge[allsublists]; (*Roman's*)
h = topoSort[allsublists]; (*kglr's*)
f == g == h

True

$\endgroup$
2
$\begingroup$

This is just a comment on the issue with using Experimental`ShortestSupersequence for this problem. The algorithm repeatedly merges two lists into a new list. This new list will always carry order information for all of the symbols encountered so far, even when insufficient information is available to establish an order. That means the new list will sometimes have the wrong order for the symbols, when further information is processed in a future merge. As an example consider doing your simple example in a different order:

Experimental`ShortestSupersequence[{a3, a2, a5}, {a1, a5}]

{a3, a2, a1, a5}

In this step, there is not enough information to decide the relative order of a1 with respect to either of a2 or a3, so Experimental`ShortestSupersequence decided that a1 came after a2 and a3. However, the subsequent list {a1, a2} establishes that a1 comes before a2, so Experimental`ShortestSupersequence made the wrong choice. Of course, there is no way to make the correct choice before processing the 3rd sublist.

So, the issue is that the algorithm using Experimental`ShortestSupersequence is bad, not that Experimental`ShortestSupersequence has a bug.

$\endgroup$

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.