Re: a little nasty problem?
- To: mathgroup at smc.vnet.net
- Subject: [mg108801] Re: a little nasty problem?
- From: David Bevan <david.bevan at pb.com>
- Date: Thu, 1 Apr 2010 05:59:44 -0500 (EST)
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,Length[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==Length[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][[#]]&,Position[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: [mg108801] 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>
>
>