void muste_linco(char *argv)
{
int i;
// RS 5.5.2014 Variable init
// SURVO_DATA d;
A=NULL;
rlab=NULL;
clab=NULL;
rdim=cdim=lr=lc=type=0;
expr[0]=EOS;
matname[0]=EOS;
pros=0;
var=NULL;
y=NULL;
outvar=NULL;
lag=NULL;
act=0;
// if (argc==1) return;
s_init(argv);
if (g<3)
{
sur_print("\nUsage: LINCO <SURVO_data>,<matrix_of_coefficients>");
WAIT; return;
}
i=data_open2(word[1],&d,1,0,0); if (i<0) return;
/* tilaa uusille muuttujille */
i=spec_init(r1+r-1); if (i<0) return;
pros=0;
act='A'; i=spfind("ACT");
if (i>=0) act=*spb[i];
i=conditions(&d); if (i<0) return; /* permitted only once */
i=matparam(); if (i<0) return;
i=matrix_load(matname,&A,&rdim,&cdim,&rlab,&clab,&lr,&lc,&type,expr);
if (i<0) return;
i=varaa_tilat(); if (i<0) return;
i=find_variables();
if (i<0)
{
if (etu==2)
{
sprintf(tut_info,"___@%d@LINCO@Error in LINCO@",-i);
s_end(argv[1]); return;
}
return;
}
linear_combinations();
data_close(&d);
s_end(argv);
}
void muste_xall(char *argv)
{
int i;
s_init(argv);
i=spec_init(r1+r-1); if (i<0) return;
i=check_parameters(); if (i<0) return;
xall();
s_end(argv);
return;
}
void muste_multvar(char *argv)
{
int i;
// char *p;
extern double entr();
// char x[LLENGTH];
// if (argc==1) return;
s_init(argv);
rr11=NULL;
// p=NULL;
p_max=NULL;
var1=NULL;
tr2=NULL;
rr11=NULL;
rr22=NULL;
perm1=NULL;
perm2=NULL;
perm_max=NULL;
if (g<3)
{
init_remarks();
rem_pr("MULTVAR <covariance_matrix_S>,L");
rem_pr("computes a variability measure Mvar(S) of S.Mustonen (1995).");
rem_pr("By default, the stepwise method is used.");
rem_pr("The exhaustive method is selected by METHOD=EXHAUSTIVE.");
rem_pr("The accuracy parameter in Cholesky decompositions is");
rem_pr("set by EPS=eps (Default EPS=0.000001).");
rem_pr("The optimally permuted covariance matrix is saved");
rem_pr("as a matrix file COVVAR.M .");
rem_pr(" ");
rem_pr("Reference: ");
rem_pr("S. Mustonen: A measure for total variability");
rem_pr(" in multivariate normal distribution");
rem_pr("Computational Statistics & Data Analysis, 23, 321-334 (1997)");
wait_remarks(2);
s_end(argv);
return;
}
i=spec_init(r1+r-1); if (i<0) return;
results_line=0;
if (g>2)
{
results_line=edline2(word[2],1);
if (results_line==0) return;
}
/* i=sp_init(r1+r-1); if (i<0) return; poistettu 1.1.1997 */
ceps=0.000001;
i=spfind("EPS");
if (i>=0) ceps=atof(spb[i]);
method=1;
i=spfind("METHOD");
if (i>=0)
{
if (strncmp(spb[i],"EXHAUSTIVE",3)==0) method=2;
else if (strncmp(spb[i],"STEPWISE",3)==0) method=1;
else method=atoi(spb[i]);
}
if (method==1) { i=maximum_var(); s_end(argv); return; }
else if (method==2 || method==3)
{ i=maximum_var_perm(); muste_fclose(f); s_end(argv); return; }
else
{
sprintf(sbuf,"\nMETHOD=%s unknown!",spb[i]);
sur_print(sbuf); WAIT; s_end(argv); return;
}
}
void muste_rndtest(char *argv)
{
int i;
char xx[LLENGTH],*sana[4];
s_init(argv);
if (g<3)
{
init_remarks();
rem_pr("Usage: RNDTEST <SURVO_data>,<variable>,<output_line>");
rem_pr("This Survo operation makes empirical statistical tests on a series");
rem_pr("numbers supposed to form a random sample from a uniform distribution");
rem_pr("in the interval (0,1).");
rem_pr("Most of these tests are explained in Volume 2 of \"The Art of Programming\"");
rem_pr("by Donald E. Knuth.");
rem_pr("The main application of RNDTEST is testing of various random number");
rem_pr("generators.");
rem_pr("");
rem_pr("A standard set of tests is performed without any extra specification.");
rem_pr("However, If RESULTS=0, no test is performed without explicit specifica-");
rem_pr("tions. To select tests in a more detailed form, following specifications");
rem_pr("can be given.");
rem_pr("");
rem_pr("SUBSAMPLES=<size>,<# of classes>");
rem_pr("The sample is divided systematically in subsamples of given <size>");
rem_pr("and their uniformity is tested by the standard Chi^2-test by divi-");
rem_pr("ding the interval (0,1) in <# of classes>.");
rem_pr("Also tests for mean=0.5 as well for the minimum ans maximum values");
rem_pr("in subsamples are made.");
rem_pr("Default is SUBSAMPLES=0 (i.e. this test is omitted).");
wait_remarks(1);
rem_pr("");
rem_pr("FREQUENCIES=<# of classes>,<lower limit>,<upper limit>");
rem_pr("The uniformity of the total sample is tested by the Chi^2-test.");
rem_pr("Default: FREQUENCIES=10,0,1");
rem_pr("");
rem_pr("MAXLAG=<largest_lag>");
rem_pr("The autocorrelations of the series are computed up to the given");
rem_pr("maximum lag. Default: MAXLAG=10");
rem_pr("");
rem_pr("GAPTEST=<lower_limit>,<upper_limit>,<max.gap>");
rem_pr("The lengths of gaps between occurrences of values in the given range");
rem_pr("are computed.");
rem_pr("Default: GAPTEST=0,0.5,10");
rem_pr("");
rem_pr("PERMTEST=<# of consecutive numbers (3,4,5,6 or 7)>");
rem_pr("Frequencies of different permutations of relative orderings are computed.");
rem_pr("Default: PERMTEST=4");
rem_pr("");
rem_pr("POKER=<# of obs.>,<# of classes>,<lower limit>,<upper_limit>");
rem_pr("Default: POKER=5,5,0,1");
wait_remarks(1);
rem_pr("");
rem_pr("COUPON=<# of classes>,<max_len>,<lower limit>,<upper limit>");
rem_pr("Coupon collector's test");
rem_pr("Default: COUPON=5,20,0,1");
rem_pr("");
rem_pr("Certain run tests are performed in any case.");
wait_remarks(2);
return;
}
p_mean=NULL;
p_min=NULL;
p_max=NULL;
fr_f=NULL;
lagv=NULL;
lagvv=NULL;
first_x=NULL;
gap=NULL;
f_perm=NULL;
f_pok=NULL;
s_pok=NULL;
f1_pok=NULL;
f_coup=NULL;
coup_ind=NULL;
s_coup=NULL;
i=spec_init(r1+r-1); if (i<0) return;
for(i=0; i<MAXRUN; ++i) runs_up[i]=runs_down[i]=0;
n_sub=0;
i=spfind("SUBSAMPLES");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,2);
if (i<1) { sur_print("\nUsage: SUBSAMPLES=<size>,<# of classes>");
WAIT; return;
}
n_sub=atoi(sana[0]); n_subclass=10;
if (i>1) n_subclass=atoi(sana[1]);
}
if (results==0) fr_n=0; else { fr_n=10; fr_a=0.0; fr_d=0.1; }
i=spfind("FREQUENCIES");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,3);
if (i<3) { sur_print("\nUsage: FREQUENCIES=<# of classes>,<lower_limit>,<upper_limit>");
WAIT; return;
}
fr_n=atoi(sana[0]); fr_a=atof(sana[1]);
fr_d=(atof(sana[2])-fr_a)/(double)fr_n;
}
if (results==0) maxlag=0; else maxlag=10;
i=spfind("MAXLAG"); if (i>=0) maxlag=atoi(spb[i]);
if (results==0) maxgap=0; else { maxgap=10; a_gap=0; b_gap=0.5; }
i=spfind("GAPTEST");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,3);
if (i<2) { sur_print("\nUsage: GAPTEST=<lower_limit>,<upper_limit>,<max.gap>");
WAIT; return;
}
a_gap=atof(sana[0]); b_gap=atof(sana[1]);
maxgap=10; if (i>2) maxgap=atoi(sana[2]);
}
if (results==0) permlen=0; else permlen=4;
i=spfind("PERMTEST");
if (i>=0)
{
permlen=atoi(spb[i]);
if (permlen && (permlen<3 || permlen>7) )
{
sur_print("\nOnly values 0 and 3,4,5,6,7 permitted in PERMTEST");
WAIT; return;
}
}
if (results==0) poklen=0; else { poklen=5; n_pok=5; pok_a=0.0; pok_d=0.2; }
i=spfind("POKER");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,4);
if (i<4) { sur_print("\nUsage: POKER=<# of obs.>,<# of classes>,<l.limit>,<u.limit>");
WAIT; return;
}
poklen=atoi(sana[0]);
n_pok=atoi(sana[1]);
pok_a=atof(sana[2]);
pok_d=(atof(sana[3])-pok_a)/(double)n_pok;
}
if (results==0) couplen=0; else { couplen=5; coup_max=20; coup_a=0.0; coup_d=0.2; }
i=spfind("COUPON");
if (i>=0)
{
strcpy(xx,spb[i]); i=split(xx,sana,4);
if (i<4) { sur_print("\nUsage: COUPON=<# of classes>,<max_len>,<l.limit>,<u.limit>");
WAIT; return;
}
couplen=atoi(sana[0]);
coup_max=atoi(sana[1]);
coup_a=atof(sana[2]);
coup_d=(atof(sana[3])-coup_a)/(double)couplen;
}
results_line=0;
if (g>3)
{
results_line=edline2(word[3],1,1);
if (results_line==0) return;
}
i=data_read_open(word[1],&d); if (i<0) return;
var=varfind(&d,word[2]);
if (var<0) return;
i=sp_init(r1+r-1);
if (i<0) { sur_print("\nToo many specifications!"); WAIT; return; }
i=conditions(&d); if (i<0) return;
i=space_allocation(); if (i<0) { sur_print("\nNot enough memory!"); return; }
i=read_data(); if (i<0) return;
rnd_printout();
data_close(&d);
s_end(argv);
}
int main256 (int argc, char *argv[]) {
int i, level;
int input_size=64, compressed_size;
char *input_name="input.combined";
unsigned char *validate_array;
seedi = 10;
if (argc > 1) input_name=argv[1];
if (argc > 2) input_size=atoi(argv[2]);
if (argc > 3)
compressed_size=atoi(argv[3]);
else
compressed_size=input_size;
spec_fd[0].limit=input_size*MB;
spec_fd[1].limit=compressed_size*MB;
spec_fd[2].limit=input_size*MB;
spec_init();
debug_time();
debug(2, "Loading Input Data\n");
spec_load(0, input_name, input_size*MB);
debug1(3, "Input data %d bytes in length\n", spec_fd[0].len);
validate_array = (unsigned char *)malloc(input_size*MB/1024);
if (validate_array == NULL) {
printf ("main: Error mallocing memory!\n");
exit (1);
}
/* Save off one byte every ~1k for validation */
for (i = 0; i*VALIDATE_SKIP < input_size*MB; i++) {
validate_array[i] = spec_fd[0].buf[i*VALIDATE_SKIP];
}
#ifdef DEBUG_DUMP
fd = open ("out.uncompressed", O_RDWR|O_CREAT, 0644);
write(fd, spec_fd[0].buf, spec_fd[0].len);
close(fd);
#endif
spec_initbufs();
for (level=7; level <= 9; level += 2) {
debug_time();
debug1(2, "Compressing Input Data, level %d\n", level);
spec_compress(0,1, level);
debug_time();
debug1(3, "Compressed data %d bytes in length\n", spec_fd[1].len);
#ifdef DEBUG_DUMP
{
char buf[256];
sprintf(buf, "out.compress.%d", level);
fd = open (buf, O_RDWR|O_CREAT, 0644);
write(fd, spec_fd[1].buf, spec_fd[1].len);
close(fd);
}
#endif
spec_reset(0);
spec_rewind(1);
debug_time();
debug(2, "Uncompressing Data\n");
spec_uncompress(1,0, level);
debug_time();
debug1(3, "Uncompressed data %d bytes in length\n", spec_fd[0].len);
#ifdef DEBUG_DUMP
{
char buf[256];
sprintf(buf, "out.uncompress.%d", level);
fd = open (buf, O_RDWR|O_CREAT, 0644);
write(fd, spec_fd[0].buf, spec_fd[0].len);
close(fd);
}
#endif
for (i = 0; i*VALIDATE_SKIP < input_size*MB; i++) {
if (validate_array[i] != spec_fd[0].buf[i*VALIDATE_SKIP]) {
printf ("Tested %dMB buffer: Miscompared!!\n", input_size);
exit (1);
}
}
debug_time();
debug(3, "Uncompressed data compared correctly\n");
spec_reset(1);
spec_rewind(0);
}
printf ("Tested %dMB buffer: OK!\n", input_size);
return 0;
}
void muste_t2test(char *argv)
{
int i,k;
int l,l2;
// if (argc==1) return(1);
s_init(argv);
if (g<3)
{
sur_print("\nUsage: T2TEST <data1>,<data2>,<output_line>");
WAIT; return;
}
tulosrivi=0;
if (g>3)
{
tulosrivi=edline2(word[3],1,1);
if (tulosrivi==0) return;
}
simumax=10000;
i=spec_init(r1+r-1); if (i<0) return;
if ((i=spfind("RESULTS"))>=0) results=atoi(spb[i]);
x=NULL;
v=NULL;
xx=NULL;
ind=NULL;
s=NULL;
s2=NULL;
ss[0]=NULL;
ss2[0]=NULL;
ss[1]=NULL;
ss2[1]=NULL;
ss_inv=NULL;
ss_apu=NULL;
ss_apu2=NULL;
ero=NULL;
i=hae_apu("prind",sbuf); if (i) prind=atoi(sbuf);
if ((i=spfind("PRIND"))>=0) prind=atoi(spb[i]);
if ((i=spfind("SIMUMAX"))>=0) simumax=atol(spb[i]);
method=1;
if ((i=spfind("METHOD"))>=0) method=atoi(spb[i]);
fixed=0;
if ((i=spfind("FIXED"))>=0) fixed=atoi(spb[i]);
orig_samples=1;
spec_rnd();
strcpy(tempname,etmpd); strcat(tempname,"SURVOHOT.TMP");
tempfile=muste_fopen(tempname,"wb");
if (tempfile==NULL)
{
sprintf(sbuf,"\nCannot open temporary file %s!",tempname);
sur_print(sbuf); WAIT; return;
}
strcpy(aineisto[0],word[1]);
i=data_read_open(aineisto[0],&d); if (i<0) return;
i=mask(&d); if (i<0) return;
m=d.m_act;
if (m==0)
{
sur_print("\nNo active variables!");
WAIT; return;
}
x=(double *)muste_malloc(m*sizeof(double));
if (x==NULL) { not_enough_memory(); return; }
v=(int *)muste_malloc(m*sizeof(int));
if (v==NULL) { not_enough_memory(); return; }
for (i=0; i<m; ++i) v[i]=d.v[i];
sur_print("\n");
talleta(1); /* data 1 */
data_close(&d);
strcpy(aineisto[1],word[2]);
i=data_read_open(aineisto[1],&d); if (i<0) return;
i=mask(&d); if (i<0) return;
if (d.m_act!=m) { data_error(); return; }
for (i=0; i<m; ++i)
{
if (v[i]!=d.v[i]) {data_error(); return; }
}
talleta(2); /* data 2 */
data_close(&d);
muste_fclose(tempfile);
n[0]=n[1]+n[2];
tempfile=muste_fopen(tempname,"rb");
xx=(double *)muste_malloc(n[0]*m*sizeof(double));
if (xx==NULL) { not_enough_memory(); return; }
fread(xx,sizeof(double),n[0]*(int)m,tempfile);
muste_fclose(tempfile);
ind=muste_malloc(n[0]);
if (ind==NULL) { not_enough_memory(); return; }
s=muste_malloc(m*sizeof(double));
if (s==NULL) { not_enough_memory(); return; }
s2=muste_malloc(m*m*sizeof(double));
if (s2==NULL) { not_enough_memory(); return; }
for (l=0; l<n[0]; ++l) ind[l]='1';
laske_summat(s,s2);
// Rprintf("s: %g %g\n",s[0],s[1]); getch();
ss[0]=muste_malloc(m*sizeof(double));
if (ss[0]==NULL) { not_enough_memory(); return; }
ss2[0]=muste_malloc(m*m*sizeof(double));
if (ss2[0]==NULL) { not_enough_memory(); return; }
ss[1]=muste_malloc(m*sizeof(double));
if (ss[1]==NULL) { not_enough_memory(); return; }
ss2[1]=muste_malloc(m*m*sizeof(double));
if (ss2[1]==NULL) { not_enough_memory(); return; }
ss_inv=muste_malloc(m*m*sizeof(double));
if (ss_inv==NULL) { not_enough_memory(); return; }
ss_apu=muste_malloc(m*m*sizeof(double));
if (ss_apu==NULL) { not_enough_memory(); return; }
ss_apu2=muste_malloc(m*m*sizeof(double));
if (ss_apu2==NULL) { not_enough_memory(); return; }
ero=muste_malloc(m*sizeof(double));
if (ero==NULL) { not_enough_memory(); return; }
// Todelliset otokset
for (l=0; l<n[0]; ++l) ind[l]='0';
for (l=0; l<n[1]; ++l) ind[l]='1';
t2_0=T2();
p_hot=1.0-muste_cdf_f((double)(n[0]-m-1)/(n[0]-2)/(double)m*t2_0,
(double)m,(double)(n[1]+n[2]-m-1),1e-15);
if (method==2)
{
t2_BF0=T2_BF();
yao_test();
print_t2_yao();
}
// Rprintf("\nt2: %g %g",t2_0,t2_BF0); getch();
else
print_t2_hot();
if (fixed) orig_samples=0;
++scroll_line;
nn1=0L; k=0;
if (simumax) sur_print("\nInterrupt by '.'");
for (nn=1; nn<=simumax; ++nn)
{
// Rprintf("\nnn=%d",nn);
for (l=0; l<n[0]; ++l) ind[l]='0';
for (l=0; l<n[1]; ++l)
{
while (1)
{
l2=n[0]*uniform_dev();
if (ind[l2]=='1') continue;
ind[l2]='1'; break;
}
}
if (method==1)
{
t2_1=T2();
// Rprintf("t2: %g %g\n",t2_1,t2_0); getch();
if (t2_1>t2_0) ++nn1;
}
else
{
t2_1=T2_BF();
// Rprintf("t2: %g %g\n",t2_1,t2_BF0); getch();
if (t2_1>t2_BF0) ++nn1;
}
++k;
// Rprintf("t2=%g\n",t2_1); i=getch(); if (i=='.') break;
/**********************************
if (sur_kbhit())
{
i=sur_getch(); if (i=='.') break;
prind=1-prind;
}
***********************************/
if (k>=1000 && prind)
{
sprintf(sbuf,"\n%d %g ",nn,(double)nn1/(double)nn);
sur_print(sbuf);
k=0;
}
}
// Rprintf("4"); sur_getch();
output_open(eout);
--nn;
if (method==1)
{
eoutput("Hotelling's two-sample test for equality of mean vectors:");
sprintf(sbuf,"T2=%g p=%d n1=%d n2=%d P1=%g",
t2_0,m,n[1],n[2],p_hot);
}
else
{
eoutput("Yao's two-sample test for equality of mean vectors:");
sprintf(sbuf,"T2=%g P1=%g (assuming nonequal cov.matrices)",
t2_BF0,p_yao);
}
eoutput(sbuf);
if (simumax>0L)
{
eoutput("Randomization test:");
p_sim=(double)nn1/(double)nn;
sprintf(sbuf,"N=%d P=%g (s.e. %g) %s",
nn,p_sim,sqrt(p_sim*(1-p_sim)/nn),method_text[method-1]);
eoutput(sbuf);
}
output_close(eout);
s_end(argv);
return;
}
void muste_covtest(char *argv)
{
int i,k,h,kk;
int l,l2,li;
// if (argc==1) return(1);
s_init(argv[1]);
if (g<2)
{
sur_print("\nUsage: COVTEST <output_line>");
sur_print("\n SAMPLES=<data(1),...,<data(m)>");
WAIT; return;
}
tulosrivi=0;
if (g>1)
{
tulosrivi=edline2(word[1],1,1);
if (tulosrivi==0) return;
}
i=spec_init(r1+r-1); if (i<0) return;
if ((i=spfind("RESULTS"))>=0) results=atoi(spb[i]);
i=hae_apu("prind",sbuf); if (i) prind=atoi(sbuf);
if ((i=spfind("PRIND"))>=0) prind=atoi(spb[i]);
simumax=10000;
if ((i=spfind("SIMUMAX"))>=0) simumax=atol(spb[i]);
spec_rnd();
strcpy(tempname,etmpd); strcat(tempname,"SURVOCOV.TMP");
tempfile=fopen(tempname,"wb");
if (tempfile==NULL)
{
sprintf(sbuf,"\nCannot open temporary file %s!",tempname);
sur_print(sbuf); WAIT; return;
}
i=spfind("SAMPLES");
if (i<0)
{
sur_print("SAMPLES=<data(1),...,<data(m)> missing!");
WAIT; return;
}
strcpy(y,spb[i]);
ns=split(y,otos,S_MAX);
if (ns<2)
{
sur_print("At least 2 samples must be given by SAMPLES!");
WAIT; return;
}
x=NULL;
v=NULL;
xx=NULL;
ind=NULL;
nt=0L;
for (k=0; k<ns; ++k)
{
strcpy(aineisto,otos[k]);
i=data_read_open(aineisto,&d); if (i<0) return;
i=mask(&d); if (i<0) return;
if (d.m_act==0)
{
sur_print("\nNo active variables!");
WAIT; return;
}
if (k==0)
{
m=d.m_act;
x=(double *)muste_malloc(m*sizeof(double));
if (x==NULL) { not_enough_memory(); return; }
v=(int *)muste_malloc(m*sizeof(int));
if (v==NULL) { not_enough_memory(); return; }
for (i=0; i<m; ++i) v[i]=d.v[i];
}
if (k!=0)
{
if (d.m_act!=m) { data_error(k); return; }
for (i=0; i<m; ++i)
{
if (v[i]!=d.v[i]) { data_error(k); return; }
}
}
sur_print("\n");
talleta(k); /* data k */
data_close(&d);
}
muste_fclose(tempfile);
tempfile=fopen(tempname,"rb");
xx=(double *)muste_malloc(nt*m*sizeof(double));
if (xx==NULL) { not_enough_memory(); return; }
fread(xx,sizeof(double),nt*(int)m,tempfile);
muste_fclose(tempfile);
ind=muste_malloc(sizeof(short)*nt);
if (ind==NULL) { not_enough_memory(); return; }
for (k=0; k<ns+1; ++k)
{
s[k]=NULL;
s[k]=muste_malloc(m*sizeof(double));
if (s[k]==NULL) { not_enough_memory(); return; }
s2[k]=NULL;
s2[k]=muste_malloc(m*m*sizeof(double));
if (s2[k]==NULL) { not_enough_memory(); return; }
}
l=0;
for (k=0; k<ns; ++k)
for (li=0L; li<n[k]; ++li) ind[l++]=k;
laske_summat();
l=0;
for (k=0; k<ns; ++k)
for (li=0; li<n[k]; ++li)
{
for (h=0; h<m; ++h)
xx[l+h]-=s[k][h]/n[k];
l+=m;
}
t0=testi();
os1=(double)(nt-ns)*m/2*log((double)(nt-ns));
nim2=0.0; a=0.0;
for (k=0; k<ns; ++k)
{
nim2+=(n[k]-1)*muste_log((double)(n[k]-1));
a+=1.0/(n[k]-1);
}
x2=t0/2+os1-(double)m/2*nim2;
a=1-(a-1.0/(nt-ns))*(2*m*m+3*m-1)/6.0/(m+1)/(k-1);
x2*=-2*a;
// Rprintf("x2=%g\n",x2); getch();
df=(double)m/2*(m+1)*(ns-1);
pr_x2=1.0-muste_cdf_chi2(x2,df,1e-7);
/*****************************************************
os1=n*p/2*log(n)
os1=10326.054776478
os2=0.5*(n1*log(det1)+n2*log(det2)+n3*log(det3))
os2=8299.3933358899
nim1=n/2*log(det)
nim1=9932.2525957076
nim2=p/2*(n1*log(n1)+n2*log(n2)+n3*log(n3))
nim2=8697.69129334
logL=os1+os2-nim1-nim2
logL=-4.4957766798343
a=1-(1/n1+1/n2+1/n3-1/n)*(2*p*p+3*p-1)/6/(p+1)/(k-1)
X2=-2*a*logL
X2=8.9516537694752
df=p/2*(p+1)*(k-1)
********************************************************/
print_t0(x2,df,pr_x2);
++scroll_line;
nn1=0L; kk=0;
for (nn=1; nn<=simumax; ++nn)
{
for (l=0; l<nt; ++l) ind[l]=0;
for (k=1; k<ns; ++k)
{
for (l=0L; l<n[k]; ++l)
{
while (1)
{
l2=nt*uniform_dev();
if (ind[l2]!=(short)0) continue;
ind[l2]=k; break;
}
}
}
t1=testi();
if (t1<t0) ++nn1;
++kk;
/*************************
if (kbhit())
{
i=getch(); if (i=='.') break;
prind=1-prind;
}
******************************/
if (kk==1000)
{
if (prind)
{
sprintf(sbuf,"\n%d %g ",nn,(double)nn1/(double)nn);
sur_print(sbuf);
}
kk=0;
}
}
output_open(eout);
--nn;
eoutput("Comparing covariance matrices:");
sprintf(sbuf,"Asymptotic X^2 test: X2=%g df=%g P=%g",x2,df,pr_x2);
eoutput(sbuf);
p_sim=(double)nn1/(double)nn;
sprintf(sbuf,"Randomization test: N=%d P=%g (s.e. %g)",
nn,p_sim,sqrt(p_sim*(1-p_sim)/nn));
eoutput(sbuf);
output_close(eout);
s_end(argv);
return;
}
void muste_tabtest(char *argv)
{
int i;
// char ch;
int ncvar;
// char nimi[LLENGTH];
char s[LLENGTH];
extern int print_line();
int ltotal;
// if (argc==1) return;
s_init(argv);
i=spec_init(r1+r-1); if (i<0) return;
r_original=r;
results_line=0;
if (g<2)
{
init_remarks();
rem_pr("Usage: TABTEST <table_of_frequencies>,L");
rem_pr("");
rem_pr("TABTEST performs various tests for independence etc. by simulation");
rem_pr("for a two-dimensional table of frequencies. The table is");
rem_pr("given in edit field in the form used by the TAB operations.");
rem_pr("The table can be also given in a simpler form without any labels:");
rem_pr("TABLE TEST / Example");
rem_pr("7 2 0");
rem_pr("3 1 5");
rem_pr("");
rem_pr("Different assumptions about the stochastic structure of the table are");
rem_pr("determined by a FIX specification with following alternatives:");
rem_pr(" FIX=Fisher Both row and column margins fixed (exact test)");
rem_pr(" FIX=RC Both row and column margins fixed");
rem_pr(" FIX=C Column margins (vertical sums) fixed");
rem_pr(" FIX=R Row margins (horizontal sums) fixed");
rem_pr(" FIX=N No fixed margins, only the grand total fixed");
rem_pr(" FIX=F(i,j) Element of row i and column j fixed");
wait_remarks(1);
rem_pr("The test statistics used in simulation is selected by a TEST specification:");
rem_pr("TEST=X^2 is the common Pearson's chi-square statistics: sum of (O-E)^2/E .");
rem_pr("TEST=G^2 is the likelihood statistics: sum of -2*O*log(O/E) .");
rem_pr("TEST=PROB is the probability of the simulated table. The unknown");
rem_pr(" margin probabilities are replaced by simulated relative");
rem_pr(" frequencies. We call this `Probability statistics'.");
rem_pr("In case FIX=Fisher, TEST=PROB is always selected.");
rem_pr("In other cases TEST=X^2 is default.");
wait_remarks(1);
rem_pr("Maximum number of replicates is given by SIMUMAX (default 10000000).");
rem_pr("The seed number of the random number generator (either 'rand' or 'urand')");
rem_pr("is given by RAND (default RAND=rand(12345). See RAND? .");
rem_pr("The process may be interrupted by pressing any key.");
rem_pr("");
rem_pr("The results are displayed after each 100 replicates as a table of the form");
rem_pr(" N P Confidence interval (level=0.95) ");
rem_pr("# of replicates Estimate of P lower limit ");
rem_pr(" s.e. Standard error upper limit ");
rem_pr("");
rem_pr("The confidence level for P is set by CONF=p (0.8<p<1). Default is CONF=0.95");
wait_remarks(1);
rem_pr("The two-way table is also saved as a matrix by using the specification");
rem_pr("MATRIX=<name_of_a_matrix_file> , say, MATRIX=T .");
rem_pr("This matrix can be analyzed further, for example, by the sucro command");
rem_pr("/CHI2 T");
rem_pr("which computes various derived tables as matrices such as the expected");
rem_pr("frequencies and decomposition of the X^2 statistics in cells and ");
rem_pr("margins. ");
wait_remarks(1);
rem_pr("........................................................................");
rem_pr("Example:");
rem_pr("TABLE T / This 2x2 table is tested with default settings.");
rem_pr("7 2");
rem_pr("1 4");
rem_pr("");
rem_pr("TABTEST T,CUR+1");
wait_remarks(2);
s_end(argv[1]);
return;
}
if (g>2)
{
results_line=edline2(word[2],1,1);
if (results_line==0) return;
}
ptext=text;
i=read_ftable(word[1],&f,&dim,&ncvar,nc,varname,cname,type,&ndec);
if (i<0) return;
if (dim!=2)
{
sur_print("\nTABTEST can handle two-way tables only!");
WAIT; return;
}
m=nc[1]; n=nc[0];
i=spfind("FIX");
if (i>=0 && muste_strcmpi(spb[i],"FIT")==0)
{
i=goodness_of_fit_test(f,m,n);
if (i>0) s_end(argv[1]);
return;
}
i=spfind("MATRIX");
if (i>=0)
{
i=table_to_matrix(spb[i],f,m,n,varname,cname);
if (i<0) return;
}
ltotal=0L;
for (i=0; i<m*n; ++i)
{
ltotal+=f[i];
if (f[i]<0L)
{
sur_print("\nNegative \"frequencies\" in the table!!!");
WAIT; return;
}
}
if (ltotal>MAXTOTAL)
{
sprintf(sbuf,"\nTotal frequency %d too great! (max=%d)",
ltotal,MAXTOTAL);
WAIT; return;
}
total=ltotal;
total0=total;
test=X2;
i=spfind("TEST");
if (i>=0)
{
strcpy(s,spb[i]); muste_strupr(s);
if (strncmp(s,"PR",2)==0) test=PROB;
else if (strncmp(s,"X2",2)==0 || strncmp(s,"X^2",3)==0) test=X2;
else if (strncmp(s,"G2",2)==0 || strncmp(s,"G^2",3)==0) test=G2;
else
{
sur_print("\nError in TEST specification!");
sur_print("\nAlternatives TEST=PROB, TEST=X2, TEST=G2");
WAIT; return;
}
}
conf_level=0.95;
i=spfind("CONF");
if (i>=0) conf_level=atof(spb[i]);
if (conf_level<0.8 || conf_level>=1.0)
{
sur_print("\nError in CONF=p! Confidence level p must be 0.8<p<1");
WAIT; return;
}
conf_coeff=muste_inv_std(1.0-(1.0-conf_level)/2);
c_margins();
i=find_fix(); if (i<0) return;
c_logn();
c_chi2(&chi2,f); chi2-=eps;
c_g2(&g2,f); g2-=eps;
if (fix==FISHER) test=PROB;
if (test==PROB)
{
switch (fix)
{
case FIX_RC:
case FISHER: c_prob(&prob,f); break;
case FIX_C: c_cprob(&prob,f); break;
case FIX_R: c_rprob(&prob,f); break;
case FIX_N: c_nprob(&prob,f); break;
case FIX_F: c_fprob(&prob,f); break;
}
prob-=eps;
}
if (fix!=FIX_RC && fix!=FISHER) cumul_freq();
g_print=&sur_print;
maxcount=10000000L;
i=spfind("SIMUMAX");
if (i>=0) maxcount=atol(spb[i]);
disp0();
i=simulation(); if (i<0) return;
g_print=&print_line;
printout();
r=r_original;
s_end(argv);
}
void muste_statmsf(char *argv)
{
int i;
// RS Variable init
prind=1;
sum=NULL;
sum2=NULL;
f=NULL;
w=NULL;
f2=NULL;
X=NULL;
rlabX=NULL;
clabX=NULL;
T=NULL;
rlabT=NULL;
clabT=NULL;
v=NULL;
s_init(argv);
typeT=lrT=lcT=0; // to avoid warnings from compiler
// specs=spec_msf;
if (g<2)
{
init_remarks();
rem_pr("STATMSF <Survo_data>,<output_line> ");
rem_pr(" LIMITS=<low1>,<up1>,<up2>,...");
rem_pr("computes means, standard deviations, and frequency distributions");
rem_pr("of active variables. Cases can be limited by IND and CASES specifications.");
rem_pr("The frequencies are computed according to a classification given by the");
rem_pr("LIMITS specification where <low1> is the lower limit of the first class 1");
rem_pr("and <up1>,<up2>,... are the upper limits of the classes 1,2,...");
rem_pr("The default setting is LIMITS=0,1,2,3,4,5 .");
wait_remarks(1);
rem_pr("STATMSF <Survo_data> / TRESHOLDS=<matrix_file>");
rem_pr("where <matrix_file> is of the form");
rem_pr("row label 1st column");
rem_pr("variable_1 treshold_value_1");
rem_pr("variable_2 treshold_value_2");
rem_pr("...");
rem_pr("computes relative frequencies of values exceeding treshold values");
rem_pr("given as the first column of <matrix_file> for variables given");
rem_pr("as row labels in <matrix_file> for active observations");
rem_pr("in <Survo_data>.");
rem_pr("The results are saved in a matrix file TAILFREQ.M .");
wait_remarks(2);
return;
}
results_line=0;
i=spec_init(r1+r-1); if (i<0) return;
i=spfind("PRIND"); if (i>=0) prind=atoi(spb[i]);
i=spfind("TRESHOLDS");
if (i>=0) { pvalues(i); return; }
if (g>2)
{
results_line=edline2(word[2],1,1);
if (results_line==0) return;
}
i=data_read_open(word[1],&d); if (i<0) return;
i=spfind("LIMITS");
if (i<0)
{
n_class=5; limit[0]=0;
for (i=1; i<=5; ++i) limit[i]=i;
}
else
{
strcpy(x,spb[i]);
n_class=split(x,osa,MAXCLASS);
for (i=0; i<n_class; ++i) limit[i]=atof(osa[i]);
--n_class;
}
i=mask(&d); if (i<0) return;
weight_variable=activated(&d,'W');
i=m_test_scaletypes(); if (i<0) return;
i=conditions(&d); if (i<0) return; /* permitted only once */
m=d.m_act;
if (m==0)
{
sur_print("\nNo active (acceptable) variables!");
WAIT; return;
}
i=m_space_allocation(); if (i<0) return;
// i=optdim_d(); if (i && i<d.m) err(0);
// i=optdim_o(); if (i && (long)i<d.n) err(0);
compute_sums();
m_printout();
data_close(&d);
s_end(argv);
}
void muste_powers(char *argv)
{
int i,k;
int j;
double a,b;
degree=2;
var_type='8';
s_init(argv);
if (g<2)
{
sur_print("\nUsage: POWERS <SURVO_data>");
sur_print("\n POW_VARS=<list_of_variables>");
sur_print("\n DEGREE=<max_power> TYPE=<1|2|4|8>");
WAIT; return;
}
strcpy(aineisto,word[1]);
i=data_open3(aineisto,&d,1,1,1,1);
if (i<0) { s_end(argv[1]); return; }
i=spec_init(r1+r-1); if (i<0) return;
i=conditions(&d); if (i<0) { s_end(argv[1]); return; }
i=list_of_vars(); if (i<0) return;
i=spfind("DEGREE");
if (i>=0) degree=atoi(spb[i]);
if (degree>MAX_POW)
{
sprintf(sbuf,"\nMax. degree is %d.",MAX_POW);
sur_print(sbuf); WAIT; return;
}
i=spfind("TYPE");
if (i>=0) var_type=*spb[i];
i=power_combinations(); if (i<0) return;
for (j=1L; j<=d.n; ++j)
{
for (i=0; i<nvar; ++i)
{
if (unsuitable(&d,j)) continue;
data_load(&d,j,var_ind[i],&a);
// Rprintf("\nvar=%d a=%g|",vara); getch();
val[i][1]=a; b=a;
for (k=2; k<=degree; ++k)
{
b*=a;
val[i][k]=b;
// Rprintf("\nval: %d %d %g %g|",i,k,a,val[i][k]); getch();
}
}
for (k=0; k<ncomb; ++k)
{
a=1.0;
for (i=0; i<nvar; ++i)
if (pow_v[k][i]>0) a*=val[i][pow_v[k][i]];
// Rprintf("\na=%g|",a); getch();
data_save(&d,j,pow_ind[k],a);
}
}
data_close(&d); // 8.8.2011/SM
s_end(argv);
}