# Strip waste braces in nested list

I have nested lists wherein there are a lot of waste levels which looks like

l = {{{{{{2, 2}}, 3}, 2, {{2, 33}}, 4, 5}}};


I would like to reduce it to somthing like

l = {{{2, 2}, 3}, 2, {2, 33}, 4, 5};


I made the function which remove waste levels on the top level:

l = {{{{{{2, 2}}, 3}, 2, {{2, 33}}, 4, 5}}};

strip = Function[{list},
If[(Head[list] === List) && (Length[list] > 0),
If[Flatten[list, 1] === list[[1]],
s = strip[list[[1]]],
s = list],
s = list];
s];
strip[l]


To do it at any depth I tried to do Map[strip[l]] without success. How I can to apply my function to all levels? Also, I guess there more appropriate way to solve my problem.

-
Strongly related – Leonid Shifrin Oct 11 '13 at 14:27

Update

Ok, since this became another shootout, here is my answer to the challenge:

lremoveFaster[lst_List]:= Replace[lst, {l_List} :> l, {0, Infinity}]


my benchmarks show that it is the fastest so far.

Initial solution

Here is a recursive version:

ClearAll[lremove];
lremove[{l_List}] := lremove[l];
lremove[l_List] := Map[lremove, l];
lremove[x_] := x;


So that

lremove[l]

(* {{{2, 2}, 3}, 2, {2, 33}, 4, 5} *)


"Theoretically", it should be more efficient than ReplaceRepeated for large lists, since the latter has to do many passes through expression. I don't have the time to benchmark right now, though.

Another difference is that lremove will be "stopped" by heads other than List, and not remove extra lists inside such heads. In contrast, ReplaceRepeated -based solution is greedy and will also work inside other heads. Which one is better depends on the goals.

-
Nice improvement. (I already voted, too). But, darn it, I considered Replace but thought it wouldn't handle {{{1}}} -- just do one replacement. Stupid me. Learned something new. Thanks for playing. – Michael E2 Oct 11 '13 at 13:37
@MichaelE2 Here you can find an explanation why Replace is more efficient in this case than ReplaceAll: how does mathematica determine which rule to use first in substitution. – Alexey Popkov Oct 11 '13 at 13:44
Thanks, @AlexeyPopkov, I was looking for some links like this one. But there were two more, one actually for a question asked by you, IIRC. Will try to find them. – Leonid Shifrin Oct 11 '13 at 13:46
@MichaelE2 Ok, this one is the one I was looking for, although there has to be yet another one that is relevant, if memory serves. – Leonid Shifrin Oct 11 '13 at 13:48
@MichaelE2 I also discussed this issue in my book, here. I don't have the time right now, but will add these links to my answer soon. – Leonid Shifrin Oct 11 '13 at 13:49

You can also use Position to find the locations of the nested braces and FlattenAt to flatten the list at those positions:

strip = Identity @ FlattenAt[#, Position[#, {_List}]] &

strip @ {{{{{{2, 2}}, 3}, 2, {{2, 33}}, 4, 5}}}
(* {{{2, 2}, 3}, 2, {2, 33}, 4, 5} *)

-
+1, very nice! This problem makes for a great small case study. – Leonid Shifrin Oct 11 '13 at 12:40
If we were playing code golf, I could beat you by three characters with strip = List @@ FlattenAt[#, Position[#, {_List}]] & :) – m_goldberg Oct 13 '13 at 10:01
@m_goldberg, if we were playing code golf I would have written it as +FlattenAt[#, #~Position~{_List}] & :-) – Simon Woods Oct 13 '13 at 15:40
@m_goldberg List @@ is not appropriate for the case in which the Head is not List. Such as strip@f[{{}}]. – luyuwuli Oct 17 '13 at 7:32
@luyuwuli. OP's question was specifically concerned withremoving "braces", so I don't think your quibble applies (pun intended :) – m_goldberg Oct 17 '13 at 10:02

Update

Here's faster way that avoid reprocessing:

deflate = Block[{flatten},
flatten[x_List] := x;
flatten[x___] := {x};
# /. List -> flatten
] &;


Original

In some cases you might be able to use Flatten. In this one, ReplaceRepeated can be use like this:

l = {{{{{{2, 2}}, 3}, 2, {{2, 33}}, 4, 5}}};

l //. {{x___}} :> {x}
(* {{{2, 2}, 3}, 2, {2, 33}, 4, 5} *)


This works, too

l //. {x_List} :> x


Comparison

Timings -- Big lists

We can create some data randomly nesting lists like this:

SeedRandom[1];
l0 = {Table[RandomInteger[{0, 3}], {5}]}
Nest[# /. i_?Positive :> RandomChoice[{0, 1, 0, 1, 3, 4}, i] &, l0, 3]

(* {{3, 1, 0, 1, 1}} *)
(* {{{0, 0, {{0, 3, 0}}}, {{{1}, {0, 0, 0}, 0}}, 0, {0}, {0}}} *)


Each positive number is replace recursively by a list of length equal to the number. We get excess braces every time the number 1 is replaced in a list {1}.

Here is a big list:

SeedRandom[1];
l0 = {Table[RandomInteger[{0, 3}], {5}]}
l2 = Nest[# /. i_?Positive :> RandomChoice[{0, 1, 0, 1, 3, 4}, i] &, l0, 38];

(* l2 // Flatten // Length *)
(* 537612 *)


It has over 95,000 extra braces:

Module[{cnt = 0},
f1 = l2 //. {x_List} :> (cnt++; x);
cnt
]
(* 95784 *)

f1 = l2 //. {x_List} :> x; // AbsoluteTiming
f2 = deflate[l2]; // AbsoluteTiming
f3 = lremove[l2]; // AbsoluteTiming
f4 = lremoveFaster[l2]; //AbsoluteTiming


{2.814402, Null}
{0.558850, Null}
{0.773060, Null}
{0.155110, Null}

f1 == f2 == f3 == f4


True

Timings -- Small lists

Here we'll use the OP's list and the site's favorite timeAvg function.

SetAttributes[timeAvg, HoldFirst]
timeAvg[func_] := Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

l //. {x_List} :> x; // timeAvg
deflate[l]; // timeAvg
lremove[l]; // timeAvg
lremoveFaster[l]; // timeAvg


9.2105*10^-6
0.0000167781
0.0000108307
6.2308*10^-6

One can see that ReplaceRepeated, while rather natural and short to code, takes rather a long time on big lists but is fastest on small ones. Leonid's lremoveFaster is fastest.

Actually, if I make flatten a global function instead of local to deflate, then the speed is comparable to ReplaceRepeated on short lists.

flatten[x_List] := x;
flatten[x___] := {x};
l /. List -> flatten // timeAvg


8.9970*10^-6

-
Very nice (I already voted), but see my update :) – Leonid Shifrin Oct 11 '13 at 12:57