Re: a little nasty problem?

*To*: mathgroup at smc.vnet.net*Subject*: [mg109099] Re: a little nasty problem?*From*: David Bevan <david.bevan at pb.com>*Date*: Mon, 12 Apr 2010 23:01:44 -0400 (EDT)

Francisco, My code got rather confused by the fact that your new data has multiple intervals with the same name (two A7s and two A8s). I believe that the following achieves what you want: In[]:== makeGraph[v_,f_]:==Select[Flatten[Table[i->j,{i,Length[v]},{j,Length[v]}]],f[v[[#[[1]]]],v[[#[[2]]]]]&] intCmp[{_,x_},{_,y_}]:==x[[1]]>==y[[1]]&&x[[2]]>==y[[2]]&&x!==y intLabel[z_]:==First[z] transRed[g_]:==Complement[g,#[[1,1]]->#[[2,2]]&/@Select[Tuples[g,2],#[[1,2]]====#[[2,1]]&]] showChains[v_]:==LayeredGraphPlot[Map[{intLabel[v[[#]]],#}&,transRed[makeGraph[v,intCmp]],{2}],VertexLabeling->True] growChain[s_,t_]:==Module[{u==t[[Last[s]]]},If[u===={},{s},Join[s,{#}]&/@u]] growChains[ss_,t_]:==Join@@(growChain[#,t]&/@ss) listChains[v_]:==Map[v[[#]]&,Module[{n==Length[v],g==transRed[makeGraph[v,intCmp]],s,t},s==Complement[First/@g,#[[2]]&/@g];t==Complement@@#&/@Transpose[{Map[#[[2]]&,Split[Union[g,Table[i->i,{i,n}]],First[#1]====First[#2]&],{2}],{#}&/@Range[n]}];FixedPoint[growChains[#,t]&,{#}&/@s]],{2}] In[]:== newData=={{"A1",{-0.131016043,0.387700535}},{"A2",{-0.197860963,0.336898396}},{"A3",{-0.088235294,0.569518717}},{"A4",{0.294117647,0.764705882}},{"A5",{-0.021390374,0.620320856}},{"A6",{-0.013368984,0.622994652}},{"A7",{-0.112299465,0.540106952}},{"A7",{0.072192513,0.687165775}},{"A8",{0.056149733,0.64973262}},{"A8",{-0.010695187,0.620320856}},{"A9",{0.165775401,0.700534759}},{"A10",{-0.056149733,0.569518717}},{"A11",{0.050802139,0.676470588}},{"A12",{-0.032085561,0.620320856}},{"A13",{-0.229946524,0.475935829}},{"A14",{-0.072192513,0.467914439}}}; In[]:== listChains[newData]; Map[First,%,{2}] showChains[newData] Out[]== {{A4,A9,A7,A8,A6,A5,A12,A10,A3,A7,A1,A2},{A4,A9,A7,A8,A6,A5,A12,A10,A3,A7,A13},{A4,A9,A7,A8,A6,A5,A12,A10,A14,A1,A2},{A4,A9,A7,A8,A8,A5,A12,A10,A3,A7,A1,A2},{A4,A9,A7,A8,A8,A5,A12,A10,A3,A7,A13},{A4,A9,A7,A8,A8,A5,A12,A10,A14,A1,A2},{A4,A9,A7,A11,A6,A5,A12,A10,A3,A7,A1,A2},{A4,A9,A7,A11,A6,A5,A12,A10,A3,A7,A13},{A4,A9,A7,A11,A6,A5,A12,A10,A14,A1,A2},{A4,A9,A7,A11,A8,A5,A12,A10,A3,A7,A1,A2},{A4,A9,A7,A11,A8,A5,A12,A10,A3,A7,A13},{A4,A9,A7,A11,A8,A5,A12,A10,A14,A1,A2}} David %^> ________________________________________ From: Francisco Gutierrez [fgutiers2002 at yahoo.com] Sent: 06 April 2010 12:26 To: mathgroup at smc.vnet.net Subject: [mg109099] [mg108905] Re: a little nasty problem? Dear Friends: As always, many thanks for the many kind and intelligent answers I got. However, none fully solves the problem.My fault - I committed an error, since I sent a misleadingly simple example. Attached below is a more complicated one ("Example 1"). It has various incomparable elements. The diverse codes I got fail to identify them. Take the very nice (and fast!) code of Valeri Astanoff. As shown in "Example 2" below it fails to see that "A8" and "A6" are incomparable. The other codes perform worse. Actually, I was able to produce a fix based on Valeri's code, which apparently solves the problems --but it's a bricoleur's thing, and rather messy. Let me try your patience once again, and ask you if you can find a neat solution Fg Example 1: new dataejemplo===={{"A1",{-0.131016043,0.387700535}}, {" A2 ",{-0.197860963,0.336898396}}, {" A3 ",{-0.088235294,0.569518717}}, {" A4 ",{0.294117647,0.764705882}}, {" A5 ",{-0.021390374,0.620320856}}, {" A6 ",{-0.013368984,0.622994652}}, {" A7 ",{-0.112299465,0.540106952}}, {" A7 ",{0.072192513,0.687165775}}, {" A8 ",{0.056149733,0.64973262}}, {" A8 ",{-0.010695187,0.620320856}}, {" A9 ",{0.165775401,0.700534759}}, {" A10 ",{-0.056149733,0.569518717}}, {" A11 ",{0.050802139,0.676470588}}, {" A12 ",{-0.032085561,0.620320856}}, {" A13 ",{-0.229946524,0.475935829}}, {" A14 ",{-0.072192513,0.467914439}}}; Example 2. New data processed by Valeri's code: {{{ A4 ,{0.294118,0.764706}},{ A9 ,{0.165775,0.700535}},{ A7 ,{0.0721925,0.687166}},{ A11 ,{0.0508021,0.676471}},{ A8 ,{0.0561497,0.649733}},{ A8 ,{-0.0106952,0.620321}},{ A6 ,{-0.013369,0.622995}},{ A5 ,{-0.0213904,0.620321}},{ A12 ,{-0.0320856,0.620321}},{ A10 ,{-0.0561497,0.569519}},{ A3 ,{-0.0882353,0.569519}},{ A7 ,{-0.112299,0.540107}},{ A13 ,{-0.229947,0.475936}}},{{ A4 ,{0.294118,0.764706}},{ A9 ,{0.165775,0.700535}},{ A7 ,{0.0721925,0.687166}},{ A11 ,{0.0508021,0.676471}},{ A8 ,{0.0561497,0.649733}},{ A8 ,{-0.0106952,0.620321}},{ A6 ,{-0.013369,0.622995}},{ A5 ,{-0.0213904,0.620321}},{ A12 ,{-0.0320856,0.620321}},{ A10 ,{-0.0561497,0.569519}},{ A14 ,{-0.0721925,0.467914}},{ A3 ,{-0.0882353,0.569519}},{ A7 ,{-0.112299,0.540107}},{A1,{-0.131016,0.387701}},{ A2 ,{-0.197861,0.336898}}}} --- On Wed, 3/31/10, David Bevan <david.bevan at pb.com> wrote: From: David Bevan <david.bevan at pb.com> Subject: [mg109099] [mg108905] RE: [mg108791] Re: a little nasty problem? To: "mathgroup at smc.vnet.net" <mathgroup at smc.vnet.net> Cc: "fgutiers2002 at yahoo.com" <fgutiers2002 at yahoo.com> Date: Wednesday, March 31, 2010, 5:32 PM Here's a much shorter and faster transRed[]: In[]:==== transRed[g_]:====Complement[g,#[[1,1]]->#[[2,2]]&/@Select[Tuples[g,2]== ,#[[1,2]]========#[[2,1]]&]] David %^> ________________________________________ From: David Bevan Sent: 31 March 2010 20:55 To: mathgroup at smc.vnet.net Cc: fgutiers2002 at yahoo.com Subject: [mg109099] [mg108905] RE: [mg108791] Re: a little nasty problem? Unfortunately, the Combinatorica functions seem to arbitrarily reverse the == direction of directed edges :( The following works though: In[]:==== <<GraphUtilities` makeGraph[v_,f_,lf_]:====Map[lf[v[[#]]]&,Select[Flatten[Table[i->j,{i,Lengt= h[== v]},{j,Length[v]}]],f[v[[#[[1]]]],v[[#[[2]]]]]&],{2}] intCmp[{_,x_},{_,y_}]:====x[[1]]>====y[[1]]&&x[[2]]>====y[[2]]&&x!====y intLabel[z_]:====First[z] In[]:==== intData===={{"C",{0.5,0.6}},{"D",{0.1,0.2}},{"A",{0.8,0.9}},{"B",= {0.4== ,0.6}},{"F",{0.6,0.65}},{"G",{0,0.7}}}; In[]:==== intGraph====makeGraph[intData,intCmp,intLabel] Out[]==== {C->D,C->B,A->C,A->D,A->B,A->F,A->G,B->D,F->C,F->D,F->B} In[]:==== transRed[g_]:====Module[{m====AdjacencyMatrix[g],r,n,i,j,k},r===== m;n====Len== gth[m];Do[If[m[[i,j]]!====0&&m[[j,k]]!====0 &&m[[i,k]]!====0&&(i!====j)&&(j= !====k)&&(== i!====k),r[[i,k]]====0],{i,n},{j,n},{k,n}];Rule@@#&/@Map[VertexList[g][[#]]= &,Po== sition[Normal[r],1],{2}]] In[]:==== redIntGraph====transRed[intGraph] Out[]==== {C->B,B->D,A->F,A->G,F->C} In[]:==== LayeredGraphPlot[redIntGraph,VertexLabeling->True] In[]:==== LayeredGraphPlot[transRed[makeGraph[Table[{i,Sort[{RandomInteger[= {0== ,100}],RandomInteger[{0,100}]}]},{i,20}],intCmp,intLabel]],VertexLabeling->= == True] David %^> ________________________________________ From: David Bevan Sent: 31 March 2010 13:33 To: mathgroup at smc.vnet.net Subject: [mg109099] [mg108905] RE: [mg108791] Re: a little nasty problem? The Combinatorica functions MakeGraph[] and either TransitiveReduction[] or= == HasseDiagram[] may do what you require. Then you could use LayeredGraphPlot[]. David %^> > -----Original Message----- > From: dh [mailto:dh at metrohm.com] > Sent: 31 March 2010 12:22 > To: mathgroup at smc.vnet.net > Subject: [mg108791] Re: a little nasty problem? > > Hi Francisco, > I am not sure if I understood correctly. > 1) Create a chain by starting at the highest interval and take all > intervals that a lower than the preceding one. > 2) delete the found intevalls with the exception of the highest one. > 3) repeat until only the highest one remains > > This can be done e.g. by: > > int ==== {{"C", {0.5, 0.6}}, {"D", {0.1, 0.2}}, {"A", {0.8, > 0.9}}, {"B", {0.4, 0.6}}, {"F", {0.6, 0.65}}, {"G", {0, 0== .7}}}; > alpha ==== int[[All, 1]]; > low ==== int[[All, 2, 1]];(*lower indices*) > high ==== int[[All, 2, 2]];(*upper indices*) > ord ==== Reverse@Ordering[low]; > res ==== {}; > While[Length[ord] > 1, > AppendTo[res, > FoldList[If[high[[#1]] >==== high[[#2]], #2, #1] &, First@ord, Rest@== ord] > ]; > ord ==== Prepend[Complement[ord, Union[Flatten@res]], First[ord]]; > ];(*create chains*) > res ==== res /. {x1___, x_, x_, x2___} -> {x1, x, > x2};(*remove duplicates*) > Map[alpha[[#]] &, res, {2}](*replace numbers by characters*) > > Daniel > > On 30.03.2010 12:00, Francisco Gutierrez wrote: > > Dear Mathgroup: > > Suppose I have a series of intervals, and I create an order relation. > E.g., x is a typical interval, x===={0.6,0.9}, and x>====y if x[[1]]>===== y[[1]]== and > x[[2]]>====y[[2]]. > > If x[[1]]>====y[[1]] and x[[2]]<y[[2]], or viceversa, the intervals are > incomparable. > > This relation violates [weakly] transitivity. > > Now, I have a set of intervals, and I want to create the lattice that > this order relation generates (suppose the weak violation of transitivity > does not pop up).. > > For example,int==== > {{C,{0.5,0.6}},{D,{0.1,0.2}},{A,{0.8,0.9}},{B,{0.4,0.6}},{F,{0.6,0.65}},{= == G > ,{0,0.7}}} > > > > I would like my code to put A at the top, with two chains: {A,F,C,B, D} > and {A,G}. Of course, it ought to flag any antichain if it exists. > > Now, there are several ways to do this. But what I have been able to > cook up is TERRIBLY inefficient. With 10 intervals it works no more. Is > there an efficient code to make the job? I am trying to do something that > is unfeasible? > > > > Perhaps I am naively attacking a problem that has no solution. Or > perhaps I am naively suggesting an easy problem is solvable. Some help ou= == t > there? > > Francisco > > > > > -- > > Daniel Huber > Metrohm Ltd. > Oberdorfstr. 68 > CH-9100 Herisau > Tel. +41 71 353 8585, Fax +41 71 353 8907 > E-Mail:<mailto:dh at metrohm.com> > Internet:<http://www.metrohm.com> > >