Deleting Lonely Numbers From a List

Question

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.

Answer 1

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

Answer 2

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.

Answer 3

Another way of doing it with a centered MovingMap :

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

Answer 4

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.

Answer 5

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

should work, I reckon.

Answer 6

Just another variant:

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

Answer 7

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}