cpbtree.pas

生物信息学中的遗传数据分析的delphi源码。

      NL[1]^.Mark;

      { Make tree }
      NL[m]^.MakeLeft  (NL[1]);
      NL[m]^.MakeRight (NL[2]);
      Root := NL[m];
      SetLeaves (2);
      SetInternals (1);
   end;

{-----------------------------ThreeLeafTree--------------------------------}

   { Make a three leaf unrooted tree for use in generating
     unrooted trees. Call TwoLeafTree to set up NL.

          [2]--->[3]
            \
     [1]--->[m+1]
       \
       [m]
   }
   procedure BIN_TREEOBJ.ThreeLeafTree (nLeaves:integer);
   begin
      TwoLeafTree (nLeaves);
      { add third leaf }
      AddNodeBelow (NL[3], NL[3]^.anc, NL[2]);
      IncLeaves;
      IncInternals;
      { unroot tree }
      SetFlag (fl_ROOTED, False);
   end;




{-----------------------------AnyTwoLeafTree-------------------------------}

   {
      Allocate n leaves and n-1 internals, make nodes m,...,m+n
      ancestors of leaves 1,..,n, and those leaves are
      left desc of the nodes, i.e.:



      1  2  3  ...   n
      .  .           .
      .  .           .
      m  m m+1     m+n-2


      and create 2-tree from any of the two leaves (not necessarly
      1 and 2):

         NL[L1]--s-->NL[L2]
           \.      .
            \a    a
             c.  .
              \..
              NL[m]
               .
               .
               .
               =

   }
   procedure BIN_TREEOBJ.AnyTwoLeafTree (nleaves, L1, L2:integer);
   var
      i, m: integer;
   begin
      AllocateNodeList (Pred (2 * nleaves));
      m := nleaves;

      for i := 1 to nleaves do
         if (i <> L1) then begin
            Inc (m);
            NL[i]^.MakeAnc (NL[m]);
            NL[m]^.MakeLeft (NL[i]);
            NL[i]^.SetLeaf;
            NL[i]^.SetNamePtr(i);
            NL[i]^.SetLeafNum(i);
            NL[i]^.Mark;
            NL[m]^.SetNamePtr (m);
            NL[m]^.Mark;
            end;

      NL[L1]^.SetLeaf;
      NL[L1]^.MakeAnc (NL[L2]^.anc);
      NL[L1]^.SetNamePtr (L1);
      NL[L1]^.SetLeafNum (L1);
      NL[L1]^.Mark;

      { Make tree }
      NL[L1]^.anc^.MakeLeft  (NL[L1]);
      NL[L1]^.anc^.MakeRight (NL[L2]);
      Root := NL[L1]^.anc;
      SetLeaves (2);
      SetInternals (1);
   end;


{-----------------------------AnyThreeLeafTree-----------------------------}

   { Make a three leaf unrooted tree for use in generating
     unrooted trees. The three start leaves can be
     any of the nLeaves in the tree.

          [L2]--->[L3]
            \
     [L1]--->[m+1]
       \
       [m]
   }
   procedure BIN_TREEOBJ.AnyThreeLeafTree (nLeaves, L1, L2, L3:integer);
   begin
      AnyTwoLeafTree (nLeaves, L1, L2);

      { add third leaf }
      AddNodeBelow (NL[L3], NL[L3]^.anc, NL[L2]);
      IncLeaves;
      IncInternals;

      { unroot tree }
      SetFlag (fl_ROOTED, False);
   end;


{-----------------------------RandomRooted--------------------------------}

   { Generate a random, rooted, labeled binary tree from a
     uniform distribution. }
   procedure BIN_TREEOBJ.RandomRooted (var U:UNIFORM; n:integer);
   var
      i, edges: integer;
      place : 1..MAXNODES;
   begin
      Init;
      TwoLeafTree (n);
      for i := 3 to n do begin
         { number of edges in current tree }
         edges := TreeLeaves + TreeInternals;
         { edge to add leaf i to }
         place := U.RandInteger (1,edges);
         if (place > Pred(i)) then
            { place is an internal edge }
            place := (place - Pred(i)) + n;
         AddNodeBelow (NL[i], NL[i]^.anc, NL[place]);
         IncLeaves;
         IncInternals;
         end;
   end;

{-----------------------------RandomUnRooted-------------------------------}

   { Generate a random, unrooted, labeled binary tree from
     a uniform distribution.

     The convention adopted is that leaves are added to
     all but two nodes, [1] and [root]:


     [1]  2   3
       \   \ /
        \   *
         \ /
        [root]


     Thus the trees generated are of the form (1,(.....));
   }
   procedure BIN_TREEOBJ.RandomUnrooted (var U:UNIFORM; n:integer);
   var
      i, edges: integer;
      place : 1..MAXNODES;
   begin
      Init;
      ThreeLeafTree (n);
      for i := 4 to n do begin
         { number of edges in current tree }
         edges := TreeLeaves + TreeInternals - 2;
         { edge to add leaf i to }
         place := U.RandInteger (2,Succ(edges));
         if (place > Pred(i)) then
            { place is an internal edge }
            place := (place - Pred(i)) + n + 1;
         AddNodeBelow (NL[i], NL[i]^.anc, NL[place]);
         IncLeaves;
         IncInternals;
         end;
   end;


   { Generate a random unlabeled rooted binary tree with the toplogy
     drawn from the Markovian distribution (= stripped dendrogram).
   }
   procedure BIN_TREEOBJ.UnlabeledMarkovian (var U:UNIFORM;n:integer);
   var
      i, place     : 0..MAXLEAVES;
   begin
      Init;
      TwoLeafTree (n);
      for i := 3 to n do begin
         { choose leaf to add next leaf to }
         place := U.RandInteger (1, Pred(i));
         AddNodeBelow (NL[i], NL[i]^.anc, NL[place]);
         IncLeaves;
         IncInternals;
         end;
   end;



{-----------------------------ReRootAt-------------------------------------}

{ Reroot tree using Outgroup and return the previous "outgroup:"

  1  2  3       3   1  2
  \   \/         \   \/
   \  /    ->     \  /
    \/             \/

  Outgroup=3    ReRoot=1
}
function BIN_TREEOBJ.ReRootAt (Outgroup:NODE_PTR):NODE_PTR;
var
   Other,
   OutAnc,
   NextNode,
   NextNodeDesc : NODE_PTR;
begin
   if (Outgroup <> NIL) and (Outgroup^.anc <> Root) then begin
      OutAnc := Outgroup^.anc;
      if (Outgroup = OutAnc^.leftdesc) then
         Other := OutAnc^.rightdesc
      else Other := OutAnc^.leftdesc;
      while (OutAnc <> Root) do begin
         NextNode := OutAnc^.anc;
         if (OutAnc = NextNode^.rightdesc) then
            NextNodeDesc := NextNode^.leftdesc
         else NextNodeDesc := NextNode^.rightdesc;
         RemoveNode (NextNodeDesc);
         AddNodeBelow (NextNodeDesc, NextNode, Other);
         Other := NextNodeDesc;
         end; { while }
      ReRootAt := Other;
      end
   else ReRootAt := NIL;
end;


{==========================================================================}
{**********************}
{                      }
{  Utility procedures  }
{                      }
{**********************}



   {---DENDROGRAM---}

   constructor DENDROGRAM.Init;
   begin
      BIN_TREEOBJ.Init;
   end;

   destructor DENDROGRAM.Done;
   begin
      BIN_TREEOBJ.Done;
   end;

{==========================================================================}
{**********************}
{                      }
{  Utility procedures  }
{                      }
{**********************}



   constructor ALLTREES.Init (n:integer; LPtr: LABELOBJ_PTR);
   begin
      L := LPtr;
      Size := n;
      Error := erOK;
   end;

   destructor ALLTREES.Done;
   begin
   end;

   function ALLTREES.TreeOK:Boolean;
   begin
      TreeOK := True;
   end;

   procedure ALLTREES.TreeOp;
   begin
      T.WriteTree (output);
   end;


   procedure ALLTREES.MakeTrees (MakeRooted:Boolean);

      procedure AddTraverse (There, Leaf:NODE_PTR);
      begin
         if (There <> NIL) and (Error = erOK) then begin
            T.AddNodeBelow (Leaf, Leaf^.NodeAncestor, There);
            T.IncLeaves;
            T.IncInternals;
            if TreeOK then
               if (T.TreeLeaves < Size) then begin
                  if MakeRooted then
                     AddTraverse (T.Root, T.NL[Succ(T.TreeLeaves)])
                  else AddTraverse (T.Root^.child^.sib, T.NL[Succ(T.TreeLeaves)])
                  end
               else TreeOp;
            T.RemoveNode (Leaf);
            T.DecLeaves;
            T.DecInternals;
            AddTraverse (There^.NodeChild, T.NL[Succ(T.TreeLeaves)]);
            AddTraverse (There^.NodeSibling,T.NL[Succ(T.TreeLeaves)] );
            end;
      end;

   begin
      T.Init;
      if MakeRooted then begin
         T.TwoLeafTree (Size);
         AddTraverse (T.Root, T.NL[3])
         end
      else begin
         T.ThreeLeafTree (Size);
         AddTraverse (T.Root^.Child^.sib, T.NL[4])
         end;
      T.Done;
   end;




begin
end.