preserve
set printback=off
set decimal=dot
*---------------------------------------------------------------------------
* kanonika1
* Program za simultanu kanonicku korelacijsku analizu
*
*
* Verzija 1.0.
*
* Kanonicka korelacijska analiza implementirana je u skladu sa
* metodama koje su predlozili Hotelling (1935; 1936) i Cooley
* and Lohnes (1971); testiranje znacajnosti kanonickih korelacija
* izvedeno je postupkom koga je predlozio Bartlett (1941).
*
*
*
* Ovaj program je revizija programa kanonika, napisanog u SS jeziku
* (Momirovic, Dobric, Bosnar i Prot, 1984).
*
* kanonika se aktivira na sledeci nacin:
* INCLUDE 'kanonika1.SPS'.
* kanonika SET1=imena varijabli/SET2=imena varijabli/INC=zeljena znacajnost/.
* Odredba INC je opciona. Ukoliko se izostavi podrazumeva se statisticka
* znacajnost na nivou 0.01.
*
* Napomena: Makro je manje robustan od regularnih SPSS komandi
* Provera regularnosti sintakse je vrlo stroga, tako da se apsolutno
* treba pridrzavati zadate sintakse.
*---------------------------------------------------------------------------
define kanonika(set1=!charend('/')
/set2=!charend('/')
/inc=!default(.01) !charend('/'))
preserve
set printback=off mxloop=100 mprint off
*---------------------------------------------------------------------------
* Cuvanje originalnog fajla
*---------------------------------------------------------------------------
save outfile='cc_tmp1.sav'
*---------------------------------------------------------------------------
* Kreiranje korelacione matrice.
*---------------------------------------------------------------------------
set results off
corr variables=!set1 !set2 /missing=listwise/matrix out(*)
set decimal=dot
set results listing printback off mprint off
*---------------------------------------------------------------------------
* Kreiranje korelacionih submatrica
*---------------------------------------------------------------------------
matrix
get r /variables=!set1/missing=omit/file=*
compute p1=ncol(r)
get r /file=* /names=varname/missing=omit/variables=!set1 !set2
compute p2=ncol(r)-p1
compute nx1=varname(1:p1)
compute nv=p1+p2
compute nx2=varname((p1+1):nv)
compute rr=r(4:(nv+3),1:nv)
compute ns=r(3,1)
compute r11=rr(1:p1,1:p1)
compute r22=rr((p1+1):nv,(p1+1):nv)
compute r12=rr(1:p1,(p1+1):nv)
compute r21=t(r12)
release r
release nv
release rr
release varname
*---------------------------------------------------------------------------
* Stampanje korelacija
*---------------------------------------------------------------------------
compute num={"1","2","3","4","5","6","7","8","9","10","11",
"12","13","14","15","16","17","18","19","20","21","22","23","24","25",
"26","27","28","29","30","31","32","33","34","35","36","37","38","39",
"40","41","42","43","44","45","46","47","48","49","50","51","52","53",
"54","55","56","57","58","59","60","61","62","63","64","65","66","67",
"68","69","70","71","72","73","74","75","76","77","78","79","80","81",
"82","83","84","85","86","87","88","89","90","91","92","93","94","95",
"96","97","98","99","100"}
print r11 /format "f8.3"/title 'Interkorelacije levog skupa varijabli'
/rnames=nx1 /cnames=nx1
print r22 /format "f8.3"/title 'Interkorelacije desnog skupa varijabli'
/rnames=nx2 /cnames=nx2
print r12 /format "f8.3"
/title 'Kroskorelacije levog i desnog skupa varijabli'
/rnames=nx1 /cnames=nx2
print /title 'REZULTATI KANONICKE KORELACIJSKE ANALIZE:' /space 2
*---------------------------------------------------------------------------
* r1 and r2 su matrice dobijene dekompozicijom Cholesk-og
* matrica interkorelacija
*---------------------------------------------------------------------------
compute r1=chol(r11)
compute r2=chol(r22)
*---------------------------------------------------------------------------
* r1inv and r2inv su inverzi r1 i r2
*---------------------------------------------------------------------------
compute r1inv=inv(r1)
compute r2inv=inv(r2)
release r1
release r2
*---------------------------------------------------------------------------
* Izracunavanje omega matrice
*---------------------------------------------------------------------------
do if (p1 le p2)
compute omega=t(r1inv)*r12*r2inv
else
compute omega=t(r2inv)*t(r12)*r1inv
end if
*---------------------------------------------------------------------------
* Singularna dekompozicija matrice omega
*---------------------------------------------------------------------------
call svd(omega,u,lambda,v)
compute dlam=diag(lambda)
release omega
release lambda
*----------------------------------------------------------------------------
* Konstrukcije struktura za ispis rezultata analize prepokrivanja
*----------------------------------------------------------------------------
compute c1={"CV1-1","CV1-2","CV1-3","CV1-4","CV1-5","CV1-6","CV1-7",
"CV1-8","CV1-9","CV1-10","CV1-11","CV1-12","CV1-13","CV1-14","CV1-15",
"CV1-16","CV1-17","CV1-18","CV1-19","CV1-20","CV1-21","CV1-22","CV1-23",
"CV1-24","CV1-25","CV1-26","CV1-27","CV1-28","CV1-29","CV1-30","CV1-31",
"CV1-32","CV1-33","CV1-34","CV1-35","CV1-36","CV1-37","CV1-38","CV1-39",
"CV1-40","CV1-41","CV1-42","CV1-43","CV1-44","CV1-45","CV1-46","CV1-47",
"CV1-48","CV1-49","CV1-50","CV1-51","CV1-52","CV1-53","CV1-54","CV1-55",
"CV1-56","CV1-57","CV1-58","CV1-59","CV1-60","CV1-61","CV1-62","CV1-63",
"CV1-64","CV1-65","CV1-66","CV1-67","CV1-68","CV1-69","CV1-70","CV1-71",
"CV1-72","CV1-73","CV1-74","CV1-75","CV1-76","CV1-77","CV1-78","CV1-79",
"CV1-80","CV1-81","CV1-82","CV1-83","CV1-84","CV1-85","CV1-86","CV1-87",
"CV1-88","CV1-89","CV1-90","CV1-91","CV1-92","CV1-93","CV1-94","CV1-95",
"CV1-96","CV1-97","CV1-98","CV1-99","CV1-100"}
compute c2={"CV2-1","CV2-2","CV2-3","CV2-4","CV2-5","CV2-6","CV2-7",
"CV2-8","CV2-9","CV2-10","CV2-11","CV2-12","CV2-13","CV2-14","CV2-15",
"CV2-16","CV2-17","CV2-18","CV2-19","CV2-20","CV2-21","CV2-22","CV2-23",
"CV2-24","CV2-25","CV2-26","CV2-27","CV2-28","CV2-29","CV2-30","CV2-31",
"CV2-32","CV2-33","CV2-34","CV2-35","CV2-36","CV2-37","CV2-38","CV2-39",
"CV2-40","CV2-41","CV2-42","CV2-43","CV2-44","CV2-45","CV2-46","CV2-47",
"CV2-48","CV2-49","CV2-50","CV2-51","CV2-52","CV2-53","CV2-54","CV2-55",
"CV2-56","CV2-57","CV2-58","CV2-59","CV2-60","CV2-61","CV2-62","CV2-63",
"CV2-64","CV2-65","CV2-66","CV2-67","CV2-68","CV2-69","CV2-70","CV2-71",
"CV2-72","CV2-73","CV2-74","CV2-75","CV2-76","CV2-77","CV2-78","CV2-79",
"CV2-80","CV2-81","CV2-82","CV2-83","CV2-84","CV2-85","CV2-86","CV2-87",
"CV2-88","CV2-89","CV2-90","CV2-91","CV2-92","CV2-93","CV2-94","CV2-95",
"CV2-96","CV2-97","CV2-98","CV2-99","CV2-100"}
*---------------------------------------------------------------------------
* Kanonicke korelacije i testiranje njihove znacajnosti
*---------------------------------------------------------------------------
compute eign=(1 &/ (1-dlam &**2)) - 1
compute wlam=1 &/ (1+eign)
compute n=nrow(wlam)
compute wilk=wlam
compute df=wlam
compute sig=wlam
compute bart2=wlam
compute tem=1
loop #l=1 to n
+ compute tem=tem*wlam(n-#l+1)
+ compute df(n-#l+1)=(p1-n+#l)*(p2-n+#l)
+ compute dof=df(n-#l+1)
+ compute bart2(n-#l+1)=-(ns-(p1+p2+3)/2)*ln(tem)
+ compute chi=bart2(n-#l+1)
+ compute sig(n-#l+1)=1-chicdf(chi,dof)
+ compute wilk(n-#l+1)=tem
end loop
compute test={dlam,wilk,bart2,df,sig}
print test /format "f10.3"
/title 'Koeficijenti kanonickih korelacija i njihova znacajnost:'
/space 2/rnames=num
/cnames={"Rho","Lambda","Hi2","df","sig"}
release eign
release wlam
release wilk
release df
release bart2
release tem
release test
release dof
release chi
release dlam
*-------------------------------------------------------------------------
* Zadrzavanje znacajnih kanonickih korelacija
*-------------------------------------------------------------------------
compute cifra=make(n,1,0)
compute inc=!inc
loop s=1 to n
do if sig(s,1) < inc
+ compute cifra(s,1)=1
end if
end loop
compute znac=csum(cifra)
release sig
release cifra
do if znac > 0
*---------------------------------------------------------------------------
* Izracunavanje i stampanje kanonickih koeficijenata levog skupa varijabli
*---------------------------------------------------------------------------
do if (p1 le p2)
compute a=r1inv*u
else
compute a=r1inv*v
end if
do if (p2 lt p1)
compute a=a(:,1:p2)
end if
compute aznac=a(:,1:znac)
print aznac/format "f8.3"
/title 'Kanonicki koeficijenti levog skupa varijabli'
/space 2/rnames=nx1/cnames=num
release r1inv
*---------------------------------------------------------------------------
* Izracunavanje i stampanje kanonickih koeficijenata desnog skupa varijabli
*---------------------------------------------------------------------------
do if (p1 le p2)
compute b=r2inv*v
else
compute b=r2inv*u
end if
do if (p1 le p2)
compute b=b(:,1:p1)
end if
compute bznac=b(:,1:znac)
print bznac/format "f8.3"
/title 'Kanonicki koeficijenti desnog skupa varijabli'
/space 2/rnames=nx2/cnames=num
release r2inv
release v
release u
*---------------------------------------------------------------------------
* Izracunavanje i stampanje struktura kanonickih faktora levog
* skupa varijabli
*---------------------------------------------------------------------------
compute tem1=r11*a
compute tem1z=tem1(:,1:znac)
print tem1z /format "f8.3"
/title 'Kanonicki faktori levog skupa varijabli'
/space 2/rnames=nx1/cnames=num
release tem1
*---------------------------------------------------------------------------
* Izracunavanje i stampanje struktura kanonickih faktora desnog
* skupa varijabli
*---------------------------------------------------------------------------
compute tem2=r22*b
compute tem2z=tem2(:,1:znac)
print tem2z /format "f8.3"
/title 'Kanonicki faktori desnog skupa varijabli'
/space 2/rnames=nx2/cnames=num
release tem2
*---------------------------------------------------------------------------
* Izracunavanje i stampanje kanonickih kros-faktoralevog skupa varijabli
*---------------------------------------------------------------------------
compute tem12=r12*b
compute tem12z=tem12(:,1:znac)
print tem12z /format "f8.3"
/title 'Kanonicki kros-faktori levog skupa varijabli'
/space 2/rnames=nx1/cnames=num
release tem12
release b
*---------------------------------------------------------------------------
* Izracunavanje i stampanje kanonickih kros-faktora desnog skupa varijabli
*---------------------------------------------------------------------------
compute tem21=t(r12)*a
compute tem21z=tem21(:,1:znac)
print tem21z /format "f8.3"
/title 'Kanonicki kros-faktori desnog skupa varijabli'
/space 2/rnames=nx2/cnames=num
release tem21
release a
*----------------------------------------------------------------------------
* Relativne varijanse, indeksi prepokrivanja i mere generalizabilnosti
* levog skupa varijabli
*----------------------------------------------------------------------------
compute f1=cssq(tem1z)/p1
compute f1=t(f1)
compute jedanc=make(znac,1,1)
compute alpha1=(p1/(p1-1))*(jedanc-jedanc&/t(cssq(tem1z)))
compute cs3=cssq(tem12z)/p1
compute cs3=t(cs3)
release tem12z
*---------------------------------------------------------------------------
* Relativne varijanse, indeksi prepokrivanja i mere generalizabilnosti
* desnog skupa varijabli
*---------------------------------------------------------------------------
compute f2=cssq(tem2z)/p2
compute f2=t(f2)
compute alpha2=(p2/(p2-1))*(jedanc-jedanc&/t(cssq(tem2z)))
compute cs4=cssq(tem21z)/p2
compute cs4=t(cs4)
release tem21z
release jedanc
*---------------------------------------------------------------------------
* Stampanje rezultata analize prepokrivanja
*---------------------------------------------------------------------------
print /title 'ANALIZA PREPOKRIVANJA:' /space 2
compute test1={f1, cs3}.
print test1/format "f15.3"
/title 'Analiza prepokrivanja levog skupa'
/space 2/rnames=c1
/cnames= {"Var.","Prepok."}
compute test2={f2, cs4 }.
print test2/format "f15.3"
/title 'Analiza prepokrivanja desnog skupa'
/space 2/rnames=c2
/cnames= {"Var.","Prepok."}
release f1
release f2
release cs3
release cs4
release alpha1
release alpha2
release test1
release test2
else
. print/title 'Nisu izdvojene statisticki znacajne kanonicke korelacije'
end if
*---------------------------------------------------------------------------
* Singularna dekompozicija matrice r12
*---------------------------------------------------------------------------
call svd(r12,x1,lambda1,x2)
*---------------------------------------------------------------------------
* Zadrzavaju se singularne vrednosti matrice r12 koje su vece od
* aritmeticke sredine svih njenih singularnih vrednosti
*---------------------------------------------------------------------------
compute dlam1=diag(lambda1)
compute suma1=csum(dlam1)
compute suma=suma1/n
compute cifra1=make(n,1,0)
loop s=1 to n
do if dlam1(s,1) >= suma
. compute cifra1(s,1)=1
end if
end loop
compute znacq=csum(cifra1)
compute x1z=x1(:,1:znacq)
compute x2z=x2(:,1:znacq)
release dlam1
release x1
release x2
release lambda1
release cifra1
release suma
release suma1
*---------------------------------------------------------------------------
* Izracunavanje i stampanje kvazikanonickih koeficijenata, sklopa, strukture,
* interkorelacija zadrzanih kvazikanonickih faktora i testiranje i stampanje
* njihove znacajnosti
*---------------------------------------------------------------------------
compute c=t(x1z)*r12*x2z
compute mm1=t(x1z)*r11*x1z
compute mm2=t(x2z)*r22*x2z
do if znacq > 1
compute d1=diag(mm1)
compute d2=diag(mm2)
compute d1=sqrt(d1)
compute d1=1&/d1
compute d1=mdiag(d1)
compute d2=sqrt(d2)
compute d2=1&/d2
compute d2=mdiag(d2)
compute m1=d1*mm1*d1
compute m2=d2*mm2*d2
compute invm1=inv(m1)
compute invm2=inv(m2)
compute c=diag(c)
compute c=mdiag(c)
compute f1=r11*x1z*d1
compute f2=r22*x2z*d2
compute a1=f1*invm1
compute a2=f2*invm2
compute ro=d1*c*d2
compute ro=diag(ro)
compute ro2=ro&*ro
compute f12=r12*x2z*d2
compute f21=r21*x1z*d1
compute df1=1
compute df2=ns-2
compute ftest1=make(znacq,1,1)
compute ftest2=ftest1
compute sig1=ftest1
loop s=1 to znacq
. compute ftest1(s,1)=ro2(s,1)*((ns-2)/(1-ro2(s,1)))
. compute ftest2=ftest1(s,1)
. compute sig1(s,1)=1-fcdf(ftest2,df1,df2)
end loop
compute lav={ro,ro2,ftest1,sig1}
print lav/format "f8.3"
/title 'Kvazikanonicke korelacije i testovi znacajnosti'/space=2
/rnames=num/cnames={"ro","ro2","f-test","sig"}
print x1z/format "f7.3"
/title 'Kvazikanonicki koeficijenti levog skupa varijabli'
/rnames=nx1/cnames=num
print a1/format "f7.3"
/title 'Sklop levog skupa varijabli'
/rnames=nx1/cnames=num
print m1/format "f7.3"
/title 'Interkorelacije levog skupa kvazikanonickih faktora'
/rnames=num/cnames=num
print f1/format "f7.3"
/title 'Struktura levog skupa varijabli kvazikanonickih faktora'
/rnames=nx1/cnames=num
print f12/format "f7.3"
/title 'Kros-struktura levog skupa'
/rnames=nx1/cnames=num
print x2z/format "f7.3"
/title 'Kvazikanonicki koeficijenti desnog skupa varijabli'
/rnames=nx2/cnames=num
print a2/format "f7.3"
/title 'Sklop desnog skupa varijabli'
/rnames=nx2/cnames=num
print m2/format "f7.3"
/title 'Interkorelacije desnog skupa kvazikanonickih faktora'
/rnames=num/cnames=num
print f2/format "f7.3"
/title 'Struktura desnog skupa varijabli kvazikanonickih faktora'
/rnames=nx2/cnames=num
print f21/format "f7.3"
/title 'Kros-struktura desnog skupa'
/rnames=nx2/cnames=num
release invm1
release invm2
release m1
release m2
release c
release a1
release a2
release ftest1
release ftest2
*---------------------------------------------------------------------------
* Relativne varijanse, indeksi prepokrivanja i mere generalizabilnosti
* levog skupa varijabli
*---------------------------------------------------------------------------
compute jedan=make(znacq,1,1)
compute red1=cssq(f1)/p1
compute red1=t(red1)
compute red3=cssq(f12)/p1
compute red3=t(red3)
compute beta1=(p1/(p1-1))*(jedan-jedan&/t(cssq(f1)))
*---------------------------------------------------------------------------
* Relativne varijanse, indeksi prepokrivanja i mere generalizabilnosti
* desnog skupa varijabli
*---------------------------------------------------------------------------
compute red2=cssq(f2)/p2
compute red2=t(red2)
compute red4=cssq(f21)/p2
compute red4=t(red4)
compute beta2=(p2/(p2-1))*(jedan-jedan&/t(cssq(f2)))
*----------------------------------------------------------------------------
* Stampanje rezultata analize redundanci.
*---------------------------------------------------------------------------
print /title 'ANALIZA PREPOKRIVANJA:' /space 2
compute test1={red1,red3,beta1}.
print test1/format "f15.3"
/title 'Analiza prepokrivanja levog skupa'
/space 2/rnames=c1
/cnames= {"Varijansa","prepokrivanje","generalizabilnost"}
compute test2={red2,red4,beta2}
print test2/format "f15.3"
/title 'Analiza prepokrivanja desnog skupa'
/space 2/rnames=c2
/cnames= {"Varijansa","prepokrivanje","generalizabilnost"}
else
compute d1=sqrt(mm1)
compute d2=sqrt(mm2)
compute d1=1/d1
compute d2=1/d2
compute f1=r11*x1z*d1
compute f2=r22*x2z*d2
compute f12=r12*x2z*d2
compute f21=r21*x1z*d1
compute ro=d1*c*d2
compute ro2=ro*ro
compute df2=ns-2
compute df1=1
compute ftest=ro2*(df2/(1-ro2))
compute sig1=1-fcdf(ftest,1,df2)
compute lav={ro,ro2,ftest,df1,df2,sig1}
end if
end matrix
*---------------------------------------------------------------------------
* Pozivanje i restrukturiranje originalnog fajla
*---------------------------------------------------------------------------
get file='cc_tmp1.sav'
restore
!enddefine.
restore