TransWikia.com

Join sublists on condition

Mathematica Asked by István Zachar on February 27, 2021

I have a nested list of integers and want to join any sublist matching a condition to its left neighbouring sublist, iteratively. Conveniently, the joining condition is whether the length of the list is 1 or less. My naive attempt:

ClearAll[joinLeft];
joinLeft[list : {__List}, n_Integer : 1] := 
  Fold[FlattenAt[
     If[Length@#2 <= n, {Most@#1, Join[Last@#1, #2]}, {#1, #2}], 
     1] &, {First@list}, Rest@list];

In[1]:= joinLeft[{{}, {1, 2, 3}, {4}, {5, 6}, {7}, {}}, 1]

Out[1]= {{}, {1, 2, 3, 4}, {5, 6, 7}}

It can be easily converted to join-to-right.

I have the feeling that this functionality exists in Mathematica, but could not figure it out. Can this be made faster and/or more elegant? How to extend it to multiple levels of nesting (starting joining-to-the-left from the inside)?

2 Answers

@DanielHuber's comment turned out to be the most general and fast for nested lists, with some modifications:

(* helper to join singletons/nonlists to nearest list *)
join[a_List, b_List] := Join[a, b];
join[a_List, b_] := Join[a, {b}];
join[a_, b_List] := Join[{a}, b];

list = {{0, {1, 2}, {3}, 4, {5, 6}, {7}}, {8}, {{1}, {2}}, 3, {{4, 5, 6}}, {{7}}};

ReplaceRepeated[list,
   {a___, b_List, c : (_List?(Length@# <= n &) | Except[_List]), d___} :>
   {a, join[b, c], d}]

Output is:

{{0, {1, 2, 3, 4}, {5, 6, 7, 8}}, {{1, 2, 3}, {4, 5, 6, 7}}}

Even more easier to convert to join-to-right:

ReplaceRepeated[list,
   {a___, b : (_List?(Length@# <= n &) | Except[_List]), c_List, d___} :>
   {a, join[b, c], d}]

{{{0, 1, 2}, {3, 4, 5, 6}, {7}}, {{8, 1}, {2}}, {{3, 4, 5, 6}, {7}}}

Note, that short lists and singletons are not joined with a sublist of higher level, only with sublist of a deeper level.

Correct answer by István Zachar on February 27, 2021

lst = {{}, {1, 2, 3}, {4}, {5, 6}, {7}, {}};

We can use SequenceReplace:

ClearAll[appendLeft1, appendRight1]

appendLeft1[l_, n_: 1] := SequenceReplace[{a_, b__} /;
  (And @@ Thread[Length /@ {b} <= n]) :> Join[a, b]] @ l

appendLeft1 @ lst
{{}, {1, 2, 3, 4}, {5, 6, 7}}
appendRight1[l_, n_: 1] :=  SequenceReplace[{a__, b_} /; 
   (And @@ Thread[Length /@ {a} <= n]) :> Join[a, b]] @ l

appendRight1 @ lst
{{1, 2, 3}, {4, 5, 6}, {7}}

We can also use Split + FixedPoint:

ClearAll[appendLeft2, appendRight2]

appendLeft2 = FixedPoint[Flatten /@ Split[#, Length[#2] <= 1 &] &, #] &;

appendLeft2 @ lst
 {{}, {1, 2, 3, 4}, {5, 6, 7}}
appendRight2 = FixedPoint[Flatten /@ Split[#, Length[#] <= 1 &] &, #] &;

appendRight2 @ lst
 {{1, 2, 3}, {4, 5, 6}, {7}}

Answered by kglr on February 27, 2021

Add your own answers!

Ask a Question

Get help from others!

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP