home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
educ
/
pstat2.zip
/
CFIT12.PQS
/
cfit12.pas
Wrap
Pascal/Delphi Source File
|
1986-12-17
|
53KB
|
1,496 lines
Program CFit12 ;
Const
Cpyrtnotice = '(C) 1986 Joseph C. Hudson 4198 Warbler Dr. Flint MI 48504' ;
MaxNumObs = 250 ;
MaxNumMissing = 10 ;
NumRegr = 196 ;
NumForms = 7 ;
TurboType = 88 ;
Type
Info = Array [ 1..3 ] of Real ;
Regression = Record
YIndex, X1Index, X2Index,
ResidualDF, NextR, NextF : Integer ;
A, B1, B2, SEE, SST, D, C11, C12, C22,
RSq, RBarSq, FRatio : Real ;
End ;
DataVector = Array [ 1 .. MaxNumObs ] of Real ;
Var
FormFeed, ResetLineFeed, SetLineFeed, ResetPrinter,
SetCondensed, SetOneWay : String [ 4 ] ;
DataFileName : String[ 80 ] ;
OutFileName : String[ 80 ] ;
DataFile,HdrOutFile : Text ;
X, Y, YHat, Residual, StdDevResid : DataVector ;
NumRow, Base, NumRegRun, NumMissingX, NumMissingY,
NumMissing, BestF, BestR, WorstF, WorstR, LastReg, J1,
XCol, YCol, RegToPrint, LinesLeft : Integer ;
Rank : Array [ 1..NumRegr ] of Info ;
RegOutFile : File of Regression ;
RegOut : Array [ 1..NumRegr ] Of Regression ;
Reg : Regression ;
Answer : Char ;
DataNotSaved, NoReg : Boolean ;
OKToRunY : Array [ 1 .. NumForms ] of Boolean ;
OKToRunX : Array [ 0 .. NumForms ] of Boolean ;
MissingX : Array [ 1 .. MaxNumMissing ] of Real ;
MissingY : Array [ 1 .. MaxNumMissing ] of Real ;
XBar, YBarr : Array [ 0 .. NumForms ] of Real ;
Max, Min,
XInc, YInc,
XMax, YMax, XMin, YMin,
YBar, X1Bar, X2Bar : Real ;
Function F ( i : Integer ; Z : Real ) : Real ;
Begin
Case i Of
0 : F := 0.0 ;
1 : F := Z ;
2 : F := Z * Z ;
3 : F := 1.0 / Z ;
4 : F := 1.0 / ( Z * Z ) ;
5 : F := Ln ( Z ) ;
6 : F := Z * Ln ( Z ) ;
7 : F := ( Ln ( Z ) ) / Z ;
End ;
End ;
Procedure SetPrintVars ;
{ The codes given here work for Star Delta, Epson RX-80, FX-80 etc }
Begin
ResetPrinter := Chr(27) + '@' ;
FormFeed := Chr(12) ;
ResetLineFeed := Chr(27) + 'A' + Chr(12) ; { Set LF to 12/72 in. }
SetLineFeed := Chr(27) + 'A' + Chr(6) ; { Set LF to 6/72 in. }
SetCondensed := Chr(15) ; { Set to 17 chars/in. }
SetOneWay := Chr(27) + 'U' + Chr(1) ; { Set unidirectional }
End ; { SetPrintVars }
Procedure NewPage ;
Begin
Write(Lst,FormFeed) ; Writeln(Lst) ; Writeln(Lst) ;
LinesLeft := 60 ;
End ; { NewPage }
Procedure CheckConstraints ( I : Integer ) ;
Var J : Integer ;
Begin
If X[I] = 0.0 Then
Begin
OKToRunX[3] := False ;
OKToRunX[4] := False ;
End ;
If X[I] <= 0.0 Then
Begin
OKToRunX[5] := False ;
OKToRunX[6] := False ;
OKToRunX[7] := False ;
End ;
If Y[I] <= 0.0 Then For J := 2 To 5 Do OKToRunY[J] := False ;
If Y[I] < Exp(-1.0) Then OKToRunY[6] := False ;
If Y[I] < Exp(1.0) Then OKToRunY[7] := False ;
End ; { CheckConstraints }
Procedure GetOutFile ( StartRow : Integer ) ;
Begin
Repeat
GoToXY(1,StartRow) ;
Writeln(Con,'Type a name for the output files, without an extension. ') ;
Writeln(Con) ;
Write(Con,'You may include a path and must include a name, e.g.') ;
Writeln(Con,' A:\DATA\OUTFILE, ') ;
Writeln(Con,'where DATA is a subdirectory and OUTFILE is a file name.');
Writeln(Con,'Do not include a "dot" or a 3 letter extension.') ;
Writeln(Con) ;
{$I-} Readln(Con,OutFileName) {$I+} ; Writeln(Con) ;
Until ( ( ( IOResult = 0 ) And ( Pos('.',OutFileName) = 0 ) )
And ( ( Pos(':',OutFileName) = 2 )
Or ((Pos(':',OutFileName)=0)And(Length(OutFileName)<80)) ) ) ;
Assign ( RegOutFile, OutFileName + '.REG' ) ;
Assign ( HdrOutFile, OutFileName + '.HDR' ) ;
End ; { GetOutFile }
Procedure GetStarted ;
Var
MaxCol, I, J, K, L, Code : Integer ;
Dummy : Real ;
Missing : String [ 20 ] ;
DataLine : String [ 255 ] ;
XorYMissing , DataOnLine : Boolean ;
Begin
ClrScr ; GoTOXY(1,2) ;
Write(Con,'What is the name of the data file? ') ;
Readln(Con,DataFileName) ; Writeln(Con) ;
Assign ( DataFile , DataFileName ) ;
{$I-} Reset ( DataFile ) {$I+} ;
If IOResult <> 0 Then NoReg := True ;
If NoReg = False Then
Begin
MaxCol := 0 ; NumRow := 0 ;
Repeat
{$I-} Read(DataFile,Dummy) {$I+} ;
MaxCol := MaxCol + 1 ;
Dummy := IOResult ;
Until Eoln(DataFile) ;
NumRow := 1 ;
Repeat
DataLine := '' ;
Readln(DataFile,DataLine) ;
J := 47 ;
Repeat
J := J + 1 ;
Until ( (Pos(Chr(J),Dataline) > 0 ) Or (J = 58)) ;
If J < 58 Then NumRow := NumRow + 1 ;
Until Eof(DataFile) ;
Reset(DataFile) ;
GoToXY(1,4) ;
Write(Con,'There are ',NumRow,' rows and ',MaxCol) ;
Writeln(Con,' columns of data.') ;
Repeat
GoToXY(1,6) ;
Write(Con,'Which column contains X? ') ;
{$I-} Readln(Con,XCol) {$I+} ;
Until ( (IOResult = 0) And ((XCol > 0) And (XCol <= MaxCol))) ;
Repeat
GoToXY(1,8) ;
Write(Con,'Which column contains Y? ') ;
{$I-} Readln(Con,YCol) {$I+} ;
Until (((IOResult=0)And(YCol<>XCol))And((Ycol>0)And(YCol<=MaxCol))) ;
Writeln(Con) ;
If XCol < YCol Then MaxCol := YCol Else MaxCol := XCol ;
For I := 1 To NumForms Do OKToRunY[I] := True ;
For I := 0 To NumForms Do OKToRunX[I] := True ;
Repeat
GoToxy(1,10) ;
Write(Con,'Do you want to omit any X or Y values ? ') ;
{$I-} Readln(Con,Answer) {$I+} ;
Answer := UpCase ( Answer ) ;
Until ( ( IOResult = 0 ) And ( Answer In [ 'Y' , 'N' ] ) ) ;
NumMissing := 0 ; NumMissingX := 0 ; NumMissingY := 0 ;
If Answer = 'Y' Then
Begin
GoToXY(1,12) ;
Write(Con,'You may specify up to ',MaxNumMissing,' values to be') ;
Writeln(Con,' omitted for X and for Y.') ; Writeln(Con) ;
Write(Con,'If you enter fewer than ',MaxNumMissing,' values') ;
Writeln(Con,' for X or Y, hit Enter with no value') ;
Writeln(Con,'to terminate entry.');
Repeat
Repeat
GoToXY(1,18) ;
Write(Con,'Enter value number ',NumMissingX+1,' for X : ') ;
Write(Con,' ':20) ; GoToXY(33,18) ;
{$I-} Readln(Con,Missing) {$I+} ;
Val ( Missing , MissingX [ NumMissingX + 1 ] , Code ) ;
Until (( IOResult = 0 ) And ( ( Code = 0 ) Or ( Missing = '') )) ;
If Missing <> '' Then NumMissingX := NumMissingX + 1 ;
Until ( (NumMissingX = MaxNumMissing ) Or ( Missing = '') ) ;
Repeat
Repeat
GoToXY(1,20) ;
Write(Con,'Enter value number ',NumMissingY+1,' for Y : ') ;
Write(Con,' ':20) ; GoToXY(33,20) ;
{$I-} Readln(Con,Missing) {$I+} ;
Val ( Missing , MissingY [ NumMissingY + 1 ] , Code ) ;
Until (( IOResult = 0 ) And ( ( Code = 0 ) Or ( Missing = '') )) ;
If Missing <> '' Then NumMissingY := NumMissingY + 1 ;
Until ( (NumMissingY = MaxNumMissing ) Or ( Missing = '') ) ;
End ; { If Answer = 'Y' }
K := 1 ;
For I := 1 to NumRow Do
Begin
For J := 1 to MaxCol Do
Begin
If J = XCol Then Read(DataFile,X[K])
Else If J = YCol Then Read(DataFile,Y[K])
Else Begin
{$I-} Read(DataFile,Dummy) {$I+} ;
Dummy := IOResult ;
End ; {Else}
End ; { For J }
Readln(DataFile) ;
XorYMissing := False ;
If NumMissingX > 0 Then
For L := 1 To NumMissingX Do
If X[K] = MissingX[L] Then XorYMissing := True ;
If ( ( NumMissingY > 0 ) And ( Not XorYMissing ) )Then
For L := 1 To NumMissingY Do
If Y[K] = MissingY[L] Then XorYMissing := True ;
If (Answer = 'N') Or ( Not XorYMissing ) Then Begin
CheckConstraints(K) ;
K := K + 1 ;
End
Else NumMissing := NumMissing + 1 ;
End ; { For I }
Close ( DataFile ) ;
If Answer = 'Y' Then NumRow := NumRow - NumMissing ;
End { If NoReg = False }
Else
Begin
Writeln(Con) ; Writeln(Con,'This file is not available.') ;
Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
Repeat Until KeyPressed ;
End ; { Else }
If NumRow < 4 Then
Begin
Writeln(Con) ;
Writeln(Con,'There are ',NumRow,' rows of data, too few to proceed.') ;
Writeln(Con) ;
Writeln(Con,'Press any key to continue.') ;
NoReg := True ;
Repeat Until KeyPressed ;
End ; { If }
End ; { GetStarted }
Procedure Regress ;
Var
I, J, K : Integer ;
SumY, SumYSq, DTemp,
SSR, SSE, MSR, MSE, MST : Real ;
SumX, SumXY : Array [ 0 .. NumForms ] Of Real ;
SumXX : Array [ 0 .. NumForms , 0 .. NumForms ] Of Real ;
Begin
For I := 0 To NumForms Do SumX [ I ] := 0.0 ;
For I := 0 To NumForms Do XBar [ I ] := 0.0 ;
SumXY := SumX ;
For I := 0 To NumForms Do SumXX [ 0 , I ] := 0.0 ;
For I := 1 To NumForms Do SumXX [ I ] := SumXX [ 0 ] ;
SumXX [ 0 , 0 ] := 1.0 ;
For I := 1 To NumForms Do
Begin
If OKToRunX[I] Then
Begin
For J := 1 To NumRow Do
SumX[I] := SumX[I] + F ( I , X[J] ) ;
XBar[I] := SumX[I] / NumRow ;
For J := 1 To I Do
If OKToRunX[J] Then
Begin
For K := 1 to NumRow Do
SumXX[I,J]:=SumXX[I,J]+(F(I,X[K])-XBar[I])*(F(J,X[K])-XBar[J]);
If I <> J Then SumXX[J,I] := SumXX[I,J] ;
End ;
End ; { If }
End ; { For }
NumRegRun := 0 ;
For I := 1 To NumForms Do
Begin
If OKToRunY[I] Then
Begin
SumY := 0.0 ; SumYSq := 0.0 ;
For J := 1 To NumForms Do SumXY[J] := 0.0 ;
For J := 1 to NumRow Do SumY := SumY + F(I,Y[J]) ;
YBar := SumY / NumRow ;
YBarr[I] := YBar ;
For J := 1 To NumForms Do
If OKToRunX[J] Then
For K := 1 To NumRow Do
SumXY[J] := SumXY[J] + (F(J,X[K])-XBar[J])*(F(I,Y[K])-YBar) ;
For K := 1 To NumRow Do SumYSq := SumYSq + Sqr(F(I,Y[K])-YBar) ;
For J := 1 to NumForms Do
Begin
If OKToRunX[J] Then
Begin
For K := 0 to J - 1 Do
Begin
If OKToRunX[K] Then
Begin
DTemp := SumXX[J,J] * SumXX[K,K] - Sqr(SumXX[J,K]) ;
If Abs(DTemp) > 1E-10 Then
Begin
With Reg Do
Begin
YIndex := I ; X1Index := J ; X2Index := K ;
D := Dtemp ; C11 := SumXX[K,K] / D ;
C12 := - SumXX[J,K] / D ; C22 := SumXX[J,J] / D ;
If K = 0 Then ResidualDF := NumRow - 2
Else ResidualDF := NumRow - 3 ;
B1 := (SumXX[K,K] * SumXY[J] - SumXX[J,K] * SumXY[K])/D ;
B2 := (SumXX[J,J] * SumXY[K] - SumXX[J,K] * SumXY[J])/D ;
A := YBar - XBar[J] * B1 - XBar[K] * B2 ;
SSR := SumXY[J] * B1 + SumXY[K] * B2 ;
SST := SumYSq ;
SSE := SST - SSR ;
RSq := ( SSR / SST ) * 100.0 ;
MSR := SSR / ( NumRow - ResidualDF - 1 ) ;
MSE := SSE / ResidualDF ;
MST := SST / ( NumRow - 1 ) ;
RBarSq := ( 1 - ( MSE / MST ) ) * 100.0 ;
FRatio := MSR / MSE ;
SEE := Sqrt(MSE) ;
NextR := -1 ;
NextF := -1 ;
NumRegRun := NumRegRun + 1 ;
RegOut[NumRegRun] := Reg ;
Rank [ NumRegRun , 1 ] := NumRegRun ;
Rank [ NumRegRun , 2 ] := Fratio ;
Rank [ NumRegRun , 3 ] := RBarSq ;
End ; { With Reg }
End ; { If Abs(D) }
End ; { If OKToRunX[K] }
End ; { For K }
End ; { If OKToRunX[J] }
End ; { For J }
End ; { If OKToRunY[I] }
End ; { For I }
End ; { Regress }
Procedure GetAverages ;
Begin
YBar := YBarr[Reg.YIndex] ;
X1Bar := XBar[Reg.X1Index] ;
X2Bar := XBar[Reg.X2Index] ;
End ; { GetAverages }
Procedure Exchange ( Var I1 , I2 : Info ) ;
Var Temp : Info ;
Begin
Temp := I1 ;
I1 := I2 ;
I2 := Temp ;
End ; { Exchange }
Procedure Heap ( I , N : Integer ) ;
Begin
While( 2 * I + 1 <= N ) And
( ( Rank[I,J1] > Rank[2*I,J1] ) Or ( Rank[I,J1] > Rank[2*I+1,J1] ) ) Do
Begin
If Rank [ 2 * I , J1 ] < Rank [ 2 * I + 1 , J1 ] Then
Begin
Exchange ( Rank[I] , Rank[2*I] ) ;
I := 2 * I ;
End
Else
Begin
Exchange ( Rank[I] , Rank[2*I+1] ) ;
I := 2 * I + 1 ;
End
End ; { While }
If ( ( 2 * I = N ) And ( Rank[I,J1] > Rank[2*I,J1] ) )
Then Exchange ( Rank[I] , Rank[2*I] ) ;
End ; { Heap }
Procedure Sort ;
Var I , M : Integer ;
Begin
I := Trunc ( ( NumRegRun / 2.0 ) + 0.1 ) ;
While I >= 1 Do
Begin
Heap ( I , NumRegRun ) ;
I := I - 1 ;
End ; { While }
M := NumRegRun ;
While M > 1 Do
Begin
Exchange ( Rank[1] , Rank[M] ) ;
M := M - 1 ;
Heap ( 1 , M ) ;
End ; { While }
End ; { Sort }
Procedure AddInfo ;
Var
I, K1, K2 : Integer ;
Begin
For I := 1 To NumRegRun - 1 Do
Begin
K1 := Trunc( Rank[I,1]+0.1) ;
K2 := Trunc( Rank[I+1,1]+0.1) ;
With RegOut[K1] Do If J1 = 2 Then NextF := K2 Else NextR := K2 ;
End ; { For }
If J1 = 2 Then K1 := WorstF Else K1 := WorstR ;
With RegOut[K1] Do If J1 = 2 Then NextF := - BestF Else NextR := - BestR ;
End ; { AddInfo }
Procedure WriteReg(I:Integer) ;
Begin
With Reg Do
Begin
Write(Lst,' ':10,I:3,' ',RegToPrint:4,' ',YIndex,' ',X1Index) ;
Write(Lst,' ',X2Index,' ',A:13,' ',B1:13,' ',B2:13);
Write(Lst,' ',ResidualDF:4,' ',FRatio:8:2) ;
Writeln(Lst,' ',RSq:8:2,' ',RBarSq:8:2,' ',SEE:13) ;
End ; { With Reg }
End ; { WriteReg }
Procedure DrawLine ;
Var I : Integer ;
Begin
Write(Lst,' ':10) ;
For I := 1 To 120 Do Write(Lst,'=') ; Writeln(Lst) ; Writeln(Lst) ;
End ; { DrawLine }
Procedure WriteHeading ;
Var I : Integer ;
Begin
Writeln(Lst) ; If Answer <> 'R' Then DrawLine ;
Writeln(Lst,' ':15,'Regr',' ':55,'Residual',' ':21,'Adj') ;
Write(Lst,' ':10,' No. No. Y X1 X2',' ','A',' ':14,'B1',' ':13,'B2') ;
Writeln(Lst,' ':15,'DF',' ':6,'F RSq RSq SEE') ;
End ; { WriteHeading }
Procedure WriteHeader(ForR : Char) ;
Var
Expression : String[40] ;
L : Integer ;
Begin
If ForR = 'F' Then Expression := 'F Ratio.'
Else Expression := 'Adjusted Coeficient of Determination.' ;
Writeln(Lst) ;
Write(Lst,' ':10,'Regression using data in ',DataFileName,'.') ;
Writeln(Lst,' X is column ',XCol,' and Y is column ',YCol,'.' ) ;
Write(Lst,' ':10,'There are ',NumRow,' valid cases. ') ;
Write(Lst,NumMissing,' cases were omitted. ') ;
Writeln(Lst,NumRegRun,' regressions were run.') ;
If NumMissingX > 0 Then
Begin
Write(Lst,' ':10,'Omitted X values : ') ;
For L := 1 To NumMissingX Do Write(Lst,MissingX[L]:10:2,' ') ;
Writeln(Lst) ;
End ;
If NumMissingY > 0 Then
Begin
Write(Lst,' ':10,'Omitted Y values : ') ;
For L := 1 To NumMissingY Do Write(Lst,MissingY[L]:10:2,' ') ;
Writeln(Lst) ;
End ;
Write(Lst,' ':10,'The regressions are sorted by ',Expression) ;
If Not DataNotSaved Then
Writeln(Lst,' Output is stored in files ',OutfileName,'.')
Else Writeln(Lst) ;
End ; { WriteHeader }
Procedure Report ;
Var
I, Ans, LinesToPrint, ExtraLines : Integer ;
ForR : Char ;
Begin
ClrScr ;
Repeat
Writeln(Con) ;
Write(Con,'Do you want the list sorted by F or by R? ');
Readln(Con,ForR) ; ForR := UpCase(ForR) ;
Until ForR in [ 'F' , 'R' ] ;
If ForR = 'F' Then RegToPrint := BestF Else RegToPrint := BestR ;
Repeat
GoToXY(1,4) ;
Writeln(Con) ;
Writeln(Con,NumRegRun,' regressions were run.') ; Writeln(Con) ;
Write(Con,'How many regressions do you want printed? ') ;
{$I-} Readln(Con,Ans) {$I+} ;
Until ( ( Ans In [ 1 .. NumRegRun ] ) And ( IOResult = 0 ) ) ;
LinesToPrint := 10 + Ans ; ExtraLines := 0 ;
If NumMissingX > 0 Then ExtraLines := ExtraLines + 1 ;
If NumMissingY > 0 Then ExtraLines := ExtraLines + 1 ;
LinesToPrint := LinesToPrint + ExtraLines ;
If ((LinesToPrint < 60) And (LinesToPrint > LinesLeft))
Or ((LinesLeft < 14) And (LinesToPrint > LinesLeft)) Then NewPage ;
DrawLine ; WriteHeader(ForR) ; WriteHeading ;
LinesLeft := LinesLeft - 9 - ExtraLines ;
For I := 1 To Ans Do
Begin
Reg := RegOut[RegToPrint] ;
With Reg Do
Begin
WriteReg(I) ;
LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
If ForR = 'F' Then RegToPrint := NextF Else RegToPrint := NextR ;
End ; { With Reg }
End ; { For }
If ForR = 'F' Then RegToPrint := WorstF Else RegToPrint := WorstR ;
Reg := RegOut[RegToPrint] ;
WriteReg(NumRegRun) ;
LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
End ; { Report }
Procedure FindMaxMin( Z : DataVector ) ;
Var I : Integer ;
Begin
Max := Z[1] ; Min := Z[1] ;
For I := 2 To NumRow Do
Begin
If Max < Z[I] Then Max := Z[I] ;
If Min > Z[I] Then Min := Z[I] ;
End ;
End ; { FindMaxMin }
Procedure FindYHat ( Var EstY : Real ; X1 : Real ) ;
Var
RHS, Y1, Y2, Z : Real ;
Begin
RHS := Reg.A + Reg.B1*F(Reg.X1Index,X1) + Reg.B2*F(Reg.X2Index,X1);
Case Reg.YIndex Of
1 : EstY := RHS ;
2 : If RHS > 0.0 Then EstY := Sqrt(RHS) Else EstY := 0.0 ;
3 : If RHS > 0.0 Then EstY := 1.0/RHS Else EstY := 0.0 ;
4 : If RHS > 0.0 Then EstY := 1.0/Sqrt(RHS) Else EstY := 0.0 ;
5 : EstY := Exp(RHS) ;
6 : If RHS <= -Exp(-1.0) Then EstY := Exp(-1.0)
Else Begin
Y2 := RHS + 2.0 / Exp(1.0) ;
Repeat
Y1 := Y2 ;
Z := Y1 * Ln(Y1) - RHS ;
Y2 := Y1 - Z / (1.0 + Ln(Y1) );
Until Abs ( Y2 - Y1 ) < 1E-10 ;
EstY := Y2 ;
End ;
7 : If RHS >= 1.0/Exp(1.0) Then EstY := Exp(1.0)
Else Begin
If RHS <= 0.0 Then EstY := 0.0
Else Begin
Y2 := Exp(3.0/2.0) ;
Repeat
Y1 := Y2 ;
Z := ( Ln(Y1) / Y1 ) - RHS ;
Y2 := Y1 - Z * Sqr(Y1) / ( 1.0 - Ln(Y1) ) ;
Until Abs ( Y2 - Y1 ) < 1E-10 ;
EstY := Y2 ;
End ;
End ;
End ; { Case }
End ; { FindYHat }
Procedure EvaluateYHat ;
Var I : Integer ;
Begin
For I := 1 To NumRow Do
Begin
FindYHat ( YHat[I] , X[I] ) ;
Residual[I] := Y[I] - YHat[I] ;
End ; { For }
End ; { EvaluateYHat }
Procedure AskWhichReg ;
Begin
Repeat
ClrScr ;
Write(Con,'What is the regression number of the regression ') ;
Writeln(Con,'you want to use ? ') ;
{$I-} Readln(Con,RegToPrint) {$I+} ;
Until ((RegToPrint In [ 1 .. NumRegRun ]) And (IOResult = 0)) ;
Reg := RegOut[RegToPrint] ;
End ; { AskWhichReg }
Procedure FindPlotCoords ( Var XLoc, YLoc : Integer ; X1, Y1 : Real ) ;
Begin
XLoc := Trunc ( 0.5 + 10.0 * ( X1 - XMin ) / XInc ) ;
YLoc := 80 - Trunc ( 0.5 + 10.0 * ( Y1 - YMin ) / YInc ) ;
If ( ( XLoc < 0 ) Or ( XLoc > 100 ) ) Then XLoc := -1 ;
If ( ( YLoc < 0 ) Or ( YLoc > 80 ) ) Then YLoc := -1 ;
End ; { FindPlotCoords }
Procedure AskWhichData ( Var Answer : Char ) ;
Begin
Repeat
ClrScr ; GoToXY(1,4) ;
Writeln(Con, 'Do you want the ') ;
Writeln(Con,' O Original') ;
Write(Con,' or T Transformed data? ') ;
Readln(Con,Answer) ; Answer := UpCase(Answer) ;
Until Answer In [ 'O' , 'T' ] ;
End ; { AskWhichData }
Procedure Plot ;
Var
Yhi, Ylo, EstY, XtoFit : Real ;
YPlot : Array [ 0 .. 8 ] Of Real ;
XPlot : Array [ 0 .. 10 ] Of Real ;
I, J, XLoc, YLoc, Value, Result : Integer ;
Grid : Array [ 0 .. 101 , 0 .. 80 ] Of Char ;
Number : String[1] ;
Begin
ClrScr ; Writeln(Con) ;
If LinesLeft < 55 Then NewPage ;
AskWhichReg ; WriteHeading ; WriteReg(1) ;
FindMaxMin(X) ; XMax := Max ; XMin := Min ;
FindMaxMin(Y) ; YMax := Max ; YMin := Min ;
EvaluateYHat ;
XInc := 0.1 * ( XMax - XMin ) ;
FindYHat ( Ylo , XMin ) ; FindYHat ( Yhi , XMax ) ;
If Ylo < YMin Then YMin := Ylo ;
If Yhi < YMin Then YMin := Yhi ;
If Ylo > YMax Then YMax := Ylo ;
If Yhi > YMax Then YMax := Yhi ;
YInc := 0.125 * ( YMax - YMin ) ;
Writeln(Lst) ;
Write(Lst,' ':10,'The increment along the X (horizontal) axis is ') ;
Write(Lst,XInc/10:14) ;
Writeln(Lst,' and along the Y (vertical) axis is ',YInc/10:14,' .') ;
For I := 0 To 10 Do XPlot[I] := XMin + I * XInc ;
For I := 0 To 8 Do YPlot[I] := YMax - I * YInc ;
For I := 0 To 100 Do
Begin
For J := 0 To 80 Do Grid[I,J] := ' ' ;
End ; { For I }
For J := 1 To 79 Do Grid[101,J] := '-' ;
For J := 0 To 16 Do Grid[101,5*J] := '+' ;
For I := 0 To 100 Do
Begin
XToFit := XMin + I * XInc / 10.0 ;
FindYHat ( EstY , XToFit ) ;
FindPlotCoords ( XLoc , YLoc , XToFit , EstY ) ;
If (( XLoc >= 0 ) And ( YLoc >= 0 )) Then Grid [ XLoc , YLoc ] := '*' ;
End ; { For I }
For I := 1 To NumRow Do
Begin
FindPlotCoords ( XLoc , YLoc , X[I] , Y[I] ) ;
If (( XLoc >= 0 ) And ( YLoc >= 0 )) Then
Begin
If Grid [ Xloc , Yloc ] In [' ','*'] Then Grid [ XLoc, YLoc ] := '0'
Else
Begin
Val ( Grid [ Xloc , Yloc ] , Value , Result ) ;
If ( ( Result = 0 ) And ( Value = 0 ) ) Then
Grid [ Xloc , Yloc ] := '2'
Else If ( ( Result = 0 ) And ( Value < 9 ) ) Then
Begin
Str( Value + 1, Number ) ;
Grid [ Xloc , Yloc ] := Number ;
End { Else }
Else Grid [ Xloc , Yloc ] := '+' ;
End ; { Else }
End ; { If }
End ; { For I }
Writeln(Lst,SetLineFeed) ; { Set line feed to 6/72 inch }
Writeln(Lst) ; Writeln(Lst) ;
Write(Lst,' ':20) ;
For I := 1 To 10 Do Write(Lst,'+....:....') ;
Writeln(Lst,'+') ;
For J := 0 To 80 Do
Begin
If J Mod 5 = 0 Then
If J Mod 10 = 0 Then Write(Lst,' ':10,YPlot[J Div 10]:9:2,'+')
Else Write(Lst,' ':19,'+')
Else Write(Lst,' ':19,'-') ;
For I := 0 To 101 Do Write(Lst,Grid[I,J]) ;
Writeln(Lst) ;
End ; { For J }
Write(Lst,' ':20) ;
For I := 1 To 10 Do Write(Lst,'+....:....') ;
Writeln(Lst,'+') ; Writeln(Lst) ;
Write(Lst,' ':14) ;
For I := 0 To 10 Do Write(Lst,Xplot[I]:9:2,' ') ;
Writeln(Lst,ResetLineFeed) ; { Reset line feed to 12/72 inch }
LinesLeft := 0 ;
End ; { Plot }
Procedure ComputeYHat ;
Var
Answer : String[20] ;
X1, EstY, G, RHS, SMuHat : Real ;
Result, Kt : Integer ;
Begin
If LinesLeft < 10 Then NewPage ;
AskWhichReg ; WriteHeading ; WriteReg(1) ;
GetAverages ;
Writeln(Lst) ; Writeln(Con) ;
Write(Lst,' ':10,' I X',' ':15,'YHat Orig Units ') ;
Writeln(Lst,'YHat Tnf Units SMuHat') ;
LinesLeft := LinesLeft - 7 ;
Kt := 0 ;
Repeat
ClrScr ; Writeln(Con) ;
Write(Con,'Enter the value of X. enter Q to quit ') ;
Readln(con,Answer) ;
Val ( Answer , X1 , Result ) ;
If Result = 0 Then
Begin
Kt := Kt + 1 ;
FindYHat ( EstY , X1 ) ;
With Reg Do
Begin
RHS := A + B1 * F(X1Index,X1) + B2 * F(X2Index,X1) ;
G := 1.0 - (1.0/NumRow) - C11 * Sqr ( F(X1Index,X1) - X1Bar ) ;
G := G - C22 * Sqr ( F(X2Index,X1) - X2Bar ) ;
G := G - 2.0 * C12 * (F(X1Index,X1)-X1Bar)*(F(X2Index,X1)-X2Bar) ;
SMuHat := SEE * Sqrt ( 1.0 - G ) ;
End ; { With Reg }
Write(Lst,' ':10,Kt:5,' ',X1:14,' ',EstY:14,' ',RHS:14) ;
Writeln(Lst,' ',SMuHat:14) ;
LinesLeft := LinesLeft - 1 ;
If LinesLeft < 1 Then NewPage ;
End ; { If }
Until Answer[1] In [ 'q' , 'Q' ] ;
End ; { ComputeYHat }
Procedure PrintHistogram ;
Var
Hist : Array [ 1 .. 13 ] Of Integer ;
Mark : Array [ 1 .. 12 ] Of Real ;
MidPoint,SMidPt : Array [ 2 .. 12 ] Of Real ;
SumR, SumRSq, SDResid, G,
TnfX1, TnfX2, TnfY, RHS : Real ;
I, K,MaxElt, PointsPerDot : Integer ;
Answer : Char ;
Begin
If LinesLeft < 25 Then NewPage ;
AskWhichReg ; WriteHeading ; WriteReg(1) ;
AskWhichData(Answer) ;
Case Answer Of
'O' : Begin
EvaluateYHat ;
Writeln(Lst) ;
Write(Lst,' ':10,'Histogram of residuals using') ;
Writeln(Lst,' the original units.') ;
SumR := 0.0 ; SumRSq := 0.0 ;
For I := 1 To NumRow Do
Begin
SumR := SumR + Residual[I] ;
SumRSq := SumRSq + Sqr( Residual[I] ) ;
End ;
SDResid := Sqrt( (SumRSq - Sqr(SumR) / NumRow) / (NumRow - 1) ) ;
For I := 1 To NumRow Do
Residual[I] := (Residual[I]-(SumR/NumRow))/SDResid ;
End ; { O }
'T' : Begin
GetAverages ;
For I := 1 To NumRow Do
Begin
TnfX1 := F(Reg.X1Index,X[I]) ;
TnfX2 := F(Reg.X2Index,X[I]) ;
TnfY := F(Reg.YIndex, Y[I]) ;
RHS := Reg.A + TnfX1 * Reg.B1 + TnfX2 * Reg.B2 ;
Residual[I] := TnfY - RHS ;
With Reg Do
Begin
G := 1.0 - (1.0/Numrow) - C11*Sqr(TnfX1-X1Bar) ;
G := G - C22 * Sqr(TnfX2-X2Bar) ;
G := G - 2.0 * C12 * (TnfX1-X1Bar) * (TnfX2-X2Bar) ;
SDResid := SEE * Sqrt ( G ) ;
End ; { With }
Residual[I] := Residual[I] / SDResid ;
End ; { For }
Writeln(Lst) ; Write(Lst,' ':10,'Histogram of standardized ') ;
Writeln(Lst,'residuals using transformed units.') ;
End ; { T }
End ; { Case }
Mark[1] := - 2.75 ;
For I := 2 to 12 Do Mark[ I ] := Mark[ I - 1 ] + 0.5 ;
For I := 1 To 13 Do Hist[ I ] := 0 ;
For I := 1 To NumRow Do
Begin
If Residual[I] < Mark[1] Then Hist[1] := Hist[1] + 1
Else If Residual [I] >= Mark[12] Then Hist[13] := Hist[13] + 1
Else Begin
K := 12 ;
Repeat
K := K - 1 ;
Until Residual[I] >= Mark[K] ;
Hist[K] := Hist[K] + 1 ;
End ; { If }
End ; { For }
MaxElt := Hist[1] ;
For I := 1 To 13 Do If Hist[I] > MaxElt Then MaxElt := Hist[I] ;
PointsPerDot := MaxElt Div 50 + 1 ;
For I := 2 To 12 Do SMidPt[I] := ( Mark[I] + Mark[I-1] ) / 2 ;
If Answer = 'O' Then For I := 2 To 12 Do
MidPoint[I] := SDResid * SMidPt[I] + SumR/NumRow ;
If PointsPerDot = 1 Then
Writeln(Lst,' ':10,'Each * represents 1 observation.')
Else Begin
Write(Lst,' ':10,'Each * represents ',PointsPerDot) ;
Writeln(Lst,' or a fraction of ',PointsPerDot,' observations') ;
End ; { If }
Write(Lst,' ':10,'The standardized cell midpoints ') ;
If Answer = 'O' Then Write(Lst,'and the cell midpoints ') ;
Writeln(Lst,'are printed.') ;
If Answer = 'O' Then Begin
Write(Lst,' ':10,'The width of each cell is one half the standard') ;
Write(Lst,' deviation of the observed residuals, which') ;
Writeln(Lst,' is ',SDResid:12,'.') ; End
Else Writeln(Lst,' ':10,'The width of each cell is 0.5.') ;
Writeln(Lst) ; Writeln(Lst) ;
For I := 1 To 13 Do
Begin
Case Answer Of
'O' : Case I Of
1 : Write(Lst,' ':10,' < ',' ':10,'|') ;
2 .. 12 : Write(Lst,' ':10,MidPoint[I]:9,' ',SMidPt[I]:9:2,' |') ;
13 : Write(Lst,' ':10,' > ',' ':10,'|') ;
End ; { Case I }
'T' : Case I Of
1 : Write(Lst,' ':26,'< ','|') ;
2 .. 12 : Write(Lst,' ':20,SMidPt[I]:9:2,' |') ;
13 : Write(Lst,' ':26,'> ','|') ;
End ; { Case I }
End ; { Case Answer }
If ( ( Hist[I] <> 0 ) And ( Hist[I] >= PointsPerDot ) ) Then
For K := 1 To Hist[I] Div PointsPerDot Do Write(Lst,'*') ;
If Hist[I] Mod PointsPerDot <> 0 Then Writeln(Lst,'*')
Else Writeln(Lst) ;
End ; { For I }
LinesLeft := LinesLeft - 25 ;
End ; { PrintHistogram }
Procedure PrintTable ;
Var
Answer : Char ;
LinesToPrint, I : Integer ;
RHS, TnfX1, TnfX2, TnfY, TnfResid,
G, SResid, StdResid, SMuHat : Real ;
Begin
AskWhichReg ;
If Reg.YIndex <> 1 Then AskWhichData(Answer) Else Answer := 'T' ;
LinesToPrint := NumRow + 8 ;
If ((LinesToPrint < 60) And (LinesToPrint > LinesLeft))
Or ((LinesLeft < 12) And (LinesToPrint > LinesLeft)) Then NewPage ;
WriteHeading ; WriteReg(1) ; Writeln(Lst) ; Writeln(Lst) ;
LinesLeft := LinesLeft - 7 ;
If Reg.YIndex <> 1 Then
Begin
Case Answer Of
'O' : Writeln(Lst,' ':10,'Data in original units.') ;
'T' : Writeln(Lst,' ':10,'Data in transformed units.') ;
End ; { Case }
End { Then }
Else Writeln(Lst) ;
Case Answer Of
'O' : Begin
EvaluateYHat ;
Write(Lst,' ':10,' I',' ':3,'X',' ':15,'Y',' ':15,'YHat',' ':12) ;
Writeln(Lst,'Residual') ;
LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
For I := 1 To NumRow Do
Begin
Write(Lst,' ':10,I:3,' ',X[I]:14,' ',Y[I]:14,' ') ;
Write(Lst,YHat[I]:14,' ') ;
Writeln(Lst,Residual[I]:14) ;
LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
End ; { For I }
End ; { O }
'T' : Begin
GetAverages ;
Case Reg.X2Index Of
0 : Begin
Write(Lst,' ':10,' I',' ':3,'X1',' ':14,'Y',' ':15) ;
Write(Lst,'YHat',' ':12,'SMuHat',' ':10) ;
Writeln(Lst,'Residual',' ':8,'Std Residual') ;
LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
For I := 1 To NumRow Do
Begin
TnfX1 := F(Reg.X1Index,X[I]) ;
TnfY := F(Reg.YIndex, Y[I]) ;
RHS := Reg.A + TnfX1 * Reg.B1 ;
TnfResid := TnfY - RHS ;
With Reg Do
Begin
G := 1.0 - (1.0/NumRow) - C11 * Sqr (TnfX1-X1Bar) ;
SResid := SEE * Sqrt ( G ) ;
StdResid := TnfResid / SResid ;
SMuHat := SEE * Sqrt ( 1.0 - G ) ;
End ; { With Reg }
Write(Lst,' ':10,I:3,' ',TnfX1:14,' ') ;
Write(Lst,TnfY:14,' ',RHS:14,' ',SMuHat:14,' ') ;
Writeln(Lst,TnfResid:14,' ',StdResid:8:4) ;
LinesLeft := LinesLeft-1 ; If LinesLeft < 1 Then NewPage ;
End ; { For I }
End ; { 0 }
1 .. NumForms : Begin
Write(Lst,' ':10,' I',' ':3,'X1',' ':14,'X2',' ':14) ;
Write(Lst,'Y',' ':15) ;
Write(Lst,'YHat',' ':12,'SMuHat',' ':10) ;
Writeln(Lst,'Residual',' ':8,'Std Residual') ;
LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
For I := 1 To NumRow Do
Begin
TnfX1 := F(Reg.X1Index,X[I]) ;
TnfX2 := F(Reg.X2Index,X[I]) ;
TnfY := F(Reg.YIndex, Y[I]) ;
RHS := Reg.A + TnfX1 * Reg.B1 + TnfX2 * Reg.B2 ;
TnfResid := TnfY - RHS ;
With Reg Do
Begin
G := 1.0 - (1.0/NumRow) - C11 * Sqr (TnfX1-X1Bar) ;
G := G - C22 * Sqr (TnfX2-X2Bar) ;
G := G - 2.0 * C12 * (TnfX1-X1Bar) * (TnfX2-X2Bar) ;
SResid := SEE * Sqrt ( G ) ;
StdResid := TnfResid / SResid ;
SMuHat := SEE * Sqrt ( 1.0 - G ) ;
End ; { With Reg }
Write(Lst,' ':10,I:3,' ',TnfX1:14,' ',TnfX2:14,' ') ;
Write(Lst,TnfY:14,' ',RHS:14,' ',SMuHat:14,' ') ;
Writeln(Lst,TnfResid:14,' ',StdResid:8:4) ;
LinesLeft := LinesLeft-1 ; If LinesLeft < 1 Then NewPage ;
End ; { For }
End ; { 1..6 }
End ; { Case }
End ; { T }
End ; { Case }
End ; { PrintTable }
Procedure PrintDetails ;
Var
Beta1, Beta2, MSE, MST, SB1, SB2, R12, T1, T2, SSE,
SSR, MSR, SSX1, SSX2X1, SSX2, SSX1X2 : Real ;
LinesToPrint, DFReg, DFTotal : Integer ;
Begin
AskWhichReg ; WriteHeading ; WriteReg(1) ;
If Reg.X2Index = 0 Then LinesToPrint := 14 Else LinesToPrint := 24 ;
If LinesLeft < LinesToPrint Then NewPage ;
Writeln(Lst) ;
Writeln(Lst,' ':10,'ANOVA Table') ; Writeln(Lst) ;
Writeln(Lst,' ':10,'Source D.F. SS',' ':14,'MS',' ':17,'F') ;
With Reg Do
Begin
SSR := SST * RSq / 100.0 ;
DFReg := NumRow - ResidualDF - 1 ;
MSR := SSR / DFReg ;
SSE := SST - SSR ;
MSE := SSE / ResidualDF ;
T1 := MSR / MSE ;
Write(Lst,' ':10,'Regression ',DFReg:3,' ':3,SSR:14) ;
Writeln(Lst,' ',MSR:14,' ',T1:9:3) ;
If X2Index > 0 Then
Begin
SSX2X1 := B2 * B2 / C22 ;
SSX1 := SSR - SSX2X1 ;
T1 := SSX1 / MSE ;
T2 := SSX2X1 / MSE ;
Writeln(Lst) ;
Write(Lst,' ':10,' X1',' ':7,' 1',' ':3,SSX1:14,' ',SSX1:14) ;
Writeln(Lst,' ',T1:9:3) ;
Write(Lst,' ':10,' X2 | X1 ',' 1',' ':3,SSX2X1:14,' ',SSX2X1:14);
Writeln(Lst,' ',T2:9:3) ;
SSX1X2 := B1 * B1 / C11 ;
SSX2 := SSR - SSX1X2 ;
T1 := SSX2 / MSE ;
T2 := SSX1X2 / MSE ;
Writeln(Lst) ;
Write(Lst,' ':10,' X2',' ':7,' 1',' ':3,SSX2:14,' ',SSX2:14) ;
Writeln(Lst,' ',T1:9:3) ;
Write(Lst,' ':10,' X1 | X2 ',' 1',' ':3,SSX1X2:14,' ',SSX1X2:14);
Writeln(Lst,' ',T2:9:3) ;
Writeln(Lst) ;
End ; { If }
DFTotal := NumRow - 1 ;
MST := SST / DFTotal ;
Writeln(Lst,' ':10,'Error',' ':7,ResidualDF:3,' ':3,SSE:14,' ',MSE:14) ;
Writeln(Lst,' ':10,'Total',' ':7,DFTotal:3,' ':3,SST:14,' ',MST:14) ;
Writeln(Lst) ; Writeln(Lst) ;
If X2Index > 0 Then
Begin
Write(Lst,' ':10,'Variable Coefficient Beta',' ':12) ;
Writeln(Lst,'S.D.ofCoef.',' ':9,'T') ;
Beta1 := B1 * Sqrt ( D * C22 / SST ) ;
Beta2 := B2 * Sqrt ( D * C11 / SST ) ;
SB1 := SEE * Sqrt ( C11 ) ;
SB2 := SEE * Sqrt ( C22 ) ;
R12 := SEE * SEE * C12 / ( SB1 * SB2 ) ;
T1 := B1 / SB1 ;
T2 := B2 / SB2 ;
Write(Lst,' ':10,' X1 ',B1:14,' ',Beta1:14,' ',SB1:14) ;
Writeln(Lst,' ',T1:9:3);
Write(Lst,' ':10,' X2 ',B2:14,' ',Beta2:14,' ',SB2:14) ;
Writeln(Lst,' ',T2:9:3);
Writeln(Lst) ;
Writeln(Lst,' ':10,'The correlation between X1 and X2 is ',R12:9:4) ;
End ; { If }
Writeln(Lst) ;
Write(Lst,' ':10,'C11 = ',C11:14,' ':5,'C22 = ',C22:14,' ':5) ;
Writeln(Lst,'C12 = ',C12:14) ;
End ; { With }
LinesLeft := LinesLeft - LinesToPrint ;
End ; { PrintDetails }
Procedure FindOrigY ;
Var
Answer : String[20] ;
Result, Kt : Integer ;
TnfY, OrigY, Y1, Y2, Z : Real ;
Begin
If LinesLeft < 10 Then NewPage ;
AskWhichReg ; WriteHeading ; WriteReg(1) ;
Writeln(Lst) ; Writeln(Con) ;
Writeln(Lst,' ':10,' I ','Y in Tnf Units ','Y in Orig Units') ;
LinesLeft := LinesLeft - 7 ;
Kt := 0 ;
Repeat
ClrScr ; Writeln(Con) ;
Write(Con,'Enter the Transformed value of Y. enter Q to quit ') ;
Readln(con,Answer) ;
Val ( Answer , TnfY , Result ) ;
If Result = 0 Then
Begin
Kt := Kt + 1 ;
Case Reg.YIndex Of
1 : OrigY := TnfY ;
2 : If TnfY > 0.0 Then OrigY := Sqrt(TnfY) Else OrigY := 0.0 ;
3 : If TnfY > 0.0 Then OrigY := 1.0/TnfY Else OrigY := 0.0 ;
4: If TnfY > 0.0 Then OrigY := 1.0/Sqrt(TnfY) Else OrigY := 0.0 ;
5 : OrigY := Exp(TnfY) ;
6 : If TnfY <= -Exp(-1.0) Then OrigY := Exp(-1.0)
Else Begin
Y2 := TnfY + 2.0 / Exp(1.0) ;
Repeat
Y1 := Y2 ;
Z := Y1 * Ln(Y1) - TnfY ;
Y2 := Y1 - Z / (1.0 + Ln(Y1) );
Until Abs ( Y2 - Y1 ) < 1E-10 ;
OrigY := Y2 ;
End ;
7 : If TnfY >= 1.0/Exp(1.0) Then OrigY := Exp(1.0)
Else Begin
If TnfY <= 0.0 Then OrigY := 0.0
Else Begin
Y2 := Exp(3.0/2.0) ;
Repeat
Y1 := Y2 ;
Z := ( Ln(Y1) / Y1 ) - TnfY ;
Y2 := Y1 - Z * Sqr(Y1) / ( 1.0 - Ln(Y1) ) ;
Until Abs ( Y2 - Y1 ) < 1E-10 ;
OrigY := Y2 ;
End ;
End ;
End ; { Case }
Writeln(Lst,' ':10,Kt:5,' ',TnfY:14,' ',OrigY:14) ;
LinesLeft := LinesLeft -1 ;
If LinesLeft < 1 Then NewPage ;
End ;
Until Answer[1] In [ 'q' , 'Q' ] ;
End ; { FindOrigY }
Procedure SaveRegression ;
Var
I : Integer ;
Begin
ClrScr ;
GetOutFile(2) ;
{$I-} ReWrite ( HdrOutFile ) ; {$I+}
If IOResult <> 0 Then
Begin
Writeln(Con) ;
Writeln(Con,'File ',OutFileName,'.HDR cannot be opened.') ;
End { If }
Else
Begin
Writeln ( HdrOutFile , TurboType ) ;
Writeln ( HdrOutFile , DataFileName ) ;
Writeln ( HdrOutFile , XCol , ' ' , YCol , ' ' , NumRow ) ;
Writeln ( HdrOutFile , NumMissing,' ',NumMissingX,' ',NumMissingY ) ;
If NumMissingX > 0 Then For I := 1 To NumMissingX Do
Writeln ( HdrOutFile , MissingX [ I ] ) ;
If NumMissingY > 0 Then For I := 1 To NumMissingY Do
Writeln ( HdrOutFile , MissingY [ I ] ) ;
Writeln(HdrOutFile,'*') ;
For I := 1 To NumForms Do
If OKToRunX[I] Then Writeln(HdrOutFile,'X',' ',I,' ',XBar[I]) ;
For I := 1 To NumForms Do
If OKToRunY[I] Then Writeln(HdrOutFile,'Y',' ',I,' ',YBarr[I]) ;
Close ( HdrOutFile ) ;
{$I-} ReWrite ( RegOutFile ) ; {$I+}
If IOResult <> 0 Then
Begin
Writeln(Con) ;
Writeln(Con,'File ',OutFileName,'.REG cannot be opened.') ;
End
Else
Begin
For I := 0 To NumRegRun - 1 Do
Begin
Seek(RegOutFile,I) ;
Write ( RegOutFile , RegOut[I+1] ) ;
End ; { For }
Close(RegOutFile) ;
DataNotSaved := False ;
End ; { Else for REG file }
End ; { Else for HDR file }
End ; { SaveRegression }
Procedure ExitPrompt ;
Begin
If ( DataNotSaved And ( Not NoReg ) ) Then
Begin
ClrScr ;
Writeln(Con) ;
Writeln(Con,'The regression output has not been saved to disk.') ;
Writeln(Con) ;
Write(Con,'Do you want to save the regression output? ') ;
Readln(Con,Answer) ; Answer := UpCase(Answer) ;
If Answer = 'Y' Then SaveRegression ;
End ; { If }
End ; { ExitPrompt }
Procedure RunRegression ;
Begin
ExitPrompt ;
NoReg := False ;
DataNotSaved := True ;
GetStarted ;
If NoReg = False Then
Begin
Regress ;
J1 := 2 ; Sort ; BestF := Trunc(Rank[1,1] + 0.1) ;
WorstF := Trunc(Rank[NumRegRun,1] + 0.1) ; AddInfo ;
J1 := 3 ; Sort ; BestR := Trunc(Rank[1,1] + 0.1) ;
WorstR := Trunc(Rank[NumRegRun,1] + 0.1) ; AddInfo ;
End ; { If }
End ; { RunRegression }
Procedure GetRegression ;
Var
I, MaxCol, K, J, L, Typ : Integer ;
XOrYMissing : Boolean ;
Dummy : Real ;
Temp : String[3] ;
Drive : String[2] ;
Begin
ExitPrompt ;
ClrScr ; Writeln(Con) ; NoReg := False ;
Write(Con,'The data file and the output files must be in the same ');
Writeln(Con,'directory or subdirectory') ;
Writeln(Con) ;
GetOutFile (4) ;
If Pos(':',OutFileName) = 2 Then Drive := Copy(OutFileName,1,2) ;
Assign ( RegOutFile , OutFileName + '.REG' ) ;
Assign ( HdrOutFile , OutFileName + '.HDR' ) ;
{$I-} Reset(RegOutFile) {$I+} ; I := IOResult ;
If I <> 0 Then Begin
NoReg := True ; Writeln(Con) ;
Writeln(Con,'The reg file ',OutFileName+'.REG', ' is not available.') ;
Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
Repeat Until KeyPressed ;
End ; { If }
If NoReg = False Then
Begin
{$I-} Reset(HdrOutFile) {$I+} ; I := IOResult ;
If I <> 0 Then Begin
NoReg := True ; Writeln(Con) ;
Writeln(Con,'The hdr file ',OutFileName+'.HDR',' is not available.') ;
Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
Repeat Until KeyPressed ;
End ; { If I <> 0 }
End ; { If NoReg = False }
If NoReg = False Then
Begin
Readln( HdrOutFile , Typ ) ;
If Typ <> TurboType Then
Begin
Close ( RegOutFile ) ; Close ( HdrOutFile ) ;
Writeln(Con) ; NoReg := True ;
Write(Con,'The output was saved with CFIT') ;
If Typ = 87 Then Write(Con,'87') ;
Writeln(Con,' and cannot be read by this program.') ;
Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
Repeat Until KeyPressed ;
End ; { If Typ <> TurboTyp }
End ; { If NoReg = False }
If NoReg = False Then
Begin
Readln( HdrOutFile , DataFileName) ;
Readln( HdrOutFile , XCol , YCol , NumRow ) ;
Readln( HdrOutFile , NumMissing , NumMissingX , NumMissingY ) ;
If NumMissingX > 0 Then For I := 1 To NumMissingX Do
Readln( HdrOutFile , MissingX [ I ] ) ;
If NumMissingY > 0 Then For I := 1 To NumMissingY Do
Readln( HdrOutFile , MissingY [ I ] ) ;
If Pos(':',DataFileName) = 2 Then
DataFileName := Copy(DataFileName,3,Length(DataFileName)-2) ;
DataFileName := Drive + DataFileName ;
Assign ( DataFile , DataFileName ) ;
{$I-} Reset ( DataFile ) {$I+} ; I := IOResult ;
If I <> 0 Then Begin
NoReg := True ; Writeln(Con) ;
Writeln(Con,DataFileName,' is not available. ') ;
Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
Repeat Until KeyPressed ;
End ; { If I <> 0 }
End ; { If NoReg = False } ;
If NoReg = False Then
Begin
If XCol < YCol Then MaxCol := YCol Else MaxCol := XCol ;
K := 1 ;
For I := 1 to NumRow + NumMissing Do
Begin
For J := 1 to MaxCol Do
Begin
If J = XCol Then Read(DataFile,X[K])
Else If J = YCol Then Read(DataFile,Y[K])
Else Read(DataFile,Dummy) ;
End ; { For J }
Readln(DataFile) ;
XorYMissing := False ;
If NumMissingX > 0 Then
For L := 1 To NumMissingX Do
If X[K] = MissingX[L] Then XorYMissing := True ;
If ( ( NumMissingY > 0 ) And ( Not XorYMissing ) )Then
For L := 1 To NumMissingY Do
If Y[K] = MissingY[L] Then XorYMissing := True ;
If (Answer = 'N') Or ( Not XorYMissing ) Then Begin
CheckConstraints(K) ;
K := K + 1 ;
End ; { If }
End ; { For I }
Close ( DataFile ) ;
I := 0 ;
While Not EOF(RegOutFile) Do
Begin
Seek ( RegOutFile , I ) ;
Read ( RegOutFile , RegOut[I+1] ) ;
I := I + 1 ;
If RegOut[I].NextF < 0 Then
Begin
WorstF := I ;
BestF := - RegOut[I].NextF ;
End ; { If }
End ; { While }
NumRegRun := I ;
I := 0 ;
Repeat I := I + 1 ; Until RegOut[I].NextR < 0 ;
WorstR := I ; BestR := - Reg.NextR ;
Close ( RegOutFile ) ;
DataNotSaved := False ;
End ; { If NoReg = False }
End ; { GetRegression }
{ Procedure Listfiles is adapted from DIRECT.INC on the Public (Software)
Library's ASM-Pascal disk. No copyright is claimed for this procedure. }
Procedure ListFiles ;
Type
Char80arr = Array [ 1..80 ] of Char ;
String80 = String[ 80 ] ;
RegisterSet = Record
AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer ;
End ;
{$I-}
Var
DTA : array [ 1..43 ] of Byte ;
DTAseg, DTAofs, SetDTAseg, SetDTAofs, Error, ErrFlag1, ErrFlag2, I, J,
Option, Dn, RowNum : Integer ;
Regs : RegisterSet ;
Buffer, NamR, CurDir : String80 ;
Ch, OrigDrive, TempDrive : Char ;
Mask : Char80arr ;
HorizTab : Byte ;
Function DefaultDrive : Char ;
Var
Regs : RegisterSet ;
Begin
Regs.AX := $1900 ;
Msdos( regs ) ;
DefaultDrive := Chr(Ord('A')+lo(Regs.AX)) ;
End ;
Procedure ChangeDrive(dr : char);
Var
Regs : RegisterSet;
Begin
Regs.AX := $0E00 ;
Regs.DX := Ord(UpCase(dr)) - Ord('A') ;
Msdos( Regs ) ;
End ;
Procedure SetDTA( Segment, Offset : Integer; var Error : Integer ) ;
Begin
Regs.AX := $1A00 ;
Regs.DS := Segment ;
Regs.DX := Offset ;
MSDos( Regs ) ;
Error := Regs.AX and $FF ;
End ;
Procedure GetCurrentDTA( Var Segment, Offset, Error : Integer ) ;
Begin
Regs.AX := $2F00 ;
MSDos( Regs ) ;
Segment := Regs.ES ;
Offset := Regs.BX ;
Error := Regs.AX and $FF ;
End ;
Procedure GetFirst( Mask : Char80arr; Var NamR : String80; Segment,
Offset, Option : Integer; Var Error : Integer ) ;
Var I : Integer ;
Begin
Error := 0 ;
Regs.AX := $4E00 ;
Regs.DS := Seg( Mask ) ;
Regs.DX := Ofs( Mask ) ;
Regs.CX := Option ;
MSDos( Regs ) ;
Error := Regs.AX and $FF ;
I := 1 ;
Repeat
NamR[ I ] := Chr( Mem[ Segment : Offset + 29 + I ] ) ;
I := I + 1 ;
Until ( Not ( NamR[ I - 1 ] In [ ' '..'~' ] )) ;
NamR[ 0 ] := Chr( I - 1 ) ;
End ;
Procedure GetNextEntry( Var NamR : String80 ; Segment, Offset,
Option : Integer ; Var Error : Integer ) ;
Var I : Integer ;
Begin
Error := 0 ;
Regs.AX := $4F00 ;
Regs.CX := Option ;
MSDos( Regs ) ;
Error := Regs.AX and $FF ;
I := 1 ;
Repeat
NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] ) ;
I := I + 1 ;
Until ( Not ( NamR[ I - 1 ] In [ ' '..'~' ] )) ;
NamR[ 0 ] := Chr( I - 1 ) ;
End ;
Begin
HorizTab := 4 ;
RowNum := 3 ;
For I := 1 to 21 Do DTA[ I ] := 0 ;
For I := 1 to 80 Do
Begin
Mask[ I ] := Chr( 0 ) ;
NamR[ I ] := Chr( 0 ) ;
End ;
NamR[ 0 ] := Chr( 0 ) ;
GetCurrentDTA( DTAseg, DTAofs, ErrFlag1 ) ;
If ErrFlag1 = 0 Then
Begin
SetDTAseg := Seg( DTA ) ;
SetDTAofs := Ofs( DTA ) ;
SetDTA( SetDTAseg, SetDTAofs, ErrFlag2 ) ;
End ;
If ((ErrFlag1 = 0) And (Errflag2 = 0)) Then
Begin
Error := 0 ;
Buffer[ 0 ] := Chr( 0 ) ;
Option := 16 ;
ClrScr ;
Write('Path : ' ) ;
ReadLn( Buffer );
WriteLn;
Buffer := Buffer + '\*.*' ;
If Pos(':',Buffer) = 2 Then
Begin
TempDrive := Copy(Buffer,1,1) ;
OrigDrive := DefaultDrive ;
ChangeDrive(TempDrive) ;
Buffer := Copy(Buffer,3,Length(Buffer)-2) ;
End ;
For I := 1 To Length( Buffer ) Do Mask[ I ] := Buffer[ I ] ;
GetFirst( Mask, NamR, SetDTAseg, SetDTAofs, Option, Error ) ;
If ( Error = 0 ) Then
Begin
GoToXY(HorizTab,RowNum) ;
Write( NamR ) ;
HorizTab := HorizTab + 15 ;
End
Else Writeln( ' Path ''', Buffer, ''' not found.' ) ;
While ( Error = 0 ) Do
Begin
GetNextEntry( NamR, SetDTAseg, SetDTAofs, Option, Error ) ;
If Error = 0 Then
Begin
GoToXY(HorizTab,RowNum) ;
Write( NamR ) ;
HorizTab := HorizTab + 15 ;
If HorizTab > 70 Then
Begin
HorizTab := 4 ;
RowNum := RowNum + 1 ;
Writeln ;
If RowNum = 23 Then
Begin
GoToXY(1,24) ;
Write(Con,'Press any key to continue.') ;
Repeat Until KeyPressed ;
ClrScr ;
RowNum := 3 ;
End ;
End ;
End ;
End; { While }
SetDTA( DTAseg, DTAofs, Error );
ChangeDrive(OrigDrive) ;
GoToXY(1,24) ;
Write(Con,'Press any key to continue.') ;
Repeat Until KeyPressed ;
End { If ErrFlag1 = 0 And ErrFlag2 = 0 }
Else
Begin
GoToXY(3,1) ;
Write(Con,'Disk access error. Press any key to continue.') ;
Repeat Until KeyPressed ;
End ; { Else }
{$I+}
End ; { ListFiles }
Procedure SetUpPrinter ;
Var
K : Integer ;
Begin
ClrScr ; Writeln(Con) ;
Writeln(Con,'Set printer to top of form and turn on.') ;
Writeln(Con) ;
Writeln(Con,'Press any key when ready.') ;
Repeat Until KeyPressed ;
SetPrintVars ;
Write(Lst , ResetPrinter , SetCondensed , SetOneWay ) ;
K := 5 ; Repeat Begin Writeln(lst) ; K := K - 1 ; End ; Until K = 1 ;
LinesLeft := 55 ;
End ; { SetUpPrinter }
Procedure Menu ;
Var AnsOK : Boolean ;
Begin
Repeat
AnsOK := False ;
ClrScr ; Writeln(Con) ;
Writeln(Con,' C Compute Y Hat Values') ;
Writeln(Con,' D Print Details of a Fit') ;
Writeln(Con,' F Find Y in Original Units Given Y in Transformed Units') ;
Writeln(Con,' G Get Regression From Disk') ;
Writeln(Con,' H Print Histogram Of Residuals') ;
Writeln(Con,' L List Files On Disk') ;
Writeln(Con,' N Run New Regression') ;
Writeln(Con,' P Plot Fitted Curve') ;
Writeln(Con,' Q Quit') ;
Writeln(Con,' R Report Regression Results') ;
Writeln(Con,' S Save Regressions to Disk') ;
Writeln(Con,' T Print Table of Residuals') ;
Writeln(Con,' U Setup Printer') ;
If NoReg Then
Begin
Writeln(Con) ;
Write(Con,'You can only use the G, L, N and Q options now. ') ;
End ; { If }
Readln(Con,Answer) ; Answer := UpCase(Answer) ;
If ( NoReg And ( Answer In [ 'G','L','N','Q' ] ) ) Then AnsOK := True ;
If ( ( Not NoReg ) And
(Answer In [ 'C','D','F','G','H','L','N','P','Q','R','S','T','U' ]))
Then AnsOK := True ;
Until AnsOK ;
If Answer = 'C' Then ComputeYHat ;
If Answer = 'D' Then PrintDetails ;
If Answer = 'F' Then FindOrigY ;
If Answer = 'G' Then GetRegression ;
If Answer = 'H' Then PrintHistogram ;
If Answer = 'L' Then ListFiles ;
If Answer = 'N' Then RunRegression ;
If Answer = 'P' Then Plot ;
If Answer = 'R' Then Report ;
If Answer = 'S' Then SaveRegression ;
If Answer = 'T' Then PrintTable ;
If Answer = 'U' Then SetUpPrinter ;
End ; { Menu }
Begin { M A I N P R O G R A M }
NoReg := True ; DataNotSaved := True ;
SetUpPrinter ;
Repeat Menu Until Answer In [ 'q' , 'Q' ] ;
ExitPrompt ;
End .