cpactive.pas

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

{$I CPDIR.INC}


unit cpactive;

{
   Holds info on currently active leaves, outgroup, rooting, and
   ladder order.

   24 Sep 1991 Code cleaned up.
   28 Jan 1993 Bug in MakeActiveleaves fixed. Previously a simple assignment
               ALeaves = AL was used, which failed horribly.
}

interface

uses
   cpvars,
   cpset,
   cptree,
   WObjects;


type
   ACTOBJ_PTR = ^ACTIVEOBJ;
      {Pointer to [ACTIVEOBJ] }
   ACTIVEOBJ = object (TObject)
      { Activities object }
      nOLeaves : 0..MAXLEAVES;    {Original unpruned leaf count }
      ALeaves : CLUSTEROBJ; {Set of active leaves, numbered by order in input file }
      AOutgroup : CLUSTEROBJ; {Set of outgroup leaves, numbered by order in input file }
      ALadder : LADDERTYPE; {Ladder order}
      AReRoot : Boolean;{Reroot flag}
      APrune : Boolean;{Prune flag}
      nALeaves : 0..MAXLEAVES;    {Number of currently active leaves }


      constructor Load (var S: TStream);
         {Load object from stream <\b S> }
      procedure Store (var S: TStream);
         {Store object in stream <\b S> }

      function NewOutgroup (var s: CLUSTEROBJ):Boolean;
         {True if outgroup <\b s> is not the same as the current outgroup [AOutgroup] }
      procedure AdjustTree (var T:TREEOBJ);
         {Calls [FastAdjustTree] to prune and root tree <\b T>, then
          ladderizes it in [[ALadder]] order}
      procedure FastAdjustTree (var T:TREEOBJ);
         {Prune from tree <\b T> any nonactive leaves and then root
          with current outgroup (if any). Sets the tree's [fl_PRUNED] flag
          and calls the tree's [OrderLeaves] method.}
      function IthActiveLeaf (IthLeaf:integer):integer;
         {Return the <\b Ithleaf> element of [[ALeaves]]}
      function NLeavesActive:integer;
         {Return the number of active leaves}
      function IsActive (Leaf:integer):Boolean;
         {True if <\b Leaf> is in [[ALeaves]]}
      function BiggestLeaf:integer;
         {Return the highest active leaf}
      function OrigLeaves:integer;
         {Return the number of active leaves}
      procedure SetDefault (i:integer);
         {Set the defaults values of all the fields:
         [[nOLeaves]] = <\b i>
         [[nALeaves]] = <\b i>
         [[ALeaves]] = \[1..<\b i>\]
         [[AOutgroup]] = \[ \]
         [[ALadder]] = [LEFTINDEX];
         [[AReRoot]] = FALSE;
         [[APrune]]  = FALSE;
         }
      procedure SetLadder (L:LADDERTYPE);
         {Set [[ALadder]] to <\b L>}
      procedure Activeleaves (s:CLUSTER);
         {Return in <\b s> the set of active leaves}
      procedure SetOutGroup (s:CLUSTER);
         {Set the outgrpup to <\b s>}
      procedure MakeOutgroup (var OG:CLUSTEROBJ);
         { Make <\b OG> the current outgroup. The leaves in <\b OG> are
           labeled with their order in the set of currently active leaves,
           so procedure translates labels into order in input file. }
      procedure SetOptions (LV:CLUSTER; LA:LADDERTYPE;
                            RR:BOOLEAN; OG:CLUSTER);
         {Set fields to supplied values}
      procedure SetOpt (LV:CLUSTEROBJ; LA:LADDERTYPE;
                            RR:BOOLEAN; OG:CLUSTEROBJ);
         {Set fields to supplied values}         
      procedure MakeCopy (var ACopy:ACTIVEOBJ);
         {Return a copy of the object in <\b ACopy> }
      procedure Dump (var f:text);
         {Dump the object's fields to the file <\b f>}
      procedure PruneTree (var T:TREEOBJ);
         {Prune the nonactive leaves from <\b T>. Sets the tree's [fl_PRUNED] flag
          and calls the tree's [OrderLeaves] method.}
      function HavePrunedOutgroup:Boolean;
         {True if the set of active leave does not include the outgroup. }
      function Pruned (var s:CLUSTEROBJ):Boolean;
         {True if the set of active leaves is included in <\b s>}
      procedure MakeActiveLeaves (var AL: CLUSTEROBJ);
         {Makes <\b AL> the set of active leaves, sets [nALeaves] to the
         cardinality of <\b AL>, and sets the flag [APrune] if that value
         is less than [[nOLeaves]]}
      function OrderInPrunedLeaves (Leaf:integer):integer;
         {Return the relative position of <\b Leaf> in the set of active leaves}
      end;

const
  RACTIVEOBJ: TStreamRec = (
    ObjType: 106;
    VmtLink: Ofs(TypeOf(ACTIVEOBJ)^);
    Load:    @ACTIVEOBJ.Load;
    Store:   @ACTIVEOBJ.Store);
    {Registration record for ACTIVEOBJ}


implementation

   constructor ACTIVEOBJ.Load (var S: TStream);
   begin
      S.Read (nOLeaves, SizeOf(nOLeaves));
      S.Read (ALadder, SizeOf(ALadder));
      S.Read (AReRoot, SizeOf(AReRoot));
      S.Read (APrune, SizeOf(APrune));
      S.Read (nALeaves, SizeOf(nALeaves));
      ALeaves.Load (S);
      AOutgroup.Load (S);
   end;

   procedure ACTIVEOBJ.Store (var S: TStream);
   begin
      S.Write (nOLeaves, SizeOf(nOLeaves));
      S.Write (ALadder, SizeOf(ALadder));
      S.Write (AReRoot, SizeOf(AReRoot));
      S.Write (APrune, SizeOf(APrune));
      S.Write (nALeaves, SizeOf(nALeaves));
      ALeaves.Store (S);
      AOutgroup.Store (S);
   end;

   function ACTIVEOBJ.OrderInPrunedLeaves (Leaf:integer):integer;
   var
      i, j:integer;
   begin
      i := 0;
      j := 0;
      while (i <> Leaf) do begin
         Inc (i);
         if (ALeaves.IsElement (i)) then
            Inc (j);
         end;
      OrderInPrunedLeaves := j;
   end;

{-----------------------------SetDefault-----------------------------------}

   procedure ACTIVEOBJ.SetDefault(i:integer);
   begin
      nOLeaves := i;
      nALeaves := i;
      ALeaves.FullSet (nOLeaves);
      AOutgroup.NullSet;
      ALadder := LEFTINDEX;
      AReRoot := FALSE;
      APrune  := FALSE;
   end;

{-----------------------------SetLadder------------------------------------}

   procedure ACTIVEOBJ.SetLadder (L:LADDERTYPE);
   begin
      ALadder := L;
   end;

{-----------------------------ActiveLeaves---------------------------------}

   procedure ACTIVEOBJ.ActiveLeaves (s:CLUSTER);
   begin
      ALeaves.MakeSet (s);
      nALeaves := ALeaves.Cardinality;
      APrune  := (nALeaves < nOLeaves);
   end;


   procedure ACTIVEOBJ.MakeActiveLeaves (var AL: CLUSTEROBJ);
   var
      i, j: integer;
   begin
      ALeaves.NullSet;
      i := 0;
      j := 0;
      while (i < nOLeaves) do begin
         Inc (i);
         if AL.IsElement (i) then begin
            Inc (j);
            ALeaves.AddToSet (i);
            end;
         end;
      nALeaves := j;
      APrune  := (nALeaves < nOLeaves);
   end;

{-----------------------------NLeavesActive--------------------------------}

   function ACTIVEOBJ.NLeavesActive:integer;
   { no. of active leaves }
   begin
      NLeavesActive := nALeaves;
   end;

{-----------------------------OrigLeaves-----------------------------------}

   function ACTIVEOBJ.OrigLeaves:integer;
   { original no. of leaves in profile }
   begin
      OrigLeaves := nOLeaves;
   end;

{-----------------------------IsActive-------------------------------------}

   function ACTIVEOBJ.IsActive (Leaf:integer):Boolean;
   begin
      IsActive := (ALeaves.IsElement (Leaf));
   end;

{-----------------------------IthActiveLeaf--------------------------------}

   function ACTIVEOBJ.IthActiveLeaf (IthLeaf:integer):integer;
   var
      i, j: integer;
   begin
      j := 0;
      i := 0;
      while (i < IthLeaf) do begin
         Inc (j);
         if IsActive (j) then
            Inc (i);
         end;
      IthActiveLeaf := j;
   end;


{-----------------------------BiggestLeaf----------------------------------}

   function ACTIVEOBJ.BiggestLeaf:integer;
   { Largest active leaf }
   begin
      if (nOLeaves = nALeaves) then
         BiggestLeaf := nOLeaves
      else BiggestLeaf := ALeaves.LastElement;
   end;


   { Make an outgroup from OG, which contains current outgroup
     where the leaves are labeled with their order in the set of
     active leaves, so we need to convert back to original numbers.
   }
   procedure ACTIVEOBJ.MakeOutGroup (var OG:CLUSTEROBJ);
   var
       i, j: integer;
   begin
      AOutgroup.NullSet;
      i := 0;
      j := 0;
      while (j < nOLeaves) do begin
         repeat
               Inc (j);
         until ALeaves.IsElement(j);
         Inc (i);
         if OG.IsElement (i) then
            AOutgroup.AddToSet (j);
         end;
   end;

   { True if outgroup s is not the same as the current outgroup }
   function ACTIVEOBJ.NewOutgroup (var s: CLUSTEROBJ):Boolean;
   begin
      NewOutgroup := (AOutGroup.Relationship (s) <> IDENTITY);
   end;

   { True if currently active leaves are a subset of the
     set s [the set of newly choosen active leaves] }
   function ACTIVEOBJ.Pruned (var s:CLUSTEROBJ):Boolean;
   begin
      Pruned := (ALeaves.Relationship (s) = SUPERSET);
   end;

{-----------------------------SetOutgroup----------------------------------}

   procedure ACTIVEOBJ.SetOutgroup (s:CLUSTER);
   begin
      AOutGroup.MakeSet (s);
   end;

{-----------------------------SetOptions-----------------------------------}

   procedure ACTIVEOBJ.SetOptions (LV:CLUSTER; LA:LADDERTYPE; RR:BOOLEAN; OG:CLUSTER);
   { quick and dirty options setting }
   begin
      ActiveLeaves (LV);
      SetLadder (LA);
      AReRoot := RR;
      SetOutGroup (OG);
   end;

{-----------------------------SetOpt---------------------------------------}

   procedure ACTIVEOBJ.SetOpt (LV:CLUSTEROBJ; LA:LADDERTYPE;
                               RR:BOOLEAN; OG:CLUSTEROBJ);
   { quick and dirty options setting }
   begin
      ALeaves :=LV;
      nALeaves := ALeaves.Cardinality;
      APrune  := (nALeaves < nOLeaves);

      SetLadder (LA);
      AReRoot := RR;
      AOutGroup :=OG;
   end;

{-----------------------------Dump-----------------------------------------}

   procedure ACTIVEOBJ.Dump (var f:text);
   begin
      writeln (f);
      writeln (f, 'Current options');
      writeln (f, '---------------');
      writeln (f);
      if APrune  then
         writeln (f, 'Trees are pruned');
      ALeaves.ShowSet   ('     Active leaves :');
      writeln (f);
      if AReRoot then
         writeln (f, 'Reroot trees');
      AOutGroup.ShowSet ('          Outgroup :');
      writeln (f);
      write (f, '            Ladder : ');
      case ALadder of
         DEFAULT: writeln (f, 'DEFAULT');
         LEFT:    writeln (f, 'LEFT');
         RIGHT:   writeln (f, 'RIGHT');
         end;
      writeln (f);
   end;

{-----------------------------AdjustTree-----------------------------------}

   procedure ACTIVEOBJ.AdjustTree (var T:TREEOBJ);
   { Prune and root tree according to
     current settings. Checks that
     current outgroup contains at least
     one active leaf.

     Do ladderize. }
   begin
      { Prune and root }
      FastAdjustTree (T);

      { Ladderize }
      T.Ladderize (ALadder);
   end;


{-----------------------------FastAdjustTree-------------------------------}

   procedure ACTIVEOBJ.FastAdjustTree (var T:TREEOBJ);
   { Prune and root tree according to
     current settings. Checks that
     current outgroup contains at least
     one active leaf.

     To save time, doesn't reorder tree.
   }
   var
      OG_PTR: NODE_PTR;
      i: integer;
      CommonLeaves : CLUSTEROBJ;
   begin
      { Prune leaves }
      if APrune then begin
         for i := 1 to nOLeaves do
            if not ALeaves.IsElement (i) then begin
               T.PruneLeaf (i);
               end;
         T.SetFlag (fl_PRUNED, True);
         end;
      T.OrderLeaves;

      { Root using outgroup }
      if AReRoot then begin
         { Ensure that there are leaves in common to
           current set of leaves and the outgroup. }
         ALeaves.Intersection (AOutGroup, CommonLeaves);
         if not CommonLeaves.Empty then
            if T.CanReRoot (AOutGroup, OG_PTR) then
               T.ReRoot (OG_PTR);
         end;
   end;


{-----------------------------PruneTree------------------------------------}

   { Just prune leaves off tree }
   procedure ACTIVEOBJ.PruneTree (var T:TREEOBJ);
   var
      i: integer;
   begin
      { Prune leaves }
      if APrune then begin
         for i := 1 to nOLeaves do
            if not ALeaves.IsElement (i) then begin
               T.PruneLeaf (i);
               end;
         T.SetFlag (fl_PRUNED, True);
         end;
      T.OrderLeaves;
   end;

{-----------------------------MakeCopy-------------------------------------}

   procedure ACTIVEOBJ.MakeCopy (var ACopy:ACTIVEOBJ);
   begin
      ACopy.SetDefault (nOLeaves);
      ACopy.SetOpt (ALeaves,ALadder,AReRoot,AOutgroup);
   end;

{ True if pruned set of leaves "CurrentLeaves" does not
  contain the current outgroup. }
function ACTIVEOBJ.HavePrunedOutgroup:Boolean;
begin
   HavePrunedOutGroup := false;
   if not AOutgroup.Empty then
      HavePrunedOutgroup := (ALeaves.Relationship (AOutGroup) = DISJOINT);
end;

begin
   RegisterType (RActiveObj);
end.