Umístnení souboru www.TrSek.com/zadania/friedman.pas

{ FRIEDMAN.PAS              Copyright (c) TrSek alias Zdeno Sekerak }
{ Program na vypocet Friedmanovho testu                             }
{ podla vzorca                                                      }
{                                                                   }
{            p          1             2                             }
{       S =  ä ( R  -  --- n (p + 1) )                              }
{           i=1   i     2                                           }
{                                                                   }
{ Datum:04.02.2004                             http://www.trsek.com }

program friedman;
uses crt,dos;
const max = 60;
      statist = 'fried_s.dat';

var n,p:integer;
    riad:integer;       { pocet riadkov }
    q:real;
    s_file:string;
    r:array[1..max,1..max] of real;
    rj:array[1..max,1..max] of real;
    s1,s5 : real;   { chi parameter pre 1% a 5% }

procedure uvod;
begin
WriteLn('Friedmanov test');
WriteLn(' /h - help');
WriteLn(' %1 - nazov suboru');
WriteLn;
end;

procedure help;
begin
WriteLn;
WriteLn('Program na vypocet Friedmanovho testu');
WriteLn('podla vzorca:');
WriteLn;
WriteLn('       p          1             2 ');
WriteLn('  S =  ä ( R  -  --- n (p + 1) )  ');
WriteLn('      i=1   i     2               ');
WriteLn;

Halt(0);
end;

procedure DivideArg;
begin
if( paramcount > 0 )then
     begin
       if( paramstr(1) = '/h' )then help;
       if( paramstr(1) = '/H' )then help;
       if( copy(paramstr(1),1,1) <> '/' )then s_file := paramstr(1);
     end;
end;

procedure ClearVar;
var x,y:integer;
begin
for x:=1 to max do
   for y:=1 to max do
     begin
       r[x,y] := 0;
       rj[x,y] := 0;
     end;
end;

function TestFile( s_file:string ):byte;
var
DirInfo: SearchRec;
begin
FindFirst(s_file, Archive, DirInfo);
TestFile := DosError;
end;

function NextInt(var s:string):real;
var err:integer;
    vys:real;
begin
Val( Copy( s, 1, Pos(';', s)-1 ), vys, err );
Delete( s, 1, Pos(';', s) );
NextInt := vys;
end;

function ReadFriedFile( s_file:string; var riad:integer ):byte;
var f:text;
    s:string;
    pom:string;
begin

{ nevyhnutne kontroly na existenciu suboru }
if( TestFile( s_file )>0 )then
   begin
     WriteLn('Subor ', s_file, ' neexistuje.');
     Halt(1);
   end;

Assign(f, s_file );
ReSet(f);

{ znuluj n,p }
n := 0; p := 0; riad := 0;

{ citaj riadky zaradom }
while( not(eof(f))) do
  begin

   { precitaj p-ty riadok }
   ReadLn( f, s );
   s := s+';';
   inc(riad);

   { inkrementuj riadok }
   p := p+1; n := 0;
   if( p>max )then
     begin
       ReadFriedFile := 1;
       exit;
     end;

   while( length(s) > 0 ) do
     begin

       { incrementuj v stlpci }
       n := n+1;
       if( n>max )then
       begin
         ReadFriedFile := 3;
         exit;
       end;

       { vybratie dalsieho faktora A }
       r[n,p] := NextInt(s);
       { vybratie dalsieho bloku }
       rj[n,p] := NextInt(s);

     end;

  end;

Close(f);
ReadFriedFile := 0;
end;

procedure ReadKeyboard;
var x,y:integer;
    s:string;
    err:integer;
begin
WriteLn('Zadaj parametre n,p:');
ReadLn(n);
ReadLn(p);

WriteLn('Dalej zadavaj hodnoty pevnosti v tahu:');
for x:=1 to n do
   for y:=1 to p do
    begin
     Write('Pec ',x,', faktor A',y,' = ');
     ReadLn(s);
     Val( s, r[x,y], err );

     Write('Pec ',x,', faktor A',y,' poradie = ');
     ReadLn(s);
     Val( s, rj[x,y], err );
    end;

{ precitaj kvantily }
Write('Zadaj prislusnu S0.01: ');
ReadLn( s1 );

Write('Zadaj prislusnu S0.05: ');
ReadLn( s5 );

WriteLn('Hodnoty zadane. Spustam vypocet.');
end;

function SumRij(j:integer):real;
var x:integer;
  sum:real;
begin
sum := 0;

for x:=1 to n do
   sum := sum + rj[x,j];

SumRij := sum;
end;

function SumMocnina:real;
var y:integer;
  sum:real;
  sumr:real;
begin
sum := 0;

for y:=1 to p do
begin
   sumr := SumRij(y);
   sum := sum + ( sumr * sumr );
end;

SumMocnina := sum;
end;

procedure ChiKvantil(var s1,s5:real; p,n:byte);
var f:text;
    i:byte;
    s:string;
begin
{ existuje subor kvantily ? }
if( TestFile( statist )>0 )then
   begin
     WriteLn('Subor ', statist, ' neexistuje.');
     Halt(1);
   end;

assign( f, statist );
reset(f);

while( not(eof(f))) do
   begin
    ReadLn(f,s);
    s := s+';';
    if( NextInt(s) = p )then
      if( NextInt(s) = n )then
        begin
          s1 := NextInt(s);
          s5 := NextInt(s);
        end;
   end;

close(f);
end;

begin
ClrScr;
s_file := '';
riad := 0;

Uvod;
DivideArg;
ClearVar;

{ nacitavanie zo suboru }
if( length( s_file ) > 0 )then
   begin
     WriteLn('Vypocet podla suboru: ', s_file );

     if( ReadFriedFile( s_file, riad )>0 )then
       begin
         WriteLn('Velke mnozstvo dat v subore.');
         WriteLn('Maximalne ', max,' poloziek.');
         Halt(2);
       end;

     { hodnoty s1, s5 }
     ChiKvantil( s1, s5, p, n );

   end
else
{ Nacitanie z klavesnice }
     ReadKeyboard;

q := SumMocnina - (n*n*p*(p+1)*(p+1))/4;

{ doplnok slovneho vyjadrenia vysledku }
WriteLn;
WriteLn('Testovacie kriterium je q=',q:0:6);
WriteLn('Prislusny chi-kvantil pro dany pocet vyberu je :');
WriteLn('   ',s1:0:3,' pro 1% hladinu a');
WriteLn('   ',s5:0:3,' pro 5% hladinu.');

Write('Z toho vyplyva, ze hypoteza ');
if q<=s1 then if q<=s5 then Write('plati ako')
                        else Write('plati')
          else if q<=s5 then Write('neplati')
                        else Write('neplati ani');
Write(' pre 95% odhad, ');
if q<=s5 then if q<=s1 then Write('tak')
                        else Write('ale plati')
          else if q<=s1 then Write('ale neplati')
                        else Write('ani');
Write(' pre 99% odhad.');

Repeat Until KeyPressed;

end.

Copyrigth by Zdeno Sekerak 2007, http://www.trsek.com