6
$\begingroup$

A singleton is a list whose elements are equal. Some ways of checking this in Mathematica:

{Equal@@#&,
 1==Length@Union@#&,
 MatchQ[#,{x_ ..}]&}

I started benchmarking:

Table[First@RepeatedTiming[#@RandomInteger[{-10,10},n]]&/@%1,{n,100}]
Table[First@RepeatedTiming[#@RandomInteger[{-10,10},10^n]]&/@%1,{n,6}]

Plotting the transposes of these lists yields

linear exponential

That's disappointing. Clearly none of these functions terminated early after seeing an inequality between a single pair of elements. I've tried a few other functions, the most promising being

If[Null===Do[If[#[[i]]==#[[i+1]],Return@0],{i,Length@#-1}],True,False]&

It does slightly worse than MatchQ; its running time scales with input too

1000

All SingletonQ functions are $O(n)$. Is it possible to write a SingletonQ which is $\Omega(n)$? Or perhaps there is always a linear cost associated with array passing conventions, and a specially allocated array is needed to achieve a constant time function (for a list whose first two elements are unequal; for a uniformly i.i.d. list I believe the running time should mimick $\log_kn$ where $k$ is the sample size for each element, which would be satisfactory to see implemented).

For the curious, here's the four functions evaluated on lists of size 100000Range@10

milli

Interestingly, last two are rougly (in ratio, asymptotically) equivalent in running time.

$\endgroup$
5
  • 6
    $\begingroup$ I think it's because you have the random number generation inside the timing measurement, which necessarily makes the process $O(n)$. With F = {Apply[Equal], 1 == Length@Union@# &, MatchQ[#, {x_ ..}] &} and test[n_Integer] := With[{a = RandomInteger[{-10, 10}, n]}, First[RepeatedTiming[#[a]]] & /@ F] you'll see that test[10^6] and test[10^8] give the same result for the MatchQ algorithm. $\endgroup$
    – Roman
    Mar 17, 2021 at 19:15
  • $\begingroup$ Awesome: you're right @Roman. With fixed code, Equal@@ and Length@Union are linear, MatchQ and Do are constant. $\endgroup$
    – Adam
    Mar 17, 2021 at 19:26
  • 2
    $\begingroup$ Could try Equal @@ MinMax[data] $\endgroup$
    – Carl Woll
    Mar 17, 2021 at 19:33
  • $\begingroup$ Interestingly, Equal@@MinMax@#& seems to have a small linear cost, about 15x faster than Equal@@#& but still increasing. $\endgroup$
    – Adam
    Mar 17, 2021 at 19:45
  • $\begingroup$ Unless your lists are large, an efficient linear scaling method will always win against the constant scaling method. This is even more true if you implement in compiler languages, which allow for an efficient loop unrolling. $\endgroup$
    – yarchik
    Mar 17, 2021 at 20:31

4 Answers 4

6
$\begingroup$

The test for singletons:

# == RotateLeft[#] &

@Daniel's setup:

ll1 = RandomInteger[{-10, 10}, nn = 10^6];
ll2 = ConstantArray[10, nn];
ll3 = ll2;
ll3[[2]] = -10;
ll4 = ll2;
ll4[[-1]] = -10;
ll5 = ll2;
ll5[[Ceiling[nn/2]]] = -10;

Timing

Map[AbsoluteTiming[# == RotateLeft[#]] &, {ll1, ll2, ll3, ll4, ll5}]
(*
  {{0.012303, False}, {0.001629, True}, {0.000892, False},
   {0.001699, False}, {0.001329, False}}
*)

Update: Response to comment — Early exit

My original answer of above is (1) simple, (2) takes advantage of efficient memory management on the CPU with RotateLeft, and (3) takes advantage of the vectorized Equal. I thought it would hard to beat in actual performance, because the hardware/library optimizations are usually hard to beat with Mathematica code, even in Compile. But @DanielLichtblau's comment set me thinking further. Here's a way to chunk the input vector, so you get the advantages (2) and (3) plus you get, somewhat, the desired early exit as soon as the difference is found (by chunk). The optimal size of the chunk is open to investigation. It depends on where the first difference occurs and perhaps the size of the cache on the CPU and so forth.

With[{chunk = 2^15 (* 32K *)},
 singletonCF = Compile[{{a, _Integer, 1}},
   Module[{
     b,
     res = a[[1]] == a[[-1]],
     k = 1,
     kmax = Length[a] - chunk},
    If[kmax < 1,
     res = Most[a] == Rest[a]
     ];
    While[res && k < kmax,
     b = a[[k ;; k + chunk]];
     res = res && Most@b == Rest@b;
     k = k + chunk
     ];
    res
    ],
   CompilationTarget -> "C"
   ]
 ]

Like a lot of Compile codes that take advantage of vectorization, compiling to C gives only a small speed-up.

array = ConstantArray[0, 10^7];
Table[
  foo = array;
  foo[[Min[k, Length@array]]] = 1;
  First@RepeatedTiming[singletonCF[foo]],
  {k, 1, 1 + Length@array, Floor[Length@array/20]}] // ListPlot
$\endgroup$
4
  • $\begingroup$ While fast, most of the time is spent in RotateLeft[], which kinda screws up the sublinear goal. (But faster is better.) Not as fast as MatchQ[#, {x_ ..}]& on a list has different elements early in the list. $\endgroup$
    – Michael E2
    Mar 18, 2021 at 16:52
  • $\begingroup$ I just noticed that Equal[] appears to be auto-parallelized (at least on packed-array examples). $\endgroup$
    – Michael E2
    Mar 18, 2021 at 21:27
  • $\begingroup$ This and other answers miss the point. In a way, so does mine. The point is that there should be a fast way that does not have O(n) complexity unless a full search is really needed. What I did is (much) slower than the MinMax method, because that one uses a C loop under the hood. What we need is a method implemented in C that short-circuits when possible (as soon as a mismatch is encountered). It's on my list... $\endgroup$ Mar 21, 2021 at 14:45
  • $\begingroup$ @DanielLichtblau So I hinted in my first comment above. The performance advantage, such as it is, comes from leveraging the strengths of the CPU and libraries, not from an algorithmic advantage. Aside from being an answer to "how can I do this quickly?" and not to the algorithmic question, I'd say it could be criticized on the ground that the true performance depends on the distribution of inputs in one's actual use-case. If you really expect True a lot of the time, this answer might be hard to beat. OTOH, if adjacent elements are often unequal, it should be beatable. $\endgroup$
    – Michael E2
    Mar 21, 2021 at 16:55
4
$\begingroup$

This can perhaps be optimized (certainly if Compile is used). The idea is to short-circuit if an element not equal to the first is encountered.

allsame[ll_List] := With[
  {first = ll[[1]]},
  Catch[
   Scan[If[# != first, Throw[False]] &, ll];
   True
   ]]

You can get an idea of how it behaves by testing against large lists both random and structured. For the latter class we have all equal elements, second one different, last one different, (one of) middle element different.

n = 10^6;
ll1 = RandomInteger[{-10, 10}, n];
ll2 = ConstantArray[10, n];
ll3 = ll2;
ll3[[2]] = -10;
ll4 = ll2;
ll4[[-1]] = -10;
ll5 = ll2;
ll5[[Ceiling[n/2]]] = -10;

In[117]:= Map[Timing[allsame[#]] &, {ll1, ll2, ll3, ll4, ll5}]

(* Out[117]= {{0.03125, False}, {1.57813, True}, {0.03125, 
  False}, {1.54688, False}, {0.765625, False}} *)

It has the expected complexity at least.

$\endgroup$
3
$\begingroup$

I'd use 'LengthWhile' and compare the length to the original list:

singletonTest[a_List]:=LengthWhile[Rest@a,First@a==#&]==Length@a;

timings = Table[
   a = RandomInteger[{-10, 10}, n];
   {n, First@RepeatedTiming[singletonTest[a]]}
   , {n, 10, 1000, 10}
   ];
ListPlot[timings, AxesLabel -> {"n", "Time[s]"}]

Which gives:

enter image description here

For constant arrays:

timings = Table[
   a = Array[10 &, n];
   {n, First@RepeatedTiming[singletonTest[a];]}
   , {n, 10, 100, 10}
   ];
ListPlot[timings, AxesLabel -> {"n", "Time[s]"}]

enter image description here

$\endgroup$
1
  • 1
    $\begingroup$ This method comes close to what might be optimal. One small change makes a big difference though. Remove the Rest@ and retime it. Much faster. I upvoted regardless, because using LengthWhile is a good idea (read: I missed the boat there). $\endgroup$ Mar 21, 2021 at 14:48
0
$\begingroup$

The compeditors:

adam0[l_List]:=Equal@@l;
adam1[l_List]:=1==Length@Union@l;
adam2[l_List]:=MatchQ[l,{x_ ..}];
adam3[l_List]:=If[Null===Do[If[l[[i]]==l[[i+1]],Return@0],{i,Length@l-1}],True,False];
allsame[ll_List]:=With[{first=ll[[1]]},Catch[Scan[If[#!=first,Throw[False]]&,ll];True]];
me2[l_List]:=l==RotateLeft[l];
singletonTest[a_List]:=LengthWhile[Rest@a,First@a==#&]==Length@a;
cw[l_List]:=Equal@@MinMax@l;
funcs={adam0,adam1,adam2,adam3,allsame,me2,singletonTest,cw};

The results on lists with 100000,200000,...1000000 random elements:

ListLinePlot[Transpose@Table[With[{list=RandomReal[{-10,10},n]},First@Timing[#@list]&/@funcs],{n,100000,1000000,100000}],PlotLegends->funcs]

allrand

adam0, allsame and adam1 are the three slowest. With them excluded, the timings look like

bestrand

Carl Woll's Equal@MinMax is darn fast. But pattern matching is blazingly fast.

The results on lists with 100000,200000,...1000000 constant elements:

ListLinePlot[Transpose@Table[With[{list=ConstantArray[1,n]},First@Timing[#@list]&/@funcs],{n,100000,1000000,100000}],PlotLegends->funcs]

allconst

singletonTest and allsame are the slowest. With them excluded, the timings look like

bestconst

Equal@MinMax wins in this case. Michael E2's RotateLeft is a close second.

Takeaway the first: don't try to beat Mathematica. Also don't write code like a mathematician (looking at you, 1==Length@Union).

Takeaway the second: the biggest brain answers are always hidden in comments!

For now, the accept goes to Michael E2: #==RotateLeft@# appears to be a great all rounder.

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