newprof.pas

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

            if bUserAbort then begin
               ErrorRec.UpDate (erUserAbort);
               RemoveDuplicates := j;
               Exit;
               end;
            end;
         {$ENDIF}
         end; { for i }
      DupBuffer^.Done;
      Freemem (DupBuffer, SizeOf (TREEBUF));
      writeln (newlog);
      writeln (newlog, j, ' trees were duplicates of other trees.');
      RemoveDuplicates := j;

      { Adjust binary flag }
      SetFlag (pr_AllBinary, (B.TreesActive = k));
      end;
end;

{-----------------------------GetCurRange----------------------------------}

{ For a distributon block return the range of the currently
  active taxa. }
procedure BLOCK.GetCurRange (var CurRange:CLUSTEROBJ);
var
   i: integer;
begin
   CurRange.NullSet;
   for i := 1 to A.nOLeaves do
      if A.IsActive (i) then
         CurRange.AddSetToSet (Range[i]);
end;


{-----------------------------GetTitle-------------------------------------}

function BLOCK.GetTitle:PChar;
begin
   GetTitle := Title;
end;



{-----------------------------ClusterCleanUp-------------------------------}

procedure BLOCK.ClusterCleanUp;
begin
   if (CH <> NIL) then begin
      dispose (CH, Done);
      if (CM <> NIL) then
         dispose (CM, Done);
      end;
   CH := NIL;
   CM := NIL;
end;

{-----------------------------Clusters-------------------------------------}

procedure BLOCK.Clusters;
var
   i    : integer;
   T    : TREEOBJ;

   procedure EnterClusters (p:NODE_PTR);
   begin
      if (p <> NIL) and (BlockError = erOK) then begin
         if not p^.IsLeaf
            and (p <> T.Root)
            then begin
            case CH^.Insert (p^.Cluster) of
                0: begin end;
               -1: BlockError := erSetHashOverFlow;
               -2: BlockError := erNoMemory;
               end;
            end;
         EnterClusters (p^.child);
         EnterClusters (p^.sib);
         end;
   end;

begin
   BlockError := erOK;
   GetMem (CH, SizeOf (HASH_TABLEOBJ));
   if (CH = NIL) then
      BlockError := erNoMemory
   else begin
      {$IFDEF WINDOWS}
      if (Counter <> NIL) then
         Counter^.UpDateText (id_Status, 'Getting clusters');
      {$ENDIF}

      CH^.Init;
      i := 0;
      while (i < B.TreesStored) and (BlockError = erOK) do begin
         Inc (i);
         if B.TreeIsActive (i) then begin
            GetTree (i, T, True);
{            T.BuildClusters;} {Already done!}
            if not IsFlag (pr_ROOTED) then
               T.ReRoot (T.FirstLeaf);
            EnterClusters (T.Root);
            T.Done;
            {$IFDEF WINDOWS}
            { Update counter and check for user abort }
            if (Counter <> NIL) then begin
               Counter^.UpDateNumber (id_TreesRead, i);
               if bUserAbort then
                  BlockError := erUserAbort;
               end;
            {$ENDIF}
            end;
         end;
      end;
end;

{-----------------------------CompMatrix-----------------------------------}

procedure BLOCK.CompMatrix;
begin
   GetMem (CM, SizeOf (MATRIXOBJ));
   if (CM = NIL) then
      BlockError := erNoMemory
   else begin
      {$IFDEF WINDOWS}
      if (Counter <> NIL) then
         Counter^.UpDateText (id_Status, 'Compatibility matrix');
      {$ENDIF}
      CM^.Init;
      CM^.MakeMatrix (CH^);
      end;
end;

{-----------------------------GetOrder-------------------------------------}

{ Return the method used to ladder trees }
function BLOCK.GetOrder:LADDERTYPE;
begin
   GetOrder := A.ALadder;
end;

{-----------------------------GetRoot--------------------------------------}

{ Return the method used root trees }
function BLOCK.GetRoot:ROOTTYPE;
begin
   if IsFlag (pr_ROOTED) then begin
      if A.AReRoot then
         GetRoot := rOUTGROUP
      else GetRoot := rROOTED;
      end
   else GetRoot := rUNROOTED;
end;


{-----------------------------CompareTwoTrees------------------------------}

procedure BLOCK.CompareTwoTrees (T1ID, T2ID:integer; Methods:word);
var
   T1,
   T2,
   SubTree       : TREEOBJ;
   X             : CLUSTERTABLEOBJ;
   Q             : QRecord;
   minNNI,
   NNI1,
   NNI2          :integer;
   SubTreeLeaves : CLUSTEROBJ;
   i, j, Pruned  : 0..MAXLEAVES;

begin
   { Ensure }
   if (Methods = 0) then
      Exit;

   write   (NewLog, 'Comparing tree ');
   write   (NewLog, T1ID);
   write   (NewLog, ' with tree ');
   writeln (NewLog, T2ID);
   writeln (NewLog);

   {---Partitions---}
   if ((Methods and tc_Partitions) = tc_Partitions) then begin

      {$IFDEF WINDOWS}
      if (Counter <> NIL) then begin
         Counter^.UpDateText (id_Method, 'Partitions');
         if bUserAbort then begin
            ErrorRec.UpDate (erUserAbort);
            Exit;
            end;
         end;
      {$ENDIF}

      GetTree (T1ID, T1, True);
      GetTree (T2ID, T2, True);
      if not IsFlag (pr_Rooted) then begin
         T1.ReRoot (T1.FirstLeaf);
         T2.ReRoot (T2.FirstLeaf);
         end;
      X.Init (T1.TreeLeaves);
      X.Build (T1);
      writeln (NewLog, 'Partition metric');
      writeln (NewLog);
      writeln (NewLog, '   d(',T1ID,',',T2ID,') = ', X.Distance (T2));
      writeln (NewLog);
      T1.Done;
      T2.Done;
      end;

   {---Triplets---}
   if ((Methods and tc_Triplets) = tc_triplets) then begin

      {$IFDEF WINDOWS}
      if (Counter <> NIL) then begin
         Counter^.UpDateText (id_Method, 'Triplets');
         if bUserAbort then begin
            ErrorRec.UpDate (erUserAbort);
            Exit;
            end;
         end;
      {$ENDIF}

      GetTree (T1ID, T1, True);
      GetTree (T2ID, T2, True);
      CompareT (T1, T2, Q);
      writeln (NewLog, 'Triplets');
      writeln (NewLog);
      QRecHeader (3);
      write (NewLog, '   ');
      ShowQRecord (Q);
      writeln (NewLog);
      T1.Done;
      T2.Done;
      end;

   {---Quartets---}
   if ((Methods and tc_Quartets) = tc_Quartets) then begin
      {$IFDEF WINDOWS}
      if (Counter <> NIL) then begin
         Counter^.UpDateText (id_Method, 'Quartets');
         if bUserAbort then begin
            ErrorRec.UpDate (erUserAbort);
            Exit;
            end;
         end;
      {$ENDIF}

      GetTree (T1ID, T1, True);
      GetTree (T2ID, T2, True);
      CompareQ (T1, T2, Q);
      writeln (NewLog, 'Quartets');
      writeln (NewLog);
      QRecHeader (3);
      write (NewLog, '   ');
      ShowQRecord (Q);
      writeln (NewLog);
      T1.Done;
      T2.Done;
      end;

   {---Nearest neighbor interchanges---}
   if ((Methods and tc_NNI) = tc_NNI) then begin

      {$IFDEF WINDOWS}
      if (Counter <> NIL) then begin
         Counter^.UpDateText (id_Method, 'NNI');
         if bUserAbort then begin
            ErrorRec.UpDate (erUserAbort);
            Exit;
            end;
         end;
      {$ENDIF}

      minNNI := MAXINT;
      for j := 1 to Leaves do begin
         GetTree (T1ID, T1, True);
         GetTree (T2ID, T2, True);
         NNI1 := DRA (T1, T2, j);

         {$IFDEF WINDOWS}
         if (Counter <> NIL) then begin
            Counter^.PassOnMsg;
            if bUserAbort then begin
               ErrorRec.UpDate (erUserAbort);
               Exit;
               end;
            end;
         {$ENDIF}
         GetTree (T1ID, T1, True);
         GetTree (T2ID, T2, True);
         NNI2 := DRA (T2, T1, j);
         NNI2 := min (NNI1, NNI2);
         minNNI := min (minNNI, NNI2);

         {$IFDEF WINDOWS}
         if (Counter <> NIL) then begin
            Counter^.PassOnMsg;
            if bUserAbort then begin
               ErrorRec.UpDate (erUserAbort);
               Exit;
               end;
            end;
         {$ENDIF}
         end;

      writeln (NewLog,'Nearest neighbour interchanges (NNI)');
      writeln (NewLog);
      writeln (NewLog, '   dus(',T1ID,',',T2ID,') = ', minNNI);
      writeln (NewLog);
      end;

   {---Greatest agreement subtree---}
   if ((Methods and tc_Subtree) = tc_SubTree) then begin

      {$IFDEF WINDOWS}
      if (Counter <> NIL) then begin
         Counter^.UpDateText (id_Method, 'Agreement subtree');
         if bUserAbort then begin
            ErrorRec.UpDate (erUserAbort);
            Exit;
            end;
         end;
      {$ENDIF}


      if IsFlag (pr_Rooted) then begin
         { For a rooted subtree we need to first get the
           two trees }
         GetTree (T1ID, T1, True);
         GetTree (T2ID, T2, True);
         CommonRootedSubtree (T1, T2, OriginalLeaves, SubtreeLeaves);
         end
      else CommonUnRootedSubtree (B, A, T1ID, T2ID, OriginalLeaves,
                                     SubTreeLeaves);

      {$IFDEF WINDOWS}
      if (Counter <> NIL) then
         if bUserAbort then begin
            ErrorRec.UpDate (erUserAbort);
            Exit;
            end;
      {$ENDIF}

      GetTree (1, SubTree, True);
      CreateSubTree (SubTree, SubtreeLeaves, OriginalLeaves);
      Pruned :=A.nALeaves - SubTree.TreeLeaves;
      writeln (NewLog, 'Greatest agreement subtree');
      writeln (NewLog);
      writeln (NewLog, '   Leaves in subtree: ',SubTree.TreeLeaves);
      writeln (NewLog, '   Leaves pruned: ',Pruned);
      { Display pruned leaf labels }
      if (Pruned > 0) then begin
         for i := 1 to Originalleaves do
            if (A.IsActive (i) and
               not Subtreeleaves.IsElement (i)) then begin
               write (NewLog, '      ');
               writeln (NewLog, L.ReturnLabel(i));
               end;
         writeln (NewLog);
         writeln (NewLog, 'Subtree (may not be unique)');
         writeln (NewLog);
         end;
      { Subtree }
      SubTree.Print (L);
      SubTree.Done;
      writeln (NewLog);
      end;
end;

{-----------------------------CurrentLeaves--------------------------------}

{ Return the active and inactive leaf labels in the collections L1 and L2 }
procedure BLOCK.CurrentLeaves (var L1, L2: PStrCollection);
var
   i: integer;
   s: array[0..MAXLENGTH] of char;
begin
   L1 := new (PStrCollection, Init (OriginalLeaves, 1));
   L2 := new (PStrCollection, Init (OriginalLeaves, 1));
   if (L1 <> nil) and  (L2 <> nil) then begin
      for i := 1 to OriginalLeaves do begin
         { get label }
         StrPCopy (s, L.ReturnLabel(i));
         if A.ALeaves.IsElement (i) then
            L1^.Insert (Strnew (s))
         else L2^.Insert (Strnew (s));
         end;
      end;
end;

{-----------------------------UpDateCurrentLeaves--------------------------}

{ Given two collections, one with active leaves, one with deleted
  leaves, update set of active leaves. }
procedure BLOCK.UpDateCurrentLeaves (L1, L2:PStrCollection;
                                      var NewLeaves: CLUSTEROBJ);
var
   s         : PChar;
   i         : integer;
   m         : LABEL_STR;
   x         : CLUSTER;
   lmax      : integer;
   j, k, nl  : integer;
begin
   writeln (newlog,'Currently active leaves:');
   lmax := L.MaxLabelLength;
   nl := 80 div (lmax + 8);
   x := [];
   i := 1;
   while (i <= L1^.Count) do begin
      s := L1^.At(Pred(i));
      m := StrPas (s);
		x := x + [L.LocateLabel (m)];

		{output the string}
		m := PadString (m, MAXLENGTH);
		write (newlog, '   ', m);
		if (i mod 4) = 0 then
         writeln (newlog);
		Inc (i);
      end;
   writeln (newlog);
   Dispose (L1, Done);
   Dispose (L2, Done);
   NewLeaves.MakeSet (x);
end;

{-----------------------------CurrentOutgroup------------------------------}

{ Return two string collections, one with the current ingroup,
  the other with the current outgroup. }
procedure BLOCK.CurrentOutgroup (var L1, L2: PStrCollection);
var
   i: integer;
   s: array[0..MAXLENGTH] of char;
begin
   L1 := new(PStrCollection, Init (OriginalLeaves, 1));
   L2 := new(PStrCollection, Init (OriginalLeaves, 1));
   for i := 1 to OriginalLeaves do begin
      { get label }
      if (A.IsActive (i)) then begin
			StrPCopy (s, L.ReturnLabel(i));
         if A.AOutGroup.IsElement (i) then
            L2^.Insert (Strnew (s))
         else L1^.Insert (Strnew (s));
         end;
      end;
end;

{-----------------------------UserOutgroup---------------------------------}

{ Given two collections of leaf labels return the outgroup set in OG,
  and dispose of the collections. }
procedure BLOCK.UserOutgroup (L1, L2:PStrCollection;
                              var OG: CLUSTEROBJ);

var
   s: PChar;
   i: integer;
   m: LABEL_STR;
   x: CLUSTER;
   n: integer;
begin
   { Extract outgroup }
   writeln (newlog, 'Current outgroup:');
   x := [];
   i := 1;
   while (i <= L2^.Count) do begin
      s := L2^.At(Pred(i));