Deleting sublists from lists

Question

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.

Answer 1

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.

Answer 2

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:

• Replace "," in a list with "."

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

Answer 3

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}

Mr.Wizard's faster answer:

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! :)

Answer 4

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

Answer 5

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

Answer 6

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}]]]]]]]

Answer 7

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

Answer 8

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}

Answer 9

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}

Answer 10

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

Answer 11

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

Using SequenceSplit (new in 11.3)

Flatten @ SequenceSplit[list, {a_Symbol, _Integer, b_Symbol} :> {a, b}]

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