# Deleting Lonely Numbers From a List

Suppose I have a list of integers like so:

list = {1,2,5,6,8,10,11,12,14,16,17,18,19};


I'd like a function that will take this list and return a new list with the numbers that are "lonely" being removed, with lonely numbers being those that have no neighbor to their left or their right, where a neighbor is a number whose difference to the next/previous number in the list is equal to 1. In the example given above this would be the numbers "8" and "14", which have no neighbors, so the list returned would be {1,2,5,6,10,11,12,16,17,18,19}.

Currently I have an ugly Do loop for this operation, but there must be a better way! We can presume the list is already sorted since it's trivial to add a Sort.

• "no neighbor to their left or their right" - that is, their difference from the numbers before or after them is greater than 1, yes? May 28, 2015 at 23:49
• Correct, editing to clarify. May 28, 2015 at 23:49
• Maybe a PatternSequence[]? That should be usable for checking neighbors… May 29, 2015 at 0:06

list = {1, 2, 5, 6, 8, 10, 11, 12, 14, 16, 17, 18, 19};

With[{nf = Nearest[#], l = #},
Pick[l, EuclideanDistance @@@ Transpose[{l, nf[#, 2][[2]] & /@ l}],1]] &@list

(* {1, 2, 5, 6, 10, 11, 12, 16, 17, 18, 19} *)


For larger lists, this should be pretty snappy:

Pick[#, Min /@
Transpose@Differences[{Most@Prepend[#, #[[1]] - 2], #,
Rest@Append[#, #[[-1]] + 2]}], 1 | 0] &@list


Lastly, assuming your OP list is an exemplar (sorted and unique elements), this is very fast:

With[{p = Join[#[[{1}]] - 2, #, #[[{-1}]] + 2]},
Union[Pick[#, Subtract[#, p[[;; -3]]], 1], Pick[#, Subtract[p[[3 ;;]], #], 1]]] &


Another way of doing it with a centered MovingMap :

DeleteCases[MovingMap[If[MemberQ[Abs@Differences@#, 1], #[[2]]] &,
list, {3, Center}, 2], Null]

notLonelyQ[{a_, b_, c_}] := If[b - a == 1 || c - b == 1, True, False]
removeLonely[list_] := Pick[
list,
notLonelyQ /@ Partition[list, 3, 1, {2, 2}]
]


Example:

removeLonely[list]
(* Out: {1, 2, 5, 6, 10, 11, 12, 16, 17, 18, 19} *)


It treats the list as if it were cyclical, so it compares the last element with the first and the first element with the last. But since the list is sorted this should not be a problem. "Code-golfed"/more compact version:

Pick[list, If[#2 - #1 == 1 || #3 - #2 == 1, True, False] & @@@ Partition[list, 3, 1, 2]]


This is faster than the more verbose version, because it is known that anonymous functions are faster than pre-defined if they are otherwise equivalent.

• For golfing purposes: Max[#2 - #1, #3 - #2] == 1 &. May 29, 2015 at 1:29

Another approach using Split:

removeLonely[list_, tol_: 1] :=
Join @@ DeleteCases[Split[Sort[list], Abs[#2 - #1] <= tol &], {_}];


I also included a tolerance parameter that defaults to 1. You can take out Sort if you are sure your list is already sorted.

Pick[list, Composition[# === {1} &, DeleteDuplicates, Differences] /@ Partition[list, 3, 1, 2]]


should work, I reckon.

Just another variant:

fun[lst_] := With[{p = Partition[{0}~Join~lst~Join~{0}, 3, 1]},
Pick[lst, FreeQ[Differences@#, 1 | -1] & /@ p, False]]

list = {1, 2, 5, 6, 8, 10, 11, 12, 14, 16, 17, 18, 19};


Using SequenceCases (new in 10.1)

If the list doesn't contain duplicates we can use

Union @ Flatten @ SequenceCases[list, {a_, b_} /; b - a == 1, Overlaps -> True]


{1, 2, 5, 6, 10, 11, 12, 16, 17, 18, 19}

Using pattern matching i.e. a combination of ReplaceRepeated(//.), Condition(/;) and RuleDelayed(:>)

list = {1, 2, 5, 6, 8, 10, 11, 12, 14, 16, 17, 18, 19};
list //. {prev___, a_, x_, b_, next___} /; (x-a!=1 && b-x!=1) :> {prev, a, b, next}


Another alternative using Split:

list = {1, 2, 5, 6, 8, 10, 11, 12, 14, 16, 17, 18, 19};

Flatten@*Cases[{_, __}]@Split[list, #2 - #1 == 1 &]

(*{1, 2, 5, 6, 10, 11, 12, 16, 17, 18, 19}*)


Or by defining a ConsecutiveQ function and using SequenceSplit:

ConsecutiveQ[list_] := AllTrue[Differences[list], # == 1 &]

Flatten@*Cases[{_, __}]@SequenceSplit[list, s : {__} /; ConsecutiveQ[s] :> s]

(*{1, 2, 5, 6, 10, 11, 12, 16, 17, 18, 19}*)