void muste_nterm(int argc, char *argv[])
{
int i;
/*
if (argc==1)
{
Rprintf("This program can be used as a SURVO 84C module only.");
return;
}
*/
s_init(argv[1]);
i=init_sequence();
if (i<0) { s_end(argv[1]); return; }
i=init_regressors();
if (i<0) return;
i=linear_regression(seq_n,10);
if (i<0) return;
data_close(&data);
edwrite(nterm_output_buffer,nterm_output_line,1);
s_end(argv[1]);
}
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;
}
/*
* Send "QUIT" command and close the connection to the server
*
* Side effects: Closes the connection to the server.
* You can't use "put_server" or "get_server" after this
* routine is called.
*
* TODO: remember servers response string and if it contains anything else
* than just "." (i.e. transfer statistics) present it to the user?
*
*/
void
close_server(
void)
{
if (nntp_wr_fp == NULL || nntp_rd_fp == NULL)
return;
if (!batch_mode || verbose)
my_fputs(_(txt_disconnecting), stdout);
nntp_command("QUIT", OK_GOODBYE, NULL, 0);
quitting = TRUE; /* Don't reconnect just for this */
(void) s_fclose(nntp_wr_fp);
(void) s_fclose(nntp_rd_fp);
s_end();
nntp_wr_fp = nntp_rd_fp = NULL;
}
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;
}
}
int muste_magic(char *argv)
{
int i,j,method,spec,offs,raja,magic;
s_init(argv);
if (g<3)
{
sur_print("\nUsage: MAGIC CREATE <dim>");
WAIT;
return(1);
}
results_line=r1+r;
i=sp_init(r1+r-1);
if (i<0) return(-1);
dim=atoi(word[2]);
i=varaa_tilat(dim);
if (i<0) return(-1);
if (dim%2==0)
{
sur_print("\nCurrently only odd dimensions allowed!");
WAIT;
return(-1);
}
method=1; // Default method for odd dimensions
spec=1;
offs=dim>>1;
magic=0;
i=spfind("METHOD");
if (i>=0) {
method=atoi(spb[i]);
}
i=spfind("OFFSET");
if (i>=0) {
offs=atoi(spb[i])-1;
}
if (offs<0 || offs>=(dim*dim))
{
if (strcmp(spb[i],"ALL")==0) offs=-1;
else
{
sprintf(sbuf,"\nERROR! OFFSET must be between 1 and %d!",dim*dim);
sur_print(sbuf);
WAIT;
return(-1);
}
}
raja=offs+1;
if (offs<0) // ALL
{
raja=dim*dim;
offs=0;
}
for (j=offs; j<raja; j++)
{
tyhjenna(dim);
switch(method)
{
case 0:
i=magic_random(dim);
break;
case 1:
i=magic_staircase(dim);
break;
case 2:
i=magic_pyramid(dim);
break;
case 3:
i=magic_variation_staircase(dim);
break;
case 4:
i=spfind("MOVE");
if (i>=0) {
spec=atoi(spb[i]);
}
if (spec<1 || spec>8)
{
sur_print("\nERROR! Knight's move should be:");
sur_print("\n1 - 2 up, 1 right 5 - 2 down, 1 left");
sur_print("\n2 - 1 up, 2 right 6 - 1 down, 2 left");
sur_print("\n3 - 2 right, 1 down 7 - 2 left, 1 up");
sur_print("\n4 - 1 right, 2 down 8 - 1 left, 2 up");
sur_print("\nUse specification MOVE to define the move.");
WAIT;
return(-1);
}
i=magic_knights_move(dim,j,spec);
break;
default:
break;
}
i=is_magic(dim);
if (i<0)
{
if (method==0) print_square(dim);
/*
sprintf(sbuf,"Non magic! Offset=%d",j+1); print_line();
print_square(dim);
if (i<99) sprintf(sbuf,"Wrong sum(s) in diagonal(s)!"); print_line();
if (i<9) sprintf(sbuf,"Wrong sum(s) in column(s)!"); print_line();
sprintf(sbuf,"Wrong sum(s) in row(s)!"); print_line();
*/
}
else
{
magic++;
print_square_info(dim,j+1);
print_square(dim);
sprintf(sbuf," ");
print_line();
}
}
if (magic<1)
{
sprintf(sbuf,"Non magic! ");
print_line();
}
s_end(argv);
return(1);
}
void muste_show(int argc,char *argv[])
{
int i;
int space_break0;
long li;
rdisp=0;
ndisp=0;
mdisp=0;
j=jmax=0;
edit=ted1=ted2=0;
tedshad=0;
shad_int=NULL;
n_shad=0;
jj=0;
cdisp=0;
testi=0;
text=NULL;
alut=NULL;
jjmax=0;
last_line32=0;
alut32=NULL;
s98_file=0;
copyfile=NULL;
empty32=0;
disp_frame=0;
win_conv=0;
text_found=0;
codes=NULL;
extern int s_init_extrasplit();
if (argc==1) return;
s_init(argv[1]);
s_init_extrasplit(); // RS ADD
word[2]=word_org[2]; // RS ADD second parameter should remain quoted
labels();
tut_init();
if (r_soft) r3+=r_soft+1;
strcpy(siirtop,argv[1]);
space_break0=space_break;
space_break=0;
jmax=1000000L;
if (hae_apu("max_show_lines",sbuf)) jmax=atol(sbuf); // 22.1.2007
i=avaa_alut();
if (i<0) return;
talleta_alku(1L,0L);
i=spec_find("WINCONV",sbuf,LLENGTH);
if (i>=0 && atoi(sbuf)>0)
{
win_conv=1;
w_codes_load(2);
}
i=spec_find("ENCODING",muste_encoding,LLENGTH-1); // RS 26.1.2014
if (i<0) win_conv=0;
else win_conv=999;
jj=r1+r;
if (g==1)
{
strcpy(tfile,eout);
if (*tfile==EOS) // 28.10.2002
{
sur_print("\nNo output file in use!");
WAIT;
return;
}
text_show(1L);
}
else
{
strcpy(tfile,word[1]);
subst_survo_path(tfile);
li=1L;
if (g>2) li=atol(word[2]);
if (li<1) li=1L;
if (g>2 && !isdigit((int)*word[2]) && *word[2]!='"')
{
li=get_editline_from_file(tfile,word[2],1);
if (li<0) return; // RS ADD
if (li==0)
{
sprintf(sbuf,"\n%s not found!",word[2]);
sur_print(sbuf);
WAIT;
}
}
i=text_show(li);
if (i>0 && edit>=0 && edit!=2) muste_fclose(text);
}
poista_alut();
space_break=space_break0;
tut_end();
if (r_soft) r3-=r_soft+1;
s_end(argv[1]);
}
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);
}
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);
}
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;
}
bool RakeResults<SampleSeq>::copy_into(FwdIter iter, FwdIter end,
typename SampleSeq::PrivateMemberAccess& received_data_p)
{
typedef typename SampleSeq::value_type Sample;
typedef OPENDDS_MAP(SubscriptionInstance*, InstanceData) InstanceMap;
InstanceMap inst_map;
typedef OPENDDS_SET(SubscriptionInstance*) InstanceSet;
InstanceSet released_instances;
for (CORBA::ULong idx = 0; iter != end && idx < max_samples_; ++idx, ++iter) {
// 1. Populate the Received Data sequence
ReceivedDataElement* rde = iter->rde_;
if (received_data_.maximum() != 0) {
if (rde->registered_data_ == 0) {
received_data_p.assign_sample(idx, Sample());
} else {
received_data_p.assign_sample(idx,
*static_cast<Sample*>(rde->registered_data_));
}
} else {
received_data_p.assign_ptr(idx, rde);
}
// 2. Per-sample SampleInfo (not the three *_rank variables) and state
SubscriptionInstance& inst = *iter->si_;
inst.instance_state_.sample_info(info_seq_[idx], rde);
rde->sample_state_ = DDS::READ_SAMPLE_STATE;
// 3. Record some info about per-instance SampleInfo (*_rank) so that
// we can fill in the ranks after the loop has completed
std::pair<typename InstanceMap::iterator, bool> result =
inst_map.insert(std::make_pair(&inst, InstanceData()));
InstanceData& id = result.first->second;
if (result.second) { // first time we've seen this Instance
ReceivedDataElement& mrs = *inst.rcvd_samples_.tail_;
id.MRS_disposed_gc_ =
static_cast<CORBA::Long>(mrs.disposed_generation_count_);
id.MRS_nowriters_gc_ =
static_cast<CORBA::Long>(mrs.no_writers_generation_count_);
}
if (iter->index_in_instance_ >= id.MRSIC_index_) {
id.MRSIC_index_ = iter->index_in_instance_;
id.MRSIC_disposed_gc_ =
static_cast<CORBA::Long>(rde->disposed_generation_count_);
id.MRSIC_nowriters_gc_ =
static_cast<CORBA::Long>(rde->no_writers_generation_count_);
}
if (!id.most_recent_generation_) {
id.most_recent_generation_ =
inst.instance_state_.most_recent_generation(rde);
}
id.sampleinfo_positions_.push_back(idx);
// 4. Take
if (oper_ == DDS_OPERATION_TAKE) {
// If removing the sample releases it
if (inst.rcvd_samples_.remove(rde)) {
// Prevent access of the SampleInfo, below
released_instances.insert(&inst);
}
this->reader_->dec_ref_data_element(rde);
}
}
// Fill in the *_ranks in the SampleInfo, and set instance state (mrg)
for (typename InstanceMap::iterator i_iter(inst_map.begin()),
i_end(inst_map.end()); i_iter != i_end; ++i_iter) {
InstanceData& id = i_iter->second;
{ // Danger, limit visibility of inst
SubscriptionInstance& inst = *i_iter->first;
// If this instance has not been released
if (released_instances.find(&inst) == released_instances.end()) {
if (id.most_recent_generation_) {
inst.instance_state_.accessed();
}
}
}
CORBA::Long sample_rank =
static_cast<CORBA::Long>(id.sampleinfo_positions_.size());
for (IndexList::iterator s_iter(id.sampleinfo_positions_.begin()),
s_end(id.sampleinfo_positions_.end()); s_iter != s_end; ++s_iter) {
DDS::SampleInfo& si = info_seq_[*s_iter];
si.sample_rank = --sample_rank;
si.generation_rank = id.MRSIC_disposed_gc_
+ id.MRSIC_nowriters_gc_ - si.generation_rank;
si.absolute_generation_rank = id.MRS_disposed_gc_ +
id.MRS_nowriters_gc_ - si.absolute_generation_rank;
}
}
return true;
}
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);
}
/****************
main(argc,argv)
int argc; char *argv[];
*******************/
void muste_facta(char *argv)
{
int i,j,h;
unsigned int ui;
double da,db;
char x[LLENGTH];
double sumlogsii;
// extern double cdf_chi2();
char acc[32];
// if (argc==1) return;
s_init(argv);
if (g<3)
{
init_remarks();
rem_pr("Usage: FACTA <corr.matrix>,k,L ");
rem_pr(" k=number of factors ");
rem_pr(" L=first line for the results ");
rem_pr(" Factor matrix saved as FACT.M ");
rem_pr(" ");
rem_pr(" METHOD=ULS Unweighted Least Squares ");
rem_pr(" METHOD=GLS Generalized Least Squares ");
rem_pr(" METHOD=ML Maximum Likelihood (default) ");
rem_pr(" Test statistics by N=<number of observations>");
rem_pr("More information by FACTA? ");
wait_remarks(2);
s_end(argv);
return;
}
results_line=0;
if (g>3)
{
results_line=edline2(word[3],1);
if (results_line==0) return;
}
i=sp_init(r1+r-1); if (i<0) return;
i=matrix_load(word[1],&E,&p,&n,&rlab,&clab,&lr,&lc,&type,expr);
if (i<0) { s_end(argv); return; } // RS CHA argv[1]
if (p!=n)
{
sprintf(sbuf,"\n%s not a square matrix!",word[1]); sur_print(sbuf); WAIT; return;
}
k=atoi(word[2]);
if (k<1 || k>p-1)
{
sprintf(sbuf,"Incorrect number (%d) of factors!",k);
if (etu==2)
{
sprintf(tut_info,"___@6@FACTA@%s@",sbuf); s_end(argv); // RS CHA argv[1]
return;
}
sur_print("\n"); sur_print(sbuf); WAIT; return;
}
*mess=EOS;
i=spfind("FEPS");
if (i>=0)
{
double eps;
eps=1.0-atof(spb[i]);
for (i=0; i<p; ++i)
for (j=0; j<p; ++j) { if (i==j) continue; E[i+j*p]*=eps; }
}
ind=3; i=spfind("METHOD");
if (i>=0)
{
if (muste_strcmpi(spb[i],"ULS")==0) ind=1;
if (muste_strcmpi(spb[i],"GLS")==0) ind=2;
}
for (i=0; i<p; ++i)
{
if (E[i*(p+1)]!=0.0) continue;
sprintf(sbuf,"Variable %.*s is a constant!",lr,rlab+i*lr);
if (etu==2)
{
sprintf(tut_info,"___@1@FACTA@%s@",sbuf); s_end(argv); // RS CHA argv[1]
return;
}
sur_print("\n"); sur_print(sbuf); WAIT; return;
}
/*
if (ind==1)
{
for (i=0; i<p; ++i)
{
if (fabs(E[i*(p+1)]-1.0)<0.0001) continue;
Rprintf("\n%s is not a correlation matrix as supposed in ULS!",
word[1]); WAIT; return;
}
}
*/
i=varaa_tilat(); if (i<0) return;
for (ui=0; ui<p*p; ++ui) S[ui]=E[ui];
sumlogsii=0.0; for (i=0; i<p; ++i) sumlogsii+=log(S[i*(p+1)]);
i=nwtrap();
if (i<0)
{
if (etu!=2)
{ sur_print("\nSolution not found!"); WAIT; return; }
s_end(argv); // RS CHA argv[1]
return;
}
h=output_open(eout); if (h<0) return;
strcpy(x,"Factor analysis: ");
switch (ind)
{
case 1: strcat(x,"Unweighted Least Squares (ULS) solution"); break;
case 2: strcat(x,"Generalized Least Squares (GLS) solution"); break;
case 3: strcat(x,"Maximum Likelihood (ML) solution"); break;
}
print_line(x);
if (*mess)
{
strcpy(x," "); strcat(x,mess);
print_line(x);
if (etu!=2) { WAIT; }
}
i=spfind("N");
if (i>=0)
{
if (ind>1)
{
double n1,c0,chi20,d0,m0,ck,chi2k,dk,mk,rho,pr;
char *q;
n1=atof(spb[i]);
if (n1<(double)k) { sur_print("\nIncorrect N!"); WAIT; return; }
c0=n1-1.0-(2.0*p+5.0)/6.0;
chi20=c0*(sumlogsii-log(det));
d0=p*(p-1.0)/2.0;
m0=chi20/d0;
ck=c0-2.0*k/3.0;
chi2k=ck*f0;
dk=((p-k)*(p-k)-p-k)/2.0;
mk=chi2k/dk;
rho=(m0-mk)/(m0-1.0);
// pr=cdf_chi2(chi2k,dk,1e-10);
pr=0.0;
sprintf(x,"factors=%d Chi^2=%g df=%d P=%5.3f reliability=%g",
k,chi2k,(int)dk,pr,rho);
if (rho>1.0) { q=strstr(x,"rel"); *q=EOS; } /* 3.6.1995 */
print_line(x);
}
else
{
double n1,uu,dk,pr;
n1=atof(spb[i]);
if (n1<(double)k) { sur_print("\nIncorrect N!"); WAIT; return; }
for (i=0; i<p; ++i) for (j=0; j<i; ++j)
{
da=0.0;
for (h=0; h<k; ++h) da+=L[i+p*h]*L[j+p*h];
S[i+p*j]=da; S[j+p*i]=da;
} /* Huom. S-diagonaali säilytetään */
mat_dcholinv(S,p,&uu);
uu=(n1-1.0)*log(uu/det);
dk=((p-k)*(p-k)+p-k)/2.0; /* ei sama kuin yllä! */
// pr=cdf_chi2(uu,dk,1e-10);
pr=0.0;
sprintf(x,"factors=%d Chi^2=%g df=%d P=%5.3f",
k,uu,(int)dk,pr);
print_line(x);
}
}
output_close(eout);
f_orientation(L,p,k);
text_labels(clab,k,lc,"F");
matrix_save("FACT.M",L,p,k,rlab,clab,lr,lc,0,"F",0,0);
strncpy(clab+k*lc,"h^2 ",8);
for (i=0; i<p; ++i)
{
da=0.0;
for (j=0; j<k; ++j)
{
db=L[i+p*j];
S[i+p*j]=db;
da+=db*db;
}
S[i+p*k]=da;
}
strcpy(acc,"12.1234567890123456");
acc[accuracy-1]=EOS;
matrix_print(S,p,k+1,rlab,clab,lr,lc,p,k+1,NULL,NULL,acc,c3,
results_line,eout,"Factor matrix");
s_end(argv);
}
void muste_cluster(char *argv)
{
int i,k;
double a;
char ch;
// if (argc==1) return;
s_init(argv);
if (g<2)
{
sur_print("\nUsage: CLUSTER <SURVO_data>,<output_line>");
WAIT; return;
}
tulosrivi=0;
if (g>2)
{
tulosrivi=edline2(word[2],1,1);
if (tulosrivi==0) return;
}
strcpy(aineisto,word[1]);
i=data_open(aineisto,&d); if (i<0) return;
i=sp_init(r1+r-1); if (i<0) return;
i=mask(&d); if (i<0) return;
scales(&d);
i=conditions(&d); if (i<0) return;
gvar=activated(&d,'G');
if (gvar<0)
{
sur_print("\nNo grouping variable (activated by 'G') given!");
WAIT; return;
}
ivar=-1; ivar=activated(&d,'I');
i=spfind("TRIALS");
if (i>=0) maxiter=atoi(spb[i]);
i=rand_init(); if (i<0) return; /* 30.4.1994 */
i=spfind("TEMPFILE");
if (i>=0) strcpy(tempfile,spb[i]);
else { strcpy(tempfile,etmpd); strcat(tempfile,"SURVO.CLU"); }
i=spfind("PRIND");
if (i>=0 && atoi(spb[i])>0) prind=1;
data_load(&d,1L,gvar,&a);
i=data_save(&d,1L,gvar,a);
if (i<0) return;
gvar2=(int *)muste_malloc(d.m_act*sizeof(int));
if (gvar2==NULL) { not_enough_memory(); return; }
k=0; n_saved=0; m=0;
for (i=0; i<d.m_act; ++i)
{
ch=d.vartype[d.v[i]][1];
if (ch=='G')
{
++k;
gvar2[n_saved]=d.v[i]; /* gvar=gvar2[0] */
++n_saved; continue;
}
if (ch=='I') { ++k; continue; }
d.v[m++]=d.v[i];
}
/*
printf("\nivar=%d gvar=%d m=%d\n",ivar,gvar,m); getch();
for (i=0; i<m; ++i) Rprintf(" %d",d.v[i]); getch();
printf("\n"); for (i=0; i<n_saved; ++i) Rprintf(" %d",gvar2[i]); getch();
*/
i=spfind("GROUPS");
if (i<0) ng=2; else ng=atoi(spb[i]);
if (ng<2) ng=2;
ng2=ng+2;
mn=m; if (mn<ng) mn=ng;
first_line=r+1; if (r+n_saved>r3) first_line=1;
n_show=n_saved; if (n_show>r3) n_show=r3;
i=varaa_tilat(); if (i<0) return;
i=lue_havainnot(); if (i<0) return;
hav_muistissa=havainnot_muistiin();
ortogonalisoi();
if (ivar_init) alustava_luokittelu();
LOCATE(first_line,1);
SCROLL_UP(first_line,r3+1,r3);
sur_print("\nCluster analysis: Iteration 1:");
while (sur_kbhit()) sur_getch();
it=0;
while (1)
{
while (1)
{
if (it) init_gr();
i=init_tilat();
if (i>=0) break;
if (maxiter==1) return;
}
iteroi();
++it;
if (maxiter>1) vertaa_muihin();
if (it==maxiter) break;
LOCATE(first_line,1);
sprintf(sbuf,"\nIteration %d (Cluster analysis)",it);
sur_print(sbuf);
for (i=0; i<n_show; ++i)
{
if (freq[i]==0) break;
sprintf(sbuf,"\n%d %g %d ",i+1,lambda2[i],freq[i]); sur_print(sbuf);
}
if (sur_kbhit())
{
i=sur_getch(); if (i=='.') break;
}
}
tulosta();
data_close(&d);
sur_delete(tempfile);
s_end(argv);
}
void muste_xcorr(char *argv)
{
int i;
s_init(argv);
if (g<4)
{
sur_print("\nUsage: XCORR <data>,<xvar>,<yvar>,L");
WAIT;
return;
}
i=sp_init(r1+r-1);
if (i<0) return;
i=data_read_open(word[1],&d);
if (i<0) return;
xvar=varfind(&d,word[2]);
if (xvar<0) return;
yvar=varfind(&d,word[3]);
if (yvar<0) return;
if (xvar==yvar) autocorr=1;
else autocorr=0;
if (g<5) tulosrivi=0;
else
{
tulosrivi=edline2(word[4],1);
if (tulosrivi==0) return;
}
i=conditions(&d);
if (i<0) return;
i=spfind("MAXLAG");
if (i<0) maxlag=12;
else maxlag=atoi(spb[i]);
if (maxlag<1) maxlag=1;
xx=NULL;
yy=NULL;
xy1=NULL;
xy2=NULL;
x2=NULL;
y2=NULL;
xs1=NULL;
xs2=NULL;
ys1=NULL;
ys2=NULL;
i=varaa_tilat_xcorr();
if (i<0) return;
n=0;
for (i=0; i<maxlag; ++i) xx[i]=yy[i]=xy1[i]=xy2[i]=0.0;
for (i=0; i<maxlag; ++i) xs1[i]=xs2[i]=ys1[i]=ys2[i]=0.0;
xsum=ysum=xsum2=ysum2=0.0;
corr=0.0;
i=lue_datat();
data_close(&d);
if (i<0) return;
if ((int)maxlag>n-1) maxlag=n-1;
tulostus();
s_end(argv);
}
