# Number of sign flips in list?

Given a list of signs:

list={1,1,-1,1,-1,-1,1,1,1,-1};


how to most conveniently and quickly determine the number of sign flips in the sequence?

flipNum[l_]:=Block[{num},
num=0;
Do[If[0>l[[i]]l[[i+1]],num=num+1;];,{i,1,Length[l]-1}];
If[0>l[[1]]l[[-1]],num=num+1;];
num
]


But I suspect there could exist a much quicker and more elegant solution in mathematica?

EDIT:

While it is true that the above code is very slow (takes 20 seconds in the benchmarks in the answers below), one can easily compile it:

flipNum = Compile[{{l, _Integer, 1}}, Block[{num}, num = 0;
Do[If[0 > l[[i]] l[[i + 1]], num = num + 1;];, {i, 1, Length[l] - 1}];
If[0 > l[[1]] l[[-1]], num = num + 1;];
num], CompilationTarget -> "C"]


With this the performance becomes:

SeedRandom[1234]
list = RandomChoice[{-1, 1}, 10000000];
AbsoluteTiming[flipNum[list]]


{0.282849, 5000678}

which makes it actually the most efficient solution without packaging the data.

If we do package the data:

SeedRandom[1234]
list = RandomChoice[DeveloperToPackedArray@{-1, 1}, 10^7];
AbsoluteTiming[flipNum[list]]


{0.224196, 5000678}

it gets a bit quicker, but loses in terms of performance to the "bitxor" and "subtract" solutions.

• At least somewhat related: (9637), (10640), (31771) Feb 16, 2018 at 7:44

If your list doesn't contain 0 you can do

list = {1,1,-1,1,-1,-1,1,1,1,-1};

Total[Abs[Differences[Sign[list]]]]/2 + Boole[Sign[First[list]] != Sign[Last[list]]]

6


Accounting for the cyclic sign flip this way isn't as elegant, but in kglr's test it's much faster than using Append[list, First[list]].

• Note that my flipNum[list] returns 6, since the sign flip between first and last list element also counts. Feb 14, 2018 at 21:29
• Add Abs[Sign[list[[1]]] - Sign[list[[-1]]]]/2 to the result to account for cyclic sign flips between first and last list elements. Feb 14, 2018 at 22:49
• @Kagaratsch Ah, I didn't realize that was a requirement. See me edit. Feb 15, 2018 at 0:32

Here's my version:

Total @ Unitize @ BitXor[list, RotateRight[list]]


6

Assuming the lists consist of only 1 and -1, then the BitXor function call will return -2 (for sign changes) and 0 otherwise. So, we can dispense with the Unitize part:

bitxor[list_] := -Total @ BitXor[list, RotateRight @ list]/2


This should be faster than the other answers as long as the input is packed. For example:

subtract[list_] := Total @ Unitize @ Subtract[list, RotateRight @ list]
differences[list_] := 1/2 Total[Abs[Differences[Sign[list]]]]+Boole[Sign[First[list]]!=Sign[Last[list]]]

data = RandomChoice[DeveloperToPackedArray @ {-1, 1}, 10^7];

r1 = bitxor[data]; //RepeatedTiming
r2 = subtract[data]; //RepeatedTiming
r3 = differences[data]; //RepeatedTiming

r1 === r2 === r3


{0.057, Null}

{0.077, Null}

{0.15, Null}

True

If the input isn't packed, then the BitXor approach becomes much slower, at least in M11.2.

list = {1, 1, -1, 1, -1, -1, 1, 1, 1, -1};

Total[Unitize[Subtract[list, RotateRight @ list]]]


6

Total @ Abs @ Subtract[list, RotateRight@list]/2


6

Length[Split[Append[list, list[[1]]]]] - 1


6

## Timings

### Functions

split = Length[Split[Append[#, #[[1]]]]] - 1 &;
fold = With[{f = First[#], r = Rest[#]},
Block[{o}, If[f == r[[-1]], o = {0, f}, o = {1, f}];
First[Fold[With[{c = #1[[1]], s1 = #1[[-1]], s2 = #2},
If[s1 == s2, {c, s2}, {c + 1, s2}]] &, o, r]]]] &;
bitxor = Total@Unitize@BitXor[#, RotateRight[#]] &;
bitxor2[list_] := -Total@BitXor[list, RotateRight@list]/2
subtract = Total@Unitize@Subtract[#, RotateRight@#] &;
subtract2 = Total@Abs@Subtract[#, RotateRight@#]/2 &;
differences = Total[Abs[Differences[Sign@#]]]/2 + Boole[Sign[First[#]] != Sign[Last[#]]]&;
flips = With[{q = Split[Positive[#]][[All, 1]]}, Length[q]-Boole[First[q] === Last[q]]]&;
partition = -Total[Cases[Apply[Times, Partition[#, 2, 1, {1, 1}], 1], Except[1]]] &;
flipNum[l_] := Block[{num}, num = 0;
Do[If[0 > l[[i]] l[[i + 1]], num = num + 1;];, {i, 1, Length[l] - 1}];
If[0 > l[[1]] l[[-1]], num = num + 1;];  num]
ProgressiveDifferences[list_] := Reverse[Differences[Reverse[list]]];
WrappingDifferences[list_] := Append[ProgressiveDifferences[list],
list[[Length[list]]] - list[[1]]]/2;
wrappingdifs = Total[Abs[WrappingDifferences[#]]] &;
count = Count[# + RotateRight@#, 0] &;
count2= Length[#] - Total[Abs[# + RotateRight@#]]/2 &;
listconvolve = Count[ListConvolve[{1, 1}, #, 1], 0] &;
listconvolve2 = Length[#] - Total[Abs[ListConvolve[{1, 1}, #, 1]]]/2 &;

funcs = {flips, split, fold, bitxor, subtract, subtract2, differences,
flipNum, partition, bitxor2, count,count2, listconvolve, listconvolve2, wrappingdifs};
labels = {"flips", "split", "fold", "bitxor", "subtract",
"subtract2", "differences", "flipNum", "partition", "bitxor2",
"count","countt2", "listconvolve", "listconvolve2", "wrappingdifs"};


### Timings for unpacked input

For unpacked input data, Alucard & Chip Hurst's listconvolve2 is the fastest among the methods posted so far followed by differences.

Version 9.0 on Windows 10 - 64bit

SeedRandom[1234]
list = RandomChoice[{-1, 1}, 10^7];
{timing, output} = Transpose[AbsoluteTiming[#[list]] & /@ funcs];
TeXForm @ Grid[Prepend[SortBy[Transpose[{labels, output, timing}], Last],
{"function", "output", "timing"}], Dividers -> All]


$$\begin{array}{|c|c|c|} \hline \text{function} & \text{output} & \text{timing} \\ \hline \text{listconvolve2} & 5000678 & 0.327872 \\ \hline \text{differences} & 5000678 & 0.392042 \\ \hline \text{subtract2} & 5000678 & 0.435157 \\ \hline \text{subtract} & 5000678 & 0.440169 \\ \hline \text{bitxor2} & 5000678 & 0.533418 \\ \hline \text{bitxor} & 5000678 & 0.536427 \\ \hline \text{count2} & 5000678 & 0.538431 \\ \hline \text{listconvolve} & 5000678 & 0.737962 \\ \hline \text{count} & 5000678 & 0.975595 \\ \hline \text{fold} & 5000678 & 1.226261 \\ \hline \text{split} & 5000678 & 1.455870 \\ \hline \text{flips} & 5000678 & 2.982931 \\ \hline \text{wrappingdifs} & 5000678 & 3.439143 \\ \hline \text{partition} & 5000678 & 7.361212 \\ \hline \text{flipNum} & 5000678 & 20.259868 \\ \hline \end{array}$$

Version 11.2 on windows 10-64bit

$$\begin{array}{|c|c|c|} \hline \text{function} & \text{output} & \text{timing} \\ \hline \text{subtract} & 5000678 & 0.459002 \\ \hline \text{subtract2} & 5000678 & 0.476543 \\ \hline \text{listconvolve2} & 5000678 & 0.501648 \\ \hline \text{count2} & 5000678 & 0.517032 \\ \hline \text{count} & 5000678 & 1.02226 \\ \hline \text{listconvolve} & 5000678 & 1.1516 \\ \hline \text{fold} & 5000678 & 1.35075 \\ \hline \text{split} & 5000678 & 1.42508 \\ \hline \text{flips} & 5000678 & 2.39839 \\ \hline \text{differences} & 5000678 & 3.14381 \\ \hline \text{wrappingdifs} & 5000678 & 3.23569 \\ \hline \text{bitxor} & 5000678 & 3.92984 \\ \hline \text{bitxor2} & 5000678 & 4.66418 \\ \hline \text{partition} & 5000678 & 5.09891 \\ \hline \text{flipNum} & 5000678 & 19.1239 \\ \hline \end{array}$$

### Timings for PackedArray input

Version 9.0 on Windows 10 - 64bit

Using a packed array as input, subtract2 is the fastest followed by subtract.

SeedRandom[1234]
list = RandomChoice[DeveloperToPackedArray@{-1, 1}, 10^7];
{timing, output} = Transpose[AbsoluteTiming[#[list]] & /@ funcs];
TeXForm @ Grid[Prepend[SortBy[Transpose[{labels, output, timing}], Last],
{"function", "output", "timing"}], Dividers -> All]


$$\begin{array}{|c|c|c|} \hline \text{function} & \text{output} & \text{timing} \\ \hline \text{subtract} & 5000678 & 0.211562 \\ \hline \text{count2} & 5000678 & 0.212565 \\ \hline \text{bitxor} & 5000678 & 0.242641 \\ \hline \text{listconvolve2} & 5000678 & 0.259692 \\ \hline \text{subtract2} & 5000678 & 0.295785 \\ \hline \text{bitxor2} & 5000678 & 0.326869 \\ \hline \text{differences} & 5000678 & 0.332885 \\ \hline \text{count} & 5000678 & 0.629674 \\ \hline \text{listconvolve} & 5000678 & 0.694850 \\ \hline \text{fold} & 5000678 & 1.269379 \\ \hline \text{split} & 5000678 & 2.291084 \\ \hline \text{wrappingdifs} & 5000678 & 3.368954 \\ \hline \text{flips} & 5000678 & 5.188834 \\ \hline \text{partition} & 5000678 & 8.494586 \\ \hline \text{flipNum} & 5000678 & 22.879290 \\ \hline \end{array}$$

Version 11.2 on windows 10-64bit(Alucard i5-6300u)

$$\begin{array}{|c|c|c|} \hline \text{function} & \text{output} & \text{timing} \\ \hline \text{bitxor2} & 5000678 & 0.159978 \\ \hline \text{count2} & 5000678 & 0.170289 \\ \hline \text{subtract2} & 5000678 & 0.176443 \\ \hline \text{bitxor} & 5000678 & 0.18276 \\ \hline \text{subtract} & 5000678 & 0.184796 \\ \hline \text{differences} & 5000678 & 0.344954 \\ \hline \text{listconvolve2} & 5000678 & 0.40738 \\ \hline \text{count} & 5000678 & 0.665442 \\ \hline \text{listconvolve} & 5000678 & 0.891994 \\ \hline \text{fold} & 5000678 & 1.42892 \\ \hline \text{split} & 5000678 & 1.64534 \\ \hline \text{flips} & 5000678 & 2.31116 \\ \hline \text{wrappingdifs} & 5000678 & 3.0645 \\ \hline \text{partition} & 5000678 & 5.5853 \\ \hline \text{flipNum} & 5000678 & 22.0245 \\ \hline \end{array}$$

• I have the feeling that this one will be quicker than the approach using Differences. Feb 14, 2018 at 21:17
• Would go with this one though, to account for cyclic boundary: Length[SplitBy[Sign[list], Sign]] - 1 + Abs[Sign[list[[1]]] - Sign[list[[-1]]]]/2 Feb 14, 2018 at 21:23
• Note that my flipNum[list] returns 6, since the sign flip between first and last list element also counts. Feb 14, 2018 at 21:29
• Thank you for the timing comparison! On my machine, adding Abs[Sign[list[[1]]] - Sign[list[[-1]]]]/2 to Chip Hurst's answer to account for the possible difference due to cyclicity does not make it slower. Will accept his answer as the most efficient one. Feb 14, 2018 at 22:48
• Observe that built-in function SequenceCount is obnoxiously slow: builtin = SequenceCount[#, {-1, 1} | {1, -1}, Overlaps -> True] &; This is an example where using a built-in function that performs your task is not advisable! Feb 15, 2018 at 0:19

For fun:

Needs["LinearAlgebraBLAS"]

l2 = RotateRight[list];
AXPY[1, list, l2];
AbsoluteTiming[Length[list] - Total[Unitize@l2]]

(*{0.0435857, 5000678}*)

• Nice one! Unfortunately, when I wrap all three lines in AbsoluteTiming, it becomes just as quick as the accepted answer. Feb 14, 2018 at 23:36
• Oh duh! I knew I was cheating somehow....
– chuy
Feb 15, 2018 at 0:02
• chuy, i don't have the LinearAlgebraBLAS package so I could not include this in the timing comparisons. Please feel free to add this to the table in my post. (+1)
– kglr
Feb 15, 2018 at 1:17
• oh its waaay slower.
– chuy
Feb 15, 2018 at 15:45
Count[ ListConvolve[{1, 1}, list,1], 0]

• Nice. You can avoid using Count with Length[list] - Total[Abs[ListConvolve[{1, 1}, list, 1]]]/2. Feb 15, 2018 at 17:57
• @ChipHurst i tried evaluating the timing and with your suggestion it became 35% faster. Feb 15, 2018 at 18:08

Another approach using Count,

Count[list+ RotateRight @ list,0]


6

Update

This version seems to be much faster. Credits to Chip Hurst.

Length[#] - Total[Abs[# + RotateRight@#]]/2 & [list]


6

flips = With[{q = Split[Positive[#]][[All, 1]]},
Length[q] - Boole[First[q] === Last[q]]] &;
flips[list]


6

works only if Length[list] >= 1 though

list = {1, 1, -1, 1, -1, -1, 1, 1, 1, -1};
cycle = Append[#, First@#] &@list;


Using SequenceCases:

patt = s : {OrderlessPatternSequence[1, -1]} :> s;

Length@SequenceCases[cycle, patt, Overlaps -> True]

(*6*)


for a list of signs list={1,1,-1,1,-1,-1,1,1,1,-1}; the following code

With[{f = First[list], r = Rest[list]},
Block[{o},
If[f == r[[-1]], o = {0, f}, o = {1, f}];
First[
Fold[
With[{c = #1[[1]], s1 = #1[[-1]], s2 = #2},
If[
s1 == s2,
{c, s2},
{c + 1, s2}
]
] &, o, r]]]]


evaluates to

6


PS. The same result is produced by

-Total[Cases[Apply[Times, Partition[list, 2, 1, {1, 1}], 1], Except[1]]]

• Note that my flipNum[list] returns 6, since the sign flip between first and last list element also counts. Feb 14, 2018 at 21:29

An approach for when you like to think your list has periodic boundary conditions

ProgressiveDifferences[list_] :=  Reverse[Differences[Reverse[list]]];
(* returns a list of x_i - x_{i+1} instead of  x_{i+1} - x_i given by Differences *)

WrappingDifferences[list_] := Append[ProgressiveDifferences[list], list[[Length[list]]] - list[[1]]]/2;
(* Difference gives an N-1 list, append the periodic boundary difference to that *)


Then

 q[list_] := Total[Abs[WrappingDifferences[list]]];


gives you the number of points where the signs disagree.

list = {1, 1, -1, 1, -1, -1, 1, 1, 1, -1};


cycle = Append[list, First @ list];


With SequenceCount

SequenceCount[cycle, {1, -1} | {-1, 1}, Overlaps -> True]


6

With DeleteCases

Length @ DeleteCases[{a_, a_}] @ Partition[cycle, 2, 1]


6