How can I find these patterns' signatures?

Question

I think I can explain it best starting with an example. I have the following lists:

{19, 19, 19, 19, 23, 19, 23}
{37, 53, 53, 53, 53, 37, 53}
{73, 59, 59, 59, 73, 73, 73}
{ 2, 83, 83, 83, 79,  2, 79}
{79, 41, 41, 41, 19, 79, 19}

(Yes, they're all primes.) I want to find patterns of returning values. The values themselves are not important, the place where they occur is. The first number maps to "a", and so do all occurences of that number. If a new number is encountered it is mapped to "b", and so on. For the example I would get

{a, a, a, a, b, a, b}
{a, b, b, b, b, a, b}
{a, b, b, b, a, a, a}
{a, b, b, b, c, a, c}
{a, b, b, b, c, a, c}

and finally I want to get a tally of all the different patterns:

{{1}, {a, a, a, a, b, a, b}}
{{1}, {a, b, b, b, b, a, b}}
{{1}, {a, b, b, b, a, a, a}}
{{2}, {a, b, b, b, c, a, c}}

I can do this with procedural programming, but I would like to learn how this is done with functional programming.

Answer 1

 Tally[ArrayComponents /@ lists]
 (* {{{1, 1, 1, 1, 2, 1, 2}, 1}, 
     {{1, 2, 2, 2, 2, 1, 2}, 1}, 
     {{1, 2, 2, 2, 1, 1, 1}, 1}, 
     {{1, 2, 2, 2, 3, 1, 3}, 2}}*)

Update 1: For completeness, to get the results using letters

Tally[(ArrayComponents /@ lists) /. n_Integer :> FromCharacterCode[n + 96]]
(* {{{"a", "a", "a", "a", "b", "a", "b"}, 1}, 
    {{"a", "b", "b", "b", "b", "a", "b"}, 1}, 
    {{"a", "b", "b", "b", "a", "a", "a"}, 1},
    {{"a", "b", "b", "b", "c", "a", "c"}, 2}}  *)

Update 2: Alternative ways to map to letters

 (* thanks: @Mr.Wizard *)
 Tally @ Characters @ FromCharacterCode[(ArrayComponents /@ lists) + 96]

or

 Tally@Map[FromCharacterCode, 96 + ArrayComponents /@ lists, {-1}]

Answer 2

I'm not sure if this suits your style intentions but it's natural to me.

I used numbers rather than letters because it makes for cleaner code but you can use FromCharacterCode[96 + i++] if letters are required.

tab =
  {{19, 19, 19, 19, 23, 19, 23},
   {37, 53, 53, 53, 53, 37, 53},
   {73, 59, 59, 59, 73, 73, 73},
   {2, 83, 83, 83, 79, 2, 79},
   {79, 41, 41, 41, 19, 79, 19}};

index = Module[{i = 1, f}, f[x_] := f[x] = i++; f /@ #] &;

index /@ tab // Tally // Column

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

Perhaps more to your liking:

index2 = # /. MapIndexed[# -> #2[[1]] &, DeleteDuplicates @ #] &;

index2 /@ tab // Tally // Column

Answer 3

I agree with Mr.Wizard that using integers is cleaner than generating symbols or strings (he also shows you a way to use strings). However, I find the following construct cleaner than using Module and incrementing a counter:

lists = {{19, 19, 19, 19, 23, 19, 23},
         {37, 53, 53, 53, 53, 37, 53},
         {73, 59, 59, 59, 73, 73, 73},
         {2, 83, 83, 83, 79, 2, 79},
         {79, 41, 41, 41, 19, 79, 19}};

patterns = # /. MapIndexed[# -> First@#2 &, DeleteDuplicates@#] & /@ lists;
Tally[patterns]

You can also use Thread (appropriately) instead of MapIndexed to get the same effect.

Answer 4

How about this?

rules[list_]:=With[{vals = DeleteDuplicates[list]}, Thread[vals -> Range@Length@vals]]

vals = {{19, 19, 19, 19, 23, 19, 23},
        {37, 53, 53, 53, 53, 37, 53},
        {73, 59, 59, 59, 73, 73, 73},
        {2, 83, 83, 83, 79, 2, 79},
        {79, 41, 41, 41, 19, 79, 19}};

Tally[#/.rules[#]&/@vals]

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

and if you want it in terms of symbols,

Tally[(# /. rules[#]) /. x_Integer :> Symbol@FromCharacterCode[x + 96] & /@ vals]

{{{a, a, a, a, b, a, b}, 1}, {{a, b, b, b, b, a, b}, 1}, {{a, b, b, b, a, a, a}, 1}, {{a, b, b, b, c, a, c}, 2}}

Answer 5

Update 12/25/12

After a bit of struggle, I came up with this method. no Do is used.

(*data*)
Clear["Global`*"]
lst = {{19, 19, 19, 19, 23, 19, 23}, {37, 53, 53, 53, 53, 37, 53}, 
       {73, 59, 59, 59, 73, 73, 73}, {2, 83, 83, 83, 79, 2,79}, 
       {79, 41, 41, 41, 19, 79, 19}};
 p = {a, b, c, d, e, f, g};(*that is what we need,7 letters max*)(*engine*)

(*engine*)
u = Map[Flatten, Map[DeleteDuplicates, Gather /@ lst, {2}]]
z = Map[MapThread[Rule, #] &, Map[{#, Take[p, Length[#]]} &, u]]
MapThread[(#1 /. #2) &, {lst, z}]

(* {{a, a, a, a, b, a, b}, 
    {a, b, b, b, b, a, b}, 
    {a, b, b, b, a, a, a}, 
    {a, b, b, b, c, a, c}, 
    {a, b, b, b, c, a, c}}  *)

old answers below

Updated based on MrWizard suggestions. I'll keep my original complicated answer below since that is what I wrote first. But credit for this updated answer goes to MrWizard, so please do not upvote me based on this new answer or I'll get upset.

Updated and improved answer

(*data*)
lst = {{19, 19, 19, 19, 23, 19, 23}, {37, 53, 53, 53, 53, 37, 
    53}, {73, 59, 59, 59, 73, 73, 73}, {2, 83, 83, 83, 79, 2, 
    79}, {79, 41, 41, 41, 19, 79, 19}};
p = {a, b, c, d, e, f, g};(*that is what we need,7 letters*)

(*engine*)
r = Gather /@ lst  (*note: Gather is listable *)
Tally@MapThread[# /.MapThread[Rule, {First /@ #2, Take[p, Length@#2]}] &, {lst, r}]   

old original answer

is a Do ok? I think I can get rid of it if I try harder.

(*data*)
lst = {{19, 19, 19, 19, 23, 19, 23},
   {37, 53, 53, 53, 53, 37, 53},
   {73, 59, 59, 59, 73, 73, 73},
   {2, 83, 83, 83, 79, 2, 79},
   {79, 41, 41, 41, 19, 79, 19}};    
p = {a, b, c, d, e, f, g};  (*that is what we need, 7 letters*)

(* engine *)
r = Gather[#, #1 == #2 &] & /@ lst;   
z = Last@Reap@Do[
     rule =Rule[#1[[1]], #2] & @@@Transpose[{  r[[i]] , p[[1 ;; Length[r[[i]]]]]}];
     Sow[lst[[i]] /. rule],
     {i, 1, Length[r]}]

Tally[#] & /@ z

gives

(*{{{a, a, a, a, b, a, b}, {a, b, b, b, b, a, b}, {a, b, b, b, a, a,a}, 
  {a, b, b, b, c, a, c}, {a, b, b, b, c, a, c}}}

 {{{{a, a, a, a, b, a, b}, 1}, {{a, b, b, b, b, a, b},1}, 
 {{a, b, b, b, a, a, a}, 1}, {{a, b, b, b, c, a, c}, 2}}}
*)