# Grouping consecutive elements at specified positions

Let

L1={1,2,4,6,8,9,10,14,15,17,21,22,72,76,80,96,106,116,117}


Question1) Group from 10-th to 14-th elements in L1.

So that the output becomes

L2={1,2,4,6,8,9,10,14,15,{17,21,22,72,76},80,96,106,116,117}


A possible solution is

{Splice[L1[[;; 10 - 1]]], L1[[10 ;; 14]], Splice[L1[[14 + 1 ;;]]]}


But I believe there is a faster solution, maybe built-in command, because such operation (grouping consecutive elements at a specified position) feels so essential, and my solution has somewhat redundant side.

Also I want to deal with case of multiple positions :

Question 2) Group from 5-th to 7-th and from 10-th to 14-th and 16th to lists in L.

So that the output becomes

{1,2,4,6,{8,9,10},14,15,{17,21,22,72,76},80,{96},106,116,117}


Is there a fast method to achieve it?

The source list can be large and there may be numerous positions to work with, but it is guaranteed that each position is consecutive, and those positions do not overlap each other.

+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-

I posted performances of various answers. Thank you all posters!

• You should submit this as a resource function, when you perfect it. A good question indeed.
– Syed
Mar 14, 2022 at 17:10
• Thank you! I am going to test the performances of answers! Mar 14, 2022 at 22:19
– Syed
Mar 15, 2022 at 11:23

ClearAll[group] ;
group[list_List, start_List, end_List] := Block[
{copy},
copy = list ;
copy[[start]] = Map[Take[list, #] &, Transpose[{start, end}]] ;
copy[[Flatten[Map[Apply[Range], Transpose[{start + 1, end}]]]]] = Nothing ;
copy
] ;

L2 == group[L1, {10}, {14}]
L3 == group[L1, {5, 10, 16}, {7, 14, 16}]

(* True *)
(* True *)

• Very nice! (+1) Mar 15, 2022 at 12:01
• Good work !!! (+1)
– Syed
Mar 15, 2022 at 12:19

TakeDrop might be interesting to you:

TakeDrop[L1, {10, 14}]
(*gives {{17, 21, 22, 72, 76}, {1, 2, 4, 6, 8, 9, 10, 14, 15, 80, 96, 106, 116, 117}}*)


From there you can use Insert:

Insert[#2, #1, 10] & @@ TakeDrop[L1, {10, 14}]
(*gives result for question 1*)


This gets awkward with multiple grouping specs.

Another approach would be to insert markers and then use SequenceReplace:

markedL1 = Insert[L1, Mark, {{5}, {8}, {10}, {15}, {16}, {17}}]
SequenceReplace[markedL1, {Mark, group : Except[Mark] ..., Mark} :> {group}]
(*gives result for question 2*)


Here's another similar approach:

taggedL1 = SubsetMap[f, L1, Join[Range[10, 14], Range[5, 7], Range[16, 16]]];
SequenceReplace[taggedL1, g : {__f} :> First /@ g]


You can see how you'd construct the Join[...] expression from your desired ranges.

Anyway, I fiddled with several ways to do this, but I didn't find a built-in command.

2nd attempt

L1 = {1, 2, 4, 6, 8, 9, 10, 14, 15, 17, 21, 22, 72, 76, 80, 96, 106,
116, 117}


Here I specify ranges (not in order but non-overlapping)

pos = List /@ # & /@ {Range[10, 14], Range[5, 7] , Range[16, 16]}


and I insert { } at these positions so the counting is not messed up.

alist = ReplacePart[L1, # -> {} & /@ pos]

{1, 2, 4, 6, {}, {}, {}, 14, 15, {}, {}, {}, {}, {}, 80, {}, 106, \
116, 117}

items = Extract[L1, #] & /@ pos

{{17, 21, 22, 72, 76}, {8, 9, 10}, {96}}

posx = pos[[All, 1]]

{{10}, {5}, {16}}

ReplacePart[alist,
posx[[#]] -> items[[#]] & /@ Range[1, Length@items]] /. {} ->
Nothing

{1, 2, 4, 6, {8, 9, 10}, 14, 15, {17, 21, 22, 72,
76}, 80, {96}, 106, 116, 117}


Original incorrect attempt

Doing only 1 replacement of the sequence even if multiple such sequences are present:

SequenceReplace[L1, L1[[10 ;; 14]] :> L1[[10 ;; 14]], 1]

{1, 2, 4, 6, 8, 9, 10, 14, 15, {17, 21, 22, 72,
76}, 80, 96, 106, 116, 117}


Case of multiple sequence replacement:

SequenceReplace[L1, {
L1[[5 ;; 7]] :> L1[[5 ;; 7]]
, L1[[10 ;; 14]] :> L1[[10 ;; 14]]
, L1[[16 ;; 16]] :> L1[[16 ;; 16]]
}
]

{1, 2, 4, 6, {8, 9, 10}, 14, 15, {17, 21, 22, 72,
76}, 80, {96}, 106, 116, 117}

• Thank you, but I think this solution does not work for list like L1 = {1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1}. And I also bet the performance is not so good because the solution search some patterns. Mar 14, 2022 at 10:01
• You are right. I will delete the answer for now and try to come up with something better.
– Syed
Mar 14, 2022 at 10:05

You may use FoldPairList with TakeList.

subGroups takes the list and the start and end indices of each group.

subGroups[list_, groupPos_] :=
Module[
{sg}
, sg =
Flatten@
FoldPairList[
{
{First@#2 - #1 - 1, Subtract @@ Reverse@#2 + 1}
, Last@#2
} &
, 0
, Sort@groupPos
]
; sg = TakeList[list, Flatten@{sg, Length@list - Total@sg}]
; MapAt[Apply[Sequence], sg, List /@ Range[1, Length@sg, 2]]
]


With L1 in OP

subGroups[L1, {{10, 14}}]

{1, 2, 4, 6, 8, 9, 10, 14, 15, {17, 21, 22, 72, 76}, 80, 96, 106, 116, 117}


and

subGroups[L1, {{5, 7}, {10, 14}, {16, 16}}]

{1, 2, 4, 6, {8, 9, 10}, 14, 15, {17, 21, 22, 72, 76}, 80, {96}, 106, 116, 117}


Hope this helps.

I try to write a function to obtain list fractured with another list of points of fracture...

        Clear["Global*"]
miLista[lista_List, filtro_List] :=
Module[{final = {}, i, j, k, provisional = {}},
(* if max{filtro] > Length[lista] error  SALIR *)
If[Max[filtro] > Length[lista],
Print["filtro has elemnts bigger than length of lista"];
Return[49404390548]];
(* si filtro no está ordenado  error  SALIR *)
If[! OrderedQ[filtro],
Print["filtro must be sorted"];
Return[49404390548]];
For[i = 1, i <= Length[filtro], i++,
If[i == 1, (* solo los primeros elementos de lista *)
For[j = 1, j < filtro[[i]], j++,
AppendTo[final, lista[[j]]]];
k = j,
If[EvenQ[i],
{provisional = {};
For[j = k, j <= filtro[[i]], j++,
provisional = AppendTo[provisional, lista[[j]]]];
AppendTo[final, provisional];
k = j;
},
{For[j = k, j < filtro[[i]], j++,
AppendTo[final, lista[[j]]]];
k = j;
}
]
]
];
For[j = k, j <= Length[lista], j++,             (*
el resto de los elementos de lista *)
AppendTo[final, lista[[j]]]];
Return[final];
]


tested it with

 miLista[Range[36], {3, 11, 16, 18, 21, 21, 29, 33}]


and gave

{1,2,{3,4,5,6,7,8,9,10,11},12,13,14,15,{16,17,18},19,20,{21},22,23,24,25,26,27,28,{29,30,31,32,33},34,35,36}

-1> Today (2022.3.19) I was able to find even faster and intuitive way to achieve it. Thanks for Edmund's introduction of TakeList command. The prerequisite for L and P are similar to 0>.

L = Range[3300000]; P = Partition[Prime[Range[220000]], 2];

imdaK2[L_, P_] :=
Module[{Q, P2}, Q = Join @@ P; P2 = 2 Range[Length[P]] - 1;
Q[[P2]] += -1;
Q2 = TakeList[L, Differences[Append[Prepend[Q, 0], Length[L]]]];
ReplacePart[
Q2, {#, 0} & /@ (Append[P2, 2 Length[P] + 1]) -> Sequence]]

imdaK2[L, P]; // Timing

{0.359375, Null}


0> This is a variation of I.M. A little faster then I.M.'s method.
Here, X is a list and P must be a ordered set of ordered pair of positive integers, which looks like
{{p1,p2},{p3,p4},{p5,p6},...,{p(2k-1),p(2k)}} should satisfy
p1<=p2 < p3<=p4 < p5<=p6<,... and p(2k) <= Length[X].

imdaK[X_, P_] := Module[{tran, accu, Q, Y}, tran = Transpose[P];
accu = Accumulate[tran[[1]] - Join[{0}, Drop[tran[[2]], -1]]];
Q = Range @@@ P;
Y = X;
Y[[accu]] = (X[[#]] & /@ (Q));
Y[[Complement[Range[accu[[-1]] - P[[-1, 2]] + Length[X]], accu]]] =
X[[Complement[Range[Length[X]], Join @@ Q]]];
Y]


1> Anxon Pués's solution for Range[30000] and Prime[Range[3000]] took 0.78 seconds. But practically not applicable for Range[3300000] and Prime[Range[220000]]

2> Syed's solution code is like

Syed[L1_, px_] := Module[{pxran, pos, alist, items, posx},
pxran = Range @@@ px;
pos = List /@ # & /@ px;
alist = ReplacePart[L1, # -> {} & /@ pos];
items = Extract[L1, #] & /@ pos;
posx = pos[[All, 1]];
ReplacePart[alist,
posx[[#]] -> items[[#]] & /@ Range[1, Length@items]] /. {} ->
Nothing]


for Range[3300000] and Prime[Range[220000]] it took 1.96 seconds :

3> lericr's first method took 1.76 seconds for Range[1000] and Prime[Range[160]]. Practically not applicable for Range[3300000] and Prime[Range[220000]]

markedL1 =
Insert[Range[1000], Mark,
Splice[{{Prime[2 # - 1]}, {Prime[2 #] + 1}}] & /@ Range[80]];
SequenceReplace[
markedL1, {Mark, group : Except[Mark] ...,
Mark} :> {group}]; // Timing


4> lericr's second method took 6.73 seconds for Range[1000] and Prime[Range[80]]. We see not practical for large list. Not very important but note that we should make f Listable to make the code work properly.

lericr2[L1_, px_] := Module[{taggedL1, tempf, tempg},
taggedL1 =
SubsetMap[Function[x, tempf[x], Listable], L1,
Join @@ (Range @@@ px)];
SequenceReplace[taggedL1, tempg : {__tempf} :> First /@ tempg]]

lericr2[Range[1000], Partition[Prime[Range[160]], 2]]; // Timing


5> I.M. 's method : For Range[3300000] and Prime[Range[220000]], it took 1.06 seconds.

ClearAll[group];
group[list_List,start_List,end_List]:=Block[{copy},copy=list;
copy[[start]]=Map[Take[list,#]&,Transpose[{start,end}]];
copy[[Flatten[Map[Apply[Range],Transpose[{start+1,end}]]]]]=Nothing;
copy];
group[Range[3300000],Prime[2Range[110000]-1],Prime[2Range[110000]]];//Timing


6> Edmund's method took 1.31 seconds for Range[300000] and Prime[Range[25000]], but didn't work for larger case, Range[3300000] and Prime[Range[220000]].

subGroups[list_, groupPos_] := Module[{sg}, sg = Flatten@FoldPairList[
{{First@#2 - #1 - 1, Subtract @@ Reverse@#2 + 1}, Last@#2} &, 0,
Sort@groupPos];
sg = TakeList[list, Flatten@{sg, Length@list - Total@sg}];
MapAt[Apply[Sequence], sg, List /@ Range[1, Length@sg, 2]]];
subGroups[Range[300000], Partition[Prime[Range[25000]], 2]]; // Timing
`