3
$\begingroup$

This is related to Splitting balls over sized bins but a simplified subproblem

I've got a list of lists of numbers, e.g.

perms = BlockRandom[
   SeedRandom[4];
   RandomInteger[3, {10, 3}]
   ] // DeleteDuplicates

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

Now for each of these lists I insert a value at a set of positions, this can be done like

insertCurVal[val_, pos_][perms_] :=
  Join @@
   Table[
    Insert[
     perms, 
     val, 
     Transpose[{Range[Length[perms]], ConstantArray[i, Length[perms]]}]
     ],
    {i, pos}
    ];

val = 1;
insertPos = {1, 2};
insertCurVal[1, {1, 2}]@perms

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

This list now has duplicate elements, since for some of the lists an insertion at 1 had the same effect as an insertion at 2.

Similarly, if we insert at 1 and 3, we get another set of dupes

Counts[insertCurVal[1, {1, 3}]@perms] // Select[GreaterThan[1]]

<|{1, 1, 1, 2} -> 2|>

Is there an efficient way to avoid these duplicates? That is, is there a way that is better than simply generating the full list and hitting it with DeleteDuplicates after the fact? I think I can assume that we'll have tens to hundreds of thousands of these lists but the number of insertion positions will remain under ~50

$\endgroup$
8
  • $\begingroup$ maybe insertCurVal2[val_, pos_][perms_] := Module[{assoc = <||>}, Join @@ Table[ AssociateTo[assoc, Thread[Insert[perms, val, Transpose[{Range[Length[perms]], ConstantArray[i, Length[perms]]}]] -> 1]], {i, pos}]];? $\endgroup$ – kglr Apr 2 at 4:06
  • $\begingroup$ @kglr isn't that just doing a de-dupe using AssociateTo instead of DeleteDuplicates? Not sure if that's any faster $\endgroup$ – b3m2a1 Apr 2 at 4:07
  • 1
    $\begingroup$ b3m2a1, ClearAll[insertCurVal3]; insertCurVal3[val_, pos_][perms_] := Fold[Join[#, AssociationThread[ Insert[perms, val, Transpose[{Range[Length[perms]], ConstantArray[#2, Length[perms]]}]] -> 1]] &, <||>, pos]; is slower for the posted example, but it deletes duplicates as it goes rather than at the end. Something similar with SparseArray might be possible as it also ignores repeated entries. $\endgroup$ – kglr Apr 2 at 4:27
  • $\begingroup$ Honestly, this feels like a chain of x-y problems. Is there some end goal to this and the chain of linked questions? $\endgroup$ – ciao Apr 2 at 4:42
  • $\begingroup$ @ciao the end goal is basically to take a bunch of lists of integers that can be written as a permutation & a partition of an integer, perform some selection rule math on them where the selection rules can be written, again, as a permutation operating on a partition of another integer + a bunch of factors that come out from taking the direct product of the indices of some D-dimensional array, and reduce all of that to math over the partitions & D-dimensional cube indices. Basically I'm trying to avoid calculating Permutations[Range[100]] and work over equivalence classes instead. $\endgroup$ – b3m2a1 Apr 2 at 4:48
3
$\begingroup$

This seems to be faster than OP's insertCurVal for long lists of perms:

The idea: Given a list of insertion positions, pos = {pos1, pos2, ..., posk}, if the input list is duplicate-free, the first step of insertions does not introduce any duplicates. If we manage to avoid duplicates up to insertion in $pos_i$, then insertion of val in $pos_{i+1}$ creates duplicates iff, for some row r of perms, the columns perms[[r, pos_i;;pos_(i+1)]] are all equal to val. So, we remove such rows before we do insertions. The results thus obtained are identical to the ones given by OP's insertCurVal.

ClearAll[insertCurValB]
insertCurValB[val_, pos_][perms_] := 
  Join[Insert[perms, val, 
        Transpose[{Range[Length[perms]], ConstantArray[First @pos, Length[perms]]}]], 
   Join @@ Table[With[{picked = Pick[Range[Length[perms]], 
         1 - Unitize[Total[Abs[val - perms[[All, i[[1]] ;; (i[[2]] - 1)]]], {2}]], 0]}, 
      Insert[perms[[picked]], val, Thread[{Range @ Length @ picked, i[[2]]}]]], 
   {i, Partition[pos, 2, 1]}]];

A faster version using b3m2a1's suggestions in comments:

ClearAll[insertCurValC]
insertCurValC[val_, pos_][perms_] := Module[{rng = Range[Length[perms]], 
       lngth = Length@perms}, 
   Join[Insert[perms, val, 
        Transpose[{rng, ConstantArray[First@pos, lngth]}]], 
    Join @@ Table[With[{picked = Pick[rng, 
       1 - Unitize[Total[Abs[val - perms[[All, i[[1]] ;; (i[[2]] - 1)]]], {2}]], 0]},
        Insert[perms[[picked]], val, 
        Transpose[{rng[[;; Length@picked]],
            ConstantArray[i[[2]], Length[picked]]}]]], 
     {i, Partition[pos, 2, 1]}]]];

Examples:

perms = BlockRandom[SeedRandom[4];
    RandomInteger[3, {10, 3}]] // DeleteDuplicates;

(res1 = insertCurVal[1, {1, 2}]@perms // DeleteDuplicates;) // 
  RepeatedTiming // First
 0.000014
(res2 = insertCurValB[1, {1, 2}]@perms;) // RepeatedTiming // First
 0.000030
(res2 = insertCurValC[1, {1, 2}]@perms;) // RepeatedTiming // First
 0.000037
res1 == res2 == res3
 True
perms1000 = BlockRandom[SeedRandom[4];
    RandomInteger[3, {1000, 15}]] // DeleteDuplicates;


(res1 = insertCurVal[1, {2, 3, 5, 12}]@perms1000 // 
      DeleteDuplicates;) // RepeatedTiming // First
0.0018
(res2 = insertCurValB[1, {2, 3, 5, 12}]@perms1000;) // 
  RepeatedTiming // First
0.0010
(res2 = insertCurValC[1, {2, 3, 5, 12}]@perms1000;) // 
  RepeatedTiming // First
0.00065
res1 == res2 == res3
True
$\endgroup$
9
  • $\begingroup$ Nice! I was working up a solution in this vein since I think it's the optimal one, but kept running into bugs $\endgroup$ – b3m2a1 Apr 2 at 6:54
  • 1
    $\begingroup$ One quick performance thing, using Transpose[{Range@Length@picked, ConstantArray[i[[2]], Length@picked]}] instead of Thread[{Range@Length@picked, i[[2]]}] is significantly faster because it allows us to avoid unpacking. Thread, in general, unpacks arrays I believe. I get about a 2x speed up with 10000 input lists. And by only calculating Range[Length[perms]] once and subsampling it to get Range[Length[picked]] we can get a small but not insignificant boost. $\endgroup$ – b3m2a1 Apr 2 at 18:40
  • $\begingroup$ @b3m2a1, updated with your suggestions. $\endgroup$ – kglr Apr 2 at 19:35
  • 1
    $\begingroup$ A corner case the tests missed: it turns out if you have a case where an insertion will introduce some kind of symmetry this breaks down: insertCurValB[1, {1, 2, 3}]@{{1, 0}, {0, 1}} (* {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}, {1, 0, 1}} *) I think a "wrap-around" case might need to be added $\endgroup$ – b3m2a1 Apr 2 at 20:00
  • 1
    $\begingroup$ It seems like this is a problem with two different lists mapping to the same list after two different insertions, which is a nastier case to check for, but if it only ever shows up when inserting both at the very start and very end of the list I think that might be workable $\endgroup$ – b3m2a1 Apr 2 at 20:07
1
$\begingroup$

Handling Accidental Dupes

With the solution outline by kglr we can get into trouble in the special case that we have two lists differ only up to a swap like,

dupePerms =
 With[{r = BlockRandom@RandomInteger[{5}, 15]},
  {
   Insert[r, 1, 3],
   Insert[r, 1, 8]
   }
  ]

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

which will cause dupes on when inserting at positions {3, 9}

insertCurValB[1, {3, 9}]@dupePerms

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

To handle this case, given j > i, when we insert val at j we can also check for any input lists that have val at j-1 and check for a corresponding list at with val at i. If we find such a list, we drop that list from our set of insertions. This is somewhat annoying to program up, but is entirely doable.

insertCurValD[val_, pos_][perms_, checkAccidents : True | False : True] :=
  
  Block[{
    p = Range[Length[perms]],
    picked,
    diffs,
    tots,
    subperms,
    subgathers, splitInds,
    potBadPick, potBad1, badVals,
    potBadPickJ, potBadJ, badValsJ,
    badPosJ,
    fullInds,
    balValIndMap
    },
   Join[
    Insert[perms, val, 
     Transpose[{p, ConstantArray[First@pos, Length[perms]]}]],
    Sequence @@
     Table[
      (* remove initial duplicates *)
      
      diffs = 1 - Unitize[(val - perms[[All, i[[1]] ;; (i[[2]] - 1)]])];
      tots = Unitize[Total[diffs, {2}], i[[2]] - i[[1]]];
      picked = Pick[p, tots, 0];
      subperms = perms[[picked]];
      If[checkAccidents,
       (* we first find all positions where val occurs at i[[2]]-1, 
       since these are the possibly duplicated vectors *)
       
       potBadPick = Pick[p, perms[[;; , i[[2]] - 1]], val];
       If[Length[potBadPick] > 0,
        
        (* 
        if we have any of these, then for each prior value of j
        we pull the correspoding vectors with val at position j, 
        but here we are
        able to subsample only the subperms which should make things somewhat \
faster
        *)
        Do[
         potBadPickJ = Pick[p[[;; Length[picked]]], subperms[[;; , j]], val];
         If[Length[potBadPickJ] > 0,
          (* 
          we know we need to check things, 
          so we delete those columns from each set and look at where they overlap
          *)
          fullInds = Range[Length[perms[[1]]]];
          potBad1 = perms[[potBadPick, Delete[fullInds, i[[2]] - 1]]];
          potBadJ = subperms[[potBadPickJ, Delete[fullInds, j]]];
          badVals = Intersection[potBadJ, potBad1];
          balValIndMap = AssociationThread[potBadJ, potBadPickJ ];
          badPosJ = Lookup[balValIndMap, badVals];
          picked = picked[[Complement[p[[;; Length[picked]]], badPosJ]]];
          subperms = perms[[picked]]
          ],
         {j, TakeWhile[pos, # < (i[[2]]) &]}
         ]
        ]
       ];
      Insert[
       subperms,
       val,
       Transpose[{
         p[[;; Length@picked]],
         ConstantArray[i[[2]], Length@picked]
         }]
       ],
      {i, Partition[pos, 2, 1]}
      ]
    ]
   ];

and now if we turn this check on we can avoid dupes

insertCurValD[1, {3, 9}]@dupePerms

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

insertCurValD[1, {3, 9}][dupePerms, False]

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

The issue is that this is actually slower than just doing a DeleteDuplicates after the fact...but I think by being cleverer with the Intersection and not wasting effort (we recalculate a lot of stuff) it could become faster.

Performance Testing

After trying a number of things, I think making use of kglr's process for removing dupes is about as good as it can get. There are a few places for performance improvements though, particularly w/r/t/ unpacking and calculating the dupe positions. Here's the fastest version I've come up with

ClearAll[insertCurValD]
insertCurValD[val_, pos_][perms_] :=
  Block[{
    p = Range[Length[perms]],
    picked,
    diffs,
    tots
    },
   Join[
    Insert[perms, val, 
     Transpose[{p, ConstantArray[First@pos, Length[perms]]}]],
    Sequence @@
     Table[
      diffs = 1 - Unitize[(val - perms[[All, i[[1]] ;; (i[[2]] - 1)]])];
      tots = Unitize[Total[diffs, {2}], i[[2]] - i[[1]]];
      picked = Pick[p, tots, 0];
      Insert[
       perms[[picked]],
       val,
       Transpose[{
         p[[;; Length@picked]],
         ConstantArray[i[[2]], Length@picked]
         }]
       ],
      {i, Partition[pos, 2, 1]}
      ]
    ]
   ];

Its performance is not always consistently ~2x faster, but it's never been less than 1.5x that I've seen. This even holds as things become memory bound

perms1000 = BlockRandom[SeedRandom[4];
    RandomInteger[3, {5000000, 15}]] // DeleteDuplicates;

(res2 = insertCurValB[1, {2, 3, 5, 12}]@perms1000;) // RepeatedTiming // First

12.

(res5 = insertCurValD[1, {2, 3, 5, 12}]@perms1000;) // RepeatedTiming // First

6.80

Interestingly, a version using Compile was slower than the uncompiled version even when making sure there were no MainEvaluate statements. My assumption is that this is an effect of being memory constrained over the large lists of partition lists.

Here's a plot & log-log-plot of the performance benefit, just so that we can see it's not a huge difference on a per-list basis

perfDat =
  Table[
   With[{p =
      BlockRandom[SeedRandom[4];
        RandomInteger[3, {n, 15}]] // DeleteDuplicates
     },
    {
     {n, AbsoluteTiming[insertCurValB[1, {2, 3, 5, 12}]@p][[1]]},
     {n, AbsoluteTiming[insertCurValC[1, {2, 3, 5, 12}]@p][[1]]},
     {n, AbsoluteTiming[insertCurValD[1, {2, 3, 5, 12}]@p][[1]]}
     }
    ],
   {n, {100, 500, 1000, 5000, 10000, 50000, 100000, 500000, 1000000, 5000000, 
     10000000}}
   ];

Grid@{{
   ListLinePlot[Transpose@perfDat, PlotRange -> All, ImageSize -> {300, 500}, 
    PlotLegends -> {"B", "C", "D"},
    AspectRatio -> Full
    ],
   ListLinePlot[Transpose@perfDat, ScalingFunctions -> {"Log", "Log"}, 
    ImageSize -> {300, 500},
    PlotLegends -> {"B", "C", "D"},
    AspectRatio -> Full]
   }}

enter image description here

$\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.