cphist.pas

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

   for i := nmin to nmax do begin
      Class := (i - nmin) div CellWidth;
      H[Class] := H[Class] + Data[i];
      if (H[Class] > MaxFreq) then
         MaxFreq := H[Class];
      end;
   MinClass := 0;
   MaxClass := (nmax-nmin) div CellWidth;
end;

procedure HISTOGRAM.Show (var f:text);
var
  i, j : integer;
begin
  Writeln (f, 'Histogram');
  if (nTooBig > 0) then begin
     writeln (f);
     writeln (f, 'WARNING: The range of allowed data (0-',MAXRANGE,') was exceeded!');
     writeln (f, '         ', nTooBig, ' values were ignored.');
     end;
  Writeln (f);
  Writeln (f, 'Class');
  writeln (f);
  for i := 0 to MaxClass do begin
	  { Class values }
	  if S.ObsTypeReal then
		  write (f, ((i * CellWidth + nMin) / 1000):7:3)
	  else write (f,i * CellWidth + nMin:7);

	  { Bar }
	  write (f, ' ',VBAR);
	  for j := 1 to Trunc (H[i] * (FORMWIDTH / MaxFreq)) do
		  write (f, BARCODE);

	  { Cell count }
	  if (H[i] > 0) then
		  writeln (f, '(',H[i],')')
	  else writeln (f);
	  end;
  write (f, '        ', ANGLE);
  for i := 1 to FormWidth + 10 do
	  write (f, HBAR);
  writeln (f);
  writeln (f);
end;

procedure HISTOGRAM.Display;
var
  i, j : integer;
begin
  {$IFDEF DEVICE}
  Show (NEWLOG);
  {$ELSE}
  DisplayBuffer.InsertATitle ('Histogram');
  DisplayBuffer.InsertNewLine;
  DisplayBuffer.InsertATitle ('Class     Count');
  DisplayBuffer.InsertNewLine;
  for i := 0 to MaxClass do begin
	  Buffer.Clear;
	  if S.ObsTypeReal then
		  Buffer.AppendSReal ((i * CellWidth + MinObs) / MAXRANGE,5,3)
	  else Buffer.AppendSInteger(i * CellWidth + MinObs,5);
	  { Cell count }
	  Buffer.AppendSInteger (H[i], 10);
	  Buffer.AppendString (' |');
	  { Bar }
	  for j := 1 to Trunc (H[i] * (FORMWIDTH / MaxFreq)) do
		  Buffer.AppendChar (BARCODE);
	  DisplayBuffer.InsertLineBuffer (Buffer);
	  end;
  DisplayBuffer.InsertNewLine;
  {$ENDIF}
end;


procedure HISTOGRAM.Dof (var f:text);
begin
   { Ensure that histogram has >1  observations
	  (for example, a user may abort before an observation
     is stored.)
   }
   if (nObs > 1) then begin
      ClassifyObs;
      Show (f);
      Stats;
      ShowStats (f);
      end;
end;

procedure HISTOGRAM.DoD;
begin
   { Ensure that histogram has >1  observations
     (for example, a user may abort before an observation
     is stored.)
   }
   if (nObs > 1) then begin
      ClassifyObs;
      Display;
      Stats;
      DisplayStats;
      end;
end;


{$IFDEF WINDOWS}

procedure HISTOGRAM.Plot (PlotDC:HDC; x0, y0, wx, hy: integer;
								  FaceName: PChar; fScale: real);
{ Plot histogram on Windows DC }
var
   OldPen,
   NewPen   : HPen;
   OldFont,
   NewFont  : HFont;
   OldBrush : HBrush;
   TM       : TTextMetric;
   yBarUnit : Real;

   xBarUnit,

   MaxBarHeight,
   xMod,
   yMod,
   yOffset,
   i, j, m,
	fWidth, fHeight  : integer;
   OldAlign : word;
   TickStr  : array[0..10] of char;
   MyFont   : TLogFont;
   ax, ay, Tick     : integer;
begin
   NewPen := CreatePen (ps_Solid, Trunc (1 * fScale), RGB(0,0,0));
   OldPen := SelectObject (PlotDC, NewPen);

   { Draw axes }
   xBarUnit := Trunc ((wx - x0) / (MaxClass + 1)); { Width of bar }
   Tick     := Trunc (xBarUnit * 0.25);            { Tick mark }
   if (Tick / fScale) > 10.0 then                  { Ensure Tick <= 10pt }
      Tick := Trunc (10 * fScale);

   { Draw y axis }
   yBarUnit     := (hy - y0) / MaxFreq;            { Y units }
   MaxBarHeight := Trunc (yBarUnit * MaxFreq);
   MoveTo (PlotDC, x0, hy);
   LineTo (PlotDC, x0, hy - MaxBarHeight);

   { When do we make a y tick? }
   { How frequent are x labels? }
   case MaxFreq of
          0..10: yMod :=    1;
         11..50: yMod :=    5;
        51..100: yMod :=   25;
      101..1000: yMod :=  100;
      else       yMod := 1000;
      end;

   { Scale font so same font can be used for x and y axes and
	  to label tops of bars. }
   fHeight := 0;
   fWidth  := 0;

   { y axis font height }
   j := Trunc (yBarUnit * yMod * 0.5);
   if (j < 1) then
      j := 1;
   if (j / fScale) > 12.0 then          { Ensure <= 12 pt }
      j := Trunc (12 * fScale);
   fHeight := j;


   { x axis and bar font width }
   m := max (MaxFreq, nMax);
   Str (m, TickStr);
   { Make largest number string 0.9 xBarWidth long }
   fWidth  := Trunc ((xBarUnit * 0.8) / StrLen(TickStr));
   fHeight := min (fHeight, fWidth);

   { Create font }
   with MyFont do begin
      lfHeight         := fHeight;
      lfWidth          := 0;
      lfEscapement     := 0;
      lfOrientation    := 0;
      lfWeight         := fw_Normal;
      lfItalic         := 0;
      lfUnderline      := 0;
      lfStrikeOut      := 0;
		lfCharSet        := ANSI_CHARSET;
      lfOutPrecision   := Out_Default_Precis;
		lfClipPrecision  := Clip_Default_Precis;
      lfQuality        := Proof_Quality;
      lfPitchAndFamily := Variable_Pitch or ff_Swiss;
      StrCopy(@lfFaceName, FaceName);
      end;
   NewFont := CreateFontIndirect (MyFont);
   OldFont := SelectObject (PlotDC, NewFont);


   GetTextMetrics (PlotDC, TM);
   with TM do
      yOffSet := (tmAscent - tmInternalLeading) div 2 + tmInternalLeading;

   { Right align y axis font }
   OldAlign := SetTextAlign (PlotDC, ta_Right or ta_NoUpdateCP);

   { Ensure centers of text and ticks align }
   GetTextMetrics (PlotDC, TM);
   with TM do
      yOffSet := (tmAscent - tmInternalLeading) div 2 + tmInternalLeading;


   { Mark ticks }
   for i := 0 to MaxFreq do begin
      if (i mod yMod) = 0 then begin
			j := Trunc (i * yBarUnit);
         MoveTo (PlotDC, x0, hy-j);
         LineTo (PlotDC, x0 - Tick, hy-j);

         { y axis label }
         Str (i, TickStr);
         TextOut (PlotDC, x0 - (Tick * 2), hy-j-yOffSet, TickStr,
						StrLen(TickStr));
         end;
      end;

   { Center align x axis text }
   SetTextAlign (PlotDC, ta_Center or ta_NoUpdateCP);

   { Draw x axis }
   MoveTo (PlotDC, x0, hy);
   LineTo (PlotDC, x0 + ((MaxClass + 1) * xBarUnit), hy);


   { How frequent are x labels? }
   case nMax of
          0..10: xMod :=  1;
      else       xMod :=  4;
      end;

   { Ticks and labels }
   for i := 0 to MaxClass + 1 do begin
		j := i * xBarUnit;
      MoveTo (PlotDC, x0 + j, hy);
      LineTo (PlotDC, x0 + j, hy + Tick);

      { x axis label }
      if S.ObsTypeReal then begin
         if (i mod 2) = 0 then begin
            Str (((i * CellWidth + nMin) / 1000):3:2, TickStr);
            TextOut (PlotDC, x0 + j + (xBarUnit div 2), hy + (Tick * 2),
                    TickStr, Strlen(TickStr));
            end
         end
		else begin
         m := i * CellWidth + nMin;
         if ((i mod xMod) = 0) and (i <> MaxClass + 1) then begin
            Str (m, TickStr);
            TextOut (PlotDC, x0 + j + (xBarUnit div 2), hy + (Tick * 2),
                     TickStr, Strlen(TickStr));
            end;
         end;
      end;

   { Captions, etc. }

   { X axis caption. Place it in center of
     x axis one tick below bottom of tick numbers. }
   SetTextAlign (PlotDC, ta_Center or ta_Top or ta_NoUpdateCP);
	ax := x0 + ((MaxClass + 1) * xBarUnit) div 2;
   ay := hy + (Tick * 2) + TM.tmHeight + Tick;
   TextOut (PlotDC, ax, ay, szXAxis, StrLen (szXAxis));

   { Title }
   SetTextAlign (PlotDC, ta_Center or ta_Top or ta_NoUpdateCP);
   TextOut (PlotDC, ax, y0 div 2, szTitle, StrLen(szTitle));


   { Y axis caption. Place it above y axis, right justified. }
   SetTextAlign (PlotDC, ta_Right or ta_Bottom or ta_NoUpdateCP);
   ax := x0;
   ay := hy - MaxBarHeight - Tick;
   TextOut (PlotDC, ax, ay, szYAxis, StrLen (szYAXis));


   { Draw bars with gray brush }
	OldBrush := SelectObject (PlotDC, GetStockObject (LtGray_Brush));

   { For bar totals }
   SetTextAlign (PlotDC, ta_Center or ta_Bottom or ta_NoUpdateCP);

   { Draw bars }
   for i := 0 to MaxClass do begin
      { Bar }
      j := i * xBarUnit;
      Rectangle (PlotDC, x0 + j, hy - Trunc (yBarUnit * H[i]),
								  x0 + j + xBarUnit, hy);

      { number }
      if (H[i] <> 0) then begin
         Str (H[i], TickStr);
         TextOut (PlotDC, x0 + j + (xBarUnit div 2),
               hy - Trunc(yBarUnit * H[i]) - Tick, TickStr, Strlen(TickStr));
         end;
      end;

   { Clean up }
   NewFont := SelectObject (PlotDC, OldFont);
   DeleteObject (NewFont);
   SelectObject (PlotDC, OldBrush);
   NewPen := SelectObject (PlotDC, OldPen);
   DeleteObject (NewPen);
	SetTextAlign (PlotDC, OldAlign);
end;





function	HISTOGRAM.CopyHistogram:Boolean;
{ Copy histogram data to clipboard }
var
	ss : array[0..MAXTEXT] of char;
	szNumber : array[0..10] of char;
	i : integer;
begin
	ss[0] := #0;
	for i := 0 to MAXCLASS do begin
	  if S.ObsTypeReal then
		  Str (((i * CellWidth + nMin) / 1000):7:3, szNumber)
	  else Str (i * CellWidth + nMin, szNumber);
		StrCat (ss, szNumber);
		StrCat (ss, #9);
		Str (H[i], szNumber);
		StrCat (ss, szNumber);
		StrCat (ss, #13);
		StrCat (ss, #10);
		end;
	CopyHistogram := CopyTextToClipBoard (ss);
end;

{$ENDIF}

begin
end.