Show positions of duplicated matrix elements

Question

1. Problem statement

I want to replace duplicated elements within a matrix with a placeholder value.

2. Example data

SeedRandom[0];
mat = RandomInteger[{1, 100}, {5, 5}];
mat // MatrixForm

There are several duplicated values between rows and one value, 68, repeated within a row (I use duplicated and repeated as synonyms, meaning more than once).

3. UniqueElements

Since V 13.1 there is UniqueElements which deletes duplicated matrix elements, but results in a ragged list, not showing the positions of the deleted values.

UniqueElements[mat] // MatrixForm

4. The solution found

    PaddedSingles[mat_?MatrixQ, rep_ : 0] :=
     (* intra row replacements *)
     ReplaceRepeated[{h___, a_, m___, a_, t___} :> {h, a, m, rep, t}] /@
      (* between rows replacements *)
      Table[
        mat[[i]] /. Alternatives @@ Union @ Flatten @ Delete[mat, {i}] :> rep,
        {i, Length @ mat}]

5. Expected result

res = PaddedSingles[mat];
res // MatrixForm

Check

DeleteCases[res, 0, {2}] == UniqueElements[mat]

(* True *)

6. Further examples

mat = {{1, 0, 1}, {0, 1, 0}, {0, 0, 2}};
res = PaddedSingles[mat, x]

{{x, x, x}, {x, x, x}, {x, x, 2}}

DeleteCases[res, x, {2}] == UniqueElements[mat]

(* True *)

mat = {{0, 1}, {1, 0}};
res = PaddedSingles[mat, x]

{{x, x}, {x, x}}

DeleteCases[res, x, {2}] == UniqueElements[mat]

(* True *)

7. Question

Maybe I should be happy with this solution, but I always feel a little bad when I have to use Table or iterators. Also, because of the mapped ReplaceRepeated and iterated ReplaceAll, my solution should become very slow when acting on large matrices. Reasons enough to ask for alternative methods.

Answer 1

duplicatePositions = 
  Apply[Join] @
  ReplaceAll[p : {{x_, _} ..} :> Rest[p]] @
  Select[Length @ # > 1 &] @
  GatherBy[Tuples @ Range @ Dimensions @ #, 
      $x |-> #[[Apply[Sequence] @ $x]]] &

You can use duplicatePositions with MapAt or with ReplaceAt or with ReplacePart:

paddedSingles = MapAt[#2, duplicatePositions @ #] @ # &;

MatrixForm[paddedSingles[mat, x &]]

paddedSinglesB = ReplaceAt[_ -> #2, duplicatePositions @ #] @ # &;

paddedSinglesC = ReplacePart[#, duplicatePositions[#] -> #2] &;


paddedSingles[mat, x &] == paddedSinglesB[mat, x] ==  paddedSinglesC[mat, x]

True 

An alternative, slower, method to find the desired position list:

duplicatePositions2 = Apply[Join] @
    ReplaceAll[p : {{x_, _} ..} :> Rest[p]] @
    Select[Length[#] >= 2 &] @
    Map[$x |-> Position[#, $x, {2}]] @ 
    Apply[Union] @ # &;

Sort @ duplicatePositions @ mat == Sort @ duplicatePositions2 @ mat

True

Answer 2

An alternative using SparseArray:

ClearAll[PaddedSingles];
PaddedSingles[mat_?MatrixQ, rep_ : 0] :=
  (f |-> f -> If[Length@f > 1, rep, First@#])[DeleteDuplicatesBy[Last@#, First]] & /@
   Normal@GroupBy[ArrayRules[SparseArray[mat], rep], Last -> First] //
     Normal@SparseArray[Splice@*Thread /@ #] &

testmat = {
  {{84, 67, 5, 22, 72}, {68, 17, 68, 77, 29}, {22, 44, 18, 47, 54}
                      , {85, 86, 18, 51, 16}, {100, 61, 2, 20, 44}}
, {{1, 0, 1}, {0, 1, 0}, {0, 0, 2}}
, {{0, 1}, {1, 0}}};

PaddedSingles /@ testmat 

(*
{{{84, 67, 5, 0, 72}, {68, 17, 0, 77, 29}, {0, 0, 0, 47, 54}
                    , {85, 86, 0, 51, 16}, {100, 61, 2, 20, 0}}
, {{0, 0, 0}, {0, 0, 0}, {0, 0, 2}}
, {{0, 0}, {0, 0}}}

*)
DeleteCases[PaddedSingles@#, 0, {2}] == UniqueElements[#] & /@ testmat
(*{True, True, True}*)

Answer 3

Using the third argument of GroupBy:

UniqueDuplicatePositions[mat_] := 
Catenate@Keys@GroupBy[Select[Position[mat, #] & /@ DeleteDuplicates@Flatten@mat, 
Length[#] > 1 &], If[Equal @@ #[[All, 1]], Rest@#, #] &]

Then, using ReplacePart:

ReplacePart[#, Thread[UniqueDuplicatePositions[#] -> x]] &@ mat // MatrixForm

@eldo always comes up with the kind of questions that make you rethink the very logic you're familiar with. And @kglr? He's the kind of genius who always seems to have the perfect solution tucked away. Keeping up with these two feels like trying to debug a perfectly written Wolfram code: super intriguing, and always a delightful challenge! 😄

Utilizing a segment from @kglr's code, we observe a quicker alternative as follows:

UniqueDuplicatePositions[mat_] := Catenate[ReplaceAll[
p : {{x_, _} ..} :> Rest[p]]@(Position[mat, #] & /@ 
Select[Tally[Flatten[mat]], #[[2]] > 1 &][[All, 1]])]

Answer 4

Clear[keepLocalDuplicates, dpos];
dpos[k_List] := 
 Position[k, #] & /@ (k // DeleteDuplicates) // Map[Rest] // Flatten
keepLocalDuplicates[mat_?MatrixQ, repl_ : "x"] := 
 Module[{mat2, cfull, pos2},
  mat2 = If[DuplicateFreeQ@#, #, 
      ReplacePart[#, Thread[dpos@# -> repl]]] & /@ mat;
  cfull = Map[Count[Flatten@mat2, #] &, mat2, {2}];
  pos2 = Position[cfull, _?(# > 1 &)];
  ReplacePart[mat2, Thread[pos2 -> repl]]
  ]

testCases = {
   {{84, 67, 5, 22, 72}, {68, 17, 68, 77, 29}, {22, 44, 18, 47, 
     54}, {85, 86, 18, 51, 16}, {100, 61, 2, 20, 44}}
   , {{1, 0, 1}, {0, 1, 0}, {0, 0, 2}}
   , {{0, 1}, {1, 0}}
   };

{ testCases // Map[MatrixForm], 
  keepLocalDuplicates /@ testCases // Map[MatrixForm]} // Column

---

Addendum

Here is a function based on Fold that marks duplicated elements from a list. This can be used as a building block.

Clear[UniqueElements];
UniqueElements[k_List, repl_ : "x"] := 
 Fold[Append[#1, If[FreeQ[#1, #2], #2, repl]] &, {}, k]

SeedRandom[1];
t1 = RandomInteger[{1, 20}, 20];

{t1, UniqueElements[t1]} // Grid