Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2000
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2000

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: programming DeleteRepetitions

  • To: mathgroup at smc.vnet.net
  • Subject: [mg23733] Re: [mg23662] programming DeleteRepetitions
  • From: "Allan Hayes" <hay at haystack.demon.co.uk>
  • Date: Mon, 5 Jun 2000 01:09:25 -0400 (EDT)
  • References: <8gv88o$5n7@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

Bob,
I have added to your codings and done more timing.

The full list is {DR1, ...., DR9}

DR1 is a new version using Splot
DR2 is Carl Woll's code that I gave before (tidied up)
DR3 is a faster rewrite of your DeleteRepetitions1
DR5 is your DeleteRepetitions1
The rest are your other examples reordered (your numbering is given against
the code).

In the timings:
test[r, n] gives the timings for  DR1, ...DRn  on a list of 1000 random
integers between 1 and r.

DR6, your DeleteRepetitions6, is fastest up to r = 20.

**TIMINGS**

test[2, 9]
        {0.11, 0.06, 0., 0.22, 0.05, 0., 0.17, 0., 1.37}
test[10, 8]
        {0.17, 0.05, 0.06, 0.22, 0.05, 0., 0.55, 0.}
test[20, 8]
        {0.11, 0.05, 0.11, 0.22, 0.11, 0., 1.16, 0.16}
test[30, 8]
        {0.1, 0.06, 0.11, 0.22, 0.11, 0.11, 1.49, 2.47}
test[40, 8]
        {0.11, 0.05, 0.17, 0.38, 0.17, 0.16, 1.87, 4.28}
test[60, 6]
        {0.11, 0.11, 0.22, 0.27, 0.22, 0.66}
test[100, 6]
        {0.16, 0.06, 0.05, 0.49, 0.44, 0.61}
test[200, 6]
        {0.11, 0.17, 0.11, 0.49, 0.94, 3.57}
test[400, 6]
        {0.17, 0.27, 0.16, 0.94, 2.42, 4.99}
test[600, 6]
        {0.16, 0.28, 0.22, 1.43, 3.79, 6.53}
test[1000, 6]
        {0.16, 0.39, 0.33, 3.07, 5.93, 7.75}
test[1000000000000, 6] (*almost certainly no repetitions*)
        {0.38, 0.55, 5.05, 5.28, 5.16, 5.33}


** CODE**

Remove["`*"];
DR1[x_List] :=
    Last[Transpose[
        Sort[Reverse /@
            First /@
              Split[Sort[
                  Transpose[{x,
                      Range[Length[x]]}]], #1[[1]] == #2[[1]] &]]]];

DF2[x_List] := Block[{i}, i[n_] := (i[n] = Sequence[]; n);
      i /@ x];

DF3[x_List] := x[[Sort[Flatten[First[Position[x, #]] & /@ Union[x]]]]];

(*2*)DF4[x_List] :=
    Module[{uniq = {}},
      If[Not[MemberQ[uniq, #]], (uniq = Append[uniq, #])] & /@ x;
      uniq];
(*1*)DF5[x_List] :=
    Take[x, #] & /@ Sort[First /@ (Position[x, #] & /@ Union[x])] //
Flatten;

(*6*)DF6[x_List] :=
    Module[{uniq = Union[x], n, portion}, n = Length[uniq];
      While[(Union[portion = Take[x, n]]) != uniq, n++];
      Take[portion, #] & /@ Sort[First /@ (Position[portion, #] & /@ uniq)]
//
         Flatten];

(*2*)DF7[x_List] :=
  Transpose[
      Union[Transpose[Join[{Range[Length[x]]}, {x}]],
        SameTest -> (#1[[2]] == #2[[2]] &)]][[2]]

(*5*)DF8[x_List] :=
  Module[{uniq = Union[x], n, portion}, n = Length[uniq];
    While[(Union[portion = Take[x, n]]) != uniq, n++];
    portion //. {a___, b_, c___, b_, d___} -> {a, b, c, d}]

(*4*)DF9[x_List] := x //. {a___, b_, c___, b_, d___} -> {a, b, c, d}

**TEST CODE**

funcs = ToExpression[Names["DF*"]]

        {DF1, DF2, DF3, DF4, DF5, DF6, DF7, DF8, DF9}

SameQ @@ Through[funcs[Table[Random[Integer, {1, 10}], {100}]]]

        True

test[r_, n_] :=
  With[{lst = Table[Random[Integer, {1, r}], {1000}]},
    Timing[#[lst]][[1]]/Second & /@ Take[funcs, n]]



--
Allan
---------------------
Allan Hayes
Mathematica Training and Consulting
Leicester UK
www.haystack.demon.co.uk
hay at haystack.demon.co.uk
Voice: +44 (0)116 271 4198
Fax: +44 (0)870 164 0565

<BobHanlon at aol.com> wrote in message news:8gv88o$5n7 at smc.vnet.net...
>
> In a message dated 5/28/2000 11:37:53 PM, pnichols at wittenberg.edu writes:
>
> >Below I give a function which removes duplicates from a list (as Union
> >does), but without sorting the result (as Union also does).  More
> >specifically, it extracts, in order, the first instance of each distinct
> >element of the list.
> >
> >Is there any simpler way to do this?  It's a simple idea, but I seem to
> >need seven different list-manipulation functions, including 3 uses of
Map!
> >
> >DeleteRepetitions[X_] :=
> >  Take[X, #] & /@
> >      Sort[First /@
> >          (Position[X, #] & /@
> >              Union[X])] // Flatten
> >
> >For example,
> >
> >In[2] := DeleteRepetitions[{3,1,2,3,3,2,4,1}]
> >
> >Out[2] = {3,1,2,4}
> >
> >In[3] := DeleteRepetitions[{b,a,b,a,c,a}]
> >
> >Out[3] = {b,a,c}
> >
> >I don't need to use this function on lists longer that 20 or so elements,
> >so speed is not a critical concern.
> >
> >Also, my version happens to work on expressions with heads other than
List
> >(because Take, Position, Union, and Flatten all do so), but I don't
really
> >need that feature.
> >
> >How would you implement this function?
> >
>
> DeleteRepetitions1[x_List] :=
>
>   Take[x, #] & /@
>
>       Sort[First /@
>           (Position[x, #] & /@
>               Union[x])] //
>     Flatten
>
> DeleteRepetitions2[x_List] := Module[{uniq = {}},
>     If[Not[MemberQ[uniq, #]], (uniq = Append[uniq, #])] & /@ x;
>     uniq]
>
> DeleteRepetitions3[x_List] :=
>   Transpose[
>       Union[Transpose[Join[{Range[Length[x]]}, {x}]],
>         SameTest -> (#1[[2]] == #2[[2]] &)]][[2]]
>
> DeleteRepetitions4[x_List] := x //. {a___, b_, c___, b_, d___} -> {a, b,
c, d}
>
> DeleteRepetitions5[x_List] :=
>   Module[{uniq = Union[x], n, portion},
>     n = Length[uniq]; While[(Union[portion = Take[x, n]]) != uniq, n++];
>     portion //. {a___, b_, c___, b_, d___} -> {a, b, c, d}]
>
> DeleteRepetitions6[x_List] :=
>   Module[{uniq = Union[x], n, portion},
>     n = Length[uniq]; While[(Union[portion = Take[x, n]]) != uniq, n++];
>     Take[portion, #] & /@
>         Sort[First /@
>           (Position[portion, #] & /@
>                 uniq)] // Flatten]
>
> testList = Table[Random[Integer, {1, 10}], {400}];
>
> funcs = ToExpression[Names["DeleteRep*"]];
>
> Demonstrating the equivalence of the functions
>
> Equal[Sequence @@ (#[testList] & /@ funcs)]
>
> True
>
> Comparing their timings
>
> Timing[#[testList]][[1]] & /@ funcs
>
> {0.01666666666665151*Second, 0.049999999999954525*Second,
> 0.10000000000002274*Second, 2.2999999999999545*Second,
>   0.016666666666765195*Second, 0.*Second}
>
> The fourth method is very slow for long lists. The fifth method speeds
this
> up provided that the list is highly redundant. The sixth method applies
this
> potential speed up to the first (original) method.
>
> Bob
>
> BobHanlon at aol.com
>




  • Prev by Date: Re: [Q] accuracy control in eq. solving?
  • Next by Date: Re: [Q] accuracy control in eq. solving?
  • Previous by thread: Re: [Q] accuracy control in eq. solving?
  • Next by thread: Re: Re: programming DeleteRepetitions