How to delete certain lists from a nested list?

Question

I have a nested list as the following example (want to remove lists with same or incremented elements such as {1,2,3,4,5}, {2,2,2,2,2}, {1,1,1,1,1}):

test={{1,2,3,4,5}, {1,1,1,1,1}, {2,4,6,8,10}, {2,2,2,2,2}, {3,5,2,4,8}};
test1=DeleteCases[test,{1,2,3,4,5}];
test1=DeleteCases[test1,{1,1,1,1,1}];
test1=DeleteCases[test1,{2,2,2,2,2}];

So the result is test1={{3,5,2,4,8}}(here I also delete the case {2,4,6,8,10} due to the equal increaments).

With the above way I can get the list which removes the list that elements are the same or incremented.

The problem is when the test is very large and I don't know what exactly elements are, how can I efficiently remove the lists where elements are the same or incremented? Is there a clever way to do this?

Thanks for all the help in advance!

Answer 1

Select[Not @* Apply[Equal] @* Differences ] @ test

Pick[test, Developer`ToPackedArray[Unitize@Total[Abs @ Differences[#, 2]]& /@ test], 1]

Select[Not @* MatchQ[{(a_) ..}] @* Differences] @ test

Cases[_?(Not @* MatchQ[{(a_) ..}] @* Differences)] @ test

DeleteCases[_?(MatchQ[{(a_) ..}] @* Differences)] @ test

all give

{{3, 5, 2, 4, 8}}

Update: Adding a pattern "to remove the cases like {1, 0, 1, 0, 1, 0, 1, 0, 1, 0}, {1, 3, 1, 3, 1, 3, 1, 3, 1,3}, where elements repeated in even and odd positions"

test2 = {{1, 2, 3, 4, 5}, {1, 1, 1, 1, 1}, {2, 4, 6, 8, 10}, {2, 2, 2, 2, 2}, 
  {3, 5, 2, 4, 8}, {1, 0, 1, 0, 1, 0, 1, 0, 1, 0}, {1, 3, 1, 3, 1, 3, 1, 3, 1, 3} };

Select[Not @* MatchQ[{(a_) ..| 
   PatternSequence[(PatternSequence[a_, b_]/; a==-b)..,a_]}] @* Differences] @ 
 test2

{{3, 5, 2, 4, 8}}

Alternatively,

Fold[Select[Not @* #2] @ # &, 
 test2,
 {Apply[Equal] @* Differences,  MatchQ[{PatternSequence[a_, b_  ]..}]}]

{{3, 5, 2, 4, 8}}

Answer 2

Select[test, (! Equal @@ #) && (! AllTrue[Differences[#], EqualTo[1]]) &]

Answer 3

You say you're interested in working with large lists. In that case it is better to avoid Select. Here is an alternate function using Dot and Pick:

removeProgressions[list_?MatrixQ]:=Module[{len=Dimensions[list][[2]]},
    Pick[list, Unitize @ Total[Abs[list . Partition[{1,-2,1}, len-2, 1, {-1, 1}, 0]], {2}], 1]
]

Timing comparison:

SeedRandom[1]
list = RandomInteger[10, {10^6, 5}];
r1 = removeProgressions[list]; //AbsoluteTiming
r2 = Select[Not @* MatchQ[{(a_)..}] @* Differences] @ list; //AbsoluteTiming

r1===r2

{0.138829, Null}

{1.98615, Null}

True

Answer 4

I think the OP wanted to remove sub-lists that used any constant increment, be it 0, 1, or some larger integer. The expression

Select[test, Length@Intersection@Differences[#] > 1 &]

removes all sub-lists with a constant increment (including in the example, those with increments of 0, 1, and 2).

Answer 5

Using GroupBy and Lookup:

Lookup[GroupBy[test, Length@Intersection@Differences[#] > 1 &], True]

(*{{3, 5, 2, 4, 8}}*)

Answer 6

test = {{1, 2, 3, 4, 5}, {1, 1, 1, 1, 1}, {2, 4, 6, 8, 10}, {2, 2, 2, 
    2, 2}, {3, 5, 2, 4, 8}, {-1, -2, -3, -4, -5}};

Select[test, !AllTrue[# == 0 &][Differences@Differences@#] &]

{{3, 5, 2, 4, 8}}