cphist.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.      *
*                                                                  *
*******************************************************************}

{$I cpdir.inc}

{*

   A simple histogram plotter for text output



    7 Jan 1992 Range overflow error fixed.
               Because function Sqr(x) returns a value
               of the same type as x, squaring an integer
               > 181 will give a negative result, hence
               giving spurious results.

   21 Jan 1992 If user aborted a routine before
               any observations had been added, program
               crashed with Runtime error 200. Fixed by
               first checking if Histogram has any data
					before trying to summarize and print.

	 6 Feb 1992 Uses text device driver.

	21 Apr 1992 Text output prettied up, now looks a bit like PAUP 3.0.

	29 May 1992 Supports Windows GDI for screen and printer.

	16 Oct 1992 Can copy class data to Clipboard.

*}

unit cphist;

interface

uses
	{$IFDEF WINDOWS}
	WinTypes,
	WinProcs,
	Strings,
	{$ENDIF}
	cpclip,
	cputil,  { utilities }
	cpwbuf;  { text buffer }

const
	MAXRANGE  = 5000;
	MAXCELLS  =  100;
	FORMWIDTH =   30;

	MAXTEXT = MAXCELLS * 11 + 3;

type
   StatsRec=record
      mean,
      stddev,
		median : real;
		n      : longint;
		case ObsTypeReal:Boolean of
			True  : (minrealobs, maxrealobs: real);
			False : (minintobs, maxintobs: word);
		end;


	RAWDATA = array[0..MAXRANGE] of word;

	HISTPTR   = ^HISTOGRAM;
	HISTOGRAM = object
   	{ Histogram object }
		Data: RAWDATA;
		nObs, maxObs, minObs: word;
		S : StatsRec;
		H : array[0..MAXCELLS] of longint;
		CellWidth:integer;
		MaxFreq:longint;
		MinClass, MaxClass: 0..MAXCELLS;
		nMin, nMax : 0..MAXRANGE;

      nTooBig : word;

		constructor Init (IsReal:Boolean);
		procedure IntegerObs (i:longint);
		procedure Real01Obs (r:real);
		procedure Stats;
		procedure ClassifyObs;
		procedure ShowStats (var f:text);
		procedure Show (var f:text);
		procedure Dof (var f:text);
		procedure Display;
		procedure DisplayStats;
		procedure DoD;
		procedure SetCaptions (lpszXAxis, lpszYAxis, lpszTitle: PChar);
		function	CopyHistogram:Boolean;
      {$IFDEF WINDOWS}
		procedure Plot (PlotDC:HDC; x0, y0, wx, hy: integer;
								  FaceName: PChar; fScale: real);

      {$ENDIF}
      private
      szXAxis,
      szYAxis,
      szTitle : array[0..80] of char;
      end;

implementation

const
   BARCODE   = #176; {皚
   VBAR      = #179; {硙
   HBAR      = #196; {膤
   ANGLE     = #192; {纝

constructor HISTOGRAM.Init (IsReal:Boolean);
var
   i:integer;
begin
   for i := 0 to MAXRANGE do
      Data[i] := 0;
   nObs   := 0;
   MaxObs := 0;
   MinObs := MAXRANGE;
   S.ObsTypeReal := IsReal;
   StrCopy (szXAxis, 'x axis');
   StrCopy (szYAxis, 'y axis');
   StrCopy (szTitle, 'Title');

   nTooBig := 0;
end;

procedure HISTOGRAM.SetCaptions (lpszXAxis, lpszYAxis, lpszTitle: PChar);
begin
   StrLCopy (szXAxis, lpszXAxis, SizeOf (szXAxis) - 1);
   StrLCopy (szYAxis, lpszYAxis, SizeOf (szYAxis) - 1);
   StrLCopy (szTitle, lpszTitle, SizeOf (szTitle) - 1);
end;

procedure HISTOGRAM.IntegerObs (i:longint);
begin
   if (i > MAXRANGE) then
      Inc (nTooBig)
   else begin
      Inc (Data[i]);
      if (i < MinObs) then
         MinObs := i;
      if (i > MaxObs) then
         MaxObs := i;
      Inc (nobs);
      end;
end;

procedure HISTOGRAM.Real01Obs (r:real);
var
   i:integer;
begin
   i :=Trunc(r * 1000);
   IntegerObs (i);
end;


procedure HISTOGRAM.Stats;
var
   i:integer;
   x1, x2, SumX, SumX2 : real;

begin
   SumX  := 0.0;
   SumX2 := 0.0;
   for i := MinObs to MaxObs do begin
      case S.ObsTypeReal of
         True:  begin
                   SumX  := Sumx  + Data[i] * (i / 1000);
                   SumX2 := SumX2 + Data[i] * Sqr (i /1000);
                end;
         False: begin
                   x1 := Data[i] * i;
                   SumX  := SumX  + x1;
                   x2 := i;
                   x2 := Data[i] * Sqr(x2);
                   SumX2 := SumX2 + x2;
                end;
         end;
      end;
   with S do begin
      mean := SumX/nObs;
      n    := nObs;
      stddev := Sqrt ((SumX2 - (Sqr (SumX) / nObs)) / Pred (nObs));
      case ObsTypeReal of
         True  : begin
                    MinRealObs := MinObs / 1000;
                    MaxRealObs := MaxObs / 1000;
                 end;
         False : begin
                    MinIntObs := MinObs;
                    MaxIntObs := MaxObs;
                 end;
         end;
     end;
end;

procedure HISTOGRAM.ShowStats (var f:text);
begin
   writeln (f, 'Summary statistics');
   writeln (f);
   with S do begin
      writeln (f, '   n: ',n:10);
      writeln (f, 'Mean: ',mean:14:3);
      writeln (f, '  sd: ',stddev:14:3);
      case ObsTypeReal of
         True: begin
                  writeln (f, ' min: ',MinRealObs:14:3);
                  writeln (f, ' max: ',MaxRealObs:14:3);
               end;
         False:begin
                  writeln (f, ' min: ',MinIntObs:10);
                  writeln (f, ' max: ',MaxIntObs:10);
               end;
         end;
      end;
   writeln (f);
end;

procedure HISTOGRAM.DisplayStats;
begin
   {$IFDEF DEVICE}
   ShowStats (NEWLOG);
   {$ELSE}
   DisplayBuffer.InsertATitle ('Summary statistics');
   DisplayBuffer.InsertNewLine;
   with S do begin
      Buffer.Clear;
      Buffer.AppendString ('   n: ');
      Buffer.AppendSInteger (n,10);
      DisplayBuffer.InsertLineBuffer (Buffer);

      Buffer.Clear;
      Buffer.AppendString ('Mean: ');
      Buffer.AppendSReal (Mean, 14,3);
      DisplayBuffer.InsertLineBuffer (Buffer);

      Buffer.Clear;
      Buffer.AppendString ('  sd: ');
      Buffer.AppendSReal (stddev, 14,3);
      DisplayBuffer.InsertLineBuffer (Buffer);
      case ObsTypeReal of
         True: begin
                  Buffer.Clear;
                  Buffer.AppendString (' min: ');
                  Buffer.AppendSReal (MinRealObs, 14,3);
                  DisplayBuffer.InsertLineBuffer (Buffer);
                  Buffer.Clear;
                  Buffer.AppendString (' max: ');
                  Buffer.AppendSReal (MaxRealObs, 14,3);
                  DisplayBuffer.InsertLineBuffer (Buffer);
               end;
         False:begin
                  Buffer.Clear;
                  Buffer.AppendString (' min: ');
                  Buffer.AppendSInteger (MinIntObs, 10);
                  DisplayBuffer.InsertLineBuffer (Buffer);
                  Buffer.Clear;
                  Buffer.AppendString (' max: ');
                  Buffer.AppendSInteger (MaxIntObs, 10);
                  DisplayBuffer.InsertLineBuffer (Buffer);
               end;
         end;
      end;
   DisplayBuffer.InsertNewLine;
   {$ENDIF}
end;

procedure HISTOGRAM.ClassifyObs;
var
   Class: 0..MAXCELLS;
   i    : 0..MAXRANGE;

   { Ensure that Width is 1,2, or 5 x 10**q }
   function MakeNice (Width: integer):integer;
   var
      tens : integer;
      remain : integer;
      x, j : integer;
   begin
      tens := 1;
      j    := 0;
      while (Width div tens) > 0 do begin
         Tens := tens * 10;
         Inc(j);
         end;




      remain := Width div (tens div 10);
      x := Width mod (tens div 10);
      if (x = 0) then begin
         case remain of
             0,1: j :=  1;
               2: j :=  2;
           3..5: j :=  5;
            6..9: j := 10;
            end;
         end
      else begin
         case remain of
            0 : j := 1;
            1 : j := 2;
            2 : j := 5;
            else j := 10;
            end;
         end;
      MakeNice := j * Tens div 10;
   end;

begin
   { Assumes real numbers are in the range 0-1 }
   if S.ObsTypeReal then begin
      nmin := 0;
      nmax := 1000;
      CellWidth := 50;
      end
   else begin
      nmin := MinObs;
      nmax := MaxObs;
      CellWidth := Succ ((nmax - nmin) div MAXCELLS);
      { Make cellwidth and origin a nice number }
      CellWidth := MakeNice (CellWidth);
      nMin      := (nMin div CellWidth) * CellWidth;
      end;
   for i := 0 to MAXCELLS do
      H[i] := 0;
   MaxFreq := 0;