Re: Re: how to get the longest ordered sub
- To: mathgroup at smc.vnet.net
- Subject: [mg103298] Re: [mg103227] Re: [mg103158] how to get the longest ordered sub
- From: DrMajorBob <btreat1 at austin.rr.com>
- Date: Mon, 14 Sep 2009 07:10:27 -0400 (EDT)
- References: <200909090845.EAA05996@smc.vnet.net>
- Reply-to: drmajorbob at yahoo.com
Fred, thanks again for looking at my code and finding improvements. Maybe
I can return the favor for once (a rarity).
My singleLongestIncreasing code had the (slight) virtue of returning the
same subsequence as Combinatorica's LongestIncreasingSubsequence function,
where your code does not. I've also modified your code to get an 8 to 9
percent improvement for long lists, and it again gets the same result as
Combinatorica.
Combinatorica needs some updates, BTW!
My earlier code:
Clear[zeroPad, longestND]
zeroPad[{}] = {0};
zeroPad[x_List] := x
longestND[x_List] :=
Module[{t = Append[x, 1 + Max[x]], len, pred, path, max},
path[i_Integer, o___Integer] /; pred[i] != {} :=
path[Last@pred@i, i, o];
len[i_] := len[i] =
Module[{mx, prior, pick, nxt = t[[i]]},
pick = Pick[Range[i - 1], Take[t, i - 1] - nxt, _?Negative];
prior = len /@ pick;
mx = Max@zeroPad@prior;
pred[nxt] = t[[Pick[pick, prior, mx]]];
1 + mx];
len /@ Range@Length@t;
Most[path@Last@t /. path -> List]
]
Yours:
fsLongest[comp_Symbol][lst_List] :=
Module[{length = Array[0 &, Length[lst]],
pos = Array[0 &, Length[lst]]},
Do[With[{z =
Pick[Range[i - 1], Take[lst, i - 1] - lst[[i]], _?comp]},
If[z == {}, length[[i]] = 1; pos[[i]] = 0,
With[{zz = length[[z]]}, length[[i]] = 1 + Max[zz];
pos[[i]] = Pick[z, zz, Max[zz]][[1]]]]], {i, 1, Length[lst]}];
lst[[Most[
NestWhileList[pos[[#]] &, Position[length, Max[length]][[1, 1]],
Positive]]]] // Reverse]
and my new one:
Clear[btLongest]
btLongest[comparison_: (Negative || NonPositive)][lst_List] :=
Module[{n = Length@lst, length, pos, z, zz, zzPos},
pos = 0 lst; length = pos + 1;
Do[z = Pick[Range[i - 1], Take[lst, i - 1] - lst[[i]], _?comparison];
z != {} && (
zz = length[[z]];
zzPos = First@Ordering[zz, -1];
length[[i]] = 1 + zz[[zzPos]];
pos[[i]] = z[[zzPos]]
),
{i, 1, n}];
lst[[Reverse@
Most@NestWhileList[pos[[#]] &, First@Ordering[length, -1],
Positive]]]]
and a test, with no repeats in the sequence (comparison = Negative or
NonPositive give the same result for these):
Needs["Combinatorica`"]
n = 35;
s = Ordering@RandomReal[{0, 1}, n^2 + 1];
Timing[mine = longestND@s]
Timing[combinatorica = LongestIncreasingSubsequence@s]
Timing[fred = fsLongest[NonPositive]@s]
Timing[bt = btLongest[NonPositive]@s]
mine == combinatorica == bt
Length /@ {mine, combinatorica, fred, bt}
Less @@@ {mine, combinatorica, fred, bt}
{0.722282, {16, 19, 23, 68, 72, 92, 135, 145, 151, 161, 164, 173, 201,
205, 209, 242, 295, 342, 365, 411, 444, 446, 458, 463, 486, 494,
496, 499, 521, 543, 552, 563, 577, 650, 674, 677, 682, 701, 707,
713, 721, 730, 734, 740, 758, 803, 815, 833, 839, 845, 856, 871,
939, 944, 950, 955, 982, 999, 1014, 1040, 1041, 1046, 1081, 1100,
1103, 1131, 1137, 1169}}
{8.06735, {16, 19, 23, 68, 72, 92, 135, 145, 151, 161, 164, 173, 201,
205, 209, 242, 295, 342, 365, 411, 444, 446, 458, 463, 486, 494,
496, 499, 521, 543, 552, 563, 577, 650, 674, 677, 682, 701, 707,
713, 721, 730, 734, 740, 758, 803, 815, 833, 839, 845, 856, 871,
939, 944, 950, 955, 982, 999, 1014, 1040, 1041, 1046, 1081, 1100,
1103, 1131, 1137, 1169}}
{0.455748, {39, 86, 91, 96, 99, 108, 135, 145, 151, 161, 166, 173,
222, 225, 239, 266, 295, 342, 365, 411, 444, 446, 458, 463, 486,
494, 496, 499, 521, 543, 552, 563, 628, 650, 674, 677, 682, 705,
718, 722, 728, 730, 734, 740, 758, 803, 815, 833, 839, 846, 909,
911, 939, 944, 950, 955, 982, 999, 1014, 1040, 1041, 1055, 1081,
1100, 1103, 1131, 1137, 1182}}
{0.410353, {16, 19, 23, 68, 72, 92, 135, 145, 151, 161, 164, 173, 201,
205, 209, 242, 295, 342, 365, 411, 444, 446, 458, 463, 486, 494,
496, 499, 521, 543, 552, 563, 577, 650, 674, 677, 682, 701, 707,
713, 721, 730, 734, 740, 758, 803, 815, 833, 839, 845, 856, 871,
939, 944, 950, 955, 982, 999, 1014, 1040, 1041, 1046, 1081, 1100,
1103, 1131, 1137, 1169}}
True
{68, 68, 68, 68}
{True, True, True, True}
A test with reals (assuming no repeats):
n = 35;
s = RandomReal[{0, 1}, n^2 + 1];
Timing[fred = fsLongest[Negative]@s;]
Timing[bt = btLongest[Negative]@s;]
Length /@ {fred, bt}
Less @@@ {fred, bt}
{0.475175, Null}
{0.445309, Null}
{65, 65}
{True, True}
And finally, a test with repeats.
Non-decreasing result:
n = 35;
s = RandomInteger[10, n^2 + 1];
Timing[fred = fsLongest[NonPositive]@s;]
Timing[bt = btLongest[NonPositive]@s;]
Length /@ {fred, bt}
LessEqual @@@ {fred, bt}
{0.446616, Null}
{0.415277, Null}
{167, 167}
{True, True}
Strictly increasing result for the same list:
Timing[fred = fsLongest[Negative]@s;]
Timing[bt = btLongest[Negative]@s;]
Length /@ {fred, bt}
Less @@@ {fred, bt}
{0.438064, Null}
{0.414591, Null}
{11, 11}
{True, True}
Bobby
On Sun, 13 Sep 2009 03:17:00 -0500, Fred Simons <f.h.simons at tue.nl> wrote:
> Hi Bobby,
>
> Many thanks for your reaction. It clarifies a lot; from your mail I did
> not see this restriction to integer lists without repeats, though I
> could have seen it by looking more carefully at the examples following
> your code.
>
> The function longestincreasingsubsequence3 that I included in my
> previous post is just a rewriting of your code, without these
> limitations. It produces a maximal STRICTLY increasing subsequence of
> any numerical list, with repeats allowed, in the same time as your
> function, and longestincreasingsubsequence3a, with arrays instead of
> functions for len and pred, even 30-40% faster . It is easy to adapt it
> for finding a maximal non-decreasing subsequence. Just replace Negative
> with (#<=0&). But once again, these functions are essentially your
> function, so I am grateful to you having posted it.
>
> Best wishes,
>
> Fred
>
>
> DrMajorBob wrote:
>> Fred,
>>
>> Thanks for looking at this!
>>
>> My singleLongestIncreasing code was meant for permutations (like
>> Combinatorica's LongestIncreasingSubsequence) or at least for integer
>> sequences with no repeats.
>>
>> Hence, it doesn't surprise me if it fails on an example like
>>
>> {207,586,803,964,352,618,586,445}
>>
>> where 586 appears twice. A simple remedy goes like this:
>>
>> s = {207, 586, 803, 964, 352, 618, 586, 445};
>> s[[t = Ordering@s]][[singleLongestIncreasing@Ordering@t]]
>>
>> {207, 586, 803, 964}
>>
>> and the same trick works for lists that are not Integer:
>>
>> s = RandomReal[{0, 10}, 25]
>> s[[t = Ordering@s]][[singleLongestIncreasing@Ordering@t]]
>>
>> {0.00676668, 7.13942, 5.40509, 3.2741, 5.53002, 8.21107, 0.244104, \
>> 0.852249, 6.67937, 6.95541, 4.69291, 5.24756, 8.37349, 8.04903, \
>> 5.9746, 4.28895, 8.13952, 3.35027, 5.79979, 4.89208, 5.45609, \
>> 8.62996, 7.58016, 9.68173, 4.20249}
>>
>> {0.00676668, 0.244104, 0.852249, 4.69291, 5.24756, 5.9746, 8.13952, \
>> 8.62996, 9.68173}
>>
>> My function is a slight modification of another code that finds ALL
>> maximal increasing subsequences (in an integer list with no repeats),
>> and that's why I used the "pred" function where List might do just as
>> well. A few random tries gave me lists with, say, 35^2 + 1 entries
>> with more than 60,000 maximal subsequences (all the same length). I
>> don't think List takes the place of "pred" in that situation. (But
>> maybe I'm wrong.)
>>
>> That earlier code is
>>
>> Clear[zeroPad, longest]
>> zeroPad[{}] = {0};
>> zeroPad[x_List] := x
>> longest[x_List] :=
>> Module[{t = Append[x, 1 + Max[x]], len, pred, path, max},
>> path[i_Integer, o___Integer] /; pred[i] != {} :=
>> Flatten[(path[#1, i, o] &) /@ pred[i]];
>> len[i_] :=
>> len[i] =
>> Module[{mx, prior, pick, nxt = t[[i]]},
>> pick = Pick[Range[i - 1], Take[t, i - 1] - nxt, _?Negative];
>> prior = len /@ pick;
>> mx = Max@zeroPad@prior;
>> pred[nxt] = t[[Pick[pick, prior, mx]]];
>> 1 + mx];
>> len /@ Range@Length@t;
>> path@Last@t /. path[any__] :> Most@{any}
>> ]
>>
>> I still haven't accomplished finding a maximal STRICTLY increasing
>> subsequence of a list with repeats.
>>
>> Bobby
>>
>> On Sat, 12 Sep 2009 12:45:58 -0500, Fred Simons <f.h.simons at tue.nl>
>> wrote:
>>
>>
>>> Hi Bobby,
>>>
>>> Since your code and Leonid's solution are so much faster than my poor
>>> backtracking program, I deciphered the code you posted in mathgroup
>>> to see what is behind it. The basic idea seems to be to construct
>>> two functions, defined on the positions of the numbers of the list,
>>> the function length giving the maximum length of an increasing
>>> sublist ending at that position, the function pos giving the position
>>> of the previous element in that increasing sublist. That enabled me
>>> to rewrite your code
>>>
>>> Clear[zeroPad, singleLongestIncreasing]
>>> zeroPad[{}] = {0};
>>> zeroPad[x_List] := x
>>> singleLongestIncreasing[x_List] :=
>>> Module[{t = Append[x, 1 + Max[x]], len, pred, path, max},
>>> path[i_Integer, o___Integer] /; pred[i] != {} :=
>>> path[Last@pred@i, i, o];
>>> len[i_] := len[i] =
>>> Module[{mx, prior, pick, nxt = t[[i]]},
>>> pick = Pick[Range[i - 1], Take[t, i - 1] - nxt, _?Negative];
>>> prior = len /@ pick;
>>> mx = Max@zeroPad@prior;
>>> pred[nxt] = t[[Pick[pick, prior, mx]]];
>>> 1 + mx];
>>> len /@ Range@Length@t;
>>> Most[path@Last@t /. path -> List]
>>> ]
>>>
>>> into the following form:
>>>
>>> longestincreasingsubsequence3[lst_List] := Module[{length, pos},
>>> Do[
>>> With[{z=Pick[Range[i-1],Take[lst, i-1] -lst[[i]], _?Negative]},
>>> If[z=={}, length[i]=1;pos[i]=0,
>>> With[{zz =length /@z}, length[i]=1+Max[zz]; pos[i]=Pick[z, zz,
>>> Max[zz]][[1]]]]], {i,1, Length[lst]}];
>>> lst[[Most[NestWhileList[pos,With[{zz=length /@ Range[Length[lst]]},
>>> Pick[Range[Length[lst]],zz, Max[zz]][[1]]], Positive]]]]//Reverse]
>>>
>>> Both functions are about as fast; maybe yours is a fraction faster.
>>> But it turns out that working with arrays rather than with functions
>>> still speeds up my implementation considerably:
>>>
>>> longestincreasingsubsequence3a[lst_List] := Module[{length=Array[0&,
>>> Length[lst]], pos=Array[0&, Length[lst]]},
>>> Do[
>>> With[{z=Pick[Range[i-1],Take[lst, i-1] -lst[[i]], _?Negative]},
>>> If[z=={}, length[[i]]=1;pos[[i]]=0,
>>> With[{zz =length[[z]]}, length[[i]]=1+Max[zz]; pos[[i]]=Pick[z, zz,
>>> Max[zz]][[1]]]]], {i,1, Length[lst]}];
>>> lst[[Most[NestWhileList[pos[[#]]&,Position[length,
>>> Max[length]][[1,1]], Positive]]]]//Reverse]
>>>
>>> In[48]:= ClearSystemCache[];
>>> lst=RandomInteger[{1,10000},2000];
>>> res1=longestincreasingsubsequence3[lst]; // Timing
>>> res2=longestincreasingsubsequence3a[lst]; // Timing
>>> Length[res1]==Length[res2]
>>>
>>> Out[50]= {4.103,Null}
>>> Out[51]= {2.34,Null}
>>> Out[52]= True
>>>
>>> Probably I would not have written this to you, if I did not want to
>>> call your attention to a small problem with your code. Here is an
>>> example:
>>>
>>> In[53]:= lst={207,586,803,964,352,618,586,445};
>>> singleLongestIncreasing[lst]
>>> longestincreasingsubsequence3[lst]
>>> longestincreasingsubsequence3a[lst]
>>>
>>> Out[54]= {207,352,586,803,964}
>>> Out[55]= {207,586,803,964}
>>> Out[56]= {207,586,803,964}
>>>
>>> Your result seems to be incorrect; 803 is not a successor of 586. But
>>> I did not study your code in so much detail that I can point to the
>>> source of the error.
>>>
>>> Kind regards,
>>>
>>> Fred Simons
>>> Eindhoven University of Technology
>>>
>>>
>>>
>>
>>
>>
>
--
DrMajorBob at yahoo.com
- References:
- how to get the longest ordered sub sequence of a list in
- From: a boy <a.dozy.boy@gmail.com>
- how to get the longest ordered sub sequence of a list in