Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2005
*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 2005

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

Search the Archive

Re: removing sublist . Again and Different

  • To: mathgroup at smc.vnet.net
  • Subject: [mg56350] Re: [mg56305] removing sublist . Again and Different
  • From: "Wolf, Hartmut" <Hartmut.Wolf at t-systems.com>
  • Date: Fri, 22 Apr 2005 06:23:45 -0400 (EDT)
  • Sender: owner-wri-mathgroup at wolfram.com

>-----Original Message-----
>From: giampi1960 [mailto:giampiero1960 at yahoo.com] 
To: mathgroup at smc.vnet.net
>Sent: Thursday, April 21, 2005 11:36 AM
>Subject: [mg56350] [mg56305] removing sublist . Again and Different
>
>hello i read borges2003xx at yahoo.it meassage :
>
>
>>i'm a newbie. How implement the _faster functon_ which removes in a
>>list every element that are a subelement.
>>which means
>>f[x]:=  {..,{1,2,3,4},..,{2,3},..} removes {2,3}.
>>thanx a lot.
>>giorgio borghi
>
>
>i ask your help for faster way to do the opposite
>f[x]:=  {..,{1,2,3,4},..,{2,3},..} removes {1,2,3,4}.
>
>best regards
>
>giampiero
>
>

Giampiero,

I'm afraid, I simple cannot understand what you want to attain. 
Could you please first specify a _slow function_ that does the job? 
Your example is rather droughty!

Alternatively specify what is a "subelement"?
Is {3,2} a "subelement" of {1,2,3,4} ? or of {4,3,2,1}? or of {3,4,1,2}?

Is the list sorted? Are all "elements" sorted? Are all "elements" ranges
of integers?
How many "elements" do you have, of what max and everage length, 
can "element" {} occur? (which might make everything collapse), etc...
And above all, you have to specify in which form you want to have the
result!

And -- if you like -- state your real problem, in case you want to hear
of other approaches.


This is an attempt by example. (A slow, but not too slow, procedure; its
essential kernel should behave as O[n log n], i.e. except for statements
like repeated Append-s, ReplaceAll-s which can be avoided.) I also will
not forge it into a function, just sketch the idea:


I assume the "elements" are ranges of Integers, not empty, but the list
is not ordered.  This here then should constitute valid test data:

In[44]:= xlen = 6; xnum = 20;

In[46]:=
re := With[{start = Random[Integer, {1, xnum}], 
      len = Random[Integer, {1, xlen}]},
    Range[start, start + len]]


In[88]:= ll = Table[re, {20}]
Out[88]=
{{9, 10}, {4, 5, 6, 7, 8, 9, 10}, {20, 21, 22, 23}, {17, 18, 19, 20},
{19, 
    20}, {4, 5, 6, 7, 8, 9}, {14, 15, 16, 17}, {7, 8, 9, 10, 11, 12},
{3, 4, 
    5, 6}, {14, 15, 16}, {9, 10, 11}, {15, 16}, {20, 21}, {17, 18}, {13,
14, 
    15, 16, 17, 18}, {18, 19, 20}, {1, 2, 3, 4, 5}, {7, 8, 9, 10, 11,
12, 
    13}, {9, 10}, {20, 21}}

(Just excuse that silly "20", where it appears again below, it should be
replaced by Length[ll].)

Now we sort this list according to the order of the last number in each
element:

In[106]:= ord = Ordering[ll, All, 
    Last[#1] < Last[#2] || Last[#1] == Last[#2] && First[#1] >=
First[#2] &]
Out[106]=
{17, 9, 6, 1, 19, 2, 11, 8, 18, 12, 10, 7, 14, 15, 5, 16, 4, 13, 20, 3}

In[107]:= ll2 = ll[[ord]]
Out[107]=
{{1, 2, 3, 4, 5}, {3, 4, 5, 6}, {4, 5, 6, 7, 8, 9}, {9, 10}, {9, 10},
{4, 5, 
    6, 7, 8, 9, 10}, {9, 10, 11}, {7, 8, 9, 10, 11, 12}, {7, 8, 9, 10,
11, 12,
     13}, {15, 16}, {14, 15, 16}, {14, 15, 16, 17}, {17, 18}, {13, 14,
15, 16,
     17, 18}, {19, 20}, {18, 19, 20}, {17, 18, 19, 20}, {20, 21}, {20, 
    21}, {20, 21, 22, 23}}

Now the idea is: if the first number of an "element" following the
current "element" is smaller or equal than the first number of this
current one, then the "current element is contained" in that element,
hence that element should be deleted. We continue such, until the
condition is false and then simply advance. So we have only a single
linear scan through the list. Let's do it:

In[108]:= dpos = {};
For[i = 1, i < Length[ll2], i = j,
  j = i + 1;
  While[j <= Length[ll2] && First[ll2[[i]]] >= First[ll2[[j]]] , 
    AppendTo[dpos, {j++}]]]

In[110]:= dpos
Out[110]=
{{5}, {6}, {7}, {8}, {9}, {11}, {12}, {14}, {16}, {17}, {19}, {20}}


These are the positions (in sorted list) to be deleted.  Let's just mark
these "elements" and look at them:

In[111]:= zz2 = ReplacePart[ll2, x /@ ll2, dpos, dpos]
Out[111]=
{{1, 2, 3, 4, 5}, {3, 4, 5, 6}, {4, 5, 6, 7, 8, 9}, {9, 10}, x[{9, 10}],

  x[{4, 5, 6, 7, 8, 9, 10}], x[{9, 10, 11}], x[{7, 8, 9, 10, 11, 12}], 
  x[{7, 8, 9, 10, 11, 12, 13}], {15, 16}, x[{14, 15, 16}], 
  x[{14, 15, 16, 17}], {17, 18}, x[{13, 14, 15, 16, 17, 18}], {19, 20}, 
  x[{18, 19, 20}], x[{17, 18, 19, 20}], {20, 21}, x[{20, 21}], 
  x[{20, 21, 22, 23}]}


In fact, it's easy to see, that those are to be deleted. (I can't
however see whether these are all.)


Before deleting, we first bring things into original order:

In[112]:= dro = Range[20] /. Thread[ord -> Range[20]]
Out[112]=
{4, 6, 20, 17, 15, 3, 12, 8, 2, 11, 7, 10, 18, 13, 14, 16, 1, 9, 5, 19}


This is just the "reversed" ordering. With that we get the elements +
marks back into original order:

In[114]:= zz2[[dro]]
Out[114]=
{{9, 10}, x[{4, 5, 6, 7, 8, 9, 10}], x[{20, 21, 22, 23}], 
  x[{17, 18, 19, 20}], {19, 20}, {4, 5, 6, 7, 8, 9}, x[{14, 15, 16,
17}], 
  x[{7, 8, 9, 10, 11, 12}], {3, 4, 5, 6}, x[{14, 15, 16}], 
  x[{9, 10, 11}], {15, 16}, {20, 21}, {17, 18}, x[{13, 14, 15, 16, 17,
18}], 
  x[{18, 19, 20}], {1, 2, 3, 4, 5}, x[{7, 8, 9, 10, 11, 12, 13}], x[{9,
10}], 
  x[{20, 21}]}

compare with

In[115]:= ll
Out[115]=
{{9, 10}, {4, 5, 6, 7, 8, 9, 10}, {20, 21, 22, 23}, {17, 18, 19, 20},
{19, 
    20}, {4, 5, 6, 7, 8, 9}, {14, 15, 16, 17}, {7, 8, 9, 10, 11, 12},
{3, 4, 
    5, 6}, {14, 15, 16}, {9, 10, 11}, {15, 16}, {20, 21}, {17, 18}, {13,
14, 
    15, 16, 17, 18}, {18, 19, 20}, {1, 2, 3, 4, 5}, {7, 8, 9, 10, 11,
12, 
    13}, {9, 10}, {20, 21}}


Now we delete:

In[116]:= zz2[[dro]] /. x[__] -> Sequence[]
Out[116]=
{{9, 10}, {19, 20}, {4, 5, 6, 7, 8, 9}, {3, 4, 5, 6}, {15, 16}, {20,
21}, 
 {17,18}, {1, 2, 3, 4, 5}}


I can't see any spurious rests:

In[117]:= Sort[%, First[#1] < First[#2] &]
Out[117]=
{{1, 2, 3, 4, 5}, {3, 4, 5, 6}, {4, 5, 6, 7, 8, 9}, {9, 10}, {15, 16},
{17, 
    18}, {19, 20}, {20, 21}}


This of course is not yet production code. I just wanted to show you a
way of how to develop an (one) algorithm.

BTW, I haven't show that it is correct!


--
Hartmut Wolf


  • Prev by Date: Re: Integrating a complicated expression involving Sign[...] etc.
  • Next by Date: Converting from string to integer
  • Previous by thread: Re: removing sublist . Again and Different
  • Next by thread: a conflicting StringReplace