3
$\begingroup$

Here I am going, as a matter of illustration, make a large string list:

l = Characters[WordList[]];
l = Table[DeleteDuplicates[l[[i]]], {i, Length[l]}];

This list would give all English words disjointed by letters. Now I want have a function that takes most frequent letter and join them into capital letter. k is the symbol for that for example k=2 takes two most frequent letters, k=3 takes 3 most frequent letters and so on.

Now I want to select from l those elements that are size 8, once with k=2 in the next step I want to look at the second part of the new list and make k=3 and so on. Here is what I did:

k = 2;
ClearAll[replace]
replace = 
  With[{commonest = 
      Commonest[Flatten[Map[Subsets[#, {k}] &, #], 1]][[
       1]]}, # //. {OrderlessPatternSequence[## & @@ commonest, 
        p___]} :> {StringJoin[ToUpperCase[commonest]], p}] &;
a1 = NestList[replace, Select[l, Length@# == 8 &], 1];
k = 3;
ClearAll[replace]
replace = 
  With[{commonest = 
      Commonest[
        Flatten[Map[Subsets[#, {k}] &, #], 
         1]][[1]]}, # //. {OrderlessPatternSequence[## & @@ commonest,
         p___]} :> {StringJoin[ToUpperCase[commonest]], p}] &;
a2 = NestList[replace, Select[a1[[2]], Length@# == 8 &], 1];
k = 4;
ClearAll[replace]
replace = 
  With[{commonest = 
      Commonest[
        Flatten[Map[Subsets[#, {k}] &, #], 
         1]][[1]]}, # //. {OrderlessPatternSequence[## & @@ commonest,
         p___]} :> {StringJoin[ToUpperCase[commonest]], p}] &;
a3 = NestList[replace, Select[a2[[2]], Length@# == 8 &], 1];

I wonder how can I do this operation meaning make a1, a2 and a3 lists without re-writting the replace function every time. As you can see a1 looks at l, and a2 looks at a1 and so on (in a1 = NestList[replace, Select[l, Length@# == 8 &], 1])

$\endgroup$
4
$\begingroup$

You can do it by defining replace as function that returns a replacer based on k and using FoldList in place of Nest.

But first I advise speeding things up by preprocessing the data.

data =
  Select[DeleteDuplicates /@ Characters[WordList[]], Length @ # == 8 &] //
    DeleteDuplicates;

This reduces the number characters processed down to 52416 from the 274098 in your list l.

Now here how is it works with FoldList and a parameratized replace.

replace[k_] := 
  With[{commonest = Commonest[Flatten[Map[Subsets[#, {k}] &, #], 1]][[1]]}, 
     # //. {OrderlessPatternSequence[## & @@ commonest, p___]} :> 
             {StringJoin[ToUpperCase[commonest]], p}] &;
k = 3; u = FoldList[replace[#2][#1] &, data, Range[2, k]];
Row[Column /@ u[[All, ;; 12]]]

results

The variable u is of course bound to the full results, but to keep this answer down to a reasonable length, I have chosen to show only the 1st 12 items in each sublist of the full output.

$\endgroup$
1
$\begingroup$

You can create a function f that generates your function like this:

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

And then

a1 = NestList[f[2], Select[l, Length@# == 8 &], 1];
a2 = NestList[f[3], Select[a1[[2]], Length@# == 8 &], 1];
a3 = NestList[f[4], Select[a2[[2]], Length@# == 8 &], 1];
$\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.