# Deleting sublists from lists

I have a list consisting of symbols and integers. I would like to delete the integers from the list only if a symbol precedes and follows each integer:

testList={a,b,3,c,4,5,d,e,f,1,g,4}


becomes:

resultList={a,b,c,4,5,d,e,f,g,4}


This is really a basic question and I almost didn't post it for that reason.

testList//.{a__,_Integer,b__}:>{a,b}


gets rid of all the integers, not the desired result.

Try

testList //. {a___, aa_Symbol, _Integer, bb_Symbol, b___} :> {a, aa, bb, b}

{a, b, c, 4, 5, d, e, f, g, 4}

% == resultList

True


Note that I replaced __ (BlankSequence) with ___ (BlankNullSequence), so this will work for an integer which appears as the second element in the list.

• Yes, I needed the triple underscore. Thanks! Oct 7, 2017 at 5:45
• You have my vote but FYI there is a better way to approach this style of replacement; please see my complementary answer. Oct 7, 2017 at 9:10

ReplaceRepeated is fine for short lists but it will get very slow if the list is long, because it starts over from the beginning of the list after each replacement. A better approach is to start the next replacement after the point of the previous one. One implementation of that:

fn1 = # /.
{a___, aa_Symbol, _Integer, bb_Symbol, b___} :>
Join[{a, aa}, fn1 @ {bb, b}] &;


With jjc385's original as:

jjc = # //. {a___, aa_Symbol, _Integer, bb_Symbol, b___} :> {a, aa, bb, b} &;


Because my function is recursive I will need to raise $RecursionLimit for this benchmark. $RecursionLimit = 1*^4;
big = RandomChoice[{1, 2, a, b, c, d}, 10000];

AbsoluteTiming[r1 = jjc[big];]
AbsoluteTiming[r2 = fn1[big];]

r1 === r2

{60.2394, Null}

{0.328343, Null}

True


Another example of this method:

A different method that might be of interest is SequencePosition, though it proves to be slower than fn1:

fn2 =
Delete[#,
SequencePosition[big, {_Symbol, _Integer, _Symbol}][[All, {1}]] + 1] &;

AbsoluteTiming[r3 = fn2[big];]

r1 === r3

{1.35279, Null}

True


## Performance Race

jjc385 challenged back with a method an order of magnitude faster than my own fn1 proposal. In reply, for the sake of performance tuning I shall make an assumption: that the list is entirely composed of Symbol and Integer expressions.

fn3 =
Pick[
#,
Unitize @ Subtract[ListCorrelate[{4, 2, 1}, Boole[IntegerQ /@ #], 2, 1], 2],
1
] &;


Test:

big = RandomChoice[{1, 2, a, b, c, d}, 50000];

jjc2[big]; // RepeatedTiming
fn3[big];  // RepeatedTiming

fn3[big] === jjc2[big]

{0.112, Null}

{0.0153, Null}

True

• You inspired me to improve, and somehow I beat you by an order of magnitude! (See my new answer.) This is at least the second time you've suggested an improvement on one of my ReplaceRepeated answers, and I greatly appreciate the comments. Oct 7, 2017 at 11:14
• @Mr.Wizard Your second solution is excellent. Thanks for sharing. Oct 7, 2017 at 13:21

Mr.Wizard inspired me to improve. While his recursive approach is elegant, the problem clearly can be done linearly. Indeed:

jjc2 = (
Sow@First@#;
BlockMap[
If[ ! MatchQ[#, {_Symbol, _Integer, _Symbol}], Sow@#[[2]] ]; &,
#, 3, 1 ];
Sow@Last@big;
// Reap
// Last@*Last
) &

(r1=jjc2@big); // AbsoluteTiming


{0.102811, Null}

fn1 = # /.
{a___, aa_Symbol, _Integer, bb_Symbol, b___} :>
Join[{a, aa}, fn1 @ {bb, b}] &;

Block[{$RecursionLimit = 1*^4}, (r2=fn1@big);] // AbsoluteTiming  {1.26777, Null} r1 === r2  True  An order of magnitude? I'll take it! :) • Heh. Nicely done. If I have time I'll try to beat this. :-) Oct 7, 2017 at 11:39 • @Mr.Wizard I'm counting on it! Oct 7, 2017 at 11:40 • Posted as an addendum to my answer. Please have a look. Oct 7, 2017 at 12:21 The slowest part of @MrWizard's solution is the conversion to 1s and 0s. Here is a faster way to do this conversion: Boole[IntegerQ /@ big]; //RepeatedTiming Replace[big, {_Integer->1, _->0}, {1}]; //RepeatedTiming  {0.018, Null} {0.0051, Null} Here is a slightly different approach to converting the 0|1 list to the desired output: deleteSingletons[list_] := With[{boole = Replace[list, {_Integer->1, _->0}, {1}]}, Pick[list, Ramp @ ListCorrelate[{-1, 1, -1}, boole, 2, 1], 0] ]  And a speed comparison: r1 = fn3[big]; //RepeatedTiming r2 = deleteSingletons[big]; //RepeatedTiming r1 === r2  {0.020, Null} {0.0070, Null} True • Nice; I noticed that was the bottleneck in my code and intended to come back to it, but I see you already did. I wish there were optimized functions that returned a binary value rather than True and False since the latter cannot be packed. Oct 7, 2017 at 20:18 f0 = Flatten @ DeleteCases[{_Integer}] @ SplitBy[#, IntegerQ] &; f0 @ testList  {a, b, c, 4, 5, d, e, f, g} Timings between those of Mr.Wizard's fn3 and jjc385's jjc2: i=1; {#, First@RepeatedTiming[result[i++] = #2[big];]}&@@@ Transpose[{{"jjc2","f0", "fn3"}, {jjc2, f0, fn3}}] // Grid // TeXForm $\begin{array}{cc} \text{jjc2} & 0.027 \\ \text{f0} & 0.012 \\ \text{fn3} & 0.0045 \\ \end{array}\$

Equal @@ (result /@ {1, 2, 3})


True

• Fast, but simple enough to use in real life. Big +1 Oct 7, 2017 at 18:28
• Yeah, I wish I had been sharp enough to see this equivalent; it's very nice. Aside: I wish SplitBy had an operator form; I wonder why it does not. Oct 7, 2017 at 20:13
• Thank you @Mr.Wizard. Re operator form for SplitBy, my first attempt was actually Composition[Flatten, DeleteCases[{_Integer}], SplitBy[IntegerQ]]:)
– kglr
Oct 7, 2017 at 20:41

Another fast one:

fsw[x_] := Module[{r = Range@Length@x, i},
i = Pick[r, x, _Integer];
x[[Complement[r, Complement[i, i + 1, i - 1, r[[{1, -1}]]]]]]]

• This one really nails down... You should also add timings for comparison... Oct 7, 2017 at 20:08

Using a less drastic pattern tend to speed things up a bit, but not as much as jjc2

fn2 = Delete[#, Transpose[{Pick[Most[#], Differences[#], 2] + 1 &[
Position[#, _Symbol, Heads -> False][[All, 1]]]}]] &;
AbsoluteTiming[r2 = fn1[big];]
AbsoluteTiming[r3 = fn2[big];]
AbsoluteTiming[r4 = jjc2[big];]
r3 === r2 === r4


{1.0232561, Null}
{0.13014199, Null}
{0.085108557, Null}
True

Not a candidate in the speed category, but readable.

list = {a, b, 3, c, 4, 5, d, e, f, 1, g, 4};
SequenceReplace[list, {a_Symbol, n_Integer, b_Symbol} :>
Sequence @@ {a, b}]


{a, b, c, 4, 5, d, e, f, g, 4}

list = {a, b, 3, c, 4, 5, d, e, f, 1, g, 4};

Delete[
list,
Cases[
Partition[MapIndexed[{##} &] @ list, 3, 1],
{{_Symbol, _}, {_Integer, x_}, {_Symbol, _}} :> x]]


{a, b, c, 4, 5, d, e, f, g, 4}

Using SequenceCases and DeleteElements:

lst = {a, b, 3, c, 4, 5, d, e, f, 1, g, 4};
res = {a, b, c, 4, 5, d, e, f, g, 4};
DeleteElements[lst, SequenceCases[lst, {a_Symbol, b_Integer, c__Symbol} :> b]] === res

(*True*)