static int table_to_matrix(char *name,FREQ *f,int m,int n,char **varname,char **cname)
{
int i;
unsigned int k;
/*
Rprintf("\nm=%d n=%d",m,n); getch();
Rprintf("\n"); for (i=0; i<2; ++i) Rprintf("%s ",varname[i]);
Rprintf("\n"); for (i=0; i<m+n; ++i) Rprintf("%s ",cname[i]); getch();
*/
tt=(double *)muste_malloc(m*n*sizeof(double));
if (tt==NULL) { not_enough_memory(); return(-1); }
rlab=muste_malloc(8*m);
if (rlab==NULL) { not_enough_memory(); return(-1); }
clab=muste_malloc(8*n);
if (clab==NULL) { not_enough_memory(); return(-1); }
for (k=0; k<m*n; ++k)
{
tt[k]=f[k];
}
lab_copy(m,cname+n,rlab);
lab_copy(n,cname,clab);
sprintf(expr,"Table_%s/%s",varname[1],varname[0]);
i=matrix_save(name,tt,m,n,rlab,clab,8,8,-1,expr,0,0);
muste_free(tt); muste_free(rlab); muste_free(clab);
return(i);
}
/*********************
static int load_Y(char *nimi)
{
int i;
i=matrix_load(nimi,&Y,&mY,&nY,&rlabY,&clabY,&lrY,&lcY,&typeY,exprY);
return(i);
}
************************/
static int save_T(char *nimi)
{
int i;
i=matrix_save(nimi,T,mT,nT,rlabT,clabT,8,8,-1,exprT,0,0);
return(i);
}
int main(int argc, char **argv)
{
int n = (argc > 1) ? atoi(argv[1]) : 100;
const char* matr_fname = (argc > 2) ? argv[2] : "l2_default.csr";
const char* pict_fname = (argc > 3) ? argv[3] : NULL;
real h = 1. / n;
int size = (n - 1) * (n - 1);
int nonz = 4 * size;
int err;
TMatrix_DCSR _m;
TMatrix_DCSR *m = &_m;
err = matrix_create(m, size, nonz, 1);
if (err) PRINT_ERROR_MESSAGE_AND_EXIT(err);
for (int i = 1; i <= size; ++i)
m->row_ptr[i] = 4 * i;
for (int i = 1; i <= n; ++i)
{
for (int j = 1; j <= n; ++j)
{
int todo[4] = {
ij2k(n, i - 1, j - 1), // bl
ij2k(n, i - 1, j - 0), // br
ij2k(n, i - 0, j - 1), // tl
ij2k(n, i - 0, j - 0), // tr
};
for (int ci = 0; ci < 4; ++ci) {
int k = todo[ci];
if (k < 0) continue;
real coeff = get_coeff(j*h - h/2, i*h - h/2);
m->diag[k] += 1 * coeff;
for (int cj = 0; cj < 4; ++cj) {
int off = loc_off(ci, cj);
if (off < 0) continue;
m->col_ind[m->row_ptr[k] + off] = todo[cj];
m->val [m->row_ptr[k] + off] -= 0.5 * coeff;
}
}
}
}
TMatrix_DCSR _l2;
TMatrix_DCSR *l2 = &_l2;
matrix_copy_fix(m, l2);
matrix_destroy(m);
if (pict_fname) matrix_portrait(l2, pict_fname, 5., 0, NULL);
if (strstr(matr_fname, ".mtx") != NULL) matrix_save_fmc(l2, matr_fname);
else matrix_save(l2, matr_fname);
return 0;
}
int main(int argc, char **argv)
{
if (argc < 3) {
fprintf(stderr, "usage: %s infile outfile {o|m} [res_pic.png] [intermid_pic.png\n");
return 2;
}
int err;
int is_in_fmc = (strstr(argv[1], ".mtx") != NULL);
int is_out_fmc = (strstr(argv[2], ".mtx") != NULL);
int type = (argv[3][0] == 'o') ? ALG_ORIG : ALG_MULT;
TMatrix_DCSR _A, *A = &_A;
TMatrix_DCSR _B, *B = &_B;
TWGraph _gr, *gr = &_gr;
if (is_in_fmc) err = matrix_load_fmc(A, argv[1]);
else err = matrix_load(A, argv[1]);
if (err != ERROR_NO_ERROR)
PRINT_ERROR_MESSAGE_AND_EXIT(err);
int size = A->size;
int *xadj, *adjncy;
int *perm, *invp;
if (!perm || !invp)
PRINT_ERROR_MESSAGE_AND_EXIT(ERROR_MEMORY_ALLOCATION);
switch (type) {
case ALG_ORIG: do_orig(A, &xadj, &adjncy); break;
case ALG_MULT: do_mult(A, &xadj, &adjncy); break;
}
TWGraph igr = { NULL, adjncy, xadj, NULL, size, xadj[size] };
tnd_perm(&igr, &perm, &invp);
SAFE(build_graph(gr, A));
SAFE(graph_reorder(gr, perm, invp));
SAFE(build_matrix(gr, B, 1));
if (argc > 4) matrix_portrait(B, argv[4], 0, 0, NULL);
if (is_out_fmc) matrix_save_fmc(B, argv[2]);
else matrix_save(B, argv[2]);
free(xadj);
free(adjncy);
if (argc > 5) {
switch (type) {
case ALG_ORIG: do_orig(B, &xadj, &adjncy); break;
case ALG_MULT: do_mult(B, &xadj, &adjncy); break;
}
igr = (TWGraph){ NULL, adjncy, xadj, NULL, size, 0 };
graph_portrait(&igr, argv[5]);
}
return 0;
}
static int save_var(double *rr,int m,char *text) /* saving the optimally permuted covariance matrix */
{
int i,j;
char nimi[LNAME];
*text=EOS;
for (i=0; i<m; ++i)
{
for (j=0; j<lr; ++j) rlab[i*lr+j]=clab[p[i]*lr+j];
}
for (i=0; i<m*lr; ++i) clab[i]=rlab[i];
strcpy(nimi,edisk); strcat(nimi,"COVVAR.M");
sprintf(sbuf,"Permuted_covariance_matrix %s",text);
matrix_save(nimi,rr11,m,m,rlab,clab,lr,lr,0,sbuf,0,0);
return(1);
}
/****************
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);
}
