newprof.pas

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

{*******************************************************************
*                                                                  *
*  COMPONENT for MS DOS and Windows source code.                   *
*                                                                  *
*  (c) 1992, Roderic D. M. Page                                    *
*                                                                  *
*  Language: Turbo Pascal (Pascal with object-oriented extensions) *
*  Compiler: Turbo Pascal 6.0 (MS DOS)                             *
*            Turbo Pascal for Windows 1.0 (WINDOWS)                *
*                                                                  *
*  Notes:    Program interface is currently Windows specific.      *
*                                                                  *
*******************************************************************}

{*

  Revised profile data structure that treats file as a series of blocks
  0..MAXBLOCKS with the TREES block as block 0. This will allow taxon and
  area cladograms to be treated equally, and for the whole file to be saved
  as a project.



  History
  =======

   3 Jun 1992 Begun.
   5 Jun ALL and RANDOM commands added.
  23 Jul 1992 Bug found in Maptrees when analysing Pete Lahanas' data.
              Would not compute losses correctly due to silly error
              involving overwriting of tn_MARKED flags in nodes.
  10 Aug 1992 Bug when saving the profile. If area cladograms had been
              calculated then blk_TREES flag wasn't set so the TAXA
              block was written as a DISTRIBUTION block. Also, same
              problem occurred as blk_TAXA flag wasn't used to determine
              which kind of labels to write.
  28 Oct 1992 Duplicated nodes due to redundancy are now flagged.
  30 Oct 1992 Bug fix: if the index of an area was > than the number of
              areas occupied by taxon then complete range would not be
              written in RANGE command.
   2 Nov 1992 Bug found when computing new host trees and already had host
              trees. After old trees were disposed B.Init was not called so
              that old values for Trees_Active, etc were still set. This was
              detected when strict consensus tree did not contain any
              clusters even when most cluster occurred in all the trees.
  21 Dec 1992 RemoveDuplicates method added to support.
   5 Jan 1993 RemoveDuplicates automatically checks for binary trees.
              Bug in GetRange fixed (if lots of trees then range string
              would overflow causing UAE).
   7 Jan 1993 Fiendishly difficult bug fixed. Program would detect errors
              within trees and halt OK, but errors caused between trees,
              such as mixing TREE and UTREE or no ENDBLOCK were not flagged,
              eventaully resulting in UAE. Cause was my utter stupidity in
              giving the same name to local error variables in BLOCK and
              PROFILE. If a with statement was used then all Error :=
              statements referred to BLOCK.Error not PROFILE.Error. Hence
              PROFILE.Error was still erOK. Fixed by renaming BLOCK.Error
              BLOCK.BlockError.
  26 Jan 1993 Load and Store methods added so objects are streamable.
  27 Jan 1993 Load an store improved, message box now informs user when
				  heuristic search exceeds 1000 trees.

	14 Jun 1993 Import method added
*}

{$I CPDIR.INC}      { Compiler directives }

unit NewProf;

interface

uses
   WinDos,
   WinTypes,
   WinProcs,
   WinCrt,
	{$IFDEF BWCC}    	{ use Borland-style dialogs }
   BWCC,
   {$IFDEF VER10}   	{ TPW 1.0 }
   WObjectB,
   StdDlgsB,
   {$ELSE}				{ TPW 1.5}
   WObjects,
   StdDlgs,
	{$ENDIF} {VER10}
	{$ELSE}           { standard dialogs }
	WObjects,
   StdDlgs,
	{$ENDIF} {BWCC}
	Strings,
   cpheader,        { resource ids }
   cpwcdial,        { counter dialog box }
   cpwbase,         { base object }
   cpmem,           { memory error handle }
	cpwbuf,          { display buffer }
   cputil,          { utility routines }
   cpstream,        { stream }
   cperror,         { errors }
   cpvars,          { global variables }
   cpwvars,         { variables }
   cptree,          { tree objects }
   cpbtree,         { binary tree objects }
   cprtree,         { random trees }
   cpactive,        { ACTIVEOBJ }
   cplabels,        { LABEL_OBJ }
   cpwntbuf,        { TREE_BUFFEROBJ }
   cpwsbuf,         { TREEBUF }
   cplex,           { LEXOBJ }
   cpnex,           { NEXUSOBJ }
   cpfile,          { file operations }
   cptread,         { TREADOBJ }
   cpwrite,         { TWRITEOBJ }
   cpimp2,          { import object }
   cpset,           { CLUSTEROBJ }
   cphset,          { }
   cpclique,        { }
   cphist,          { histogram }
   cpplot,          { Plot dialog }
   cpwperm,         { permutations }
   cpwrand,         { uniform random number generator }
   cpenc,           { triplets and quartets }
   cptable,         { cluster table }
   cpnni,           { nni }
   cpagree,         { agreement subtree }
   cpwdlg;          { dialog box }

const
	MAXBLOCKS = 10;

	{ flags }
	pr_ROOTED        = $0001;
	pr_IMPORTED      = $0002;
	pr_ALLBINARY     = $0004;
	pr_MODIFIED      = $0008;
	pr_IMPORTONLY		= $0010;

	{ NEXUS block flags }
	blk_TAXA         = $0010;
	blk_TREES        = $0020;
   blk_DISTRIBUTION = $0040;
   blk_BOTHTANDD    = blk_TREES or blk_DISTRIBUTION;

   { source flags }
   pr_RANDOM        = $0100;
   pr_ALL           = $0200;

type
   MODELTYPE = (NONE, EQUIPROBABLE, MARKOVIAN, UNLABELED);
      {Kinds of models for generating random trees }
   ROOTTYPE  = (rNONE, rROOTED, rUNROOTED, rOUTGROUP);
      {Kinds of rooting}
   RANDOMREC = record
      {Information used to generate random trees }
      Model  : MODELTYPE; {Model used}
      Seed   : longint;   {Seed for random number generator}
      ntrees : integer;   {Number of trees to generate}
      ntaxa  : integer;   {Number of leaves in trees}
      Root   : ROOTTYPE;  {Kind of rooting used}
      end;

   MAPREC = record
      DupCount,
      TotalLeaves,
      LeavesAdded,
      Losses : integer;
      end;

   RANGES =  array[1..MAXNODES] of CLUSTEROBJ;

   SWAPMETHODS = (NOSWAP, NNISWAP, SPRSWAP);
	CRITERIA     = (DUPLICATIONS, ADDED, LOSSES);
   MAKETREEREC = record
      AllBlocks : Boolean;
		Criterion : CRITERIA;
      Method    : SWAPMETHODS;
      end;


   { An individual "block" of trees and labels }
   PBLOCK = ^BLOCK;
   BLOCK = object (BASEOBJECT)
      BlockError     : integer;
      lpszInfo       : PChar;                { Information }
      Title          : array[0..128] of char;
      CurTree        : integer;              { Index of current tree }
      L              : LABEL_OBJ;            { Leaf labels }
      B              : TREE_BUFFEROBJ;       { Tree buffer }
      A              : ACTIVEOBJ;
      ntaxa          : integer;
      ntrees         : integer;
      FileFormat     : integer;
      ImportFileName : string;
      Range          : RANGES;
      TotalRange     : CLUSTEROBJ;
      OutgroupOK     : Boolean;
      CH             : HASHTABLEPTR;
      CM             : MATRIXOBJ_PTR;
      WorkTree       : TREEOBJ;
      RandInfo       : RANDOMREC;

      constructor Init;
      constructor Load (var S: TStream);
      procedure Store (var S: TStream);

      destructor Done;virtual;
		function GetTitle:PChar;
      function GetOrder:LADDERTYPE;
      function GetRoot:ROOTTYPE;
		function Leaves:integer;
      function OriginalLeaves:integer;
      function RemoveDuplicates:integer;
      function Trees:integer;
      function TotalTrees:integer;
      function WriteTrees (FName:string; Comments:PChar;
                           UserFormat:Word):Boolean;
      function ValidOutGroup (var Outgroup: CLUSTEROBJ):Boolean;
      procedure ClusterCleanUp;
      procedure Clusters;
      procedure CompareTwoTrees (T1ID, T2ID:integer; Methods:word);
      procedure CompMatrix;
      procedure CurrentLeaves (var L1, L2:PStrCollection);
      procedure CurrentOutgroup (var L1, L2: PStrCollection);
      procedure DumpTrees (var f:text);
      procedure GetCurRange (var CurRange:CLUSTEROBJ);
      function GetRange (r: PChar; Maxlen : integer):integer;
      procedure GetTree (TreeNumber: integer; var Tree: TREEOBJ;
                         Adjust: Boolean);
      procedure GetWorkTree;
      procedure NewSelfCompare (Measure:word; ShowHist:Boolean;
                                       var Hist: HISTPTR);
      procedure SaveLabels (var f:text);
      procedure SaveTrees (var f:text);

      procedure SelectTrees (Selection: PChar);
      procedure SetOrder (Order: LADDERTYPE);
      procedure SetRoot (R: ROOTTYPE);
      procedure ShowTrees (T1, T2:longint; Compress,IncludeInActive:Boolean);
      procedure Statistics (var H: HISTPTR);
		procedure UpDate (ChkBinary, ChkOutGrp: Boolean;
                        var OutGroup: CLUSTEROBJ);

      procedure UpDateCurrentLeaves (L1, L2:PStrCollection;
                                      var NewLeaves: CLUSTEROBJ);
      procedure UserOutgroup (L1, L2:PStrCollection;
                              var OG: CLUSTEROBJ);


      procedure BuildRanges (var T:TREEOBJ;
                                var SubRange, Missing: CLUSTEROBJ);

      end;

   { A complete file with multiple blocks }
   PPROFILE = ^PROFILE;
   PROFILE = object (BASEOBJECT)
      Error     : integer;
      szFileName: array[0..fsPathName] of char;
      Blocks    : array[0..MAXBLOCKS] of PBLOCK;
      nBlock    : integer;
      nCurBlock : 0..MAXBLOCKS;
      CurBlock  : PBLOCK;         { current block }
      Import    : IMPOBJ_PTR;


      SP       : STREAMOBJ_PTR;   { input stream }
      C        : NEXUS_OBJ;       { NEXUS file reader }
      TR       : TREADOBJ_PTR;    { generic tree reader }

{      RandInfo : RANDOMREC;}

		{ For tree mapping }
      Images   : array[1..MAXNODES] of integer;
      Dups     : array[1..MAXNODES] of Boolean;
      SubRange,
      Missing  : CLUSTEROBJ;
      AbsenceIsPrimitive : Boolean;
      MapWidespread      : Boolean;


      constructor Init;

      constructor Load (var S: TStream);
      procedure Store (var S: TStream);

      destructor Done;virtual;
		function AreasInCommon:integer;
		function CurTreeIsActive:Boolean;
      function GetCurTreeNum:integer;
      function LabelsInCommon (var OtherL: LABEL_OBJ):integer;
      function MaxLabelSpace (DC: HDC):integer;
      procedure AllTrees;
      procedure ClearRandInfo;
      procedure MakeBlock;
      procedure PlotCurTree (PlotDC: HDC; var PlotInfo:TPlotRec);
      procedure RandomTrees;
      procedure Read (szFName: PChar);
      procedure Save;
      procedure SaveToStream;
      procedure SetCurBlock (i:integer);
      procedure SetCurTreeNum (i:integer);

      procedure MapTrees (var SppTree, AreaTree: TREEOBJ;
                      var RA: RANGES; var MapInfo:MAPREC);
      procedure ReconcileTrees (var Spptree, AreaTree:TREEOBJ;
                             var ReconTree: FIT_TREEOBJ; var RA:RANGES;
                             var SppLabels: LABEL_OBJ);
      procedure DoReconcile (var RT: FIT_TREEOBJ);
      procedure DoDescribe (MapAllBlocks: Boolean;var H1, H2: HISTPTR);
      procedure DoPruneEach;

		procedure MakeTree(var Settings:MAKETREEREC);

		procedure ImportFile (FileName: PChar; Format: integer);
      private
      U : Uniform;

		{ File reading }
      procedure ReadAllCommand;
      procedure ReadDistributionBlock;
      procedure ReadImportCommand;
      procedure ReadImportFile;
      procedure ReadLabelsCommand;
      procedure ReadRandomCommand;
      procedure ReadRangeCommand;
      procedure ReadTaxaBlock;
      procedure ReadTranslateCommand;
      procedure ReadTrees;
      procedure ReadTreesBlock;
      procedure SetRandomGenerator;
      end;

const
  RBlock: TStreamRec = (
    ObjType: 102;
    VmtLink: Ofs(TypeOf(BLOCK)^);
    Load:    @BLOCK.Load;
    Store:   @BLOCK.Store);

const
  RProfile: TStreamRec = (
    ObjType: 103;
    VmtLink: Ofs(TypeOf(PROFILE)^);
    Load:    @PROFILE.Load;
    Store:   @PROFILE.Store);


implementation

{-----------------------------Init-----------------------------------------}

constructor BLOCK.Init;
var
   i : 1..MAXNODES;
begin
   BlockError    := erOK;
   lpszInfo := NIL;
   Title[0] := #0;
   CurTree  := 1;
   ntaxa    := 0;
   ntrees   := 0;
   B.Init;
   L.Init;
   FileFormat := frmt_STANDARD;
   Flags  := pr_ROOTED or pr_ALLBINARY;
   for i := 1 to MAXNODES do
      Range[i].NullSet;
   TotalRange.NullSet;
   OutgroupOK := False;
   CH := NIL;
   CM := NIL;
end;
{-----------------------------Load-----------------------------------------}
constructor BLOCK.Load (var S: TStream);
var
   lpsz: PChar;
   i : integer;
begin
   if (S.Status = 0) then B.Load (S);
   if (S.Status = 0) then L.Load (S);
   if (S.Status = 0) then A.Load (S);
   lpszInfo := S.StrRead;
   lpsz := S.StrRead;
   if (lpsz <> NIL) then
      StrCopy (Title, lpsz)
   else Title[0] := #0;
   if (S.Status = 0) then S.Read (Flags, SizeOf (Flags));
   if (S.Status = 0) then S.Read (OutgroupOK, SizeOf (OutgroupOK));
   if (S.Status = 0) then S.Read (RandInfo, SizeOf (RandInfo));
   for i := 1 to A.nOLeaves do
      Range[i].Load (S);
   CH := NIL;
   CM := NIL;
end;
{-----------------------------Store----------------------------------------}
procedure BLOCK.Store (var S: TStream);
var
   i: integer;
begin
   B.Store (S);
   L.Store (S);
   A.Store (S);
   S.StrWrite (lpszInfo);
   S.StrWrite (Title);
   S.Write (Flags, SizeOf (Flags));
   S.Write (OutgroupOK, SizeOf (OutgroupOK));
   S.Write (RandInfo, SizeOf (RandInfo));
   for i := 1 to A.nOLeaves do
      Range[i].Store (s);
end;

{-----------------------------Done-----------------------------------------}

destructor BLOCK.Done;
begin
   StrDispose (lpszInfo);
   B.Done;
   L.Done;

   { Default values }
   Flags := pr_ROOTED or pr_AllBinary;
end;


function BLOCK.RemoveDuplicates:integer;
{ Inactive any active tree that duplicates an already existing tree and
  return the number of trees removed, else -1 if unable to allocate memory. }
var
   DupBuffer : PTREEBUF;
   i         : integer;
   T         : TREEOBJ;
   k, j         : integer;
begin
   GetMem (DupBuffer, SizeOf (TREEBUF));
   if (DupBuffer = NIL) then
      RemoveDuplicates := -1
   else begin
      DupBuffer^.Init (B.TreesActive);
      {$IFDEF WINDOWS}
      if (Counter <> NIL) then
         Counter^.SetMeter (id_Meter, B.TreesStored);
      {$ENDIF}

      j := 0;
      k := 0;
      for i := 1 to B.TreesStored do begin 
	   	if B.TreeIsActive (i) then begin
            GetTree (i, T, True);

            { Ensure unrooted trees are treated correctly }
            if not IsFlag (pr_ROOTED) then
               T.ReRoot (T.FirstLeaf);

            if (DupBuffer^.InsertTree (T) = NIL) then begin
               { tree is a duplicate so inactivate }
               B.SwitchTreeOff (i);
               Inc (j);
               end
            else begin
               { check if binary }
               if T.IsBinary then
                  Inc (k);
               end;
            T.Done;
            end;

         {$IFDEF WINDOWS}
         if (Counter <> NIL) then begin
            Counter^.UpDateMeter (id_Meter, i);