ststat.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);

  s := 0.0;
  for i := 0 to NData-1 do begin
    t := TDoubleArray(Data)[i];
    if (t = 0.0) then
      RaiseStatError(stscStatBadData);
    s := s+(1.0/t);
  end;
  Result := NData/s;
end;

function Largest(const Data: array of Double; K : Integer) : Double;
begin
  Result := Largest16(Data, High(Data)+1, K);
end;

function Largest16(const Data; NData : Integer; K : Integer) : Double;
var
  b, t, i, j : integer;
  Size : LongInt;
  temp, pval : Double;
  SD : PDoubleArray;
begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);
  if (K <= 0) or (K > NData) then
    RaiseStatError(stscStatBadParam);

  Size := LongInt(NData)*sizeof(Double);
  {if (Size > MaxBlockSize) then}
  {  RaiseStatError(stscStatBadCount);}
  getmem(SD, Size); {raises exception if insufficient memory}
  try
    move(Data, SD^, Size);

    {make K 0-based}
    dec(K);

    {use quicksort-like selection}
    b := 0;
    t := NData-1;
    while (t > b) do begin
      {use random pivot in case of already-sorted data}
      pval := SD^[b+random(t-b+1)];
      i := b;
      j := t;
      repeat
        while (SD^[i] > pval) do
          inc(i);
        while (pval > SD^[j]) do
          dec(j);
        if (i <= j) then begin
          temp := SD^[i];
          SD^[i] := SD^[j];
          SD^[j] := temp;
          inc(i);
          dec(j);
        end;
      until (i > j);
      if (j < K) then
        b := i;
      if (K < i) then
        t := j;
    end;
    Result := SD^[K];

  finally
    freemem(SD, Size);
  end;
end;

{debug version of Largest: slower but simpler}
{$IFDEF Debug}
function LargestSort(const Data: array of Double; K : Integer) : Double;
var
  Size : Cardinal;
  NData : Integer;
  SD : PDoubleArray;
begin
  NData := High(Data)+1;
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);
  if (K <= 0) or (K > NData) then
    RaiseStatError(stscStatBadParam);

  {copy and sort array}
  Size := CopyAndSort(Data, NData, SD);
  try
    {K=1 returns largest value, K=NData returns smallest}
    Result := SD^[NData-K];
  finally
    freemem(SD, Size);
  end;
end;
{$ENDIF}

function Median(const Data: array of Double) : Double;
begin
  Result := Median16(Data, High(Data)+1);
end;

function Median16(const Data; NData : Integer) : Double;
var
  m : Integer;
begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);

  m := NData shr 1;
  if odd(NData) then
    Result := Largest16(Data, NData, m+1)
  else
    Result := (Largest16(Data, NData, m+1)+Largest16(Data, NData, m))/2.0;
end;

function Mode(const Data: array of Double) : Double;
begin
  Result := Mode16(Data, High(Data)+1);
end;

function Mode16(const Data; NData : Integer) : Double;
var
  maxf, i, f : Integer;
  Size : Cardinal;
  last, max : Double;
  SD : PDoubleArray;
begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);

  {copy and sort array}
  Size := CopyAndSort(Data, NData, SD);
  try
    {find the value with highest frequency}
    last := SD^[0];
    max := last;
    f := 1;
    maxf := f;

    for i := 1 to NData-1 do begin
      if SD^[i] = last then
        {keep count of identical values}
        inc(f)
      else begin
        {start a new series}
        if f > maxf then begin
          max := last;
          maxf := f;
        end;
        last := SD^[i];
        f := 1;
      end;
    end;

    {test last group}
    if f > maxf then
      max := last;

    Result := max;
  finally
    freemem(SD, Size);
  end;
end;

function Percentile(const Data: array of Double; K : Double) : Double;
begin
  Result := Percentile16(Data, High(Data)+1, K);
end;

function Percentile16(const Data; NData : Integer; K : Double) : Double;
const
  eps = 1.0e-10;
var
  ibin : Integer;
  Size : Cardinal;
  rbin, l, h : Double;
  SD : PDoubleArray;
begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);
  if (K < 0.0) or (K > 1.0) then
    RaiseStatError(stscStatBadParam);

  {copy and sort array}
  Size := CopyAndSort(Data, NData, SD);
  try
    {find nearest bins}
    rbin := K*(NData-1);
    ibin := Trunc(rbin);
    if Frac(rbin) < eps then
      {very close to array index below}
      Result := SD^[ibin]
    else if (Int(rbin)+1.0-rbin) < eps then
      {very close to array index above}
      Result := SD^[ibin+1]
    else begin
      {need to interpolate between two bins}
      l := SD^[ibin];
      h := SD^[ibin+1];
      Result := l+(h-l)*(K*(NData-1)-ibin);
    end;
  finally
    freemem(SD, Size);
  end;
end;

function PercentRank(const Data: array of Double; X : Double) : Double;
begin
  Result := PercentRank16(Data, High(Data)+1, X);
end;

function PercentRank16(const Data; NData : Integer; X : Double) : Double;
var
  b, t, m : Integer;
  Size : Cardinal;
  SD : PDoubleArray;
begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);

  {copy and sort array}
  Size := CopyAndSort(Data, NData, SD);
  try
    {test end conditions}
    if (X < SD^[0]) or (X > SD^[NData-1]) then
      RaiseStatError(stscStatBadParam);

    {find nearby bins using binary search}
    b := 0;
    t := NData-1;
    while (t-b) > 1 do begin
      m := (b+t) shr 1;
      if (X >= SD^[m]) then
        {search upper half}
        b := m
      else
        {search lower half}
        t := m;
    end;

    {now X is known to be between b (inclusive) and b+1}
    {handle duplicate elements below b}
    while (b > 0) and (SD^[b-1] = X) do
      dec(b);

    if (SD^[b] = X) then
      {an exact match}
      Result := b/(NData-1)
    else
      {interpolate}
      Result := (b+(X-SD^[b])/(SD^[b+1]-SD^[b]))/(NData-1);

  finally
    freemem(SD, Size);
  end;
end;

const
  sqrt2pi = 2.5066282746310005; {sqrt(2*pi)}

function GammaLn(X : Single) : Single;
  {-Returns ln(Gamma(X)) where X > 0}
const
  cof : array[0..5] of Double = (
    76.18009172947146, -86.50532032941677, 24.01409824083091,
    -1.231739572450155, 0.1208650973866179e-2, -0.5395239384953e-5);
var
  y, tmp, ser : Double;
  j : Integer;
begin
  if (X <= 0) then
    RaiseStatError(stscStatBadParam);

  y := X;
  tmp := X+5.5;
  tmp := tmp-(X+0.5)*ln(tmp);
  ser := 1.000000000190015;
  for j := low(cof) to high(cof) do begin
    y := y+1.0;
    ser := ser+cof[j]/y;
  end;
  Result := -tmp+ln(sqrt2pi*ser/X);
end;

const
  MFactLnA = 65;
var
  FactLnA : array[2..MFactLna] of Single; {lookup table of FactLn values}

function FactLn(N : Integer) : Single;
  {-Returns ln(N!) for N >= 0}
begin
  if (N <= 1) then
    Result := 0.0
  else if (N <= MFactLnA) then
    {use lookup table}
    Result := FactLnA[N]
  else
    {compute each time}
    Result := GammaLn(N+1.0);
end;

const
  MFactA = 33;
var
  FactA : array[2..MFactA] of Double; {lookup table of factorial values}

function Factorial(N : Integer) : Extended;
begin
  if (N < 0) then
    RaiseStatError(stscStatBadParam);

  if (N <= 1) then
    Result := 1.0
  else if (N <= MFactA) then
    {use lookup table}
    Result := FactA[N]
  else
    {bigger than lookup table allows. may overflow!}
    Result := exp(GammaLn(N+1.0))
end;

function Permutations(Number, NumberChosen : Integer) : Extended;
begin
  if (Number < 0) or (NumberChosen < 0) or (Number < NumberChosen) then
    RaiseStatError(stscStatBadParam);
  {the 0.5 and Int function clean up roundoff error for smaller N and K}
  Result := Int(0.5+exp(FactLn(Number)-FactLn(Number-NumberChosen)));
end;

function Combinations(Number, NumberChosen : Integer) : Extended;
begin
  if (Number < 0) or (NumberChosen < 0) or (Number < NumberChosen) then
    RaiseStatError(stscStatBadParam);
  {the 0.5 and Int function clean up roundoff error for smaller N and K}
  Result := Int(0.5+exp(FactLn(Number)-FactLn(NumberChosen)
    -FactLn(Number-NumberChosen)));
end;

function Rank(Number: Double; const Data: array of Double;
  Ascending: Boolean) : Integer;
begin
  Result := Rank16(Number, Data, High(Data)+1, Ascending);
end;

function Rank16(Number: Double; const Data; NData : Integer;
  Ascending: Boolean) : Integer;
var
  r : Integer;
begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);

  {Data not known to be sorted, so must search linearly}
  if (Ascending) then begin
    for r := 0 to NData-1 do
      if TDoubleArray(Data)[r] = Number then begin
        Result := r+1;
        exit;
      end;
  end else begin
    for r := NData-1 downto 0 do
      if TDoubleArray(Data)[r] = Number then begin
        Result := NData-r;
        exit;
      end;
  end;
  Result := 0;
end;

function Smallest(const Data: array of Double; K : Integer) : Double;
begin
  Result := Smallest16(Data, High(Data)+1, K);
end;

function Smallest16(const Data; NData : Integer; K : Integer) : Double;
var
  b, t, i, j : integer;
  Size : LongInt;
  temp, pval : Double;
  SD : PDoubleArray;
begin
  if (NData <= 0) then
    RaiseStatError(stscStatBadCount);
  if (K <= 0) or (K > NData) then
    RaiseStatError(stscStatBadParam);

  Size := LongInt(NData)*sizeof(Double);
  {if (Size > MaxBlockSize) then}
  {  RaiseStatError(stscStatBadCount);}
  getmem(SD, Size); {raises exception if insufficient memory}
  try
    move(Data, SD^, Size);

    {make K 0-based}
    dec(K);
    {use quicksort-like selection}
    b := 0;
    t := NData-1;
    while (t > b) do begin
      {use random pivot in case of already-sorted data}
      pval := SD^[b+random(t-b+1)];
      i := b;
      j := t;
      repeat
        while (SD^[i] < pval) do
          inc(i);
        while (pval < SD^[j]) do
          dec(j);
        if (i <= j) then begin
          temp := SD^[i];
          SD^[i] := SD^[j];
          SD^[j] := temp;
          inc(i);
          dec(j);
        end;
      until (i > j);

      if (j < K) then
        b := i;
      if (K < i) then
        t := j;
    end;
    Result := SD^[K];
  finally
    freemem(SD, Size);
  end;
end;

{debug version of Smallest: slower but simpler}