How to efficiently find positions of duplicates?

Question

Is there an efficient way to find the positions of the duplicates in a list?

I would like the positions grouped according to duplicated elements. For instance, given

list = RandomInteger[15, 20]

{3, 3, 6, 11, 13, 13, 11, 1, 2, 3, 12, 8, 9, 9, 4, 15, 5, 6, 9, 12}

the output should be

positionDuplicates[list]

{{{1}, {2}, {10}}, {{3}, {18}}, {{4}, {7}}, {{5}, {6}}, {{11}, {20}}, {{13}, {14}, {19}}}

Here's my first naive thought:

positionDuplicates1[expr_] :=
  Position[expr, #, 1] & /@ First /@ Select[Gather[expr], Length[#] > 1 &]

And my second:

positionDuplicates2[expr_] := Module[{seen, tags = {}},
  MapIndexed[
   If[seen[#1] === True, Sow[#2, #1], 
     If[Head[seen[#1]] === List, AppendTo[tags, #1]; 
      Sow[seen[#1], #1]; Sow[#2, #1]; seen[#1] = True, 
      seen[#1] = #2]] &, expr]
  ]

The first works as desired but is horrible on long lists. In the second, Reap does not return positions in order, so if necessary, one can apply Sort. I feel the work done by Gather is about what it should take for this task; DeleteDuplicates is (and should be) faster.

---

Here is a summary of timings on a big list.

list = RandomInteger[10000, 5 10^4];
positionDuplicates[list]; // Timing
positionDuplicates2[list] // Sort; // Timing
Sort[Map[{#[[1, 1]], Flatten[#[[All, 2]]]} &, Reap[MapIndexed[Sow[{#1, #2}, #1] &, list]][[2, All, All]]]] (* Daniel Lichtblau *)
Select[Last@Reap[MapIndexed[Sow[#2, #1] &, list]], Length[#] > 1 &]; // Timing
positionOfDuplicates[list] // Sort; // Timing (* Leonid Shifrin *)
GatherBy[Range@Length[list], list[[#]] &]; // Timing (* Szabolcs *)
Gather[list]; // Timing
DeleteDuplicates[list]; // Timing

{82.378231, Null} (* my #1)
{0.675543, Null} (* my #2)
{0.387743, Null} (* Daniel Lichtblau *)
{0.223374, Null} (* Szabolcs's suggested improvement of my #2 *)
{0.062060, Null} (* Leonid Shifrin *)
{0.021962, Null} (* Szabolcs's answer *)
{0.009456, Null} (* Gather - for comparison purposes *)
{0.000493, Null} (* DeleteDuplicates *)

Answer 1

You can use GatherBy for this. You can map List onto Range[...] first if you wish to have exactly the same output you showed.

positionDuplicates[list_] := GatherBy[Range@Length[list], list[[#]] &]

list = {3, 3, 6, 11, 13, 13, 11, 1, 2, 3, 12, 8, 9, 9, 4, 15, 5, 6, 9, 12}

positionDuplicates[list]

(* ==> {{1, 2, 10}, {3, 18}, {4, 7}, {5, 6}, {8}, {9}, 
        {11, 20}, {12}, {13, 14, 19}, {15}, {16}, {17}} *)

If you prefer a Sow/Reap solution, I think this is simpler than your version (but slower than GatherBy):

positionDuplicates[list_] := Last@Reap[MapIndexed[Sow[#2, #1] &, list]]

If you need to remove the positions of non-duplicates, I'd suggest doing that as a post processing step, e.g. Select[result, Length[#] > 1&]

Answer 2

Here is a version based on sorting, and using Mr. Wizard's dynP function:

dynP[l_, p_] := 
   MapThread[l[[# ;; #2]] &, {{0}~Join~Most@# + 1, #} &@Accumulate@p]

positionOfDuplicates[list_] :=
   With[{ord = Ordering[list]},
      SortBy[dynP[ord, Length /@ Split[list[[ord]]]], First]
   ]

so that

positionOfDuplicates[list]

(* {{1,2,10},{3,18},{4,7},{5,6},{8},{9},{11,20},{12},{13,14,19},{15},{16},{17}} *)

It is also fast enough, although not as fast as the one based on GatherBy.

Answer 3

If you wanted to retain each value as well as its positions, this works.

Sort[
 Map[{#[[1, 1]], Flatten[#[[All, 2]]]} &, 
  Reap[MapIndexed[Sow[{#1, #2}, #1] &, list]][[2, All, All]]]]

(* Out[178]= {{0, {14}}, {1, {17, 19}}, {4, {4, 
   20}}, {5, {12}}, {7, {10}}, {9, {13}}, {10, {2, 
   6}}, {11, {3}}, {12, {7, 15}}, {13, {8, 9, 11}}, {14, {1, 16, 
   18}}, {15, {5}}} *)

It's maybe 20x slower than the GatherBy though.