7
$\begingroup$

Take a list with repetitions, say {a, a, b, c}, and some permutation thereof, say {c, a, b, a}. I want to know which permutations of the new list return it into the old one, in this case {2, 4, 3, 1} and {4, 2, 3, 1}}. The following code does this, but it is highly non-optimal:

{a, a, b, c}
RandomSample[%]
Permutations[Range[Length[%]]]
Pick[%, %%[[#]] === %%% & /@ %]

Here we are checking for all possible permutations, which scales badly with the size of the list. How can this be improved? Is there a built-in (similar to FindPermutation) that can help us? Perhaps if we first Tally the list?

FWIW, any format for the output is allowed. A list of positions is fine, but also a Cycles object, or any other format that contains the relevant information.

$\endgroup$
2
  • $\begingroup$ Nice question (+). Please notice that desired permutations possess a group structure. Starting from this idea, they can be easily described by the PermutationGroup. $\endgroup$
    – yarchik
    Nov 7 '20 at 22:03
  • $\begingroup$ @yarchik - surprisingly, I found using Permute with the appropriate groups was pretty slow, so I pursued other means. $\endgroup$
    – ciao
    Nov 8 '20 at 19:04
6
$\begingroup$

Here's a quick-n-dirty idea, can be much further optimized, will revisit when/if I have time.

f1 = Select[Tuples[PositionIndex[#2] /@ #1], Unequal @@ # &] &;

Takes original list and permuted list as arguments, returns all permutation lists to return latter to former.

A quick test:

l1 = RandomInteger[4, 11]
l2 = RandomSample@l1

r2 = (perms = Permutations[Range[Length[l1]]];
     Pick[perms, l2[[#]] === l1 & /@ perms]); //AbsoluteTiming // First

r1 = f1[l1, l2]; // AbsoluteTiming // First

r1 == r2

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

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

90.2257

0.0197286

True

As is, it can handle pretty large cases:

l1 = {a, b, c, c, c, c, d, e, e, f, f, f, g, h, i, i, j, j, k, l, m, n, n};
l2 = RandomSample[l1];

Short[f1[l1, l2], 5]

{{5,19,6,8,18,22,4,15,23,7,13,14,16,3,10,21,1,11,17,20,9,2,12},{5,19,6,8,18,22,4,15,23,7,13,14,16,3,10,21,1,11,17,20,9,12,2},<<2301>>,{5,19,22,18,8,6,4,23,15,14,13,7,16,3,21,10,11,1,17,20,9,12,2}}

And a more efficient realization that can be orders of magnitude better in time and RAM:

f2 = Module[{p1 = PositionIndex[#2] /@ #1 &[#1, #2], p2, p3},
    p2 = Union[p1];
    p3 = PositionIndex[p1] /@ p2;
    p1 = {p1};
    
    Do[p1 = 
       Join @@ (With[{t = #}, (ReplacePart[t, 
                Thread[p3[[idx]] -> #]] & /@ 
              Permutations[p2[[idx]]])] & /@ p1);, {idx, Length@p2}];
    p1] &;

Which will handle bigger cases:

l1={a, b, c, c, c, c, d, e, e, f, f, f, g, h, i, i, j, j, k, l, m, n, n,n, o, o, o, o, p, q, r, s, s, s, s, s, t, u, v, w};
l2={u, l, m, o, e, j, f, n, o, s, d, o, a, i, h, c, n, g, v, c, n, p, j,s, w, f, s, c, s, c, r, f, o, s, t, i, e, q, b, k};

res=f2[l1,l2];
Length[res]
RandomSample[res, 3]

19906560

{{13,39,28,16,30,20,11,5,37,26,32,7,18,15,14,36,23,6,40,2,3,8,21,17,12,4,9,33,22,38,31,24,34,10,27,29,35,1,19,25},{13,39,30,28,16,20,11,5,37,32,7,26,18,15,14,36,23,6,40,2,3,8,17,21,33,9,4,12,22,38,31,27,34,10,29,24,35,1,19,25},{13,39,28,16,20,30,11,37,5,26,32,7,18,15,36,14,6,23,40,2,3,21,17,8,12,33,4,9,22,38,31,34,27,29,10,24,35,1,19,25}}

And an even speedier way:

   f3 = Module[{start, pos, dispos, posdispos},
    pos = PositionIndex[#1] /@ #2;
    dispos = Union[pos];
    posdispos = PositionIndex[pos] /@ dispos;
    posdispos[[Ordering[dispos]]] // 
     Flatten[Outer[Join, Sequence @@ (Permutations /@ #), 1], 
        Length[#] - 1][[All, Ordering[Flatten[dispos]]]] &
    ]&;
$\endgroup$
2
$\begingroup$

It is not necessary to produce a lot of invalid permutations.

Consider:

orig = {a, b, a, e, d, e}
samp = RandomSample[orig]

We first determine which symbols occur only once and which several times:

t = Split@Sort[orig];
single = Flatten@Select[t, Length[#] == 1 &];
multi = Union@Flatten@Select[t, Length[#] > 1 &];

Next we determine the positions of the symbols in orig and samp:

posorigs = Flatten[Position[orig, #] & /@ single];
posorigm = Flatten[Position[orig, #] & /@ multi, {3, 1}];
possamps = Flatten[Position[samp, #] & /@ single];
possampm = Flatten[Position[samp, #] & /@ multi, {3, 1}];

We the create a list with permutations. To begin with, there is only one member with the positions of the single symbols. Then we calculate the permutations of the multi symbols in possampm:

perm = Table[0, Length[orig]];
perm[[posorigs]] = possamps;
possampm = Permutations /@ possampm;

Now we add for every multi symbols all its permutations to our permutation vector:

perms = {perm};
MapThread[Function[{p1, p2},
   perms = Flatten[Reap[
       Do[
        (t = perms[[i]]; t[[p1]] = #; Sow[t]) & /@ p2
        , {i, Length[perms]}]
       ][[2]], 1]], {posorigm, possampm}];
perms

In the end we can check:

Equal @@ (samp[[#]] & /@ perms)

And for convenience all in one piece:

orig = {a, b, a, e, d, e}
samp = RandomSample[orig]
t = Split@Sort[orig];
single = Flatten@Select[t, Length[#] == 1 &];
multi = Union@Flatten@Select[t, Length[#] > 1 &];
posorigs = Flatten[Position[orig, #] & /@ single];
posorigm = Flatten[Position[orig, #] & /@ multi, {3, 1}];
possamps = Flatten[Position[samp, #] & /@ single];
possampm = Flatten[Position[samp, #] & /@ multi, {3, 1}];
perm = Table[0, Length[orig]];
perm[[posorigs]] = possamps;
possampm = Permutations /@ possampm;
perms = {perm};
MapThread[Function[{p1, p2},
   perms = Flatten[Reap[
       Do[
        (t = perms[[i]]; t[[p1]] = #; Sow[t]) & /@ p2
        , {i, Length[perms]}]
       ][[2]], 1]], {posorigm, possampm}];
perms
Equal @@ (samp[[#]] & /@ perms)
$\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.