Research positions of lists of varying size

Question

I'm new to the site and I am French, so I ask your indulgence for my future mistakes in English.

I would like to optimise the following code :

Proc1V1[x_] :=
  Block[
        {ListO = x, F°1B1, F°1B1oneseq, F°2B1, F°2B1oneseq, F°3B1, F°4B1, F°1B2, 
         Res1V1},


    F°1B1 = Table[
                  Partition[ListO, j, 1],
                  {j, 1, Length[ListO], 1}
                 ];

    F°1B1oneseq = Partition[ListO, 1, 1];

    F°2B1 = Sort[
                 Tally [
                        Flatten[F°1B1, 1]
                       ],
                  #1 [[2]] > #2 [[2]] &
                ];

    F°2B1oneseq = Tally[F°1B1oneseq][[All, 1]];

    F°3B1 = Sort[
                 F°2B1 [[1 ;; (Position[F°2B1[[All, 2]], 1][[1, 1]])-1]][[All, 1]],
                 Length[#1] > Length[#2] &
                ];

    F°4B1 = Join[
                 TakeWhile[F°3B1, Length[#] > 1 &], 
                 F°2B1oneseq
                ];

    F°1B2 = Table[
                  Position[ F°1B1[[ Length[ F°4B1 [[i]]] ]],F°4B1 [[i]]],
                  {i, 1, Length[F°4B1], 1}
                ];

    Res1V1 = {F°1B2, F°4B1}
   ];

After applying AbsoluteTiming on the different steps of my algorithm, F°1B2 appeared to be the longest step in the calculation. So I focus on it. The algorithm acting at F°1B2 is responsible for determining the positions of the various lists of numbers stored in F°4B1 and contained in F°1B1. It may be noted here that ListO is a simple list of integers or reals.

For example:

ListO = {1, 2, 3, 4, 5, 6, 7}

I've tried using Compile but this does not work if it has to deal with lists of different size.

I know that finding an alternative to the Position is a recurring topic on StackExchange but I have yet to find a reliable solution to replace F°1B2 by a faster algorithm, especially because Proc1V1 is the first algorithm to a broader set and therefore it is difficult to change the structure of the data it produces.

Edit n°1

---

To better understand my project, I will give an overview of the context. My goal is to make an algorithm to detect and store the sequences detected in an ordered list of number (Real or Integer number). To start, I got used to test my code with :

ListTest= IntegerPart [ RandomReal [ 10,50 ] ] ;

Therefore, Proc1V1 must detect the different sequences contained inside ListTest. It is important to note here that a set of numbers will be considered as a sequence, if it appears at least twice in ListTest and if it is length is greater than 1. To do this (it’s probably perfectible but I have not found better yet), the algorithm I did create partitions of different lengths in the starting list ListTest. These partitions are compared and sorted at F°2B1. All other operations are responsible for ensuring that the definition of the sequences as I defined above is respected.

If all operations are relatively fast, the operation performed under F°1B2 turns long . For the rest of the algorithms which I wrote it, I need that Proc1V1 provide me the positions of these sequences inside F1B2 and obviously the sequences identified.

Final Edit

---

Tested functions

Proc1V1 : see above.

Proc1V1alt1[list_]:= {#[[1,2]],#[[All,1]]}&/@ ReplaceList[list,{a___,x__,___}:>{Length@{a}+1, {x}}]~GatherBy~Last~Cases~{_,__};

Proc1V1alt2[list_]:= {#[[1,2]],#[[All,1]]}&/@ (Join@@Table[{i,list[[i;;j]]},{i,Length[list]}, {j,i,Length[list]}])~GatherBy~Last~Cases~{_,__};

Proc1V1alt3[list_]:= Block[ {bigL=list,z1,z2,z3,z4,z5,z6,z7,minlength}, minlength=1; z1=Flatten[Position[#,True]]& /@Rest@ListCorrelate[bigL,bigL,1,x,SameQ,List];
z2=Split[#,(#1+1===#2)&]&/@z1; z3=DeleteCases[z2,q_List/;Length[q]<minlength,{2}]; z4=DeleteCases[MapIndexed[w[#2,#1]&,z3],w[_,{}]]; z5=Flatten[z4/.w[{u_},q_List]:>Map[w[bigL[[#]],First[#]+{0,u}]&,q]]; z6=Split[Sort[z5],First[#1]===First[#2]&]; z7={#[[1,1]],Union@@(Last/@#)}&/@z6 ];

Proc1V1alt4: See Rasher's post.

With :

Proc1V1 : personal function.
Proc1V1alt1 : Mr Wizard's function n°1.
Proc1V1alt2: Mr Wizard's function n°2.
Proc1V1alt3 : Wouter's function.
Proc1V1alt4 : Rasher's function

Test code

ValeurPerfTemps= Table[ AbsoluteTiming[ func[IntegerPart[RandomReal[10,i]]] ][[1]], {i,50,500,1} ];

ListLinePlot[ValeurPerfTemps]

Result

Conclusion

In the context of my original question, the function n°2 of Mr. Wizard is the most suitable. Nevertheless, it is important to note that my function Proc1V1 takes place in a set of algorithm, and some of which are specifically dedicated to the elimination of sequences "encapsulated" (ex : 123 is contained in 11234). Actually I will use Rasher's function, which is very fast.

Thank you all for your help.

Benchmark

---

On my computer :
Proc1V1[{3, 0, 1, 0, 3, 2, 2, 0, 3, 0, 1, 3, 0, 2, 3, 3, 0, 0, 1, 2}]
give
{{{{1}, {9}}, {{4}, {8}}, {{2}, {10}, {18}}, {{1}, {9}, {12}, {16}}, \ {{1}, {5}, {9}, {12}, {15}, {16}}, {{2}, {4}, {8}, {10}, {13}, {17}, \ {18}}, {{3}, {11}, {19}}, {{6}, {7}, {14}, {20}}}, {{3, 0, 1}, {0, 3}, {0, 1}, {3, 0}, {3}, {0}, {1}, {2}}}

Answer 1

I didn't read all of your question so I may misunderstand, but based on the example at the bottom I believe your operation is equivalent to this:

sspos[list_] := {#[[1, 2]], #[[All, 1]]} & /@
   ReplaceList[list, {a___, x__, ___} :> {Length@{a} + 1, {x}}
   ] ~GatherBy~ Last ~Cases~ {_, __};

test = {3, 0, 1, 0, 3, 2, 2, 0, 3, 0, 1, 3, 0, 2, 3, 3, 0, 0, 1, 2};

sspos[test] // Grid

{3}      {1,5,9,12,15,16}
{3,0}    {1,9,12,16}
{3,0,1}  {1,9}
{0}      {2,4,8,10,13,17,18}
{0,1}    {2,10,18}
{1}      {3,11,19}
{0,3}    {4,8}
{2}      {6,7,14,20}

Can you confirm that this works as you desire? If so I will explain it, and also seek to improve it. If not I'll try again.

---

I waited to add an explanation of the code above because I was trying to figure out a more efficient approach that would make it obsolete, but since I haven't succeeded I'll do that now. Also I just corrected an error; apologies if it caused you frustration.

The core of the function is:

ReplaceList[list, {a___, x__, ___} :> {Length@{a} + 1, {x}}]

This is simply a fancy way to generate all subsequences of list, along with their positions. It came naturally to me because I am familiar with this method⁽¹⁾⁽²⁾ but one could just as well (in fact, better) use Table:

f1 = ReplaceList[#, {a___, x__, ___} :> {Length@{a} + 1, {x}}] &;

f2 = Join @@ Table[{i, #[[i ;; j]]}, {i, Length@#}, {j, i, Length@#}] &;

f1[test] === f2[test]

True

The output of either function is a list with elements of the form: {startposition, sequence}, e.g. {4, {0, 3, 2, 2}}. This list is passed to GatherBy with Last for the second parameter. (Using infix notation that probably adds confusion, but which I have difficulty not using.) This groups these elements by the sequence, e.g. {0, 3, 2, 2}.

Next Cases is used with a pattern of {_, __} so as to extract only groups with more than one member. (Again using infix notation; sorry.) It occurs to me that this would probably have been clearer using DeleteCases with a pattern of {_}.

Finally, the Function {#[[1, 2]], #[[All, 1]]} & is mapped onto the remaining groups, which extracts one copy of the sequence (by which the elements were grouped) and the startposition for every element.

Answer 2

One possible answer would be to try and reconstruct your problem analysis from the code you gave. I will not attempt that here.

Rather, I'll start from your statement

"..a set of numbers will be considered as a (sub)sequence, if it appears at least twice in (sic) and if its is length is greater than 1".

That sounds like searching for subsequences of length 2 or larger in a given list.

More specificaly, we could ask for sublists themselves, their multiplicity, their starting position(s) and even cases where a sublist is contained also as a part in a longer sublist (pardon my French: "enchevêtrement") as in ...12...12...0123..12...0123....

This raises the question of how to count the ..12.. substrings with or without double counting those inside the ..0123.. substring.

An attempt to program this using ListCorrelate :

test = IntegerPart[RandomReal[4, 24]];
test={3,0,1,0,3,2,2,0,3,0,1,3,0,2,3,3,0,0,1,2}; minlength=2;

z1=Flatten[Position[#, True]] & /@ Rest@ListCorrelate[test, test, 1, x, SameQ, List];
z2=Split[#, (#1 + 1 === #2) &] & /@ z1;
z3=DeleteCases[z2, q_List/;Length[q]<minlength, {2}];
z4=DeleteCases[MapIndexed[w[#2, #1] &, z3], w[_, {}]];

Edit and correction 2014/04/05 18:30 UTC+1 (using the test from your edit):
Second edit 2014/04/06 19:32 UTC+1 (to conform to Mr.Wizard's output format)

z5 = Flatten[z4 /. w[{u_}, q_List] :> Map[w[test[[#]], First[#] + {0, u}] &, q]]; 
z6 = Split[Sort[z5], First[#1] === First[#2] &]; 
z7 = {#[[1, 1]], Union @@ (Last /@ #)} & /@ z6; 
z7[[Ordering[PadRight[#, Max[Length /@ Last /@ z7], " "] & /@ (Last /@ z7)]]]//Grid 

{ {{3, 0}, {1, 9, 12, 16}},
    {{3, 0, 1}, {1, 9}},
    {{0, 1}, {2, 10, 18}},
    {{0, 3}, {4, 8}}  }  

In this case equivalent to , but for test = {1, 1, 1, 2, 3, 1, 1, 2, 3, 1}; the results are quite different. I have always admired one-liners, and Mr.Wizard's is a gem.