newprof.pas

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

      write (newlog, #9, s);
      m := StrPas (s);
      n := L.LocateLabel (m);
      if A.APrune then
         n := A.OrderInPrunedLeaves (n);
      x := x + [n];
      Inc (i);
      end;
   writeln (newlog);
   OG.MakeSet (x);
   Dispose (L1, Done);
   Dispose (L2, Done);
end;

{-----------------------------DumpTrees------------------------------------}

procedure BLOCK.Dumptrees (var f:text);
var
   i: integer;
   T: TREEOBJ;
begin
   for i := 1 to B.TreesStored do begin
      GetTree (i, T, false);
      T.WriteTree (f);
      T.Done;
      end;
end;

{-----------------------------Leaves---------------------------------------}

{ Return numbner of active leaves }
function BLOCK.Leaves:integer;
begin
   Leaves := A.nALeaves;
end;

{-----------------------------Trees----------------------------------------}

{ Number of currently active trees in the block }
function BLOCK.Trees:integer;
begin
   Trees := B.TreesActive;
end;

{-----------------------------TotalTrees-----------------------------------}

{ Number of currently active trees in the block }
function BLOCK.TotalTrees:integer;
begin
   TotalTrees := B.TreesStored;
end;

{-----------------------------GetTree--------------------------------------}

{ Get tree TreeNumber from buffer and adjust if requested }
procedure BLOCK.GetTree (TreeNumber: integer; var Tree: TREEOBJ;
                         Adjust: Boolean);
begin
   Tree.Init;
   B.GetTree (TreeNumber, Tree);
   Tree.SetFlag (fl_ROOTED, IsFlag (pr_ROOTED));
   if Adjust then
      A.AdjustTree (Tree);
end;

{-----------------------------GetWorkTree----------------------------------}
{ Get the current tree and store in WorkTree }
procedure BLOCK.GetWorkTree;
begin
   GetTree (CurTree, WorkTree, True);
end;

{-----------------------------OriginalLeaves-------------------------------}

function BLOCK.OriginalLeaves:integer;
begin
   OriginalLeaves := A.OrigLeaves;
end;

{-----------------------------GetRange-------------------------------------}
{ Return a string representation of the currently active
  trees in the buffer.

  5 Jan 1993. Range checking added for r.
  Returns 0 if successful, otherwise -1
}
function BLOCK.GetRange (r: PChar; Maxlen : integer):integer;
const
   SAFEMARGIN = 15;
var
   First,
   Last,
   i      : integer;
   TmpStr : array[0..10] of char;
begin
   GetRange := 0;
   if (B.TreesActive = B.TreesStored) then
      StrCopy (r, '1-.')
   else begin
      r[0]  := #0;
      First := 0;
      i := 0;
      while (i < B.TreesStored) and (Strlen (r) < MaxLen + SAFEMARGIN)
         do begin
         Inc (i);
         if B.TreeIsActive (i) then begin
            if (First = 0) then
               First := i;
            Last := i;
            end
         else begin
            if (First <> 0) then begin
               StrCat (r, ' ');
               Str (First, TmpStr);
               StrCat (r,TmpStr);
               case (Last - First) of
                  0: begin end;
                  1: begin
                        StrCat (r, ' ');
                        Str (Last, TmpStr);
                        StrCat (r,TmpStr);
                     end;
                  else begin
                     StrCat (r, '-');
                     Str (Last, TmpStr);
                     StrCat (r,TmpStr);
                     end;
                  end;
               First := 0;
               end;
            end;
         end; { while }
         if (i <> B.TreesStored) then begin
            r[0] := #0;
            StrCopy (r, '1-.');
            GetRange := -1;
            end;
      end;
end;

{-----------------------------SelectTrees----------------------------------}

{ Given a string describing a range of trees,
  switch on or off the appropriate trees. Assumes that
  string is syntactically correct. }
procedure BLOCK.SelectTrees (Selection: PChar);
type
   States = (stSTART, stNUMBER, stALL, stLETTER, stRANGE, stQUIT, stDONE);
var
   sCount,
   i ,
   Low,
   High,
   Code  : integer;
   Token : array[0..10] of char;
   st    : STATES;
   curch : char;
   nMin,
   nMax  : integer;

   function NextChar:char;
   begin
     NextChar := Selection[scount];
     Inc (sCount);
   end;

   function NonSpaceChar:char;
   begin
     while (Selection[scount] = ' ') do Inc(sCount);
     NonSpaceChar := Selection[scount];
     Inc (sCount);
   end;

begin
   B.SwitchAllTreesOff;
   nMin := 1;
   nMax := B.TreesStored;

   scount := 0;
   st     := stSTART;
   curch  := NextChar;
   while (st <> stQUIT) and (st <> stDONE) do begin
      case st of
         stSTART:
            case curch of
               ' ':    curch := NonSpaceChar;
               #0      : st := stQUIT;
               '0'..'9': st := stNUMBER;
               'a'..'z',
               'A'..'Z': st := stALL;
               end;
         stALL:
             begin
                Token[0] := curch;
                Token[1] := #0;
                i := 1;
                curch := NextChar;
                while (curch in ['a'..'z','A'..'Z']) do begin
                   Token[i] := curch;
                   Inc (i);
                   Token[i] := #0;
                   curch := NextChar;
                   end;

                if (StrIComp (Token, 'all') = 0) then begin
                   st := stDONE;
                   B.SwitchAlltreesOn;
                   end
                else st := stQUIT;
             end;
         stNUMBER:
            begin
               i := 1;
               Token[0] := curch;
               Token[1] := #0;
               curch := NextChar;
               while (curch in ['0'..'9']) do begin
                  Token[i] := curch;
                  Inc (i);
                  Token[i] := #0;
                  curch := NextChar;
                  end;
               Val (Token, Low, Code);
               if (Code <> 0) or (Low < nMin) then
                  st := stQUIT
               else
                  case curch of
                     '-' : begin curch := NonSpaceChar; st := stRANGE; end;
                     #0  : begin
                              { Single number }
                              B.SwitchTreeOn (Low);
                              st := stDONE;
                           end;
                     ' ' : begin
                              { Single number }
                              B.SwitchTreeOn (Low);
                              st := stSTART;
                           end;
                     else st := stQUIT;
                     end;
            end;
         stRANGE:
            begin
            case curch of
               '.' :
                  begin
                      High := nMax;
                      curch   := NextChar;
                   end;
                '0'..'9':
                   begin
                      Token[0] := curch;
                      Token[1] := #0;
                      i := 1;
                      curch := NextChar;
                      while (curch in ['0'..'9']) do begin
                         Token[i] := curch;
                         Inc (i);
                         Token[i] := #0;
                         curch := NextChar;
                         end;
                      Val (Token, High, Code);
                      if (Code <> 0) or (High < Low) or (High > nMax) then
                         st := stQUIT;
                   end;
                else st := stQUIT;
                end;

             if (st <> stQUIT) then begin
                st := stSTART;
                { Process a range }
                for i := Low to High do
                   B.SwitchTreeOn (i);
                end;
            end;


         end; { case }
   end;
end;



{-----------------------------SetOrder-------------------------------------}

procedure BLOCK.SetOrder (Order: LADDERTYPE);
begin
   A.SetLadder (Order);
end;

{-----------------------------ShowTrees------------------------------------}

{ Draw trees in display buffer }
procedure BLOCK.ShowTrees (T1, T2:longint; Compress,
                           IncludeInActive:Boolean);
var
   i:integer;
   T:TREEOBJ;
begin
   {$IFDEF WINDOWS}
   if (Counter <> NIL) then
      Counter^.SetMeter (id_Meter, Succ (T2-T1));
   {$ENDIF}

   for i := T1 to T2 do begin
		if B.TreeIsActive (i) or IncludeInActive then begin
         write (NewLog, 'Tree ',i);
         if not B.TreeIsActive (i) then
            write (NewLog, ' (Inactive)');
         writeln (NewLog);
         GetTree (i, T, True);
         if Compress then
            T.CompressPrint (L)
         else T.Print (L);
         T.Done;
         end;

      {$IFDEF WINDOWS}
      if (Counter <> NIL) then begin
         Counter^.UpDateMeter (id_Meter, Succ(i - T1));
         if bUserAbort then begin
            ErrorRec.UpDate (erUserAbort);
            Exit;
            end;
         end;
      {$ENDIF}
      end; { for i }
end;

{-----------------------------Statistics-----------------------------------}

{ Compute tree statistics and return a histogram
  (if appropriate). }
procedure BLOCK.Statistics (var H: HISTPTR);
var
   Sourdis,
   Topol   : BOOLEAN;
   i,
   Topology: integer;
   T       : TREEOBJ;
   MakeHist:Boolean;
begin
   {$IFDEF WINDOWS}
   if (Counter <> NIL) then
      Counter^.SetMeter (id_Meter, B.TreesActive);
   {$ENDIF}

   writeln (NewLog, 'Tree information:');
   writeln (NewLog,   '   Trees in memory = ', B.treesStored);
   if (Trees < B.TreesStored) then
      writeln (NewLog,'   Trees currently active = ', B.TreesActive);
   writeln (NewLog,   '   Leaves = ', Leaves);
   if (Leaves < OriginalLeaves) then
         writeln (NewLog, '   ', OriginalLeaves - Leaves,
            ' leaves have been pruned');
   if IsFlag (pr_ROOTED) then
      writeln (NewLog, '   Trees are rooted')
   else writeln (NewLog, '   Trees are unrooted');
   if IsFlag (pr_AllBinary) then
      writeln (NewLog, '   Trees are all binary (fully resolved)');
   writeln (NewLog);

   { what can we output? }
   Sourdis := (Leaves < MaxSourdis);
   Topol   := ((IsFlag(pr_ROOTED) and (Leaves <= 15))
              or (not IsFlag (pr_ROOTED) and (Leaves <=19)));
   write (NewLog, '      ');
   if not IsFlag(pr_ALLBINARY) then
      write (NewLog, TAB, ' Internal');
   if Sourdis then
      write (NewLog, TAB, '             Sourdis');
   if Topol then
      write (NewLog, TAB, ' Topology');

   writeln (NewLog);
    write (NewLog, '  Tree');
   if not IsFlag(pr_ALLBINARY) then
      write (NewLog, TAB, '    nodes');
   if Sourdis then
      write (NewLog, TAB, '              number');
   if Topol then
      write (NewLog, TAB, '   number');

   if Sourdis and not IsFlag (pr_ALLBINARY) then
      write (NewLog, TAB, '         Resolutions');



   writeln (NewLog);
   writeln (NewLog);
   MakeHist := (Topol and (Trees > 1));
   if MakeHist then
      H := new (HISTPTR, Init (False));
   for i := 1 to B.TreesStored do
      if B.TreeIsActive (i) then begin

         {$IFDEF WINDOWS}
         if (Counter <> NIL) then begin
            Counter^.UpDateMeter (id_Meter, i);
            if bUserAbort then begin
               ErrorRec.UpDate (erUserAbort);
               { Clean up histogram }
               if MakeHist then begin
                  Dispose (H);
                  H := NIL;
                  end;
               Exit;
               end;
            end;
         {$ENDIF}

         GetTree (i, T, True);
         write (NewLog, i:6);
         if not IsFlag (pr_ALLBINARY) then
            write (NewLog, TAB, T.TreeInternals:9);
         if Sourdis then begin
            if T.IsBinary then
               write (NewLog, TAB, T.SourdisNumber:20:0)
            else
               write (NewLog, TAB, '                   -');
            end;
         if Topol then begin
            T.Ladderize (LLR);
            if T.IsBinary then begin
               if T.IsFlag (fl_ROOTED) then
                  Topology := T.RRANK (T.Root)
               else Topology := T.CRANK (phi(T.TreeLeaves));
               if MakeHist then
                  H^.IntegerObs (Topology);
               write (NewLog, TAB, Topology:9);
               end
            else write (NewLog, TAB, '        -');
            end;

         { Rohlf's CI2 }
         if Sourdis and not IsFlag (pr_ALLBINARY) then
            write (Newlog, T.RohlfCI2:20:0);

        writeln (NewLog);
        T.Done;
        end;
   writeln (NewLog);
   if MakeHist then begin
      if (H^.nObs > 1) then begin
         writeln (NewLog);
         writeln (NewLog, 'Frequency distribution of topologies');
         writeln (NewLog);
         H^.Dof (NewLog);
         end
      else begin
         Dispose (H);
         H  := NIL;
         end;
      end;
end;

{-----------------------------NewSelfCompare-------------------------------}

   { Compare each active tree in profile with every other
     tree. Ensures matrix will fit on paper/screen.

     For example:

     Matrix                Matrix into bands

     谀哪哪目