6
$\begingroup$

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!

$\endgroup$
  • $\begingroup$ Is {-1,-2,-3,-4,-5} also to be removed? It has constant increment -1. $\endgroup$ – Henrik Schumacher Jul 17 at 0:17
  • $\begingroup$ 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 $\endgroup$ – Xuemei Gu Jul 17 at 0:18
6
$\begingroup$
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}}

$\endgroup$
  • $\begingroup$ wow, amazing! thank you so much $\endgroup$ – Xuemei Gu Jul 16 at 13:43
  • $\begingroup$ 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! $\endgroup$ – Xuemei Gu Jul 16 at 16:29
  • 1
    $\begingroup$ @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. $\endgroup$ – lirtosiast Jul 16 at 22:44
  • $\begingroup$ @XuemeiGu, please see the update. $\endgroup$ – kglr Jul 16 at 22:53
  • $\begingroup$ @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! $\endgroup$ – Xuemei Gu Jul 17 at 0:25
5
$\begingroup$
Select[test, (! Equal @@ #) && (! AllTrue[Differences[#], EqualTo[1]]) &]
$\endgroup$
  • $\begingroup$ thank you very much! Your method is very quick compare to my for-loop way, thanks! $\endgroup$ – Xuemei Gu Jul 16 at 13:30
2
$\begingroup$

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

$\endgroup$
2
$\begingroup$

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

$\endgroup$
  • $\begingroup$ Ah, the discrete Laplacian in disguise! Very neat. $\endgroup$ – Henrik Schumacher Jul 17 at 0:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.