Program for compute Friedman test

Category: Homework in Pascal

Program: Friedman.pas
File exe: Friedman.exe
need: Fried.dat,  Fried_s.dat

{ 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.