How can I regroup elements in a list into a tree based on their values?

Question

I have a list of elements in an outline, here is an example that is only 3 levels deep:

{
    {{"1"},"Setup code"},
    {{"1","1"},"Local variables"},
    {{"1","2"},"Option variables"},
    {{"1","3"},"Check for null Input"},
    {{"2"},"Argument Logic"},
    {{"2","1"},"X Spec"},
    {{"2","2"},"One Dimensional Case"},
    {{"2","2","1"},"Tick and Label Generation"},
    {{"2","2","2"},"plot generation"},
    {{"2","2","3"},"bin names generation"},
    {{"2","2","4"},"bar chart generation"},
    {{"2","3"},"Y Spec"}
}

And I'd like to transform it into a list of trees of the form {parentNode, {childNode1, childNode2, ...}}, and the nodes themselves are are like {{"1","2",...}, "label"}. For example, the above would become:

answer = {
{
    {{"1"},"Setup code"},
    {
        {{"1","1"},"Local variables"},
        {{"1","2"},"Option variables"},
        {{"1","3"},"Check for null Input"}
    }
},

{
    {{"2"},"Argument Logic"},
    {
        {{"2","1"},"X Spec"},
        {
             {{"2","2"},"One Dimensional Case"},
             {
                  {{"2","2","1"},"Tick and Label Generation"},
                  {{"2","2","2"},"plot generation"},
                  {{"2","2","3"},"bin names generation"},
                  {{"2","2","4"},"bar chart generation"}
             }
        },
        {{"2","3"},"Y Spec"}
    }
}

}

The reason being that once it is in this form, OpenerView[] could be used to make an interactive collapsable outline, for instance:

ToOutline[l_List] := 
  Panel @ Grid[
     Partition[
      Panel /@ ToOutline1 /@ l //. {x_, list_List} :> 
        ToOutline1[{x, list}], 4, 4, 1, {}], 
     Alignment -> Top] /. {n : {__String}, s_String} :> 
    Row[{StringJoin @ Riffle[n, "."] , "  ", s}];
ToOutline1[{x_, list_List}] := 
 OpenerView[{x, Column[Panel /@ list]}, True]
ToOutline[answer]

generates

Motivation

This questions helps solve the problem of extracting comments from a file in Wolfram Workbench of the form (* tag:1:2:2:3... text... *). So for example if I had commented my function MyFun with a comment like (* MyFun:1:... text... *), I could extract them as follows:

CommentsToOutlineElements[filePath_, ID_] := Module[{allComments, commentsIDs, IDs, commentsStrings},
    allComments = Cases[Import[filePath, "Comments"], _?(!StringFreeQ[#, ID]&)]
    commentsIDs = StringSplit[#1, Whitespace][[1]]& /@ allComments;
    commentsStrings = StringCases[#1, Shortest[s__]~~Whitespace~~Longest[c__] :> c][[1]]& /@ allComments;
    IDs = Rest[StringSplit[#,":"]]& /@ commentsIDs;
    Transpose @ {IDs, commentsStrings}
]
CommentsToOutlineElements["User/...", "MyFun"]

And then generate a nice outline of the function, as per this question.

Answer 1

It would be nice to have a real big sample, but I hope it works anyway. Here is the approach: I would extract the information level by level and build up the structure. Level 1 contains the sections and this is basically your starting point

Select[input, Length[First[#]] === 1 &]

All section number lists which have a length of one are your sections. The first one looks like this

{{"1"}, "Setup code"}

Lets say our current output is a list of all those entries. What you want to do now is to extract all sections of level 2 which have the same first number like the above. Lets say we found 3 subsections call them s1,s2,s3 and we call the section entry from above elm then we want to replace in our current output

elm -> {elm, {s1, s2, s3}}

This can be done level by level until we are finished. To make it a bit more concrete: the front of our rule above must ensure, that we work only on the elements of the current level, therefore, we check the length of the section numbering

elm : {l : {__String}, what_String} /; Length[l] === 1 :> blub

To extract s1,... we Select from our input all entries which are one level deeper than the current one (this means Length[..]===2 here) and which have the same section numbers up to the current level. For instance, all childs of {2,2,3} have to look like {2,2,3,..}. In a generic solution this call is therefore

Select[input, Length[First[#]] === i + 1 && First[#][[Range[i]]] === l &]

where i is the current level. We need the First[#] because the section numbers are in the first part of every entry.

One last thing: If an entry has no sub-entries, the Select returns {} which I simply filter in a second rule. The nice thing is that when we are finished, the output does not change anymore. This is perfect for FixedPoint

TransformDoc[input_] :=
 Block[{i = 0}, 
  FixedPoint[
   (i++; # /. elm : {l : {__String}, what_String} /; Length[l] === i :> 
    {elm,Select[input, Length[First[#]] === i + 1 && 
     First[#][[Range[i]]] === l &]} /. 
    {whatever__, {}} :> whatever) &, 
  Select[input, Length[First[#]] === 1 &]]
 ]

I hope I explained all details enough to understand the rule I used.

input = {{{"1"}, "Setup code"}, {{"1", "1"}, 
    "Local variables"}, {{"1", "2"}, "Option variables"}, {{"1", "3"},
     "Check for null Input"}, {{"2"}, "Argument Logic"}, {{"2", "1"}, 
    "X Spec"}, {{"2", "2"}, "One Dimensional Case"}, {{"2", "2", "1"},
     "Tick and Label Generation"}, {{"2", "2", "2"}, 
    "plot generation"}, {{"2", "2", "3"}, 
    "bin names generation"}, {{"2", "2", "4"}, 
    "bar chart generation"}, {{"2", "3"}, "Y Spec"}};
TransformDoc[input] // ToOutline

Finally, please give me a chance to maybe make you reconsider your approach. Why do you need the section numbering at all? Look at LaTeX, as long as you don't want to mix different sections at different places you only need to markup whether you need a section, a subsection, ... The numbering and the structure can simply be build from this. Wouldn't it be easier to just give a number defining the depth of your comment and the rest is calculated automatically?

Answer 2

This is a job for recursion:

ClearAll[f];    
f[{fst : {{left__}, _}, sub : Longest[{{left__, __}, _} ...], rest___}] :=
    {{fst, f[{sub}]} /. {el_, {}} :> el, Sequence @@ f[{rest}]};
f[x_] := x;

The usage is

f[your-initial-structure]

Answer 3

ReplaceRepeated with some pre-processing to re-structure outline into the desired form.

The key ideas are

1. construct a tree with root 0 using the information in the first column of outline
2. pre-process the vertex list to turn leaf indices to strings
3. Use ReplaceRepeated starting from the root node, and replacing each processed node i with the list {"i", {children of i}}.

First, few simple helper functions:

ClearAll[fatherF, rootsF, chldrnListF]
fatherF = Function[{item, list},   If[Length[item] == 1, {0}, 
      Pick[list, (item[[;; -2]] == #) & /@ list]]];
(* create a list of children lists - the leaf nodes of the tree marked as strings in each part *)
chldrnListF = Function[{grph}, 
 VertexOutComponent[grph, #, 1]& /@ VertexList[grph] /.
   i_Integer /; VertexOutComponent[grph, {i}, 1] == {i} :> ToString[i]];
(* to extract roots *)
rootsF = Function[{grph}, 
 Pick[VertexList[grph], (VertexInComponent[grph, {#}, 1] == {#}) & /@
  VertexList[grph]]];

and some pre-processing:

indices = First /@ outline;
fathers = fatherF[#, indices] & /@ indices;
edgelist = (Thread[fathers -> indices] /.
   Rule[a_, b_] :>
     Rule[Position[indices, First@a, 1], Position[indices, b, 1]] /. {} -> {{0}}) //
  Map[First@(Sequence @@ #) &, #, {2}] &
(* {0->1,1->2,1->3,1->4,0->5,5->6,5->7,7->8,7->9,7->10,7->11,5->12} *)
(* if needed remove the zero node to get a forest *)
edgelistb = edgelist /. Rule[0, _] :> Sequence[]

and a long "one"-liner:

({0} //. (i_Integer :> {ToString[i], Rest[chldrnListF[Graph@edgelist][[i + 1]]]}) /. 
   x_String :> ToExpression[x] // Part[#, 1, 2] &) /. i_Integer :> outline[[i]];
% == answer
(* True *)

outline as a tree or a forest:

labels = MapIndexed[First[#2] -> Placed[Rotate[ToString[#1], 15 Degree], Below] &,    outline];
{grph, grphb} = {Graph[edgelist, VertexLabels -> Prepend[labels, {"0"}],
    ImagePadding -> 50, ImageSize -> 600], 
 Graph[edgelistb, VertexLabels -> labels, ImagePadding -> 50, ImageSize -> 400]};
Panel@Row[{grph, grphb}, Spacer[10]]

Details of the steps:

grph = Graph[edgelist];
tmp = If[MemberQ[rootsF[grph], 0],
  rootsF[grph] //. (i_Integer :> {ToString[i], Rest[chldrnListF[grph][[i + 1]]]}),
  rootsF[ grph] //. (i_Integer :> {ToString[i], Rest[chldrnListF[grph][[i]]]})] /.
x_String :> ToExpression[x]
(* {{"0",{{"1",{"2","3","4"}},{"5",{"6",{"7",{"8","9","10","11"}},"12"}}}}}*)
(* post process to transform strings  back to integers and get the appropriate part*)
treeList = If[MemberQ[rootsF[grph], 0], Part[#, 1, 2], #] &[tmp]
(*{{1,{2,3,4}},{5,{6,{7,{8,9,10,11}},12}}} *)
(* map back to outline *)
tocTreeList = treeList /. i_Integer :> outline[[i]]
(* {{{{"1"},"Setup code"},
    {{{"1","1"},"Local variables"},
    {{"1","2"},"Option variables"},
    {{"1","3"},"Check for null Input"}}},
  {{{"2"},"Argument Logic"},
   {{{"2","1"},"X Spec"},
   {{{"2","2"},"One Dimensional Case"},
    {{{"2","2","1"},"Tick and Label Generation"},
     {{"2","2","2"},"plot generation"},
     {{"2","2","3"},"bin names generation"},
     {{"2","2","4"},"bar chart generation"}}},
  {{"2","3"},"Y Spec"}}}} *)
 answer == tocTreeList
 (* True *)

Answer 4

A concise GatherBy solution:

fn[x_, i_: 1] :=
  {#, fn[{##2}, i + 1]} /. {a_, {}} :> a & @@@
    GatherBy[x, #[[1, i]] &]

fn[in] === answer

True

Related:

• Create Nested List from tabular data