Web pdp-10.trailing-edge.com

Trailing-Edge - PDP-10 Archives - decuslib20-01 - decus/20-0020/bact2l.sta
There are 2 other files named bact2l.sta in the archive. Click here to see a list.
100'  NAME--BACT2L
110'
120'  DESCRIPTION--A BAYESIAN ANALYSIS OF A 2 LEVEL CONTINGENCY TABLE
130'
140'  SOURCE--DEAN MYRON TRIBUS,THAYER SCHOOL OF ENGINEERING,
150'  DARTMOUTH COLLEGE, HANOVER,N.H. 03755
160'
170'  INSTRUCTIONS--THE DATA OF THE TABLE ARE PRESUMED TO BE ARRANGED
180'  IN THE FOLLOWING FORM:
190'
200'  :::::     A1     :     A2     :             :     AR
210'  :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
220'  :B1::    N(1)    :    N(2)    :     ETC     :    N(R)    ::B(1)
230'  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
240'  :B2::   N(R+1)   :   N(R+2)   :     ETC     :   N(2*R)   ::B(2)
250'  :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
260'  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
270'
280'  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
290'  :BS::N((S-1)*R+1):N((S-1)*R+2):     ETC     :   N(R*S)   ::B(S)
300'  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
310'      A(1)          A(2)                           A(R)        N
320'
330'  THE TABLE IS OF DIMENSION R*S. R,S,P1,C1 AND C2 ARE INSERTED IN
340'  LINE 1830 AS DATA STATEMENTS
350'
360'  R = THE NUMBER OF ATTRIBUTES FOR CHARACTERISTIC A.
370'  S = THE NUMBER OF ATTRIBUTES FOR CHARACTERISTIC B.
380'  P1= THE PRIOR PROBABILITY THAT A AND B ARE DEPENDENT.
390'      PUT P1=0.5 IF NO DATA IS AVAILABLE(THIS WILL GIVE ABOUT THE
400'      SAME RESULTS AS A CHI-SQUARE TEST).
410'  IF CHARACTERISTIC A WAS CONTROLLED DURING THE TEST OR IF THE
420'  PROBABILITY OF OCCURRENCE OF A WAS KNOWN WITHOUT THE DATA IN THE
430'  TABLE, PUT C1=1. OTHERWISE PUT C1=0.
440'  IF CHARACTERISTIC B WAS CONTROLLED DURING THE TEST OR IF THE
450'  PROBABILITY OF OCCURRENCE OF B WAS KNOWN WITHOUT THE
460'  DATA IN THE TABLE,PUT C2=1. OTHERWISE PUT C2=0.
470'
480'      ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
490'  NOTE::::::::::: DO NOT PUT BOTH C1 AND C2=1  :::::::::::::::::::::::::
500'      ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
510'
520'  ENTER DATA IN LINE 1840 AS N(Y) FOR Y=R*S.
530'
540'
550'  *  *  *  *  *  *  MAIN PROGRAM  *  *  *  *  *  *  *
560'
580 DIM N(100),A(10),B(10),F(3),G(3),H(3)
590 FOR Y=1 TO R*S
610 LET N=N+N(Y)
620 NEXT Y
630 REM************THIS LOOP FINDS A(I)*************
640 FOR I=1 TO R
650 LET A(I)=0
660 FOR Y=I TO (S-1)*R+I STEP R
670 LET A(I)=A(I)+N(Y)
680 NEXT Y
690 NEXT I
700 REM***********************************************
710 REM*************THIS LOOP FINDS B(J)***************
720 FOR J=1 TO S
730 LET B(J)=0
740 FOR Y=1+(J-1)*R TO J*R
750 LET B(J)=B(J)+N(Y)
760 NEXT Y
770 NEXT J
780 REM *************************************************
790 REM***********THIS LOOP FINDS F(1)******************
800 LET F(1)=0
810 FOR I=1 TO R
820 LET Z=A(I)
830 GO SUB 1700
840 REM   **************************************************************
850 REM  **** SUB 1250 FINDS LOG OF Z FACTORIAL AND CALLS IT F   *******
860 REM   **************************************************************
870 LET F(1)=F(1)+F
880 NEXT I
890 REM********************************************************
900 REM ********THIS LOOP FINDS F(2)****************************
910 LET F(2)=0
920 FOR J=1 TO S
930 LET Z=B(J)
940 GO SUB 1700
950 LET F(2)=F(2)+F
960 NEXT J
970 REM************************************************************
980 LET Z=N
990 GO SUB 1700
1000 LET F(0)=F
1010 REM**************THIS LOOP FINDS F(3)***********************
1020LET F(3)=0
1030 FOR I=1 TO R
1040 FOR J=1 TO S
1050 LET Y=(J-1)*R+I
1060 LET Z=N(Y)
1070 GO SUB 1700
1080 LET F(3)=F(3)+F
1090 NEXT J
1100 NEXT I
1110 REM**********************************************************
1120 REM******NEXT LOOPS WILL BE SKIPPED IF C1+C2=0**************
1130 FOR I=1 TO R*C1
1140 LET Z=S-1
1150 GO SUB 1700
1160 LET H(1)=H(1)+F
1170 LET Z=A(I)+S-1
1180 GO SUB 1700
1190 LET H(1)=H(1)-F
1200 NEXT I
1210 FOR J=1 TO S*C2
1220 LET Z=R-1
1230 GO SUB 1700
1240 LET H(2)=H(2)+F
1250 LET Z=B(J)+R-1
1260 GO SUB 1700
1270 GO SUB 1700
1280 LET H(2)=H(2)-F
1290 NEXT J
1300 REM****************************************************************
1310 REM*******FOLLOWING SECTION FINDS G(1),G(2),G(3)*******************
1320 LET Z=R-1
1330 GO SUB 1700
1340 LET G(1)=F
1350 LET Z=N+R-1
1360 GO SUB 1700
1370 LET G(1)=G(1)-F
1380 LET Z=S-1
1390 GO SUB 1700
1400 LET G(2)=F
1410 LET Z=N+S-1
1420 GO SUB 1700
1430 LET G(2)=G(2)-F
1440 LET Z=R*S-1
1450 GO SUB 1700
1460 LET G(3)=F
1470 LET Z=N+R*S-1
1480 GO SUB 1700
1490 LET G(3)=G(3)-F
1500REM*************************************************************
1510 LET E1=LOG(P1/(1-P1))+F(3)+G(3)-F(1)-G(1)-F(2)-G(2)
1520 LET E1=E1-(C1+C2)*G(3)+C1*(F(1)+G(1)+H(1))+C2*(F(2)+H(2)+G(2))
1530 LET P=1/(1+EXP(-E1))
1540 PRINT "P(DEPENDENCE)="P
1550 PRINT
1560 PRINT "N="N;"N(Y)=";
1570 FOR Y=1 TO R*S
1580 PRINT N(Y);
1590 NEXT Y
1600 PRINT
1610 IF C1=0 THEN 1640
1620 PRINT "P(A/X) KNOWN"
1630 GO TO 1690
1640 IF C2=0 THEN 1670
1650 PRINT "P(B/X) KNOWN"
1660 GO TO 1690
1670 PRINT "NO CONTROLS"
1680 GO TO 1690
1690 GO TO 1850
1700 REM **************************************************************
1710 REM **   THIS SUBROUTINE COMPUTES LOG OF Z FACTORIAL, CALLS IT F **
1720 REM ****************************************************************
1730 LET F=0
1740 IF Z=0 THEN 1820
1750 IF Z>50 THEN 1800
1760 FOR F9=1 TO Z
1770 LET F=F+LOG(F9)
1780 NEXT F9
1790 GO TO 1820
1800 LET F=(Z+(1/2))*LOG(Z)-Z+LOG(SQR(6.283185))
1810 REM ********END OF SUBROUTINE  ***********************************
1820 RETURN
1830
1840
1850 END