How to remove redundant {} from a nested list of lists?

Question

There are numerous examples here, whose end result is the removal of empty brackets {} and empty lists. I still can't find an example of simply removing redundant brackets though.

It's hard for me to believe there isn't already a common solution to this problem. Please point me there if I missed it. As I am new to Mathematica I am learning primarily by example so when I ran into this problem I was at a loss of where to even start.

For example I have this list as INPUT to a new function:

{
{{{0, 5}, {1, 4}, {2, 3}, {3, 2}, {4, 1}, {5, 0}}},
{{{1, 5}, {2, 4}, {3, 3}, {4, 2}, {5, 1}}},
{{{2, 5}, {3, 4}, {4, 3}, {5, 2}}},
{{{3, 5}, {4, 4}, {5, 3}}},
{{{4, 5}, {5, 4}}},
{{{5, 5}}, {{5, 5}}}
}

I would like the new function to generate this list as OUTPUT:

{
{{0, 5}, {1, 4}, {2, 3}, {3, 2}, {4, 1}, {5, 0}},
{{1, 5}, {2, 4}, {3, 3}, {4, 2}, {5, 1}},
{{2, 5}, {3, 4}, {4, 3}, {5, 2}},
{{3, 5}, {4, 4}, {5, 3}},
{{4, 5}, {5, 4}},
{{5, 5}, {5, 5}}
}

---

The actual input TO new function:

{{{{0, 5}, {1, 4}, {2, 3}, {3, 2}, {4, 1}, {5, 0}}}, {{{1, 5}, {2, 4}, {3, 3}, {4, 2}, {5, 1}}}, {{{2, 5}, {3, 4}, {4, 3}, {5, 2}}}, {{{3, 5}, {4, 4}, {5, 3}}}, {{{4, 5}, {5, 4}}}, {{{5, 5}}, {{5, 5}}}}

The actual output FROM new function:

{{{0, 5}, {1, 4}, {2, 3}, {3, 2}, {4, 1}, {5, 0}}, {{1, 5}, {2, 4}, {3, 3}, {4, 2}, {5, 1}}, {{2, 5}, {3, 4}, {4, 3}, {5, 2}}, {{3, 5}, {4, 4}, {5, 3}}, {{4, 5}, {5, 4}}, {{5, 5}, {5, 5}}}

Answer 1

Starting with:

a = {{{{0, 5}, {1, 4}, {2, 3}, {3, 2}, {4, 1}, {5, 0}}}, {{{1, 5}, {2, 4}, {3, 3}, {4, 
      2}, {5, 1}}}, {{{2, 5}, {3, 4}, {4, 3}, {5, 2}}}, {{{3, 5}, {4, 4}, {5, 3}}}, {{{4, 
      5}, {5, 4}}}, {{{5, 5}}, {{5, 5}}}};

This is probably the simplest:

a //. {x_List} :> x

---

A single-pass method

Though using ReplaceRepeated is pleasingly concise it is not efficient with deeply nested lists. Because ReplaceAll and ReplaceRepeated scan from the top level the expression will have to be scanned multiple times.

Instead we should use Replace which scans expressions from the bottom up. This means that subexpressions such as {{{{6}}}} will have redundant heads sequentially stripped without rescanning the entire expression from the top. We can start scanning at levelspec -3 because {{}} has a Depth of 3; this further reduces scanning.

expr = {{1, 2}, {{3}}, {{{4, 5}}}, {{{{6}}}}};

Replace[expr, {x_List} :> x, {0, -3}]

{{1, 2}, {3}, {4, 5}, {6}}

Here I will use FixedPointList in place of ReplaceRepeated to count the number of times the expression is scanned in the original method:

Rest @ FixedPointList[# /. {x_List} :> x &, expr] // Column

{{1,2},{3},{{4,5}},{{{6}}}}
{{1,2},{3},{4,5},{{6}}}
{{1,2},{3},{4,5},{6}}
{{1,2},{3},{4,5},{6}}

We see that the expression was scanned four times, corresponding to the three levels that were stripped from {{{{6}}}} plus an additional scan where nothing is changed, which is how both FixedPointList and ReplaceRepeated terminate. To see the full extent of this scanning try:

expr //. {_?Print -> 0, {x_List} :> x};

Or to merely count the total number of matches attempted:

Reap[expr //. {_?Sow -> 0, {x_List} :> x}][[2, 1]] // Length

50

We see that only 7 expressions in total are scanned with the single-pass method:

Reap[
  Replace[expr, {_?Sow -> 0, {x_List} :> x}, {0, -3}]
][[2, 1]] // Length

7

Timings

Let us compare the performance of these two methods on a highly nested expression.

fns = {Append[#, RandomInteger[9]] &, Prepend[#, RandomInteger[9]] &, {#} &};

SeedRandom[1]
big = Nest[RandomChoice[fns][#] & /@ # &, {{1}}, 10000];
Depth[big]

3264

big //. {x_List} :> x                           // Timing // First
Replace[big, {x_List} :> x, {0, -3}] ~Do~ {800} // Timing // First

0.452

0.468

On this huge expression the single-pass Replace is about 800 times faster than //..

Answer 2

NOTE: merged from a later duplicate question

---

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.

Answer 3

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} *)

Answer 4

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