Number of sign flips in list?

Question

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?

I have this ad-hoc solution:

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[Developer`ToPackedArray@{-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.

Answer 1

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[Developer`ToPackedArray@{-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}$$

Answer 2

Here's my version:

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

6

Addendum

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[Developer`ToPackedArray @ {-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.

Answer 3

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

Answer 4

For fun:

Needs["LinearAlgebra`BLAS`"]

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

(*{0.0435857, 5000678}*)

Answer 5

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

Answer 6

Count[ ListConvolve[{1, 1}, list,1], 0]

Answer 7

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

6

works only if Length[list] >= 1 though

Answer 8

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)

Answer 9

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

Answer 10

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.

Answer 11

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

For better readability

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