aron (05/04/83)
echo x - anova.i cat >anova.i <<'!Funky!Stuff!' FUNCTION anova(mat/MATRIX/,print/LGL,1,TRUE/) STRUCTURE( ssq /REAL,4,NAOK/ df /REAL,4,NAOK/ msq /REAL,4,NAOK/ f /REAL,4,NAOK/ pf /REAL,4,NAOK/ ) # do anova calculations call avcalc(NROW(mat),NCOL(mat),mat,ssq[1],ssq[2],ssq[3],ssq[4],df[1], df[2],df[3],df[4],msq[1],msq[2],msq[3],f[1],f[2],pf[1],pf[2]) # set unused table values to NA NASET(msq[4]) NASET(f[3]) NASET(f[4]) NASET(pf[3]) NASET(pf[4]) # return results RETURN(ssq,df,msq,f,pf,&) if(print) { # set up anova STR, call printing STRUCTURE(z/STR,1/) VALUE(z)=outstr #collect all args outstr=alcdir(1,fname,TFUN) # new result structure nres=0; RETURN(z,&) # return z as only arg. CHAIN(avprt) } END !Funky!Stuff! echo x - avprt.i cat >avprt.i <<'!Funky!Stuff!' FUNCTION avprt(z/STR/) INCLUDE(print) INCLUDE(io) ARGSTR(z) ARG( ssq /REAL,4,NAOK/ df /REAL,4,NAOK/ msq /REAL,4,NAOK/ f /REAL,4,NAOK/ pf /REAL,4,NAOK/ ) STRUCTURE(val/REAL,5,NAOK/) SKIP(OUTFC) FPRINT(OUTFC," SSq DF MSq", " F PF") SKIP(OUTFC) val[1] = ssq[1] val[2] = df[1] val[3] = msq[1] val[4] = f[1] val[5] = pf[1] call lnfmt("Between rows: ",5,val) SKIP(OUTFC) val[1] = ssq[2] val[2] = df[2] val[3] = msq[2] val[4] = f[2] val[5] = pf[2] call lnfmt("Between columns: ",5,val) SKIP(OUTFC) val[1] = ssq[3] val[2] = df[3] val[3] = msq[3] val[4] = f[3] val[5] = pf[3] call lnfmt("Residual: ",5,val) FPRINT(OUTFC," --------------------") val[1] = ssq[4] val[2] = df[4] val[3] = msq[4] val[4] = f[4] val[5] = pf[4] call lnfmt(" Total: ",5,val) RETURN(ssq,df,msq,f,pf) END !Funky!Stuff! echo x - bfprt.i cat >bfprt.i <<'!Funky!Stuff!' FUNCTION bfprt(z/STR/) ARGSTR(z) ARG(mdiff /MATRIX,NAOK/ mt /MATRIX,NAOK/ mpt /MATRIX,NAOK/ ) STATIC( integer nc) nc = NCOL(mdiff) call ptfmt("Difference between Column Means:",nc,mdiff) call ptfmt("t Statistics:",nc,mt) call ptfmt("t Statistics Probability:",nc,mpt) RETURN(mdiff,mt,mpt) END !Funky!Stuff! echo x - bonferroni.i cat >bonferroni.i <<'!Funky!Stuff!' FUNCTION bonferroni(mat/MATRIX/,mse/REAL/,print/LGL,1,TRUE/) STATIC( integer i,j,k,ni,nj; real adiff,at,apt) STRUCTURE( mdiff /MATRIX,NCOL(mat),NCOL(mat),NAOK/ mt /LIKE(mdiff)/ mpt /LIKE(mdiff)/ ivec /REAL,NROW(mat),NAOK/ jvec /LIKE(ivec)/ ) ni = 0 nj = 0 DO i = 1, NCOL(mat) { DO j = i+1, NCOL(mat) { DO k = 1, NROW(mat) { ivec[k] = mat[k,i] if (.not.(NA(mat[k,i]))) { ni = ni + 1 } jvec[k] = mat[k,j] if (.not.(NA(mat[k,j]))) { nj = nj + 1 } } call bfcalc(NROW(mat),ni,nj,ivec,jvec,mse,adiff,at,apt) mdiff[i,j] = adiff mdiff[j,i] = -adiff mt[i,j] = at mpt[i,j] = apt mt[j,i] = -at mpt[j,i] = apt } } DO i = 1, NCOL(mat) { NASET(mdiff[i,i]) NASET(mt[i,i]) } RETURN(mdiff,mt,mpt,&) if(print) { # set up bonferroni STR, call printing STRUCTURE(z/STR,1/) VALUE(z)=outstr #collect all args outstr=alcdir(1,fname,TFUN) # new result structure nres=0; RETURN(z,&) # return z as only arg. CHAIN(bfprt) } END !Funky!Stuff! echo x - emedit.i cat >emedit.i <<'!Funky!Stuff!' FUNCTION emedit(defin/CHAR/,pos/INT,1,2/) INCLUDE(attach) STATIC( integer outfc,sattac ) outfc=sattac(TSTRING(EDIT_FILE),WRITE,AUTO) STRUCTURE( args /FROM(defin),CHAR,OPTIONAL/ deflt /FROM(defin),CHAR,OPTIONAL/ file /CHAR,1,STRING(EDIT_FILE)/ ) if(MISSING(args))nargs=0; else nargs=LENGTH(args) call macout(DATANAME(defin),nargs,args,deflt,LENGTH(defin),defin,outfc) call rewnd(outfc) call sclose(outfc) #so ed can write on the file call excmd(TSTRING(emacs EDIT_FILE),-1) # allow user to edit CHAIN(Define,file,pos) END !Funky!Stuff! echo x - pairedt.i cat >pairedt.i <<'!Funky!Stuff!' FUNCTION pairedt(mat/MATRIX/,print/LGL,1,TRUE/) STATIC( integer i,j,k; real amean,avar,at,adf,apt) STRUCTURE( mdiff /REAL,NROW(mat)/ mmean /MATRIX,NCOL(mat),NCOL(mat),NAOK/ mvar /LIKE(mmean)/ mt /LIKE(mmean)/ mdf /LIKE(mmean)/ mpt /LIKE(mmean)/ ) DO i = 1, NCOL(mat) { DO j = i+1, NCOL(mat) { DO k = 1, NROW(mat) { mdiff[k] = mat[i,k] - mat[j,k] } call ptcalc(NROW(mat),mdiff,amean,avar,at,adf,apt) mmean[i,j] = amean mvar[i,j] = avar mt[i,j] = at mdf[i,j] = adf mpt[i,j] = apt mmean[j,i] = -amean mvar[j,i] = avar mt[j,i] = -at mdf[j,i] = adf mpt[j,i] = apt } } DO i = 1, NCOL(mat) { NASET(mmean[i,i]) NASET(mvar[i,i]) NASET(mt[i,i]) NASET(mdf[i,i]) NASET(mpt[i,i]) } RETURN(mmean,mvar,mt,mdf,mpt,&) if(print) { # set up pairedt STR, call printing STRUCTURE(z/STR,1/) VALUE(z)=outstr #collect all args outstr=alcdir(1,fname,TFUN) # new result structure nres=0; RETURN(z,&) # return z as only arg. CHAIN(ptprt) } END !Funky!Stuff! echo x - ptprt.i cat >ptprt.i <<'!Funky!Stuff!' FUNCTION ptprt(z/STR/) ARGSTR(z) ARG(mmean /MATRIX,NAOK/ mvar /MATRIX,NAOK/ mt /MATRIX,NAOK/ mdf /MATRIX,NAOK/ mpt /MATRIX,NAOK/ ) STATIC( integer nc) nc = NCOL(mmean) call ptfmt("Means:",nc,mmean) call ptfmt("Variances:",nc,mvar) call ptfmt("t Statistics:",nc,mt) call ptfmt("Degrees of Freedom:",nc,mdf) call ptfmt("t Probability:",nc,mpt) RETURN(mmean,mvar,mt,mdf,mpt) END !Funky!Stuff! echo x - tkprt.i cat >tkprt.i <<'!Funky!Stuff!' FUNCTION tkprt(z/STR/) ARGSTR(z) ARG(mdiff /MATRIX,NAOK/ mq /MATRIX,NAOK/ ) STATIC( integer nc) nc = NCOL(mdiff) call ptfmt("Difference between Column Means:",nc,mdiff) call ptfmt("q Statistics:",nc,mq) RETURN(mdiff,mq) END !Funky!Stuff! echo x - tukey.i cat >tukey.i <<'!Funky!Stuff!' FUNCTION tukey(mat/MATRIX/,mse/REAL/,print/LGL,1,TRUE/) STATIC( integer i,j,k; real adiff,aq) STRUCTURE( mdiff /MATRIX,NCOL(mat),NCOL(mat),NAOK/, mq /LIKE(mdiff)/ ivec /REAL,NROW(mat)/ jvec /LIKE(ivec)/ ) DO i = 1, NCOL(mat) { DO j = i+1, NCOL(mat) { DO k = 1, NROW(mat) { ivec[k] = mat[k,i] jvec[k] = mat[k,j] } call tkcalc(NROW(mat),ivec,jvec,mse,adiff,aq) mdiff[i,j] = adiff mdiff[j,i] = -adiff mq[i,j] = aq mq[j,i] = -aq } } DO i = 1, NCOL(mat) { NASET(mdiff[i,i]) NASET(mq[i,i]) } RETURN(mdiff,mq,&) if(print) { # set up tukey STR, call printing STRUCTURE(z/STR,1/) VALUE(z)=outstr #collect all args outstr=alcdir(1,fname,TFUN) # new result structure nres=0; RETURN(z,&) # return z as only arg. CHAIN(tkprt) } END !Funky!Stuff! echo x - vmedit.i cat >vmedit.i <<'!Funky!Stuff!' FUNCTION vmedit(defin/CHAR/,pos/INT,1,2/) INCLUDE(attach) STATIC( integer outfc,sattac ) outfc=sattac(TSTRING(EDIT_FILE),WRITE,AUTO) STRUCTURE( args /FROM(defin),CHAR,OPTIONAL/ deflt /FROM(defin),CHAR,OPTIONAL/ file /CHAR,1,STRING(EDIT_FILE)/ ) if(MISSING(args))nargs=0; else nargs=LENGTH(args) call macout(DATANAME(defin),nargs,args,deflt,LENGTH(defin),defin,outfc) call rewnd(outfc) call sclose(outfc) #so ed can write on the file call excmd(TSTRING(vi EDIT_FILE),-1) # allow user to edit CHAIN(Define,file,pos) END !Funky!Stuff! echo x - u/eedit.i cat >u/eedit.i <<'!Funky!Stuff!' FUNCTION edit( name/CHAR,OPTIONAL/ ) INCLUDE(u/action,attach) STATIC( logical streq; integer sattac,sopen,fd,i,j,lnow,islenz; POINTER p ) STATIC( CHARACTER(tmp,5) ) if(MISSING(name)){ # edit the dump file fd=sopen(TSTRING(DUMP_FILE),READ) if(fd<0)FATAL(No dumped expression) call sclose(fd) if(streq(TSTRING(eedit),TEXT(fname))) call excmd(TSTRING(emacs DUMP_FILE),-1) # fd=sattac(TSTRING(DUMP_FILE),READ,SOURCE) # why? action=SOURCE_ACTION STRUCTURE(sounam/CHAR,1,STRING(DUMP_FILE)/) RETURN(sounam) } else{ # edit a character vector if(DATANAME(name)==SNULL) FATAL(No name for edited data) if(islenz(TEXT(DATANAME(name)))>4){ # check for leading "mac." call concat(tmp,1,TEXT(DATANAME(name)),1,4); call jputch(tmp,5,"EOS") if(streq(tmp,TSTRING(mac.))){ WARNING(Use emedit for macros) CHAIN(emedit,=name) } } fd=sattac(TSTRING(EDIT_FILE),WRITE,AUTO) for(i=1; i<=LENGTH(name); i=i+1) call ptline(fd,TEXT(name[i]),islenz(TEXT(name[i]))) call sdetac(fd) call excmd(TSTRING(emacs EDIT_FILE),-1) fd=sattac(TSTRING(EDIT_FILE),READ,AUTO) # open for reading lnow=max0(2*LENGTH(name),100) # allow for expansion STRUCTURE(newfil/CHAR,lnow/) for(i=1; ; i=i+1){ call gtline(fd,BUFFER,j) if(j<0)break if(i>lnow){ lnow=2*lnow p=VALUE(newfil) ALLOCATE(newfil/CHAR,lnow/) call pcopy(p,VALUE(newfil),i-1,CHAR) } newfil[i]=istrng(BUFFER,j) } CLEAR # restore buffer LENGTH(newfil)=i-1 STRUCTURE(dsname/CHAR,1/) ENCODE("$",C(TEXT(DATANAME(name)))) # make sure no extra prefix is put on by assign dsname=istrng(BUFFER,BUFPOS) CLEAR CHAIN(_,dsname,=newfil) } END !Funky!Stuff! echo x - u/vedit.i cat >u/vedit.i <<'!Funky!Stuff!' FUNCTION vedit( name/CHAR,OPTIONAL/ ) INCLUDE(u/action,attach) STATIC( logical streq; integer sattac,sopen,fd,i,j,lnow,islenz; POINTER p ) STATIC( CHARACTER(tmp,5) ) if(MISSING(name)){ # edit the dump file fd=sopen(TSTRING(DUMP_FILE),READ) if(fd<0)FATAL(No dumped expression) call sclose(fd) if(streq(TSTRING(vedit),TEXT(fname))) call excmd(TSTRING(vi DUMP_FILE),-1) # fd=sattac(TSTRING(DUMP_FILE),READ,SOURCE) # why? action=SOURCE_ACTION STRUCTURE(sounam/CHAR,1,STRING(DUMP_FILE)/) RETURN(sounam) } else{ # edit a character vector if(DATANAME(name)==SNULL) FATAL(No name for edited data) if(islenz(TEXT(DATANAME(name)))>4){ # check for leading "mac." call concat(tmp,1,TEXT(DATANAME(name)),1,4); call jputch(tmp,5,"EOS") if(streq(tmp,TSTRING(mac.))){ WARNING(Use vmedit for macros) CHAIN(vmedit,=name) } } fd=sattac(TSTRING(EDIT_FILE),WRITE,AUTO) for(i=1; i<=LENGTH(name); i=i+1) call ptline(fd,TEXT(name[i]),islenz(TEXT(name[i]))) call sdetac(fd) call excmd(TSTRING(vi EDIT_FILE),-1) fd=sattac(TSTRING(EDIT_FILE),READ,AUTO) # open for reading lnow=max0(2*LENGTH(name),100) # allow for expansion STRUCTURE(newfil/CHAR,lnow/) for(i=1; ; i=i+1){ call gtline(fd,BUFFER,j) if(j<0)break if(i>lnow){ lnow=2*lnow p=VALUE(newfil) ALLOCATE(newfil/CHAR,lnow/) call pcopy(p,VALUE(newfil),i-1,CHAR) } newfil[i]=istrng(BUFFER,j) } CLEAR # restore buffer LENGTH(newfil)=i-1 STRUCTURE(dsname/CHAR,1/) ENCODE("$",C(TEXT(DATANAME(name)))) # make sure no extra prefix is put on by assign dsname=istrng(BUFFER,BUFPOS) CLEAR CHAIN(_,dsname,=newfil) } END !Funky!Stuff! echo x - avcalc.r cat >avcalc.r <<'!Funky!Stuff!' ROUTINE(avcalc,anova calculations) subroutine avcalc(nr,nc,mat,rssq,cssq,essq,tssq,rdf,cdf,edf,tdf, rmsq,cmsq,emsq,rf,cf,rpf,cpf) integer nr, # INPUT: number of rows in mat nc # INPUT: number of columns in mat real mat(nr,nc), # INPUT: matrix of values rssq, # OUTPUT: row sum of squares cssq, # OUTPUT: column sum of squares essq, # OUTPUT: error sum of squares tssq, # OUTPUT: total sum of squares rdf, # OUTPUT: row degrees of freedom cdf, # OUTPUT: column degrees of freedom edf, # OUTPUT: error degrees of freedom tdf, # OUTPUT: total degrees of freedom rmsq, # OUTPUT: row mean square cmsq, # OUTPUT: column mean square emsq, # OUTPUT: error mean square rf, # OUTPUT: row F statistic cf, # OUTPUT: column F statistic rpf, # OUTPUT: row F statistic probability cpf # OUTPUT: column F statistic probability integer i,j,ntot real trow,strow,tcol,stcol,tot,stot,cortrm # calculate sum of squares ntot = nr * nc stot = 0 tot = 0 DO i = 1, nr { DO j = 1, nc { tot = tot + mat(i,j) stot = stot + mat(i,j)**2 } } cortrm = tot**2 / ntot tssq = stot - cortrm strow = 0 DO i = 1, nr { trow = 0 DO j = 1, nc { trow = trow + mat(i,j) } strow = strow + trow**2 } rssq = strow/nc - cortrm stcol = 0 DO j = 1, nc { tcol = 0 DO i = 1, nr { tcol = tcol + mat(i,j) } stcol = stcol + tcol**2 } cssq = stcol/nr - cortrm essq = tssq - rssq - cssq # compute degrees of freedom rdf = nr - 1 cdf = nc - 1 edf = rdf * cdf tdf = ntot - 1 # compute mean squares rmsq = rssq/rdf cmsq = cssq/cdf emsq = essq/edf # compute F statistic rf = rmsq/emsq cf = cmsq/emsq # compute F statistic probability rpf = pfdis(rf,rdf,edf) cpf = pfdis(cf,cdf,edf) return END !Funky!Stuff! echo x - bfcalc.r cat >bfcalc.r <<'!Funky!Stuff!' ROUTINE(bfcalc,bonferroni calculations) subroutine bfcalc(nr,ni,nj,ivec,jvec,mse,adiff,at,apt) integer nr, # INPUT: length of i,jvec ni, # INPUT: number of values in ivec nj # INPUT: number of values in jvec real ivec(nr), # INPUT: first column jvec(nr), # INPUT: second column mse, # INPUT: error of Mean Stuare from anova adiff, # OUTPUT: difference between column means at, # OUTPUT: t of difference apt # OUTPUT: probability of t real mean,imean,jmean imean = mean(ivec,ni) jmean = mean(jvec,nj) adiff = imean - jmean at = adiff/sqrt( (mse/ni) + (mse/nj) ) apt = ptdis(at,nr-1) return END !Funky!Stuff! echo x - lnfmt.r cat >lnfmt.r <<'!Funky!Stuff!' ROUTINE(lnfmt,format output line) subroutine lnfmt(nmat,nval,valvec) INCLUDE(print) INCLUDE(io) integer nval # INPUT: number of values real valvec(nval) # INPUT: vector of values CHARACTER(nmat,18) # INPUT: line header integer i ENCODE(C(nmat)) DO i=1, nval { if (valvec(i) == 0) { ENCODE(" -- ") } else { ENCODE(R(valvec(i),10,3,-1)) } } FPRINT(OUTFC) END !Funky!Stuff! echo x - ptcalc.r cat >ptcalc.r <<'!Funky!Stuff!' ROUTINE(ptcalc,pairedt calculations) subroutine ptcalc(nr,mdiff,amean,avar,at,adf,apt) integer nr # INPUT: length of mdiff real mdiff(nr), # INPUT: vector of differences amean, # OUTPUT: mean of mdiff avar, # OUTPUT: variance of mdiff at, # OUTPUT: t of mdiff adf, # OUTPUT: degrees of freedom of mdiff apt # OUTPUT: probablity of at real mean,var,ptdis amean = mean(mdiff,nr) avar = var(mdiff,nr) at = amean/sqrt(avar/nr) adf = nr-1 apt = ptdis(at,adf) return END !Funky!Stuff! echo x - ptfmt.r cat >ptfmt.r <<'!Funky!Stuff!' ROUTINE(ptfmt,format pairedt output) subroutine ptfmt(nmat,nc,pmat) INCLUDE(print) INCLUDE(io) integer nc real pmat(nc,nc) CHARACTER(nmat,30) integer i,j,k SKIP(OUTFC) FPRINT(OUTFC,C(nmat)) SKIP(OUTFC) ENCODE(SP(10)) for (k = 1; k <= nc; k = k + 1) { ENCODE(I(k,5),SP(5)) } FPRINT(OUTFC) SKIP(OUTFC) for(i = 1; i <= nc; i = i + 1) { ENCODE(SP(3),I(i,4),SP(3)) for (j = 1; j <= nc; j = j + 1) { if (i == j) { ENCODE(" -- ") } else { ENCODE(R(pmat(i,j),10,3,-1)) } } FPRINT(OUTFC) } END !Funky!Stuff! echo x - tkcalc.r cat >tkcalc.r <<'!Funky!Stuff!' ROUTINE(tkcalc,tukey calculations) subroutine tkcalc(nr,ivec,jvec,mse,adiff,aq) integer nr # INPUT: length of i,jvec real ivec(nr), # INPUT: first column jvec(nr), # INPUT: second column mse, # INPUT: error of Mean Square from anova adiff, # OUTPUT: difference between column means aq # OUTPUT: q of difference real mean,imean,jmean imean = mean(ivec,nr) jmean = mean(jvec,nr) adiff = imean - jmean aq = adiff/sqrt(mse/nr) return END !Funky!Stuff! echo x - Smakefile cat >Smakefile <<'!Funky!Stuff!' #Used by S MAKE utility pairedt: i/pairedt.o pairedt.x ptcalc.o # f77 -i $(STRIP) -o x/pairedt i/pairedt.o pairedt.x ptcalc.o $(LIBR) @touch pairedt @echo pairedt loaded ptprt: i/ptprt.o ptprt.x ptfmt.o # f77 -i $(STRIP) -o x/ptprt i/ptprt.o ptprt.x ptfmt.o $(LIBR) @touch ptprt @echo ptprt loaded tukey: i/tukey.o tukey.x tkcalc.o # f77 -i $(STRIP) -o x/tukey i/tukey.o tukey.x tkcalc.o $(LIBR) @touch tukey @echo tukey loaded tkprt: i/tkprt.o tkprt.x ptfmt.o # f77 -i $(STRIP) -o x/tkprt i/tkprt.o tkprt.x ptfmt.o $(LIBR) @touch tkprt @echo tkprt loaded anova: i/anova.o anova.x avcalc.o # f77 -i $(STRIP) -o x/anova i/anova.o anova.x avcalc.o $(LIBR) @touch anova @echo anova loaded avprt: i/avprt.o avprt.x lnfmt.o # f77 -i $(STRIP) -o x/avprt i/avprt.o avprt.x lnfmt.o $(LIBR) @touch avprt @echo avprt loaded vedit vagain: i/vedit.o u/vedit.x f77 -i $(STRIP) -o x/vedit i/vedit.o u/vedit.x $(LIBR) -ln x/vedit x/vagain 2>/dev/null || true @touch vedit vagain @echo vedit vagain loaded eedit eagain: i/eedit.o u/eedit.x f77 -i $(STRIP) -o x/eedit i/eedit.o u/eedit.x $(LIBR) -ln x/eedit x/eagain 2>/dev/null || true @touch eedit eagain @echo eedit eagain loaded vmedit: i/vmedit.o vmedit.x # f77 -i $(STRIP) -o x/vmedit i/vmedit.o vmedit.x $(LIBR) @touch vmedit @echo vmedit loaded emedit: i/emedit.o emedit.x # f77 -i $(STRIP) -o x/emedit i/emedit.o emedit.x $(LIBR) @touch emedit @echo emedit loaded bonferroni: i/bonferroni.o bonferroni.x bfcalc.o # f77 -i $(STRIP) -o x/bonferroni i/bonferroni.o bonferroni.x bfcalc.o $(LIBR) @touch bonferroni @echo bonferroni loaded bfprt: i/bfprt.o bfprt.x ptfmt.o # f77 -i $(STRIP) -o x/bfprt i/bfprt.o bfprt.x ptfmt.o $(LIBR) @touch bfprt @echo bfprt loaded !Funky!Stuff!