12
$\begingroup$

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.

Improve this question
$\endgroup$
1

9 Answers 9

Reset to default
9
$\begingroup$

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

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

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.

Improve this answer
$\endgroup$
17
$\begingroup$ 
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}$$

Improve this answer
$\endgroup$
18
  • $\begingroup$ I have the feeling that this one will be quicker than the approach using Differences. $\endgroup$
    – Kagaratsch
    Feb 14, 2018 at 21:17
  • $\begingroup$ 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 $\endgroup$
    – Kagaratsch
    Feb 14, 2018 at 21:23
  • $\begingroup$ Note that my flipNum[list] returns 6, since the sign flip between first and last list element also counts. $\endgroup$
    – Kagaratsch
    Feb 14, 2018 at 21:29
  • 1
    $\begingroup$ 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. $\endgroup$
    – Kagaratsch
    Feb 14, 2018 at 22:48
  • 2
    $\begingroup$ 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! $\endgroup$
    – QuantumDot
    Feb 15, 2018 at 0:19
8
$\begingroup$

For fun:

Needs["LinearAlgebra`BLAS`"]

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

(*{0.0435857, 5000678}*)
Improve this answer
$\endgroup$
4
  • $\begingroup$ Nice one! Unfortunately, when I wrap all three lines in AbsoluteTiming, it becomes just as quick as the accepted answer. $\endgroup$
    – Kagaratsch
    Feb 14, 2018 at 23:36
  • $\begingroup$ Oh duh! I knew I was cheating somehow.... $\endgroup$
    – chuy
    Feb 15, 2018 at 0:02
  • $\begingroup$ chuy, i don't have the LinearAlgebra`BLAS package so I could not include this in the timing comparisons. Please feel free to add this to the table in my post. (+1) $\endgroup$
    – kglr
    Feb 15, 2018 at 1:17
  • $\begingroup$ oh its waaay slower. $\endgroup$
    – chuy
    Feb 15, 2018 at 15:45
4
$\begingroup$ 
Count[ ListConvolve[{1, 1}, list,1], 0]
Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ Nice. You can avoid using Count with Length[list] - Total[Abs[ListConvolve[{1, 1}, list, 1]]]/2. $\endgroup$
    – Greg Hurst
    Feb 15, 2018 at 17:57
  • $\begingroup$ @ChipHurst i tried evaluating the timing and with your suggestion it became 35% faster. $\endgroup$
    – Alucard
    Feb 15, 2018 at 18:08
4
$\begingroup$

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

Improve this answer
$\endgroup$
0
3
$\begingroup$ 
flips = With[{q = Split[Positive[#]][[All, 1]]},
          Length[q] - Boole[First[q] === Last[q]]] &;
flips[list]

6

works only if Length[list] >= 1 though

Improve this answer
$\endgroup$
2
$\begingroup$

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]]]
Improve this answer
$\endgroup$
1
  • 2
    $\begingroup$ Note that my flipNum[list] returns 6, since the sign flip between first and last list element also counts. $\endgroup$
    – Kagaratsch
    Feb 14, 2018 at 21:29
2
$\begingroup$

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.

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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