(FILECREATED "11-Feb-86 22:59:29" {QV}<IDL>SOURCES>ANOVA.;14 31702
changes to: (VARS ANOVACOMS)
previous date: " 7-Oct-85 23:25:07" {QV}<IDL>SOURCES>ANOVA.;13)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ANOVACOMS)
(RPAQQ ANOVACOMS ((* analysis of variance fns)
(FNS ANOVA ANOVA.BEFOREP ANOVA.GT ANOVA.INCSHP ANOVA.NEST ANOVA.TESTLINE CONTAINS
EMS EMS.COEFF FACTORLAB FACTORNUM FCODE INTERSECT SOURCELABELS)
(MACROS CONTAINS FCODE INTERSECT)))
(* analysis of variance fns)
(DEFINEQ
(ANOVA
[ULAMBDA ((MTABLE (EXPECTS ARRAY) (SATISFIES MTABLE:FORMAT='FULL) "Invalid moments table")
(RANDOM (ONEOF LABEL NUMBERP LST))
(NESTING ALIST))
(* DECLARATIONS: (ACCESSFNS ALINE ((SS (PROGN DATUM)) (DF (IPLUS DATUM 1)) (MS (IPLUS DATUM 2))
(FVAL (IPLUS DATUM 3)) (P (IPLUS DATUM 4)))))
(* jop: " 5-Sep-85 19:01" posted: "13-JUL-77 11:43")
(* Produces an ANOVA table from the moments matrix MTABLE. NESTING specifies the nesting relationships.
RANDOM specifies the random factors and is used to decide on the appropriate F denominator.)
(DPROG ((NMOMS (GETRELT (fetch SHAPE of MTABLE)
(fetch NDIMS of MTABLE)) IJK (* Number of moments))
(SHAPE (fetch SHAPE of MTABLE) ROWINT (USEDIN ANOVA.GT EMS.COEFF))
(M (CONV.SIMARRAY MTABLE T) SIMARRAY (USEDIN ANOVA.GT))
(NF (SUB1 (fetch NDIMS of MTABLE)) INTEGER (USEDIN ANOVA.GT ANOVA.NEST EMS.COEFF
SOURCELABELS)
(* No. of factors))
THEN (CROSSED NIL (ONEOF NIL ROWINT) (USEDIN ANOVA.NEST EMS.COEFF SOURCELABELS))
(ALLFACS NIL (ONEOF NIL ROWINT) (USEDIN ANOVA.NEST EMS.COEFF))
(NLINES NIL (ONEOF NIL INTEGER) (USEDIN ANOVA.NEST EMS.COEFF SOURCELABELS))
(NCELLS 1 IJK (USEDIN ANOVA.GT))
(DIFF NIL BOOL (* T if cell N's differ))
(WSS 0.0 FLOATING (* Within-cell sum-of-squares.
Stays 0 if no estimates are found))
(NHARM 0.0 FLOATING (* Harmonic mean of cell N's))
(ANOVA NIL SIMARRAY)
(ANROW NIL ROWSCALAR)
(RANDROW NIL (ONEOF NIL ROWINT) (USEDIN EMS.COEFF)
(* If RANDOM, then the row of random factors))
(NLINES1 NIL INTEGER (USEDIN ANOVA.TESTLINE) (* # of output lines, including error))
(WDF NIL FLOATING (* Within-cell df))
(MIDX (create ROWINT
NELTS ←(fetch NELTS of SHAPE)) ROWINT (USEDIN ANOVA.GT)
(* Indexing vector))
(I1 (create ROWINT
NELTS ← NF) ROWINT (USEDIN ANOVA.GT)
(* See ANOVA.GT))
(I2 (create ROWINT
NELTS ← NF) ROWINT (USEDIN ANOVA.GT)
(* Ditto)))
(if (EQ NMOMS 2)
then (UERROR "Two moments not interpretable"))
(ANOVA.NEST NESTING MTABLE 0)
[if RANDOM
then (SETQ RANDROW (create ROWINT
NELTS ← NF
INIT ← 0))
(SETQ RANDOM (for R inside RANDOM declare (RANDROW ROWINT)
collect (SETRELT RANDROW (SETQ R (FACTORNUM M R))
1)
(FACTORLAB M R]
[for I to NF do (SETQ NCELLS (ITIMES NCELLS (GETRELT SHAPE I]
(* compute NHARM as harmonic mean of nonzero cell)
(DPROG ((NOBS 0.0 FLOATING))
[if (EQ NMOMS 1)
then (SETQ NHARM (SETQ NOBS (FLOAT NCELLS)))
else (bind TEMP N FIRSTN (GSBM ←(SETUP M (QUOTE ROWMAJOR)))
declare (N SCALAR)
(TEMP SCALAR)
(FIRSTN (ONEOF NIL ARITH))
(GSBM GENSTATEBLOCK)
until (fetch DONE of GSBM)
do (if (AND (SETQ N (GETAELT M (NEXT GSBM)))
(FGREATERP N 0.0))
then (fadd NOBS N)
(fadd NHARM (FQUOTIENT 1.0 N))
(if (NULL FIRSTN)
then (SETQ FIRSTN N)
elseif DIFF
elseif (NOT (EQP N FIRSTN))
then (SETQ DIFF T))
(SKIP GSBM 1) (* Skip the mean)
(if (AND (SETQ TEMP (GETAELT M (NEXT GSBM)))
(FGREATERP TEMP 0.0))
then (fadd WSS (FTIMES (FDIFFERENCE N 1.0)
TEMP)))
(SKIP GSBM (IDIFFERENCE NMOMS 3))
else (UERROR "Empty cell in MTABLE: " MTABLE]
(SETQ ANOVA (ALLOC.SARRAY (ROWINTOF (SETQ NLINES1 (if (FGREATERP WSS 0.0)
then
(SETQ WDF
(FLOAT (IDIFFERENCE
(FIX NOBS)
NCELLS)))
(ADD1 NLINES)
else NLINES))
5)
(QUOTE FULL)
0.0))
(SETQ ANROW (fetch ELEMENTBLOCK of ANOVA))
(if LABPROPFLAG
then [SETTITLE ANOVA (APPLY (FUNCTION MAKETITLE)
(CONS NIL
(CONS MTABLE
(if RANDOM
then (LIST (LIST (QUOTE LIST)
"with"
(CONS (QUOTE LIST)
RANDOM)
"considered random"]
(for I from 1 as LAB in (QUOTE (SumSq df MS F p))
do (SETLEVLAB ANOVA 2 I LAB))
(SETLEVLAB ANOVA 1 1 (QUOTE Gnd-mean))
(SOURCELABELS MTABLE ANOVA 2)
(if (FGREATERP WSS 0.0)
then (SETLEVLAB ANOVA 1 NLINES1 (QUOTE Error)))
(SETDIMLAB ANOVA 1 (QUOTE Source))
(SETDIMLAB ANOVA 2 (QUOTE Column)))
(ASSERT (FGTP NHARM 0.0))
(SETQ NHARM (FQUOTIENT NCELLS NHARM))
(if (AND DIFF (IGREATERP NF 1))
then (SETARRAYPROP ANOVA (QUOTE HMEAN)
(SELECTQ (SYSTEMTYPE)
((TENEX TOPS-20)
(* :F to copy the constant box)
(fetch F of NHARM))
NHARM))))
(SETRELT MIDX (ADD1 NF)
(if (EQ NMOMS 1)
then 1
else 2)) (* ANOVA.GT only looks at the means)
[if (AND DIFF (EQ NF 1))
then (DPROG ((MROW (MOMENTS.FEW (FSELECT M (ROWPTROF (QUOTE ALL)
2))
(FSELECT M (ROWPTROF (QUOTE ALL)
1))
2) ROWSCALAR))
(DECL (ANROW ROWFLOAT)) (* Special one-way case to avoid unweighted means)
[SETRELT ANROW (fetch MS of 1)
(SETRELT ANROW (fetch SS of 1)
(FTIMES (GETRELT MROW 1)
(GETRELT MROW 2)
(GETRELT MROW 2]
(SETRELT ANROW (fetch DF of 1)
1.0)
(SETRELT ANROW (fetch SS of 6)
(FTIMES (FDIFFERENCE (GETRELT MROW 1)
1.0)
(GETRELT MROW 3)))
(SETRELT ANROW (fetch DF of 6)
(FDIFFERENCE NCELLS 1.0))
(SETRELT ANROW (fetch MS of 6)
(FQUOTIENT (GETRELT ANROW (fetch SS of 6))
(FDIFFERENCE NCELLS 1.0)))
(SETRELT ANROW (fetch SS of 11)
WSS)
(SETRELT ANROW (fetch DF of 11)
WDF)
(SETRELT ANROW (fetch MS of 11)
(FQUOTIENT WSS WDF)))
else (for I AGT AFI SS DF to NLINES as II from 1 by 5
declare (ANROW ROWFLOAT)
(SS FLOATING)
(DF FLOATING)
do (SETQ AFI (GETRELT ALLFACS I))
(replace NELTS of I1 with (replace NELTS of I2 with NF))
(* Rows may have been shortened in previous calls)
(for J to NF do (SETRELT MIDX J 1)) (* Reset index to 1)
(SETQ AGT (ANOVA.GT AFI)) (* Returns result as a cons cell)
(SETQ SS (FTIMES NHARM (CDR AGT)))
(SETQ DF (FLOAT (CAR AGT)))
[for J from 2 to (SUB1 I) as JJ from 6 by 5 when (CONTAINS AFI
(GETRELT ALLFACS J))
do [SETQ SS (FDIFFERENCE SS (GETRELT ANROW (fetch SS of JJ]
(* Recursively compute ss as G-SS from other lines, DF as TT-DF from other lines of table. Start after the
Grand-mean cause it is already taken out in ANOVA.GT)
(SETQ DF (FDIFFERENCE DF (GETRELT ANROW (fetch DF of JJ]
(SETRELT ANROW (fetch SS of II)
SS) (* Put away SS, DF in table, SS corrected for NHARM)
(SETRELT ANROW (fetch DF of II)
DF)
(SETRELT ANROW (fetch MS of II)
(FQUOTIENT SS DF)) (* Store the MS)
finally (if (FGREATERP WSS 0.0)
then (* Fill-in the within-cell error line)
(SETRELT ANROW (fetch SS of II)
WSS)
(SETRELT ANROW (fetch DF of II)
WDF)
(SETRELT ANROW (fetch MS of II)
(FQUOTIENT WSS WDF]
(* Compute F-tests taking RANDROW into account to
choose the denominators)
(for LINE TESTLINE F to NLINES1
declare (F FLOATING)
(LINE INTEGER (USEDIN ANOVA.TESTLINE))
as LL from 1 by 5 do (if (AND (SETQ TESTLINE (ANOVA.TESTLINE (ADD1 LINE)
1))
(ILEQ TESTLINE NLINES1))
then (* Don't use the highest order interaction as a
substitute for the within-cell error)
(SETQ TESTLINE (IDIFFERENCE (ITIMES 5 TESTLINE)
4))
[SETQ F (FQUOTIENT (GETRELT ANROW (fetch MS of LL))
(GETRELT ANROW (fetch MS of TESTLINE]
(SETRELT ANROW (fetch FVAL of LL)
F)
[SETRELT ANROW (fetch P of LL)
(FPROB.LISP F (GETRELT ANROW
(fetch DF of LL))
(GETRELT ANROW (fetch DF of TESTLINE]
else (SETRELT ANROW (fetch FVAL of LL)
NIL)
(SETRELT ANROW (fetch P of LL)
NIL)))
(RETURN ANOVA))])
(ANOVA.BEFOREP
[DLAMBDA ((LINE1 INTEGER)
(LINE2 INTEGER))
(* rmk: " 1-MAY-79 17:02" posted: " 1-MAY-79 17:10")
(* Returns T if LINE1 should come before LINE2 in an ANOVA or EMS table. The LINEs represent ALLFACS involved.
The crucial ordering is that a line must come after all lines it contains. Within that, the esthetic order is -
1: a line with fewer factors comes before a line with more factors; -
2: otherwise, the line with the one in the right-most mismatch comes first.)
[if (CONTAINS LINE2 LINE1)
elseif (CONTAINS LINE1 LINE2)
then NIL
else (for I1←LINE1 by (LRSH I1 1) as I2←LINE2 by (LRSH I2 1) bind RONE NBITS1←0
NBITS2←0
until I1=I2
unless (LOGAND I1 1)=(LOGAND I2 1)
do (* I1=I2 => they are both zero.)
(if (INTERSECT I1 1)
then (add NBITS1 1)
(if RONE=NIL
then RONE←1)
else (* If 1-bit of I1 is off, then 1-bit of I2 is on)
(add NBITS2 1)
(if RONE=NIL
then RONE←2))
finally (RETURN (if NBITS1 lt NBITS2
elseif NBITS1=NBITS2
then RONE=1]])
(ANOVA.GT
[DLAMBDA ((SET INTEGER)
(RETURNS LISTP))
(* jop: " 7-Oct-85 23:18")
(* Accumulates the sum of a set of observations squared, as well as the number of that set; these are the NIN and T
numbers referred to in the documentation)
(DECL (M SIMARRAY (BOUNDIN ANOVA))
(NF INTEGER (BOUNDIN ANOVA))
(NCELLS INTEGER (BOUNDIN ANOVA))
(SHAPE ROWINT (BOUNDIN ANOVA))
(MIDX ROWINT (BOUNDIN ANOVA) (* Index to M))
(I1 ROWINT (BOUNDIN ANOVA) (* Factors in SET))
(I2 ROWINT (BOUNDIN ANOVA) (* Factors within cells)))
(* MIDX, I1, and I2 are only used within ANOVA.GT but
are bound outside to avoid reallocating them for each
call)
(DPROG ((NIN 1 IJK (* Product of # levels of factors in SET))
(NOUT 1 IJK (* Product of levels for factors not in SET))
(L1 0 INTEGER (* Length of I1))
(L2 0 INTEGER (* Length of I2))
(MN 0.0 FLOATING (* Current mean estimate))
(SUMSQ 0.0 FLOATING (* Mean-centered sum of squares))
(TOT NIL FLOATING (* Floating scratch)))
(for I to NF
do
(* Separate shape into 2 vectors: factors in SET and factors not in SET. I1, I2 are their indices.
The outside loop will increment the I1 set while inner increments the I2)
(if (INTERSECT SET (FCODE I))
then (SETQ NIN (ITIMES NIN (GETRELT SHAPE I)))
(SETRELT I1 (add L1 1)
I)
else (SETRELT I2 (add L2 1)
I)))
(replace NELTS of I1 with L1) (* Contracting lengths of factor vectors)
(replace NELTS of I2 with L2)
(SETQ NOUT (IQUOTIENT NCELLS NIN))
(for I to NIN
do (* Enumerate first set of subscripts, accumulating sum
of squared deviations from mean of the within cells
totals)
(SETQ TOT 0.0)
(bind TEMP for J to NOUT
do (* Accumulate sum of observations across all levels of
factors not in the set SET. There must be no empty
cells.)
(if (SETQ TEMP (GETAELT M (AELTPTR M MIDX)))
then (fadd TOT TEMP)
else (UERROR "Missing cell mean"))
(ANOVA.INCSHP SHAPE MIDX I2)) (* We now have a within cell sum so we update the
running mean and sumsq)
(SETQ TOT (FQUOTIENT (FDIFFERENCE TOT MN)
I))
(fadd MN TOT)
(fadd SUMSQ (FTIMES TOT TOT (SUB1 I)
I))
(ANOVA.INCSHP SHAPE MIDX I1))
[RETURN (if (ZEROP SET)
then (* The grand-mean)
(CONS 1 (FQUOTIENT (FTIMES TOT TOT)
NOUT))
else (* Correct DF for the estimated grand mean.)
(CONS (IVALUE (SUB1 NIN))
(FQUOTIENT SUMSQ NOUT])])
(ANOVA.INCSHP
[DLAMBDA ((SHAPE ROWINT)
(INDEX ROWINT (SATISFIES (AND INDEX:NELTS=SHAPE:NELTS
(for I to SHAPE:NELTS never INDEX$I GT SHAPE$I))))
(SUB ROWINT (SATISFIES (AND (SUB:NELTS LT SHAPE:NELTS)
(for I to SUB:NELTS never SUB$I GT SHAPE:NELTS)))))
(* bas: "30-NOV-77 20:54" posted: "30-NOV-77 21:07")
(* Version of INCSHP specialized for ANOVA. Increments INDEX relative to SHAPE but only those elements that are
selected by SUB. That is, it increments either the within cell index or the cell index depending on which factor
selector is based in)
(for I IX to 1 by -1 from SUB:NELTS
do (IX←SUB$I)
(if INDEX$IX LT SHAPE$IX
then (RETURN INDEX$IX←INDEX$IX+1)
else (INDEX$IX←1)))])
(ANOVA.NEST
[DLAMBDA ((NESTING ALIST)
(LABSOURCE ARRAY (* Either a shape vector or moments table))
(START (MEMQ 0 1) (* 1 from EMS, 0 from ANOVA for grand mean)))
(* rmk: "30-APR-79 02:02" posted: "19-SEP-77 09:47")
(* Processes the nesting specification for an ANOVA design, producing the rows describing the output lines.
A nest-specification is a list of dimension numbers or labels, with the first one in the list being nested within
the following ones. E.g. (X Y Z) means X is nested within Y and Z, which is equivalent to the pair
(X Y) and (X Z) but not to the pair (X Y) (Y Z); the latter further implies that Y is nested within Z.
Results are returned by the free vars CROSSED, ALLFACS, and NLINES)
(DECL (NF INTEGER (BOUNDIN ANOVA EMS))
(CROSSED (ONEOF NIL ROWINT) (BOUNDIN ANOVA) (* length NLINES, set of crossed factors for this line))
(ALLFACS (ONEOF NIL ROWINT) (BOUNDIN ANOVA) (* length NLINES, CROSSED union all super-factors of
crossed factors))
(NLINES (ONEOF NIL INTEGER) (BOUNDIN ANOVA) (* # of lines of the anova output)))
(DPROG ((SUPFACTS (create ROWINT
NELTS ← NF
INIT ← 0) ROWINT (* Code union representing set of factors within which
this one is nested))
(NPOSS ((LLSH 1 NF)
-START) INTEGER (* # of possible lines; don't include grand mean for
EMS)))
(NESTING←(for NSPEC SUB in NESTING
collect (SUB←(FACTORNUM LABSOURCE NSPEC:1))
(<(FACTORLAB LABSOURCE SUB)
!(for SUPER SUP K←0 in NSPEC::1
collect [K←(LOGOR K (FCODE SUP←(FACTORNUM LABSOURCE SUPER]
(FACTORLAB LABSOURCE SUP)
finally (if (CONTAINS K (FCODE SUB))
then (UERROR "Circular nesting specification: "
NESTING))
(SUPFACTS$SUB←K))
>)))
(CROSSED←(create ROWINT
NELTS ← NPOSS))
(ALLFACS←(create ROWINT
NELTS ← NPOSS))
(NLINES←0)
(for CR ALLF from START to NPOSS-1 when (for J SUPS to NF first ALLF←CR
when (INTERSECT CR (FCODE J))
always (AND ~(INTERSECT CR SUPS←SUPFACTS$J)
ALLF←(LOGOR ALLF SUPS)))
do (add NLINES 1) (* Don't include lines containing a factor and its
super-factors)
(CROSSED$NLINES←CR)
(ALLFACS$NLINES←ALLF))
(ALLFACS:NELTS←NLINES)
(DPROG ((ORDER (ORDERROW ALLFACS (FUNCTION ANOVA.BEFOREP)) ROWINT)
(SCR (create ROWINT
NELTS ← NLINES) ROWINT))
(for I from 1 to NLINES do (SCR$I←CROSSED$(ORDER$I)))
(swap CROSSED SCR)
(for I from 1 to NLINES do (SCR$I←ALLFACS$(ORDER$I)))
(swap ALLFACS SCR)) (* Return NESTING with the labels all coerced to their
official spellings)
(RETURN NESTING))])
(ANOVA.TESTLINE
[DLAMBDA ((TL INTEGER (* The line we are now considering))
(CI INTEGER (SATISFIES (NOT (IGREATERP CI NLINES1)))
(* Index of the coefficient to be considered))
(RETURNS (ONEOF INTEGER NIL)))
(* rmk: "28-APR-79 14:44" posted: "17-SEP-78 22:31")
(* Returns the line for which all coefficients from CI onward match the corresponding coefficients for line LINE,
except that the LINE,CI coefficient must be zero)
(DECL (LINE INTEGER (BOUNDIN ANOVA))
(ALLFACS ROWINT (BOUNDIN ANOVA))
(NLINES INTEGER (BOUNDIN ANOVA))
(NLINES1 INTEGER (BOUNDIN ANOVA)))
[if LINE lt NLINES1
then (bind TEMP (NEED ←(if (IEQP LINE CI)
then (* Want a 0 corresponding to the diagonal)
0
else (EMS.COEFF ALLFACS$LINE CI)))
declare (NEED INTEGER) for L from TL to NLINES+1
when (IEQP (if L gt NLINES
then (* Fake the coefficient for the within-cell error)
0
else (EMS.COEFF ALLFACS$L CI))
NEED)
do (* Go to NLINES+1, cause we want to know whether we'd
like the within-cell error, even if we don't have one.)
(if (IEQP CI NLINES)
then (RETURN L)
elseif TEMP←(ANOVA.TESTLINE L CI+1)
then (RETURN TEMP]])
(CONTAINS
[DLAMBDA ((BIG INTEGER)
(SMALL INTEGER)
(RETURNS BOOL))
(* rmk: "22-JUL-77 21:52" posted: "22-JUL-77 22:07")
(* Are the one-bits of SMALL also on in BIG?)
(IEQP SMALL (LOGAND BIG SMALL))])
(EMS
[ULAMBDA ((NLEVELS [ONEOF VECTOR (ARRAY (SATISFIES NLEVELS:FORMAT='FULL (IGEQ NLEVELS:SHAPE$(
NLEVELS:NDIMS)
3])
(RANDOM (ONEOF LABEL NUMBERP LST))
(NESTING ALIST)
(RETURNS MATRIX))
(* rmk: "29-APR-79 14:49" posted: "28-APR-78 21:21")
(* Produces an EMS table corresponding to a moments table with factor levels represented by NLEVELS, the nesting
relationships in NESTING, and the factors in RANDOM considered random. If shape is more than a vector, then it is
considered to be the moments table itself, as opposed to a shape. This is just application of the formulas from the
BIOMED document.)
(DPROG ((SHAPE NIL ROWINT (USEDIN EMS.COEFF))
(NF NIL INTEGER (USEDIN ANOVA.NEST EMS.COEFF SOURCELABELS))
(CROSSED NIL (ONEOF NIL ROWINT) (USEDIN ANOVA.NEST EMS.COEFF SOURCELABELS))
(ALLFACS NIL (ONEOF NIL ROWINT) (USEDIN ANOVA.NEST EMS.COEFF))
(NLINES NIL (ONEOF NIL INTEGER) (USEDIN ANOVA.NEST EMS.COEFF SOURCELABELS)))
(if NLEVELS:NDIMS=1
then (SHAPE←(CONV.SIMARRAY NLEVELS):ELEMENTBLOCK)
(NF←SHAPE:NELTS)
else (SHAPE←NLEVELS:SHAPE)
(NF←(SHAPE:NELTS-1)))
(NESTING←(ANOVA.NEST NESTING NLEVELS 1))
(RETURN (DPROG ((RANDROW (create ROWINT
NELTS ← NF
INIT ← 0) ROWINT (USEDIN EMS.COEFF))
(EMS (ALLOC.SARRAY (ROWINTOF NLINES NLINES)
'FULL 0) SIMARRAY)
THEN (GSBEMS (SETUP EMS 'ROWMAJOR) GENSTATEBLOCK))
(RANDOM←(for R F inside RANDOM
collect (RANDROW$(F←(FACTORNUM NLEVELS R))←1)
(* Change numbers to labels for title)
(FACTORLAB NLEVELS F)))
[for I from 1 to NLINES
do (SKIP GSBEMS I-1)
(for J from I to NLINES do (SETAELT EMS (NEXT GSBEMS)
(EMS.COEFF ALLFACS$I J]
(if LABPROPFLAG
then (SETTITLE EMS
(MAKETITLE 'EXPECTED% MEAN% SQUARES < " for " NLEVELS>
< " with "
<'LIST (if NESTING
then <'LIST ! NESTING>
else "no")
"nesting" >>
(if RANDOM
then <'LIST <'LIST ! RANDOM>
"considered random"
>
else "no random factors")))
(SOURCELABELS NLEVELS EMS 1)
(LAB.COPYDIM EMS EMS 1 2)
(SETDIMLAB EMS 1 'Source)
(SETDIMLAB EMS 2 'Coeff))
(RETURN EMS))))])
(EMS.COEFF
[DLAMBDA ((SET INTEGER)
(J INTEGER))
(* rmk: "29-APR-79 14:52" posted: "17-SEP-78 22:47")
(* Computes Jth EMS coefficient for the line with SET
factors involved)
(DECL (RANDROW (ONEOF NIL ROWINT) (BOUNDIN ANOVA EMS))
(CROSSED ROWINT (BOUNDIN ANOVA EMS))
(ALLFACS ROWINT (BOUNDIN ANOVA EMS))
(NF INTEGER (BOUNDIN ANOVA EMS))
(NLINES INTEGER (BOUNDIN ANOVA EMS))
(SHAPE (BOUNDIN ANOVA EMS)))
(if (CONTAINS ALLFACS$J SET)
then
(* (LOGXOR SET -1) is the complement of SET -
(LOGXOR ALLFACS$J CROSSED$J) is the set of super-factors for line J, since ALLFACS= (LOGOR SUPS CROSSED) when SUPS
and CROSSED are disjoint)
(for JJ ALPHA←1
(CSET ←(LOGXOR SET -1))
(SUPS ←(LOGOR SET (LOGXOR ALLFACS$J CROSSED$J))) to NF
do ALPHA←ALPHA*(if (CONTAINS (LOGAND CSET CROSSED$J)
(FCODE JJ))
then (if RANDROW
then RANDROW$JJ
else (RETURN 0))
elseif (CONTAINS SUPS (FCODE JJ))
then 1
else SHAPE$JJ)
finally (RETURN ALPHA))
else 0)])
(FACTORLAB
[DLAMBDA ((LABSOURCE ARRAY)
(FNO INTEGER))
(* rmk: "21-SEP-78 22:37" posted: "21-SEP-78 22:37")
(* Returns the label for factor FNO, or FNO)
(OR (if LABSOURCE:NDIMS=1
then (GETLEVLAB LABSOURCE 1 FNO)
elseif (GETDIMLAB LABSOURCE FNO))
FNO)])
(FACTORNUM
[DLAMBDA ((VORA ARRAY (* Vector => labels from levels, otherwise from
dimensions))
(FSPEC ANY (* Factor specification))
(RETURNS INTEGER))
(* rmk: "11-OCT-77 16:21" posted: "17-SEP-77 00:37")
(* Maps FSPEC into a factor number)
(DPROG ((FNUM NIL INTEGER))
(UERRORGUARD (if VORA:NDIMS=1
then FNUM←(MAKE1SLTR VORA FSPEC 1)
else (FNUM←(MAKE1DIMSPEC VORA FSPEC))
(* Can't be the last prtition dimension)
(OR (FNUM LT VORA:SHAPE:NELTS)
(UERROR)))
"Illegal factor specification: " FSPEC)
(RETURN FNUM))])
(FCODE
[DLAMBDA ((FNUM INTEGER)
(RETURNS INTEGER))
(* rmk: "29-APR-79 14:41" posted: "29-APR-79 14:42")
(* Converts a factor number into its bit-code)
(LLSH 1 FNUM-1)])
(INTERSECT
[DLAMBDA ((A INTEGER)
(B INTEGER)
(RETURNS BOOL))
(* rmk: "17-SEP-77 21:00" posted: "12-JUL-77 10:30")
~(IEQP 0 (LOGAND A B))])
(SOURCELABELS
[DLAMBDA ((LABSOURCE ARRAY)
(OUTPUT ARRAY)
(STARTLINE (MEMQ 1 2) (* 2 from ANOVA, 1 from EMS cause no grand-mean)))
(* rmk: "29-APR-79 14:54" posted: "17-OCT-77 00:23")
(* Generates labels for the source dimension of ANOVA and EMS output. The main-effects are represented by their
labels if possible, else by FACTOR1, FACTOR2, etc The interaction labels are either minimal discriminating prefixes
of the main-effect labels, or simply the factor number)
(DECL (CROSSED ROWINT (BOUNDIN ANOVA EMS))
(NLINES INTEGER (BOUNDIN ANOVA EMS))
(NF INTEGER (BOUNDIN ANOVA EMS)))
(DPROG ((FLABELS (create ROWPTR
NELTS ← NF) ROWPTR (* Factor labels: main-effect labels in CAR,
interaction labels in CDR)))
(for I LAB from 1 to NF
do (LAB←(FACTORLAB LABSOURCE I))
(FLABELS$I←LAB)
(for J JLAB JJLAB K←1
(ILAB ←(NTHCHAR LAB 1)) from 1 to I-1 when ILAB=(GETRELTD FLABELS J)
do (JLAB←FLABELS$J)
(for old K from K+1 to (IMAX (NCHARS LAB)
(NCHARS JLAB))
unless (STREQUAL ILAB←(OR (SUBSTRING LAB 1 K (CONSTANT (CONCAT)))
LAB)
JJLAB←(OR (SUBSTRING JLAB 1 K (CONSTANT (CONCAT)))
JLAB))
do ((GETRELTD FLABELS J)←(MKATOM JJLAB))
(RETURN))
(ILAB←(MKATOM ILAB))
finally ((GETRELTD FLABELS I)←ILAB)))
[for L CL from STARTLINE to NLINES
do (CL←CROSSED$L)
(SETLEVLAB OUTPUT 1 L (for J TEMP from 1 until TEMP←(FCODE J) gt CL
join (if (IEQP CL TEMP)
then (RETURN (if (type? INTEGER (TEMP←FLABELS$J))
then (PACK* 'Factor J)
else TEMP))
elseif (INTERSECT CL TEMP)
then <'*(GETRELTD FLABELS J)
>)
finally (RETURN (PACK $$VAL ::1])])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS CONTAINS MACRO (ARGS (SUBPAIR (QUOTE (BIG SMALL))
ARGS
(COND [(NLISTP (CADR ARGS))
(QUOTE (IEQP SMALL (LOGAND BIG SMALL]
(T (QUOTE ([LAMBDA ($$SM)
(DECLARE (LOCALVARS $$SM))
(IEQP $$SM (LOGAND BIG $$SM]
SMALL]
[PUTPROPS FCODE MACRO ((FNUM)
(LLSH 1 (SUB1 FNUM]
[PUTPROPS INTERSECT MACRO ((A B)
(NOT (IEQP 0 (LOGAND A B]
)
(PUTPROPS ANOVA COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (585 31189 (ANOVA 595 . 11412) (ANOVA.BEFOREP 11414 . 12821) (ANOVA.GT 12823 . 16530) (
ANOVA.INCSHP 16532 . 17463) (ANOVA.NEST 17465 . 20867) (ANOVA.TESTLINE 20869 . 22546) (CONTAINS 22548
. 22918) (EMS 22920 . 25716) (EMS.COEFF 25718 . 27074) (FACTORLAB 27076 . 27512) (FACTORNUM 27514 .
28433) (FCODE 28435 . 28759) (INTERSECT 28761 . 29006) (SOURCELABELS 29008 . 31187)))))
STOP