11
$\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.

$\endgroup$
8
$\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]].

$\endgroup$
  • $\begingroup$ Note that my flipNum[list] returns 6, since the sign flip between first and last list element also counts. $\endgroup$ – Kagaratsch Feb 14 '18 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 '18 at 22:49
  • 1
    $\begingroup$ @Kagaratsch Ah, I didn't realize that was a requirement. See me edit. $\endgroup$ – Chip Hurst Feb 15 '18 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.

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

$\endgroup$
  • $\begingroup$ I have the feeling that this one will be quicker than the approach using Differences. $\endgroup$ – Kagaratsch Feb 14 '18 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 '18 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 '18 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 '18 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 '18 at 0:19
7
$\begingroup$

For fun:

Needs["LinearAlgebra`BLAS`"]

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

(*{0.0435857, 5000678}*)
$\endgroup$
  • $\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 '18 at 23:36
  • $\begingroup$ Oh duh! I knew I was cheating somehow.... $\endgroup$ – chuy Feb 15 '18 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 '18 at 1:17
  • $\begingroup$ oh its waaay slower. $\endgroup$ – chuy Feb 15 '18 at 15:45
4
$\begingroup$
Count[ ListConvolve[{1, 1}, list,1], 0]
$\endgroup$
  • 1
    $\begingroup$ Nice. You can avoid using Count with Length[list] - Total[Abs[ListConvolve[{1, 1}, list, 1]]]/2. $\endgroup$ – Chip Hurst Feb 15 '18 at 17:57
  • $\begingroup$ @ChipHurst i tried evaluating the timing and with your suggestion it became 35% faster. $\endgroup$ – Alucard Feb 15 '18 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

$\endgroup$
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

$\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]]]
$\endgroup$
  • 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 '18 at 21:29
1
$\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.

$\endgroup$

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.