1
$\begingroup$

I have the list: 

l = 
  {{"d", "w", "x"}, {"a", "d"}, {"e", "h", "u", "d", "c", "q"}, 
   {"e", "c", "e", "a", "d", "e"}, {"s", "x", "r", "t", "v", "f"}, {"s"}, 
   {"c", "d", "e"}, {"s", "t", "y", "m"}, {"t", "d", "t", "u", "i", "q"}};

I want to select those elements that they are of length 6, so I evaluate 

sizedl = Select[l, Length@# == 6 &]

and get

{{"e", "h", "u", "d", "c", "q"}, {"e", "c", "e", "a", "d", "e"}, 
 {"s","x", "r", "t", "v", "f"}, {"t", "d", "t", "u", "i", "q"}}

I next want to find the most common characters, pair them and capitalise them. I have the following function to do that.

replace = 
  With[
    {commonest = 
       Commonest[Flatten[Map[Subsets[#, {2}] &, #], 1]][[1]]}, 
    # //. {OrderlessPatternSequence[## & @@ commonest, p___]} :> 
             {StringJoin[ToUpperCase[commonest]], p}] &;

Alpha = NestList[replace, sizedl, 1]

The second part of Alpha gives:

{{"ED", "c", "h", "q", "u"}, {"ED", "a", "c", "e", "e"}, 
 {"s", "x", "r", "t", "v", "f"}, {"t", "d", "t", "u", "i", "q"}}

Now, in this new list I have two elements of 5 and two elements of size 6. I want to get rid of the ones that are size 5 and repeat the same procedure. 

sizedl1 = Select[Alpha[[2]], Length @ # == 6 &];
Alpha = NestList[replace, sizedl1, 1];

I wonder how can I do this procedure for t times without repeating the code as above.

Clarification: The output for t=3 should look like this: 

l = {{"d", "w", "x"}, {"a", "d"}, {"e", "h", "u", "d", "c", 
"q"}, {"e", "c", "e", "a", "d", "e"}, {"s", "x", "r", "t", "v", 
"f"}, {"s"}, {"c", "d", "e"}, {"s", "t", "y", "m"}, {"t", "d", 
"t", "u", "i", "q"}};

k = 2;
ClearAll[replace]
replace = 
  With[{commonest = 
      Commonest[
        Flatten[Map[Subsets[#, {k}] &, #], 
         1]][[1]]}, # //. {OrderlessPatternSequence[## & @@ commonest,
         p___]} :> {StringJoin[ToUpperCase[commonest]], p}] &;

m=1;
sized1 = Select[l, Length@# == 6 &];
a1 = NestList[replace, sizedl, m][[2]]

sized2 = Select[a1, Length@# == 6 &];
a2 = NestList[replace, sized2, m][[2]]

sized3 = Select[a2, Length@# == 6 &];
a3 = NestList[replace, sized3, m][[2]]

OUTPUT:

{{"ED", "c", "h", "q", "u"}, {"ED", "a", "c", "e", "e"}, {"s", "x", 
  "r", "t", "v", "f"}, {"t", "d", "t", "u", "i", "q"}}

{{"s", "x", "r", "t", "v", "f"}, {"TU", "d", "i", "q", "t"}}

{{"SX", "f", "r", "t", "v"}}
| improve this question | |
$\endgroup$
  • $\begingroup$ what is "replace" in your code? $\endgroup$ – J42161217 Oct 15 '18 at 13:21
  • $\begingroup$ Thank for the notice, I corrected it. replace it the function that does the replacement. $\endgroup$ – Wiliam Oct 15 '18 at 13:23
  • $\begingroup$ what about p and k in the replace function? $\endgroup$ – J42161217 Oct 15 '18 at 13:38
  • $\begingroup$ k is a number which indicates pairs and is equal to 2. Fixed it. and p is variable that indicates what shall be capitalised. $\endgroup$ – Wiliam Oct 15 '18 at 13:40
  • $\begingroup$ for the sake of example lets us take t=2. But in general I am dealing with a list that has 56000 elements and I want to apply the method for arbitrary t. $\endgroup$ – Wiliam Oct 15 '18 at 13:51
2
$\begingroup$ 
replaceselect = Composition[replace, Select[Length @ # == 6 &]];
Rest @ NestWhileList[replaceselect , l, Length@# > 1 &]

{{{"ED", "c", "h", "q", "u"}, {"ED", "a", "c",    "e", "e"}, {"s", "x", "r", "t", "v", "f"}, {"t", "d", "t", "u", "i", "q"}},
{{"s", "x", "r", "t", "v", "f"}, {"TU", "d", "i", "q",    "t"}},
{{"SX", "f", "r", "t", "v"}}}

| improve this answer | |
$\endgroup$
  • $\begingroup$ Such short and neat answer deserves a wow. I learnt a lot from you so far @kglr $\endgroup$ – Wiliam Oct 15 '18 at 15:34
  • 1
    $\begingroup$ Thank you for the accept and kind words @William. $\endgroup$ – kglr Oct 15 '18 at 15:36

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.