# How to delete certain lists from a nested list?

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!

• Is {-1,-2,-3,-4,-5} also to be removed? It has constant increment -1. Commented Jul 17, 2019 at 0:17
• yes, arbitrary constant increment. @kglr and @JJBK has already given some answers. These answers can be modified such as Select[test, (! Equal @@ #) && (! Equal @@ Differences[#]) &] or DeleteCases[_?(MatchQ[{((n_) ..)}]@*Differences)]@test Commented Jul 17, 2019 at 0:18

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

Pick[test, DeveloperToPackedArray[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}}

• wow, amazing! thank you so much Commented Jul 16, 2019 at 13:43
• Do you also how to apply 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? thank you very much! Commented Jul 16, 2019 at 16:29
• @XuemeiGu Use reference.wolfram.com/language/ref/FindRepeat.html as Select[test, Length@FindRepeat@# > 2 &] to remove all lists that are just 2 repeated elements. Commented Jul 16, 2019 at 22:44
• @XuemeiGu, please see the update.
– kglr
Commented Jul 16, 2019 at 22:53
• @lirtosiast, this is a very nice solution. I just find out that FindRepeat is new in mathematica 11.2. I didn't realize this function because of my old version. Thanks! Commented Jul 17, 2019 at 0:25
Select[test, (! Equal @@ #) && (! AllTrue[Differences[#], EqualTo[1]]) &]

• thank you very much! Your method is very quick compare to my for-loop way, thanks! Commented Jul 16, 2019 at 13:30

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

• Ah, the discrete Laplacian in disguise! Very neat. Commented Jul 17, 2019 at 0:30

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

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

Using GroupBy and Lookup:

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

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