# Building a tree

Given a list of word characters, such as this one, I'd like to build a tree, similar to this makeTree function, but with the tree in a different format. So, for an input such as

test = {{"h", "e", "l", "l", "o"}, {"h", "o", "l", "o"}, {"h",
"e", "a"}, {"h", "e", "l", "l", "o", "s"}, {"b", "r", "o"}};


I'd like the output to be

output = StartOfString[
"h"["e"["a"[EndOfString],
"l"["l"["o"[EndOfString, "s"[EndOfString]]]]],
"o"["l"["o"[EndOfString]]]], "b"["r"["o"[EndOfString]]]]


So that

TreeForm@output


gives

So far I haven't got a perfect solution, that's why I'm not posting. I know I must be missing lots of good ways to do this. What I want is not so much one single good solution, or "a fix to what I tried", but to see several ways to tackle the problem, particularly but not at all limited to elegant rule-based solutions

-
You know I don't post homework or without trying so if you want to close it I'll stay here defending it. It better be 5 against 1 –  Rojo Jul 9 '12 at 23:08
brb, while I close this question with the force of a thousand suns! :P –  The Toad Jul 9 '12 at 23:17
I think you're missing an "l" in "hollow" within the output and TreeForm. –  Mr.Wizard Jul 11 '12 at 12:43
@Mr.Wizard let's say I had an extra "l" in the input so I don't have to reupload the image :) –  Rojo Jul 11 '12 at 13:22
@Rojo, take a look at the timing study w/ recursive version - mathematica.stackexchange.com/questions/69942/… –  alancalvitti Jan 1 at 20:01

I favor tree transformations, so I would reuse the makeTree function you linked to (because it is reasonably efficient), as follows:

ClearAll[makeRojoTree];
makeRojoTree[words_List] :=
StartOfString @@
ReplaceRepeated[
makeTree[words], {
({} -> {}) :> EndOfString,
Rule[x_, l_List] :> x @@ l
}
]


The argument can be either a list of words, or a list of lists of words characters (as in your test), since makeTree is already polymorphic. Applying it to your test, we get:

makeRojoTree[test]

(*

StartOfString[
"h"["e"["l"["l"["o"[EndOfString, "s"[EndOfString]]]],
"a"[EndOfString]], "o"["l"["l"["o"[EndOfString]]]]],
"b"["r"["o"[EndOfString]]]
]

*)


which is slightly different in terms of ordering of the branches from what you have as a desired answer, but this can be fixed if you impose some specific ordering.

Comparing the performance to makeTree itself, we see that it is only about 1.5 times slower:

allWords=DictionaryLookup["*"];

(allTree=makeTree[allWords]);//Timing

(* {5.297,Null} *)

(rTree = makeRojoTree[allWords]);//AbsoluteTiming

(* {8.4375000,Null} *)


EDIT

To make this self contained, this is a slightly tuned up version of the linked makeTree, with the slightly different behaviour that it keeps duplicates

ClearAll[makeTree];
makeTree[wrds : {__String}] := makeTree[Characters[wrds]];
makeTree[{b___, {}, a___}] := Prepend[makeTree[{b, a}], {} -> {}];
makeTree[wrds_] :=
Reap[Scan[Sow[Rest[#], First@#] &,
wrds], _, #1 -> makeTree[#2] &][[2]]


and this is a tweaked version of that that returns what the OP wants without resorting to the original makeTree

ClearAll[makeTreeRojo];
Module[{makeTreeRojoAux},
makeTreeRojo[wrds_] := DeleteCases[StartOfString @@ makeTreeRojoAux[wrds], List, Infinity, Heads->True];
makeTreeRojoAux[{b___, {}, a___}] :=
Prepend[makeTreeRojoAux[{b, a}], EndOfString];
makeTreeRojoAux[wrds_] :=
Reap[Scan[Sow[Rest[#], First@#] &,
wrds], _, #1 @ makeTreeRojoAux[#2] &][[2]];
]

-
Nice one, +1... 1.5 times slower but less than half the storage, which isn't so much in either case –  Rojo Jul 10 '12 at 0:00
@Rojo Thanks. One could as well modify the original makeTree to squeeze some speed out, but I did not bother. –  Leonid Shifrin Jul 10 '12 at 0:11
I'll see if I understand it now, squeeze some speed out, and offer to edit your answer, adding the code to make it self contained –  Rojo Jul 10 '12 at 0:18
@Rojo Be my guest. I am off to bed in 5 minutes, but feel free to edit the post. –  Leonid Shifrin Jul 10 '12 at 0:23

Here is a very concise way to convert the list of strings to your desired format:

StartOfString @@ (
(Composition @@ #)[EndOfString] & /@ test //. h_[a___, x_[y__], b___, x_[z__], c___] :> h[x[y, z], a, b, c]

(* {"h"["e"["l"["l"["o"[EndOfString, "s"[EndOfString]]]],
"a"[EndOfString]], "o"["l"["l"["o"[EndOfString]]]]], "b"["r"["o"[EndOfString]]]} *)


This is a rather perverse use of Composition, but the fact that Composition[f, g][x] is f[g[x]] lends itself very nicely to the way in which you want your tree built.

-
Almost great! but check the TreeForm. The e in hello, hea, and hellos aren't groups –  Rojo Jul 9 '12 at 23:34
Btw, loved the Composition to "unflatten" –  Rojo Jul 9 '12 at 23:38
Thanks for helping fix my pattern! :) –  The Toad Jul 10 '12 at 0:18
Well deserved +1. Exactly the kind of answer I was (and still am) hoping to see appear –  Rojo Jul 10 '12 at 0:19
This is very nice conceptually, but a performance disaster for large lists of words / word letters (which is a general feature of this sort of patterns, alas). Since I think that performance is generally important for this type of problems, I don't upvote this time. –  Leonid Shifrin Jul 10 '12 at 0:27

Using a recursive Query:

byPrefixTree = Query[{
Query[Select[# != {} &] /* GroupBy[First], All, Rest],
Query[Select[# == {} &]]}] /* Merge[Join] /*
Query[All, First, byPrefixTree[#] &];


Can be used directly to reconstruct a directory tree from FileNames[...,Infinity].

• Can it be optimized? ~1000 files nested up to 15 folders deep took ~15sec.

• So far haven't been successful merging the 2 Select calls with a single GroupBy[#=={}&] as then the keys may be any subset of {True,False}. Wanted to /* with MapAt or similar

• Operator form is broken- throws a recursion limit exception.

On Rojo's data:

  testData =
test // AssociationMap[{SoS, Sequence @@ # , EoS} &] //
KeyMap[StringJoin] // Dataset


testData [byPrefixTree] // Normal

(* <|SoS-><|h-><|e-><|l-><|l-><|o-><|s-><|EoS-><|hellos-><||>|>|>,EoS-><|hello-><||>|>|>|>|>,a-><|EoS-><|hea-><||>|>|>|>,o-><|l-><|o-><|EoS-><|holo-><||>|>|>|>|>|>,b-><|r-><|o-><|EoS-><|bro-><||>|>|>|>|>|>|> *)


Desired form (though unsorted)

(testData[byPrefixTree][Map[Normal, #, All] &][First] //
Normal) //. {Rule[EoS, val_] :> EoS,
Rule[x_, l_] :> x @@ l} // TreeForm


-

I may be off the mark by not making nested compositions. So, for what it's worth:

pref[list_] := (f[m_] := m[[1 ;; #]] & /@ Range[Length@m];
g[t_] := Rule @@@ Partition[t, 2, 1];
Module[{str = {StartOfString, ##, EndOfString} & @@@ (Characters /@
list)}, TreePlot[Union[Flatten[g /@ (f /@ str)]],
Automatic, {StartOfString},
VertexRenderingFunction -> ({LightYellow, EdgeForm[Black],
Rectangle[# - {0.4, 0.2}, # + {0.4, 0.2}], Black,
Text[Last@#2, #1]} &)]])


Testing:

pref[{"hello", "holo", "hea", "hellos", "bro"}]


pref[{"bro", "hea", "holo", "hello", "help"}]


-