7
$\begingroup$

In a list of positive integers, I would like to find the largest n such that Range[n] is a subset of the list. So for example given {1,2,3,5,7} I want the answer to be 3, while if the list is {2,4,5}, the answer should be 0.

I can think of various algorithms that involve looping over the list, but there must be a better way. In my particular case, the lists are pretty small (well under 100 elements).

$\endgroup$
2
  • $\begingroup$ I'd say that in the second example the answer is 1. $\endgroup$
    – Kuba
    Dec 12 '14 at 12:39
  • $\begingroup$ @Kuba No, I would like the answer to be zero, since Range[2] is not a subset of the given set. $\endgroup$
    – rogerl
    Dec 12 '14 at 23:00
7
$\begingroup$

If speed is important, I think that this is a typical example in which compilation of a straightforward algorithm gives better results than making use of the advanced functions of Mathematica. Here is such a compiled function:

f= Compile[{{lst, _Integer, 1}}, Module[{result=0,counting=0},
  Do[ 
    If[n==counting+1,
      counting=n,
      If[counting>result, result=counting]; counting=If[n==1, 1, 0] ],
  {n, lst}];
  Max[{result, counting}]]]

On my computer, for a list of 10^6 positive integers, this function is more than 20 times faster than the splitting technique:

SeedRandom[42];
list=RandomInteger[{1,10},10^6];
Select[Split[list,#1+1==#2&],#[[1]]==1&]//Max // Timing
f[list] // Timing
fC[list] // Timing

(* {2.418016,5} *)
(* {0.109201,5} *)
(* {0.015600,5} *)

Here the function fC is identical to f, but compiled with the option CompilationTarget->"C". So when available, this gives another factor about 9.

$\endgroup$
4
$\begingroup$

This seems to be substantially faster.

extend[list_List, pos_List /; Length[pos] > 0, depth_Integer] := 
 extend[list, 
  pos[[Flatten[
      Position[list[[DeleteCases[Flatten[pos], Length[list]] + 1]], 
       depth + 1]]]] + 1, depth + 1]

extend[list_List, {}, depth_Integer] := depth - 1

extend[list, Position[list, 1], 1]

Also, using Max gives negative infinity when there is no element 1 in the list.

This seems analogous to Boyer-Moore. Therefore, a further improvement would be to extend the first matching substring as much as possible (let's say the length of the substring is n), and then at the second matching substring check to see if it could be longer (by checking the element n positions after the start of the second matching substring), etc.

$\endgroup$
9
  • $\begingroup$ Nice idea! But there seems to be some bugs. Your code cancelled with SeedRandom[42]; list = RandomInteger[{1, 4}, 100]; extend[list, Position[list, 1], 1]. Any idea if what's happening? $\endgroup$ Dec 12 '14 at 6:24
  • $\begingroup$ Should have been Drop[Flatten[pos] + 1, -1] (since the last element is not extensible). Fixed that, but I still get a different answer than the code based on Split on a few test cases. I will look into that. $\endgroup$
    – xcah
    Dec 12 '14 at 8:29
  • $\begingroup$ This needs to be reworked a little more, but the idea is right. The problem is that the Positions in the sublist need to be translated back to their position in the original list (when searching for the higher elements). $\endgroup$
    – xcah
    Dec 12 '14 at 8:43
  • $\begingroup$ OK, I think that should do it. The Drop[..,-1] had to be changed to DeleteCases[..,Length[list]] becase we only want to delete the last of the matches with the value we are currently searching if it is the last element in the list. And the pos[[some_fun[pos]]] allows us to map positions in the sublist back to positions in the original list. Over a bunch of random examples, the output of the above matches the code based on Split above. $\endgroup$
    – xcah
    Dec 12 '14 at 8:53
  • $\begingroup$ @xcah I have been notified of a pending edit to this post. Is the item you added different from the very first item in the list, addressed in (13529)? $\endgroup$
    – Mr.Wizard
    Dec 12 '14 at 17:53
3
$\begingroup$
SeedRandom[42];
list = RandomInteger[{1, 7}, 1000];
Select[Split[list, #1 + 1 == #2 &], #[[1]] == 1 &] // Max
(* 3*)
$\endgroup$
2
  • $\begingroup$ Nice. Is the Length /@ necessary? Doesn't Max[{{1,2,3}}] yield 3? $\endgroup$
    – rogerl
    Dec 12 '14 at 3:15
  • $\begingroup$ @rogerl That's right. Edited. Thanks! $\endgroup$ Dec 12 '14 at 4:03
2
$\begingroup$
ClearAll[f1, f2]
f1 = Module[{i = 1}, While[SequencePosition[#, Range[i], 1] =!= {}, i++]; i-1]&;
f2 = Module[{i = 0}, While[SequencePosition[#, Range[++i], 1] =!= {}]; i-1]&;

f1 /@ {{1, 2, 3, 5, 7}, {3, 2, 1, 5, 7}, {3, 2, 7, 5}}

{3, 1, 0}

f2 /@ {{1, 2, 3, 5, 7}, {3, 2, 1, 5, 7}, {3, 2, 7, 5}}

{3, 1, 0}

Timings:

Both f1 and f2 are faster than all the methods (except possibly fC in Fred Simon's answer which I cannot use because I don't have a C compiler installed) posted so far.

SeedRandom[42];
list = RandomInteger[{1, 10}, 10^6];
rsel = Max @ Select[Split[list,#1+1==#2&],#[[1]]==1&] // Timing; (* belisarius *)
rext = extend[list, Position[list, 1], 1] // Timing; (* xcah *)
rf = f[list] // Timing; (* fred simons *)
rf1 = f1[list] //Timing;

Grid[{{"Select", "extend", "f", "f1"}, {rsel, rext, rf, rf1}}, Dividers->All]// TeXForm

$\begin{array}{|c|c|c|c|c|} \hline \text{Select} & \text{extend} & f & \text{f1} & \text{f2} \\ \hline \{1.453,5\} & \{0.137,5\} & \{0.039,5\} & \{0.008,5\} & \{0.008,5\} \\ \hline \end{array}$

With list = RandomInteger[{1, 1000}, 10^6];

$\begin{array}{|c|c|c|c|c|} \hline \text{Select} & \text{extend} & f & \text{f1} & \text{f2} \\ \hline \{1.68,2\} & \{0.047,2\} & \{0.039,2\} & \{0.012,2\} & \{0.011,2\} \\ \hline \end{array}$

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