Mathematica 9 is now available
Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2007

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

Search the Archive

Re: Tally[ ] and Union[ ]

  • To: mathgroup at smc.vnet.net
  • Subject: [mg83395] Re: [mg83367] Tally[ ] and Union[ ]
  • From: DrMajorBob <drmajorbob at bigfoot.com>
  • Date: Mon, 19 Nov 2007 06:17:05 -0500 (EST)
  • References: <18041847.1195406295111.JavaMail.root@m35>
  • Reply-to: drmajorbob at bigfoot.com

There is, apparently, something wrong with Tally, but your test wasn't the  
right one, since cgraph's 5th and 10th elements were not returned in the 
Tally results. Here's a modification of your code and some tests:

Needs["Combinatorica`"];
diagrams::usage = "Calculate diagrams";
basicedges::usage;

wick[a_, b_] := pair[a, b];
wick[a_, b__] :=
   Sum[Expand[pair[a, {b}[[i]]] Delete[Unevaluated[wick[b]], i]], {i,
     Length[{b}]}];
ham[n_Integer] := (ns = 4*n - 3; {c[ns], c[ns + 1], d[ns + 2],
     d[ns + 3]});
basicedges[n_] :=
   Flatten[Table[{{{i, i + 1}, EdgeColor -> Red}}, {i, 1, 2*n, 2}],
    1];
hamserie[n_Integer] := Flatten[Table[ham[i], {i, n}]];
cvertices[n_Integer] := {{n, 1}, {n, 0}};
cvertexserie[n_Integer] := Flatten[Table[cvertices[i], {i, n}], 1];
pair[c[_], c[_]] := 0;
pair[d[_], d[_]] := 0;
pair[a_Integer, b_Integer] /; (a > b) := pair[b, a];

diagrams[n_] :=
   Module[{wickli, rep, i, cgraph, cvertices, congraph, le, un, ta},
    wickli = wick[Sequence @@ hamserie[n]] /. Plus -> List;
    le = Length[wickli[[1]]];
    wickli =
     wickli /. {pair[c[i_], d[j_]] -> pair[i, j],
       pair[d[i_], c[j_]] -> pair[i, j]};
    graph = {};
    While[wickli =!= {},
     wickli = rempar[First[wickli], wickli, n, le]];
    (*edge reduction and edgelist construction for use by \
Combinatorica*)
    rep = Dispatch[
      Flatten[Table[{Rule[2*i - 1, i], Rule[2*i, i]}, {i, 2*n}]]];
    graph = (Take[#, -le] /. rep /. pair[a__]^_ -> pair[a]) & /@
      graph;
    be = basicedges[n];
    cgraph = Map[List, (graph /. {pair -> List, Times -> List}), {2}];
    cvertices = List /@ cvertexserie[n];
    cgraph = Join[be, #] & /@ cgraph;
    cgraph = Graph[#, cvertices] & /@ cgraph;
    (*Now I compare Union and Tally*)
    saved = cgraph;
    un = Union[cgraph, SameTest -> IsomorphicQ];
    Print["Union: number of elements: ", Length[un]];
    Print[GraphicsGrid[
      Partition[ShowGraph[#] & /@ un, 3, 3, {1, 1}, {}]]];
    ta = Sort@Tally[cgraph, IsomorphicQ][[All, 1]];
    Print["Tally: Number of Elements: ", Length[ta]];
    Print[GraphicsGrid[Partition[ShowGraph /@ ta, 3, 3, {1, 1}, {}]]];
    Print[GraphicsGrid[
      Partition[ShowGraph /@ ta[[{2, 4}]], 3, 3, {1, 1}, {}]]];
    Print["Are 2 and 4 isomorphic? ", IsomorphicQ[ta[[2]], ta[[4]]]];
    Print["Are 4 and 2 isomorphic? ", IsomorphicQ[ta[[4]], ta[[2]]]];
    ];

rempar[li_, wickli_List, n_Integer, le_] :=
   Module[{lis, mult, gem, pre, i}, lis = {Take[li, -le]};
    pre = Drop[li, -le];
    Do[lis = Join[lis, lis /. {i -> i + 1, i + 1 -> i}], {i, 1,
      4*n - 1, 2}];
    lis = Union[lis];
    mult = Length[lis];
    graph = Join[graph, {li*mult}];
    Complement[wickli, pre*lis]];

diagrams[3]
Union: number of elements: 8
Tally: Number of Elements: 11
Are 2 and 4 isomorphic? True
Are 4 and 2 isomorphic? True

saved // Length
index = Thread[saved -> Range@Length@saved];
(u = Union[saved, SameTest -> IsomorphicQ]) // Length
(t = Sort@Tally[saved, IsomorphicQ][[All, 1]]) // Length

21

8

11

These are the cgraph indices returned by Union and Tally:

u /. index
t /. index

{1, 11, 4, 21, 8, 18, 15, 6}

{1, 11, 4, 2, 8, 14, 3, 18, 15, 7, 6}

Comparing cgraph[[5]] and cgraph[[10]] is irrelevant, as you can see.

(boo = Boole@Outer[IsomorphicQ, t, t, 1]) // MatrixForm;
boo == Transpose@boo
Cases[Position[boo, 1], {a_, b_} /; a < b, 1]

True

{{2, 4}, {5, 7}, {8, 10}}

boo is NOT an identity matrix, so Tally did something very odd.

Bobby

On Sun, 18 Nov 2007 03:53:16 -0600, Michael Weyrauch  
<michael.weyrauch at gmx.de> wrote:

> Hello,
>
> in the  Mathematica 6.0 documentation it says in the entry for Tally: 
> Properties and Relations:
>
> "A sorted  Tally is equivalent to a list of counts for the  Union:"
>
> This is what I indeed expect of Tally and Union, in particular then it
> holds for any list:
> Length[Tally[list]]    is equal to     Length[Union[list]].
>
> Now, I have an example, where Mathematica 6.0 produces a result where
> Tally[list] and Union[list] are different in length, which surprises me.
> And in fact,  the result of Tally[ ] seems wrong to me.
>
> You can reproduce this result using the small Mathematica package   
> enclosed, which
> uses Combinatorica.  (Sorry for the somewhat complicated example, but I  
> did not find
> a simpler case showing the effect.)
>
> If you load this package into a notebook and then execute
>
> diagrams[2]
>
> Tally and Union produce the expected result: both lists have equal  
> length.
> (The list elements are diagrams.)
>
> However, if you execute
>
> diagrams[3]
>
> Tally and Union produce lists of different length.
>
> To my opinion,  it really should never happen that Tally and Union
> produce lists of different length. I just expect of Tally to tell me the  
> multpilicities in the equivalence classes, in addition to
> the information produced by Union.  (The two list to be compared are  
> called "ta" and "un" in the package  enclosed.)
>
> Strangely enough, the program compares list elements 5 and 10  
> explicitly, and comes to the
> conclusion that element 5 and 10 belong to the same equivalence class, 
> nevertheless they are
> both listed seperately in the Tally, but - correctly - lumped up  in the  
> Union.
>
> Do I misinterpret something here or is there a bug in Tally?  (Tally is  
> new in Mathematica 6, and I
> would find it extremely useful, if it would do what I expect it to do.)
>
> Michael
>
> Here comes my little package in order to reproduce the effect....
>
> BeginPackage["wick`"]
>
> Needs["Combinatorica`"];
> diagrams::usage="Calculate diagrams";
> basicedges::usage;
>
> Begin["`Private`"]
>
> wick[a_, b_] := pair[a, b];
> wick[a_, b__]:= Sum[Expand[pair[a, {b}[[i]]]  
> Delete[Unevaluated[wick[b]], i]], {i, Length[{b}]}];
> ham[n_Integer]:=(ns=4*n-3;{c[ns],c[ns+1],d[ns+2],d[ns+3]});
> basicedges[n_]:=Flatten[Table[{{{i,i+1},  EdgeColor->Red}},  
> {i,1,2*n,2}],1];
> hamserie[n_Integer]:=Flatten[Table[ham[i],{i,n}]];
> cvertices[n_Integer]:={{n,1},{n,0}};
> cvertexserie[n_Integer]:=Flatten[Table[cvertices[i],{i,n}],1];
> pair[c[_],c[_]]:=0;
> pair[d[_],d[_]]:=0;
> pair[a_Integer,b_Integer]/;(a>b):=pair[b,a];
>
> diagrams[n_]:=Module[{wickli, rep, i, cgraph, cvertices, congraph, le,  
> un, ta},
>
>   wickli=wick[Sequence@@hamserie[n]]/.Plus->List;
>   le=Length[wickli[[1]]];
>   wickli=wickli/.{pair[c[i_],d[j_]]->pair[i,j],
>                   pair[d[i_],c[j_]]->pair[i,j]};
>   graph={};
>   While[wickli=!={},
>         wickli=rempar[First[wickli],wickli,n, le]];
>
>   (*edge reduction and edgelist construction for use by Combinatorica*)
>   rep=Dispatch[Flatten[Table[{Rule[2*i-1,i],Rule[2*i,i]},{i,2*n}]]];
>   graph=(Take[#,-le]/.rep/.pair[a__]^_->pair[a])&/@graph;
>
>   be=basicedges[n];
>   cgraph=Map[List,(graph/.{pair->List, Times->List}),{2}];
>   cvertices=List/@cvertexserie[n];
>   cgraph=Join[be,#]&/@cgraph;
>   cgraph=Graph[#,cvertices]&/@cgraph;
>
>   (* Now I compare Union and Tally *)
>   un=Union[cgraph,SameTest->IsomorphicQ];
>   Print["Union: number of elements: ", Length[un]];
>   Print[GraphicsGrid[Partition[ShowGraph[#]&/@un, 3,3,{1,1},{}]]];
>
>   ta=Tally[cgraph,IsomorphicQ];
>   ta=Sort[ta];
>   Print["Tally: Number of Elements: ", Length[ta]];
>   Print[GraphicsGrid[Partition[ShowGraph[#]&/@(First/@ta),  
> 3,3,{1,1},{}]]];
>
>   Print["Are 5 and 10 isomorphic? ", IsomorphicQ[cgraph[[5]],  
> cgraph[[10]]]];
>
>   ];
>
> rempar[li_,wickli_List,n_Integer,le_]:=Module[{lis, mult, gem,  pre, i},
>   lis={Take[li,-le]}; pre=Drop[li,-le];
>   Do[lis=Join[lis,lis /. {i->i+1, i+1->i}], {i,1,4*n-1,2}];
>   lis =Union[lis];
>   mult=Length[lis];
>   graph=Join[graph,{li*mult}];
>   Complement[wickli,pre*lis]
> ];
>
> End[];
> EndPackage[];
>
>
>
>
>
>
>



-- 

DrMajorBob at bigfoot.com


  • Prev by Date: Re: data structures in Mathematica
  • Next by Date: Re: Basic Question about Mathematica
  • Previous by thread: Tally[ ] and Union[ ]
  • Next by thread: NAntiDerivative function for using NDSolve to compute antiderivatives