shapes/0000755000176200001440000000000014367300611011536 5ustar liggesusersshapes/NAMESPACE0000754000176200001440000000124114030654250012753 0ustar liggesusers# Export all names exportPattern(".") # Import all packages listed as Imports or Depends import( minpack.lm, scatterplot3d, rgl, MASS ) importFrom("graphics", "arrows", "lines", "par", "persp", "plot", "points", "text", "title") importFrom("stats", "cmdscale", "cor", "cov", "nlm", "pchisq", "pf", "prcomp", "predict", "qchisq", "rnorm", "var", "lm", "optim", "qnorm", "sd") importFrom("grDevices", "col2rgb", "rgb") importFrom("graphics", "abline", "legend") importFrom("stats", "coef", "princomp", "rbeta", "runif") importFrom("utils", "tail") importFrom("grDevices", "rainbow") importFrom("utils", "head")shapes/demo/0000755000176200001440000000000013334626562012473 5ustar liggesusersshapes/demo/shapes.R0000754000176200001440000000335111672130356014077 0ustar liggesusers#2D example : female and male Gorillas (cf. Dryden and Mardia, 1998) data(gorf.dat) data(gorm.dat) n1<-dim(gorf.dat)[3] n2<-dim(gorm.dat)[3] k<-dim(gorf.dat)[1] m<-dim(gorf.dat)[2] gor.dat<-array(0,c(k,2,n1+n2)) gor.dat[,,1:n1]<-gorf.dat gor.dat[,,(n1+1):(n1+n2)]<-gorm.dat plotshapes(gorf.dat,gorm.dat) gorf<-procGPA(gorf.dat) gorm<-procGPA(gorm.dat) plotshapes(gorf$rotated,gorm$rotated) gor<-procGPA(gor.dat) shapepca(gor,type="r",mag=3) cat("First 3 PCs for pooled gorilla data") for (ii in 1:1000000){a<-1} shapepca(gor,type="v",mag=3) cat("First 3 PCs for pooled gorilla data") for (ii in 1:1000000){a<-1} gor.gp<-c(rep("f",times=30),rep("m",times=29)) x<-cbind(gor$size,gor$rho,gor$scores[,1:3]) pairs(x,panel=function(x,y) text(x,y,gor.gp), label=c("s","rho","score 1","score 2","score 3")) #Some tests test1<-testmeanshapes(gorf.dat,gorm.dat) print(test1) cat("Highly significant difference in mean shape") gorf<-procGPA(gorf.dat) gorm<-procGPA(gorm.dat) mag<-2 TT<-gorf$mshape YY<-gorm$mshape par(mfrow=c(1,2)) YY<-TT+(YY-TT)*mag tpsgrid(TT,YY,-150,-150,300,2,0.1,22) title("TPS grid: Female mean (left) to Male mean (right)") cat("##########################################################\n") cat("#3D example\n#") cat("##########################################################\n") # Male macaques data (Dryden/Mardia 1998) data(macm.dat) out<-procGPA(macm.dat) par(mfrow=c(2,2)) plot(out$rawscores[,1],out$rawscores[,2],xlab="PC1",ylab="PC2") title("PC scores") plot(out$rawscores[,2],out$rawscores[,3],xlab="PC2",ylab="PC3") plot(out$rawscores[,1],out$rawscores[,3],xlab="PC1",ylab="PC3") plot(out$size,out$rho,xlab="size",ylab="rho") title("Size versus shape distance") shapes/demo/00Index0000754000176200001440000000007407730546542013632 0ustar liggesusersshapes Examples of statistical shape analysis shapes/README.md0000755000176200001440000000053014040323303013005 0ustar liggesusers# shapes This is the development version of the R package *shapes* (which will eventually be version 1.2.7). The current released version 1.2.6 is on CRAN at https://cran.r-project.org/web/packages/shapes/index.html To use this library in R: ```xml library("devtools") install_github("iandryden/shapes") library(shapes) ``` shapes/data/0000755000176200001440000000000014367226001012447 5ustar liggesusersshapes/data/qset2.dat.rda0000644000176200001440000000216314367226002014747 0ustar liggesusers]klUZњ%!$ZsۮYnٙݝnE@|`D4-Ԩ`L5V?Q U5 R Tg~q;ι?sΝeLDӴZ!x yZ  C[JPvQެ-?ޠ{V}}'=[[&=|C_H7Tl0R,Q`Z?6e/fɏ^ gʟ 1F[^^d|;4LX`ݼYٻ[C?*PAQp뻉~S'v vU%Bcrx)= ~kzu)ƎB)Zc_x1#߰w[EK "v ;$ۂ]-Bw*gQ(sɸ KQ_m8IW![ǹug3_&_|7OA{? KV΢OB2Wi{^N-fſ=!S0Ə QĿ~%v.'1גz7WH ᱿|WJ|׋IxuCo,_Q98O7Spޕ|>Jtt,w«yا>૾GV? Zk>/sǾ,IDQɟ(kNt^/}WҏGzv$ _Kx+:â 9܅R?HJ_g="ⷖϒsޑggW="qʾD:zozoGGrwsr>.KW'w:,ť xQ7.߯ajr^z8Y{r>K8 <|T?I::doJ/99kƥߛgeW$<8WQ!'˹]8~x7Xs4T_s5w[6tnONCs/Wcp_|῎- ۶ shapes/data/nsa.rda0000644000176200001440000000112414367226002013717 0ustar liggesusers]S=hA)t4F-bS,blr (xw;w;?;{{1ND@NA`E#vtSBRY(jQu&T̾7͌( %󼬗Ϛo,xyo{ .Hv{ć3Uܡl98xkEgcqTŽ Bbk8"v/smSxrj HbJW^}T +ڰawbM3n%v`gX/#U/>X;W7I?oQգ.a/\c]RXUU:xH"^.mEKsbN_>]-1xG/_y9pjqOlti\/} zNW~x2|"+aE@l/_|CBi(ڠyMѴ Li5Mf)!UQL1CF0LM2h240J "Й2h  BhF &hڍ<⿩kWӜƸ\eI8HY$NNL9JdFcJԀ"L,F MJ(9(RbHR0KK4$Qw19)Y"_M1.6K,AQ&y QΏMg4:<'=ӻwƝwS^e h}|CСT"EUӻ2" w&O7Ã3Gu ,(VM$(H-m&i*sg5'FUxvp Ub%D4ERqf\R= mR:مSN:w@ĕyn,mm Tɱ* "\Fa\q' I)pTDB&b " "@Zh' aqr@%*̜qmK[Tq)d$'.#}ۻnroRTɓ$f[t:}{8㈸8g F=${EA1UVH<]t -U828ezyIqG-}˕ N8sv̸2+d&(XJ1P%HUұRN#q2"p7\ArZƢ\5SbjaN8 CKM3,0eyK By7D+c7;ۤIĬm:vtu xLJ1ttfNsOaOs|{? !()RI"XjI*h,ݒP!:Eh@,'@+ك2rm. o{EfV$1mF;!kUr02.0t heZ)@ +;D'R.Y!IU I !\˥V/ M@@_FΕ &Z#mݜUO>(@e6 &)٘K^WTcBqܮ;eJW)vC K\@% ?:h6%;sA\:N0Ln,nVk]hjd5k[jF'qyoo#)Xo}gKb@8:DQf҆w̶sJ ;ǔh<wH dvW%-H=z`^h=l)I4^Ph[\V˲a4[FG)$a1O~Um|DdsdҾ^kZxzXɔDL TQf:hW ZD PEQ8_DTR$!$@QJFI4A 9.h4/Σ<.Y¸,jKb ͉lm#CaD\Ā@͒Ioj]&͵X`obg&?Z[̍!)yXU-3Lo ptc'9x0$!UD3]aZJPkDnRLK$3X/ZoziFXoP4sԊ;ic酻*CA ´@M&59^lq»,GgtTOCyhoj=)qL9HNLit+$tbNjam8ZMAidm75%vVkeRdtL5tm/Y{A,5`$PS!G,1߉fe]%!P*I k 8it VNM:iMK46e1cRHRf$F YوdaFA`I0EThd ֺ5W4R24FY#lT@fSJ*Q* ԃL!VhJMRmdRBF Qɖ4!dhDXtrQFHM,$Fh"(mBAX,@EYIJl2LF4m@3AfaDL$i&IFdE)TSDMDA13P4Rh%4FP)d0l#@L1b $5dba &,a3iFH2CFM40Ed"ڃF%`0ِeh$DLL(ҙȤeiM IlLFJ4(H$c Hah!&62&a% MQbBlTh"LbB$)$4$Y.Jli"f!RE,F4$6FP dȑ"ԒRVPJfE$J 6"ƍDm!41F(ԥXFhI"#20(ȩ( RHTD]"H8~~ƳVD> vRmVP3CW/u{x2c30G蘑E 4iDAۤSix]QWwked}1w -ѩ0]Bj6٣j؎3yd58w$'W<8uZ͵͚ՠC$lN"epXfÏz.L3bd4&1:Y&2 >ő.eNIJSLUpN/y85y)ًC[!mdpiqB{pSk"Qf nD=+-hQ1R)2O0B}*zNR47SYʎewCsy-tό@l9jl쮝g,mވDHwy;5G:W :JbFv^8cJ$(\\W|Q&ӹeYtLOY4AQqTpJO:3O(ΏvuJk>Z8w}"ffs4ȡoV z%57:M)Ib(Ku4K|/.PAe?& d 2wbӿl\>C >MwDH~v'h8ko;$"ņ 3i FuFĊu漡ZʳeEX4KpYs݊Ֆ~:׹cDAD;]pprps;ۜpө 'Xg:kkc}-UI9;j 4[T"tr3Ӆ@{rh+9U>9PD(6 ER𓷗pI$ xK!ǠԝZ@x~8*+̕63 X6C&%'$iYΗPs)5 ͰG/Qޱ $P8廝IG@H#ثL{!d = Bqh|ng qV6f=0_  <15ڂs;aLFLh:kW+-h znݾ*>z1XB $o}k~uI3d~yjf#ڮn! %>-0S螔')`1r1A=V3ơ8]n*|zG⭷0#;?H|mqQ7>2<]_<%.;.^_ |FX~s 0ێMo01ޛsBRg Z9c=_/a~r%ѫC?|.w8'sn &3!{fs r3 ͹^fr@EM5%|{/>9ssc(oOC+Syӂ8u,v'Qw#vU88g Q[s$7tDŽ ub_T${'C~96'}SLG]^0s;VvfiBOh޶k8;M6O"W&|?13(/9iîμj-nk ʜm}߽ &zw$ '"I[XuE^ dM?nbٯ">l6/n|H Ͼ?0f6X'-Ʀ;78=hlbA4etGjpM'PANm)<# ]y{03-m Ø05"~ ~fUּ70J%JUrܔ5 =Yĕ,vrҡqmn`~S'Adִ{"1 fGS6L}Zr C DFJZ72q7SƤ 4r>9Wq8 g4),+G9üMj)d(}=͖\ݫ .싲:Pٞ7: M;Y ߂1){UPAx*Y>s`*VxR+T|e~] MɴYff򎼺,"RPQ?`sÍثwwu,>״h+~v2o.yx@l)ΔJjS,6CmF^I:6rW4s<΀Cҡ"u ^_FZ'/}3+&W儑.7EGl i T!K+eتrr|U>EJ߄g cJ'2EL(ݲ)3l#u$9'`hrk̻2=y{Uk5e {5p{O?(ćII_*m>/4( 7G {ÐGhEz !W"$-g'{cۗ8Ku ZQ}6Ui%L:fъ#` 4`r<ª#& $MT&@ Ĝ!xa%\COʘ'K@jbJ`r+vE3 hmZnkӪ8=h4X< ;wǚ] P/8Ϫ7c >aƈͼP"͎}Mz3tX=%* :/h+J,USaCe>PURNRy@_D] ߽WtM{MCٯ6]!'w~DgNKs *C6Jw`~۪+}Pl Z;H7) |M3XpWAobN?h'K~Jdޙ߇H_5f_Ԋp}蜥Ls4pznXQzv,26^ ofңhg1.|VzB4곂3ݧ~oXA[lajݒ[h`fOhc鷻'3w6a]3U&972{I1j%"7f TNeT%tz[\ C"۪%eYW\,N_fBiߖasᶛl Qt~ oꝮ]6y!aEh1WQ8㘮 #/{皵nV(_M|c !b1'`d$4FĊ;r\MPnܰD6kX go> OLjUVKwU!=/xt0U^q:@hwyJCQ!;͂[_w >Co [gwN`MaWUdS;=FGpP%qP.q QwodY6_úxc5O/(Kb֙cS~֭> Ks~:[E l-}o.F]udݨ~k턓,̏y< ]puΥ`L@ȉ \0 vZ_ŀeBk$Ro4ܻdeiu5 J,ǎ?z\\tVWU:e2cnTaC7{joԦ-ö8Ų;,(oѻg$#x҆(PHhN)ӢA8Eǰ\8Tso~NahI=S=i͏ZҽJ)'wBvߟMGrd7Ra ޝ u헦ATF"Pf~bLVH}w$sP8rIu p_o3H,ڶA+'%<&?/y A僱gк) baY"GtT͑M8P;7Ŭ"Įj Y/1 19-;*.I,4S)ӊ*@븰w0cv c\frPqlk +;}Z{9_Q^an*ob_PdWVp׿3+bՏT "_WOATc{xe>b^nӈ}70#y -2bue<#TkQ kɆb{U[L?)T)cIfXi^d߇P@Da/u<7_ZyWZN3C?d/c4o@oy$ф l47U۸+tP jnXgn l9#|ף׵,w oH[ćƇ(,UP4s ԔYN$ JZZev?k؅IcXYgO_n %<곱jU5'ZM*'喙sI<˭S=]هu̿zT+}\xݕ IKMjK|в=%#rG>ѮǡOQGD},;|]DxQ}u,ȼtCr?#=5/5⧔Xm<9+/1+`8am^VM<ԾȈ`.*;zi:O<˷MCX16)NQN>y٭&o\qľbĦǣF2-m6EHWE?%o9W>>W/ko+%@鰀`+s3/5yrXı YŬrdl-pHe?ϗ MBdH#H4\ !_. KIG#m6=QOY1ysˁ |CB PRB~nQ>dXf!/ h΁ бw%ѨB4%_Z:(mkfԨr[N\5ݱ@9_G1W,y_8>*,ӑ䟐DRYc`/M~kNma3k?kq߶xE^SY_ߥK7:}撃 'O8=re?Ashapes/data/sooty.rda0000644000176200001440000000136514367226002014322 0ustar liggesusersUkHSaǏ2&,I ""KB :DgYRe49K]TitѾ*,2"l89.{v:.T*DA2\/F? [h{ Dbfbu8/ZbbYT#/S9$}e+[YӁ]JU5Wj~?7jTR~b0_^nxsJ^97N[FyKkWބoҚ+͑i_nU)a߳:wTӴ6,Iʴ̯v#yG&]mUM0kXQѺX ̋`a?~i̠U*dVTq+u+7Ѣc0'dܖlюlLJ~1?ѹs;q Ոyuı G.8 LCl@-q1O$ՠ tз\/b.D޷zg& d۪@3ѱt"$ sz@gy7$Z:~[ IDx4c k=ybkD's}B" :";_F vG'sjێgPw>Ʊnzn|7ԙd߇l{cAaa.!'ZXP|QDQ}gZ*˾?JN Zshapes/data/qcet2.dat.rda0000644000176200001440000000257214367226002014733 0ustar liggesusers]VklU޶P,EZMHL-bUZj[Y Ru_;;wf߳[*DMĘ(HDH`EQ@JM5*AXN{9|qo\\R׬R~u^\%Yy8o0jnLCzVMtVĕnYWD …ۣz7aM|0vv^D[Bh@O<(G$>m!7\ok(=4k:b`vNlyI$ANm>p޻1( +؟߆10M1`_}ǁ7~%O/F#-#;m3DŽ|D9 !^* ga) iHBͭ|q#ʜO50܆y3poПJvo^_" <;3Sx1 z7=x'WWïaO ¾4ox|>=cG`/&O͏}rzِ]-πOexӟBoc\B5m)_٧$5<=Rzc=sb7د2?t3)ysY9GHޑ` ~} {N{sC^Le|y dTx>evo^Է}P#_!dUw.Kys]7왒 shapes/data/mice.rda0000644000176200001440000007107414367226002014066 0ustar liggesusers7zXZi"6!X;q])TW"nRʟ$T~u}}XM;Ȉ4J qj(w'oSsNˬ.X42 >S>T5jSX!`iuh>\@{8o/8 W6;^os1pɤ|I.7`E?3-S%a;Cvr,{Z OɦAUyv NC~u;j1ш7 C1<[|H{8xDqT kM OQݦˈ4!ӝA9ZK,xwۯOdb΋ylTk#B'?`V M/MӁek3-ٳ\v!X!8"PZ^te=J,!&;{߱ڦ+ayQJyw7Ys@-zhfqràM'r/kM4o1(=;H>yΪ=Hܠ̞kԔ &2f5;dA:ί6u7iiPBv"}5~`o(u9*NVN<8ǽSO|yo`x˩[4`xܖcJdʦg^=/ah຿Ia$ XFOmSO >҂y V Y~骕+4e +.))1 RFP~v(jC./ʼW}l[%Y=-0 ˆnC'xTfQ]Q28$qs3dlĔ;#TZ曵jf$Le-~)F΢3Ҽm}[wˣ5믂}^toefi`GqWGI rѧ)]=6"Abg|歐lmWI.] C6 %4b/ލW/=LP^.Jq"GoFÓl7^kϯ|1r!/^L}=nBV@_G8Y?u BZ T}WS=?.Jj2/Z_2{ѷppo6U] ;/:P gf8dX눧-4F{SkH}#ke`!צtrGaAA]BH@L⑀r"Asr 1up\"(d g!7ػ} l创 & tZTczN33[J/#A}E5k"_驇Pۙ*yW#}HAћ},%H*ν.9h(Sz~˝w ^ \Tk[$-yjvz:YP#";NIgc%9{:XX ~q>a_PICz1"(GWbB0[>s_냫Ζwd'3'9Mf󕃷rjL׌\Wf$DA]+H&L=p щvI%CH$+c_Oc'POX8 Ϭ=lفѢ9jNx¦xR %( JNQd7$cO`jM|uVl";JF >]paT"d/+'(FFQ;]-;o#z9ޯh9 qԌU sRۄCVưJ;0hV:qf)S14"E0Ným!)뾮`N REwE| qeyBKc=F'o9rA=gȣ J5X5D?@kX{"yyE? ޏz7qݑl:h|U?b켗Ya!.@7(HYpgE%{Ep$bJ'nnpd堳3ƶjSq|8ɧ8۾hʁxSTG RvyuM6"[l9u)<ov܅!:X.V!˯1d&Qp8 -l_"W H /BJ)sx;5PrSr:G r޾IMcwY+lw=E.iMqIveEDjH vQA&*n:!ݹ3=ؙ?;F)vزW~> GD`K kqk%׵o֑gػrNrH}%3}/5f|LJz;4n7Έ@43.B`c$^{z׊A@9,{QU4$=H *mbwg6>`\.ON'?LKF `g\ {ݥŒvWN]"0ܬZE.۟;ݕhG:w$jZ+5}^>UZPsz۠(/Lܳ9G]|8xFd,fmu# "izK`1g`o(H*;ȞǸ*níY'+d o%D@ 2Ì6~xzzP\O|>ّk5_XM/ RLNJ' .}~Lt r` EWnI dvCl-&}}~E38lldABHjTޖP$ Q[chyq x( (,Zf TC]á)ጠ'Ѡ5nsd,<̙CZˎZ6OWWȈA-FyvN MU4*mRQrTvðpw  Z72+g8GRKߜÐ;^>N򵨃؉\(A"t^(w!& $,Oz[qÈҭX .p֨59WIv.Rt S"̅YRx&/#Mͼ  cBuIV䥴zP(*uA:=]_"\c`ܝeȩ)̛ETH\ gd}EcEk鰜H?O_,2rWh)Js]~WՉKlp"m`*PD!z'r(n>n%ɣٵ)' ((o]«#SZexp8aQdx|l.K+ xAA(txfזUm쨲7TGxnRQܛ_/m(~>!|ˬœ@i9Iv傐EJK750 G=MhۣLRMVINԆ*pX/04Khtv  V zҍ;#H֟??ԟ ٪,iܪ~>-ilR_74ˆA |@|,E.V6$aÔ*te qqVFz!XcȂg}@㱫apŔYI&cveMC= k]0.XP t^)P찪yl0I┐=|yAIL ~;(4SYN g0O<}R%yҚ`uW6vXXE& ĄطxP{=3χ-d)ɓιfا:l!eWW[3#-:WTck|ТPy7feVP_E%ו>OQz3Pvţڗ1 m͜<0GP}@~K’g*L&K?q"튧%L5l#L10sФ"E9CbQc_=.AͲ.4@RLFѫmW4* AENR֞\[h-B!6>v2w\||C60U1Hz*XD:Jo!iG\f92﯏z4RY~XPo11v%:Z_lޜ\O:JvXlY"`TapEa4Ia7iFU\/ı#u. w#XɎO(vҟYv,i?T t6K"9zFWG?շʉZ\51KʠWuݷBOT\ABf Q9_z`ŕRxIfZ_ 閭QK'?a~)TqN;of̂~Gk+Ql&qk=_2;' .ܞ{FSFy 囊LC!1i^皯0Xd&u_8Uco>J c2ʅ΄5NWƪaLy_=ke63_k;yz Hr'tjAK V{("|[kAyDYg';GJWBz>Gk\A.Y05d6?[ J ;jgɐ^L2yKQӛ]Hޣߋn/$CMZcE=PvA^2}O17גu}݌C blrpqNJH5*^^d.O6JxMLi"O?WoA.cd0UM6 ]7x^;ǧٿWoa;a,HI#xFA!Za$Ք `9 7Ot̶0 |YKH]iB X C{TIJ8glzi3,A52&o7!!̯UΝFg6z򞜬d "{hf)o5].W߃$aNmڮZۓ"l`p9S6eFtavR!iIԿJߕX2$7@ZOu~`u'*}:i\Ai/$4,vuVLm!Sð:"(Ɛ׽ef'نRiw-_yCāߛ!+.{O4_Lb"R)J/ ÂA TAcR t=O(JU<rB,L_#|dw Uvc;(s{Ş?j vEor0&k_U]*R<۫v1#S$}`Z]X=dk)MA T8:A(]3 OYx:RA^}mt04ey_Ca-ɺ䖒L +A/NC#Hj~jIg)Or{ߕ8V{8'_Kِ|X]"C8$KYySqDu:>P[zoⓘE F}qhr -k@]!y7sI*f/}fYI{- MgAS{K"&Hʤ%;Ias~YKje{:Y(O@d مg @hpRmq[ GgPo2;9unPmEN6Hrb+ AP!)|82|ȡVXY-Mé6~R 5u_#h?CЍGkvo[DIzkSGcdL0\\3tve-.Wd=֭f)N!b[zs=R >/{aDequJ.IAiGC҈D|%a "IbM+U_dt@-1۹|:5$Mc(./MS g}) TujyĒ! id6Q=ٛ+b/l+faJڹ]{_,̩4HGgck{\`D\[F>{LmKV|D+l6V~n \rRpB8}ڵ@pJS'LEжa6g;e}'o|4вTCy4AKZ1ߚeu1KOq"وʙ ~s]Y;j6un8%a4z0+v׷ *і_6I!cƍ-ß+T)W$h<ސ>$GVmzbzm# az=IlD%6AЏƒCPcT5?6W,EwDhjX&+b[)t8HjPv#r%M#ĀArp)J<ɩ^rT~<\n{Ev/Pat4V{"Dn]>l4r!A!eIDq~x~oT#2 _JeHv^χ&@yշf sL Xtah"zt :gYYt66t 01`3&}OK׺ŀX ǿ&upCMjX! (}2?]Ko(>iqc)Z$Psy`ͤ˸k&6=!N }: N Cj &< `tRʏ:[fb`9FttҡvGgά)'咾/ő)C6χ(ݺR]u'-rsYz;dߑDx-nӾW՛KˆC1TA.7TAa07I/'zQDc2Wʜ=nA7ɮpeD,j1 mP;?sG pr S :OIPh;!3:JS)JWsM4B;;2JKv(} KL1g-uU,9VLLX3G{PGǗ_S O^ΆG[EI}Pٷ%66bI:0olܒ˝`,![g.{\iM i1&0h签;g ;h.\4+ ~a;dO3 nNjnq(dMfҌ>Oj嫷QSRiK' EMJm?IJ#ѩ\H3&t\Fg6}t7\RgPф0Զ k_EQ1&9eJh5D1Ѽi祍坨Y#8-1\~VT<-TEfMh5qK!-9 xd o?HHx7 q-;+& n]rf#<@f)w&3RH@[IRn9so5RfQ,:i#(Tmd V+p4xGbN,/ܾ+Dh* wG"Xj*rힵlRF$GTn^Lgywl|pOfrEX% p#ּc:2 >Ʉha٫+g !urRa8K_ / L'& dc,"d%(_O$eM3P@L?n2jS!cWXgC>'|}oobPYBA@сOئܸFCdQ_^vO 9"{0> "im_@V"\4vSM832:̡Q˓T,?$R0~'vi6dǰf,>u lГ+s_ϼʬM=Gb3;,( V{CTˏݲu4 2~+cb^ka#րѪUY]Z|:W q$[f/8rV[+9۪3‚i LlL^I@<&Qy†z`?+Q~+]Anl৔acU1H4~\].W˼‡&AŅMJEAqɞq6 UUP #4v?@TAܤnӝNсYiMꞚG4'SbEl8~wzA wt6 6leӀ?5z<э(9CeHr q@K:IatxZw;M'ח?z,CļfB=픎ū5%D51l䨛8 S*pdb.zcͣ;eG>Ɯ9 Ǿ-`^f< w O&yf%Gw2h4텁7y[1=ע>xqOr!ՙ]DZǏ3o4ۑjlYmxm)P]fUBa[ߙ3Yxc7ʯnm3 Yz^~M=8tƽFVY  E jt@V$D8k[0 UNL J.DM=<$IZjIYD~h1%c~aS{BnċN]"\5nk9\,- Q3E@$_v?H>"!3(LjRҝsY@뫠RyG9+kڡI}[KL"&`A'?wd36ddT`o/ExKq!+zQP^$?_'^XhCFi "R%EΪtz L#>m~˭|bMoBOm!ԅ";o[uI=kKlJ:e(r)!~BL,09bT<H8FGS@]، pV| >g8d:Ljg0ؠn{3†dRt VT 7WXFo]J|$o Қ̥?;o2Sbg!eYTspCw viZŻ%(_K$Mg?GDwHv(NBeJfM6IZ,@%b ތڼ[s1\bJG\=m^F\71jy\ֺFS_L:=>zsm wq|TX! u!k 8J^$ =`ʛnvW皋$Ǻ?YYʕ?Z"9ra4m>S5 ǁo$8_%pd=]&V&gX~PҼ3kuhRH~VF;e]p-\:`_@صcWa\5@)~Rݒ\ז>BےdJyˌ߮B--O8V|eQtr~g[Le})1u8TA"9AaSZ(T[f]ؗ5҄)WMmd*1Q::nHZ6-xóT-B2_դ gMe9x}P!'N7:̆(ҨVƗLBNf_b%9 +3vVUD[ikIG|0u}N;N|6fή8Xd4%Y҆Erצ.xвĪ%괷{@(-PTjyBxǦ4oi;Vnt/r5t7#H[ {W>Am a@`@=S9Rַh~ʯ8su#3Z@xpNb:{kO<v\hyuCo7y".T+a He)wdl@.Ko^C0^# )Ng(l \+!NDb! T~4s'2VhϞdhq<NH PLw;Rz^Ќ'tKvp9kc9_D b߂y"8+M gDIq?`ϑmX#71HN~i^Ga9Q AWrC M;"]|ef mzbyV4&) z9ǁOً'Ku屯p#s` mb %-DG!2I7dEC 4f볢 j):Zx3OPh ϔAK LK5,Q$B|I+Du{1[D)5+It* orlS@pyu ʸ=Ѷ[N<|^>hXJKWja5'ޙN6j/FDMf:WKTHSgI F^쌣3Byvi,h#kˌymwG,+ -Xu.w016| . ǰJvD͏k(B(ByGAi|dbU:Dy` 8UD 5&w|[6l+9( k<ԆX ]> Z_'8&G*fLFa5Mwe~Ӡ/2 һjq\+ [~T4+6`o) Q=Oh&bp3/lD5`LQ y`l(AmyWd;Æ*RY0Iyla?؊Y@+"ЮUK2q~bvM-1* GM09*!1ōlHzwtE=vM:7Vw&kuo>P<˫AZ'a) } \IWlÐA$L $eߞ!86EnW_=k? DOe:E*PEqZ׵^es4tgQR?cv43Pk{3:D<&̸&d$GbhD%ٯJU}6~X;ƥZHU4\ؔ7ϷDTڶ)XQ|+vtmHjhNjW65%0@* 9Ac@?Xqt>^daG}CAz8 JiF ֡* P zBP٪:w϶8b+`0ھN_HdzT%,m+Q@CK. MLKgUw7X%7`bٴ\}h _OUI܊mgƀgkSJaqReFduP!xHBt"T2}/yy;IE{m>Mg Jԓ,^_*}'P|`Z>fĻu5p#g Y0&]٧$'?(U,XLiؠ X>bm.H@dЗݡz^ݓs׉kqj3(y+sJb,y%#@s*/ [ {lY Om\hM"⩨l`ޮoD=簯gj3L!Bzj|h&̔D!fHP)u%ip؈~}lP <&FR@v.ÙUʹf I$R;i&rSQ5OQ UИyr988&' s-fȪ ckNZIJ^;{u: QS}bYjt4 L eP(b!LJJ}2T_;x޸TK0/)>j){!vr ~q*|Tڑ b)=%h0)@kΙkQ/x.)=AlƦݏ$5F%v|nT \^r4T.gɈ{d1%(&=3Loɏy#Oƥfg^FM& Yw7fBYz.:Us@ ӛRR nj#(~al}}EPnf`tX#%$eqI44c}s1"RF ۛO295FC?5BxIרq6B޼sS1{Vgf㞝7*h RxYT@w.A*nP3B(2#H=lt, "pߌD &!V鄴柌ޘ&2s@vd.l gTBgϊ>˯KajN?%39bQ6`aT:ho-#IMiQBFˋ0'**UN又I!+%4_sҪuAM~Bp5}V&=-ӏ^yx`N.Fl-VA~~)\$UcoznobNixQ~ Qu܌:Y$<(v ,`#z*lP':U(r4!q99 ."zbkQ07"g_̧:Vr9AVA=)J5 w7xLPBYnvՕ9h%[3N"Mogj&8 3Ϩa, U^l/>6?TӕGCa0܎vk_W3m}|k"FHNvk]͖~%GيE(G@g3k:Ű*sY,+adjF b F8(@g5TO%rS< +]f}>!#E?o*.{C^^ZM\47sI}SG>wYūv/ʻ^I̮ï JND6&vvZ |v+C_V*p.es]M$&}e 3D[`Bʃ]ԭD#||g"l<@B<qE.d䨃"/wH5P9km;/N2t;rl.2z G+^Sg:tωu1-CN#O0f2.{8Bo,)[%tNCqӊdȹ4$[% ~aٶ\Y9%`rLj7=3Wf4nIfKQ[c&1w1(K*#wp)B(3=;ORUHX.`O{ͺ"On!'}eV>Y;ڈ਱vUGWy(] ]=V6#;)ءedx=^M#dxSw?SHd֊Y Z }wS 1C5psħ}=:tcnOU:mD¢H L'1Q9-!&BAQGU_bHFKWAqNpi _nd4=pj_K΁sϿ4 1vzu.-Gut &m[IT(Wm-)33P~1jEIz:CY% =dO8$\HZ##n[9XI=XsHKb!AjSmC:y^'50*vn+Jߜc$=7qI$Q2/^#o9S іL<}{s(AzRF0i.sƠwZ~]:=]6$B MíJȓ @d):BO2$EJi{bM0Fau1\5`Z_;p,q5bpYBlxP6Nݟr_B@qY["i9H&doNnW_jtRd.&H̿WEnA;IUVj?GhFc!h vIs%éP׍ԏ/ 4U&~8 }7$ID|Yl 4zv"kbA4)q ݡCD* ,Y035/5%@j&I=%o_h %4YՅym7!;ܲ#}wvs'o~_7ߨoS E.fgIfS͡|I'yT5ۅrA,is5.qqTּxL` "1M46Wtφ؁b5QHH!T?N)s^j /XQIV!C9ޢMJ5*.ʣ``6EZV mRqKs ;:ǶyЖ *" u}\o&M (r7wpfFF::zU%}$!rװR@Zσ^+3u_MA%b܁;Bn ^3B1KTQ{'\RZ~.]$DAJa4WC2bpu[`q#<;q8\K ơJ@ɱ!F~=3v brp/cB9oW2ZBS9t>pNY@qe}PkI@8"Kȅf`up-OD&WkgRB\6!=G^J{evb%aiG;6(ɤ4us}DCǚו(Ja ixejկ鲊ZW7Іjxi!v7{5VvfK؍+Uw@:W@{L\p](rnN[†XL@ ۣps:hX<9Zɷ09_cEAŴƒ +eqwn;K "*Zl/@,!_lȁTd\*~פ&¸f:4~8IB͍$1WĿnkQޏ#nYLad}h1`#$׮"KU9NbqG5rw;H[- ilsNeywJFv-ѷk1i E+[+3.Wg/VS[8Gǡ= 3})kd)jQX>?_@}=$#Y%ke?4fK-%9m{~ 3yb/ɃO;NVBr[Y{VQӶ(fD^v8҉sX3ʩKv啽Tz]'i-D~q%D1ѿ Y7]A/ Kaڀ"n2}_?m b@eJ9퐌XxS494SߊTy rZ>s%0bF9j* j,ͬG _c%z>H39U`< x0*RDV'xܻsC]5_{wo'VrDޫs  x$[rogqCkr&gPW |K:ϡ@'bFiZ&a@f@dB p_B.CYbKUҁ ۄD_"k;ޭW ]9˨Q_2ơpF -ɸd.ҍO3!̔͟O2=!,m/ !6{fkq4-8udaCbu}p#⒢MsA\"M2*{ Pn9mc\C㲹b7 ^.BP0&NunC ߹`ޝz)Rrs0&+IjcYv J 9m&7pqà1zOjفAA49†/QD}!n9=/$\,yFT;;١83)N<]kU-O탡uHo^L/0EpeSD)Kьg  \:jMYX8KA'IvO(fŴFx'j c/Aѩ"9T;㬔sw2p=\}%Ek xy&;glSdЕjDC:&dP~d-Qm :-=^m<`g÷űs'܀-Y ¾5v|ifk"Hћ ï fBHjfqdvt9fgG`r0;e[k Ґ8{K/C]cDwx=2;hazI %L^/ĭL r\R|<3}M rV |=G4K -xP(LY o+iCYŠn2^}j 3EnG>4ZTyDUV[a +J4Ŏ.{,Hk1)m5E^SlgEj|X4.$*if":d΋Prǧ@C@͛S]}e1VI74ݷMtIvn~L{ `L.5 ߮8S|_l'XdBǏ9zQV^L$ 'g~QBsNNJz\vu;bɿ1LZn}rYLyǠ5a΋zw M `*N)7NJp6h33cCY'[4'DGU4_yo on3׍ͪCSV`{ >M^ bARa]*Rښ1- +{a_K k/* xN}zCtͧwa6Wzr^gl' buVVC?mJ`IPADAGڦy1uq_fCxc3i X6`l4 %\nݚQSxʆP;Q쉹]L*M}ƴ*$YF;vҏ,ɛ=m+kLmzz:jxf"bj$cv#(y>#2BQPͷ1*vnysVU_L 8ʲ\-؅k<{JGhcF0Hj ΩrŖH}FDscLҧ5< ĶK&/_mWM@ƀ~,60!YUWjkʩbZ%fB|^Mm{/&%$̑EXQYnX#8xdd lb!88zSK[)Gn1hcK뗄D6HtNq8_"!\GL8߫rpM)ܰMM{^N[=]F8wū,qU@ <۽Bofq6K,#3/s5I|5Q o-᥼@~OG4$x\6 UР, Ŕ(LVãbI+vf@_0:BmL™R\fR. sˢBNkw_+jʓnJxjXa]1:sз_PKֻ}:<:Q6zqߏ3`4iXvT[:DYyI(X֘j/Jg2lFTӷκ4$W V-`G0v0q`GN!5M!P< kSEձ  5re,$Aƫzo-.6nOQWdFBYfFk_N0] w7kDx7o*"ptl(Y*-]E Ψa%X>; }dfNLĆHhev$%r=h;`-gXXdk?v4τ&^O Ef*8[S;Oſ3&gJ(T`z[$&E,Xe)$QC*n굣8KJVGs&j#Ԟ&GIBTUhi]D!}^^ =Z#<A9@0o6(›+ǖ?UB>էp¯ڇCBH].6\pC5B]L~j\s9ݔ1Nt6w|֐0ww?NY ֓1}/0f# V3U*PHihFT&`(G9o&UqiV_+a(jr pާQ @tJbh7; }NS.T_drLj~DWF坔xdb!̖f:pF8s+ls*Ы 5"O:Z"[ K($v* ^cxR |2DIt$n}XPJ\łoS)I7y1Z=ܡ ;UNJ*PG_{I}eR| |\i﷿ 3OQO0]x\ fH}OP"[fJލX^/?րtrwG=)&Z>t3'c&'0*/FW&%RƐ El%pD:RBR|s^`N<d'{qҊGv{faS ~{ ZVI|:uէgQH.uFc' Ұ=?;1f$ 5" GGZq&'7 O|n -ٻl-Vz#TB[ y辩T6+ bIж\KCWv#G%@PP3icv+/#{Jv* yvP:GoN J;}iĵQKHx^} ZS Uְ~SC y_t}#ֺO)~I9bB|*63fn`R@Y. 0-STd{dd mm-PFw U{Z2( ͱuc\o #UEovە@!rI*bH-\ud30l=Oby.5Z*<5#F7X-)٘InR9zڟ"oyfq^H׻6sU4tq *Ͳ.4,ŕ e:mI-Q  ]F4lU8Iu 䭗I#s"(MK|$:!愳'm,Z>% GrᨴwI(jי;YpܼePRwr%ucõ.\PBv6ӓqS0L- ,3RfP/RZ 6W hƦNpd"1QŚdFL_m V~k'(7`FCmɦlJk6ֱ ^eEJ =Hkc\x ^]h K2(pZQl#4aC]7- eslǵ&rMTP9<Ez[?02AM!0j7tߜO~ 6)X*_~0],o7| 3@?r 8ˋ<7x{݋*Z^Uw_ Da"oiR+p\-c[מ,֌\!Ь9-ָ% XRl7aH?1:>R ]0KYH^QL=W3|V(yE|K{ Fdsm۸f"k.-pɂ5eE <Җ+㐥!fz6C\طr^f܂O# , t'P2~ 6/$+a=cԏ'F6lG\؜kgcwIGWј095+Q);"o?٠ن]wkN#7@OijN:pVPqri߅YL# 5pmS_hkD!//}ո*R!@!ׯ6R߰T aV'a4aKӐ?4Cg) .%m:i|%?Xg$OIiƒ@)Bw%IVj}lAi@udL@'WGǗmNGs_f ۠W/ݎju +]xK#}CIJL X^GZsH%tAYII⩈ 8dbfd׺yP'KbE{7Z>9F#yr4(\w>E`22٩LO>V3&[.ڊHl/Bz~I(J_/TDW 鋹d\Ce/_IiA$ :PՉ_J@9Z}Zto;4;8 sهN4n:+gBEW1,]( [N1Eq4vL˗KY0PiFr@E*J1n6XO|_$J} mب.gH`q:[¡+0FK#z #7t"FUpw7&աۛ$׼d(Y@N)k+sd^1S_1(mS3e[cȏ̑IlKH0уzX54>4YT~<+d dѢX@op3 א8DXI'ɒKY 9ۃE{YZx0H^I%y$HtEkK~כ*S9դڏcY(<+ d ~^5d۷.hK`ߞXFzMeP @ҳ?C4qLz7b/"l]X6XɱKt7<2w6 \uR%έ{K/>Щ(m qE3[(]+o:4Kpro/1F,5۪n{~P#">u]IG։R ;\?r80 kNԊJĂp>v9Ƥ%NHrE|yxun]dx 2|@B +(*P;]$sq:ۋ`I&r2fh@F'N3~ ])/Du \w$rٽvFHmOH8(υFNWkzVEBz&g!mwHhMgmf[g8ӇM& Q~s|;F Vg) yQ))5O =2ʺLbƤ$+R4 ؍NPKi wMZRŰfˆv Љ^-_(s,"UG( hyP$xm]vN|/ek?Q!WD!`BFJ;u_[6\\=#7/N4 ^-S [ @Idu։Ea^ىƁ^5 /VʓW,/]Vߐ|wp}*g'4x&4-xmd) ;3kh -}Vb4-gƼYSX~,'= Bl{Tߐ}KS?V.?B;( j}/@_vpc$&dj\6./vχۂ>-Jʈ06Lp4vF Ʉ#u8V3C }Lp A`_F65+YnϵE.%@9Y OH!8 Y"y^`f%wC޲F@t5}X)- `KUSnxтyR0_Ԕ ʼn'LH e aݜi1V2e|RuױsuMåXOeZMx" *G@ptA^hggXD* %%ۛP?2m|vX#9,^?*kNp)S"Vz g5S$Lr[JKOX(:RvY&ٖ@S0 3e<f{{ F~!59W"SUjS;j}Z~/_Q `3'b`\(ROUIp힓(ʢ OӜⓏ%O-} eN'\^b]t|{M1mDR{zMGs0s cajWHJۮw,O*&>Kr.ջVmUL_tE0S3xÆGpL=_qaδF;D6Os(tKœBGњ+I6UgIx>)WV+_1t Š&C,,Te.eCmF6*ׇg&@Q! 30FqFY?%׏d2*>U8O,:Xsw qQ=̲W)2ʵ{j8#Ձ֝LH+쁼:?OTtpjF+)Ģo䘶q3qllǺjP8(<Ѩ(PdVZ<85WiFv@Y6/ Z(ɶC~*Pc]@Yt, 1BtX]Z/_oӠxh%w_U u#cDɭn؇mОhjGAvY:B.B)7 ? WKQ(mCę\]f3ғ }x^KЉ0rzM°azh;ߚ%<7B\[R4|ʉv44f]+b}o;rrm= h`d/ +D doϙSΒ?=Cꑋ$5~%,l7* RVj xEc g45;I1 L]><<{7;g6:e4k~z½_pKkE&/e0YsSY$ /.e-HJQ#rjwt1|jOnWn>* k- b=q;4D=3⎏} Ù*vV("_ꗢ@bMD?blK{%,GO"")`L:sX}W.L>gn(lT BP)yZJe,*fdMןY$i|r:mO=-ֺEXPs(@wi-bȼ5ObBD~(DIpYӊ V7(|g 鎤yYt Yu wFgr{o|ίY6m;$Ղ&JiO4Щsz⻌ANC 3n_9#\ f? k{n%>0 YZshapes/data/macm.dat.rda0000644000176200001440000000226614367226002014632 0ustar liggesusers LSWKST6tiKyﭔ[(FRh# %l2EL1b+l1D(@ SmzY2f79w=7~w!yǒdX,ScmBwu˔eAsv">im"j'YE.ֶ</^[fOrq%Au. ɸS8*V0[p/qyj>(z~x1AI^{ R3zF5sM/s- i9Z7 )fI@kįfƼa߱,.BiW)|uVF/֝P_$aPO/Py=YozF3 yk=KXX}cKD]v84g+g!땍.8.8-zKI+''RMH[3E /JMzL~ 11bΎG>K5՞)(g@ olH{ۛ M:\m}хC 绺M”J\уcCX׾zJw<}6  C6q Fxsq"Dv+AWnU*7eDF @7BdeoD]8_N|YnH&!R e'DU͐o-bEs>(ӲHԁ d 4oQ^K(ݧp~]e+?gC}Ӷɬ!xfI[ "v]i#[΅Cq ;!nycoDՔϱFsYfw(ky5n۩|!|LL|Cdzr8A6!fɓQ/p"ɹ!Hlm|XWE)kq߲!}#Z|%ҖV> vC`8IA2H1ь{)+M{nu Ҷr-L@T*B 2Hur% cJ"U,{:3cH{3،U7}ұ +ͽrSoeL~߹LhufP75k5HJshapes/data/apes.rda0000644000176200001440000000527414367226001014077 0ustar liggesusersBZh91AY&SYcs|tUU@@@@@` x4OU8n(DUO F&2 yOM1DFzL2aIħI@iM100004hhh4ihd 4dd@E2@h643B<ɉzfS&zIB1B!##DPh"ȃ@1)XRQ m!  Y @m!eɄrƹ9'!#c"j*e-H*vcq%}8p|rOhvIYF!\K#55ybu1PLݒfzRc䙡*۠L fSU XO12 4ՒX^BntSdSP ?~ͦ\$h% ^|*,GIaN%_Ue7b>8LNn ǮYc]* W/n6uߚXϽz$c,mp^llyM2GoW*>9lxrw^@OUQ yR;oQܨ}FCc |P̽6COflQEnȐE|<?dmJ@IH$ Fs7s7}aN~w]qQTՍji|o"&k+ }EJ^ >SR^H qG2@3++TRĘ^"{wZ* .Q2STQeqߍkpD b("D4"r?DuBB"V`#%JP_mikx)x 1 f^<"2"Hڢ6تڸԶSjRKSYk6ZJTE@!bH8~_cSbY|~0n ⒲# 7^l˅)lQT\#-ͺc2.2,]+|BHFˆIc媸*2g-ôtp˝ gASC([^KҒ4)% J H$ K\., ERw$.] Bd$- L1[%~W2\U#waAE6%YZcU"rMeKR01*رjpţb& ]I٢ M0ʙ9SK`ŭ-Xo !hKJhJI*넜 ١)UdjV˻LJD+œ\pMN85R$͔4NGJ)-"-EEF*,(BS)*02@Yb!1fQdI*T!*I#df0X KQXѥJIbA$ bf4(g$JDi2RFfC# `C Rl EQAXXE(6F1BhZa$ ktmfͬT,*ᴛJV6f6!Dܢ/<|mSO!8‚ k )S{4AC>1_7Ru` K) ܍ղeb8+-р:puكN]C^s&!A/tvBf( m÷闄ѻ"Z 8H(a CdePp̵[DHR(q_6%3R")>lRi)A,]G"bX"Jut\<۪Q;ATx4xlZ#NEIQ=}-(AY"h0auR`hȄ2C9vunThXg\XH"ư9d7N-@$dkhHI i:J)ʚ]6A$ Ӹ<#zCyRH"'#BY`{yBOaH5nSMf77't^ Yf%pkז I{ Y4A*t t:M#UGTM$) 6if@I=vdPrr98bUFEhXHFKrZ[0u D Ypm3"(HQshapes/data/schizophrenia.dat.rda0000644000176200001440000001227114367226002016560 0ustar liggesusersey8TǑ|JBY:EHRI Q"{$[hCc;1af1eI<ǝ{yf}u~#9~#~.n.<'7,tW.8dsZUַRȆNω_~Olpؿۍ`G)BKZ0^tog'L}"=<#-2c!Hj|4{w01gD1(~^˹4Jy sű|7s,%}tEFb4?,M'Nc&أ$R7Yi}~fVN̓ 암v jUhғctv8P>3 qd23m aO2 @BCsXS_|cGvn9lC#LC{7E79c/&g/UC5wŅhm"+^ WÐlD :ȧ%&ݓr8:L&:m#Hr{Khu9%cډp?@'e@XA$PK?9qsc٦ 2@F,~<‚>Lu,_nAEqc_By^6 ~ g~tgy Q[u"v#uJ_VT2{&C~ygN7"LdGẃ3 H14j]zda5@8 =6-_3޶[8`mEzox~bJ^zP^X'Zc}]?y^;ڱ'Eq|=۔ypAjcHLdEb=\Sv 41;Ȇ2|?xcٯP WcG}rRWw'CË/-~٭VI!sY Њ3^#@ƙmbl? N8ɎHuxTS[cJt@5-+HW1wxAxB8&jȃ }}}_L鳲ԾpܯeR1f{! /s8 @]tthT~h7v0 K?`Bػ{SM,kA3 #zA~žQQ iȡF #~:LC1!i(OFZMEˠ̾b`B$:?0py7dq8ʭ4q,+'46;=<Pe =kLVs/P=oPSF WtA|x:ш _Kpв"HF݋yAI/i rsΰ' )p.AOGU>c#S)O 4\}:;'e8?V|l7veZ >bEfhÈ]^6 Ov% ȳ +32l^Dʂvf|VhfSa| 1K@j`R`j'vEm6 m]B".;8=hX< ;/CCF{hvb_Ssg;*}%hCP$}#Oz-:h9gTjPu(Vl]lʂz͛>P9=]+I~8z4w/q_m$N c GtL9 #UR%;0e !(6zψ|Z }!HRKDŽG^@Nyʿ Ӌ+ӠotrȝţZG'ÿ %MC,>RƗcC9@Lkt*v~p%|⅊OX: "\#;mxTvv"/n:4!$-anhjB:%oQ9$vI:F`s8o3e6a]ЛųY&..hz5O'@e05ӑ2'"Ͼ`e4 RP-vC}!P`Kr53uʰ>4pB"@t&_ /t?U kCBBN:_wOC64L\ 5nN5\,(L|c '|LirlX4D ;rܸal(V[7Q _n>όj}VwM!=/yr4MqZ@hw} CQ!5͒ T_C_GK`L~sJbA}pZ?G+VHVxq{ۧ`n2~I\ec`:%*ꉌ4[cyX'dтXlI!~ʪͦسC`[v_tk aiNOm'3>__cv:Oz|h?fo-QqBДv`̚q1O ;Ի~ۥk?"rm ?]W* u cn1U;X&cXDW̸, f;5KJ ,ÌyS|rsӍPW[VAK= 42+K@Y#T̋O!E!, 9qrͱuwyXU7?P~yhe=S=i㏾ZҾ?% S E>ak!gt{;CFx50iOKРqV#Yyf{Iޮz_vx!<?Gn>0jD% }<;Ģ][rb_SB~_(W9 _/i\R+_@Ihvust.՜7͗,~pވfsD]TCNi|C}q8k58 ?ׅ?}ݶ|04į}nV6$n6QĔi1.OcxS:lBXJ4|.T-wN2kM|=iVrEd-҄ [b/ CB.[lm+\>m,v3eEfLH ) [mY 8^:.%ߙݘ ^(_جI˜x19 ;+.I,4QW(3J@븴c!`ƘAƸ԰>DZ頞li|Cyaoy(aノ>m_Z]ޤU?*+REVM,Ia1j& PFeUdkAosb/6Vloܸ=rS yxBY;~]'DwxEuC,ȼtr8/=5ۮ⧔szXmՐ,9+1 늀`0iu{콬/W" {NE}Š99㯧9gF1K'^ľbĦmVF2Wj[6FH 7N`rFM%~8|j4k_.+\\Rx;KsaA@g ;[1¥%5CXlr-Vdl-<ʚ.Ipe?_2\d0x!`S لb-~=>(,&F\zQ퓟b:B߹ˁK"Ksjb͉xˢ x̗!lKEK+jXH:_ z׉}OlX`XkEיѶ:6& +xmnNyaNTi Õ|6,_I3Ow` ?O#Y(֓*QyIny1F~^6+t #@62j_7Y=8ކA3>5Á5&)7G]##U۸`7XoF Eh,oӢu1AZ6ϯ5x@ؑk{.JuyL "UL R;޶ $ۯǽzh"֟z/)m;?y]8N*~UuɁnP,ގ'\?U:"v&W438n 0".L;:DX0} ThUS\6y<l>Hڼ0:Z>lZ"#N A[݋{PnŸĸC2t0ƪu6T7rA3>q P?r/X}B1Rnxܜ D@Rkt-D3Q"YBH͌R!4*jZEhFZu\0VV[fMSlkMf-JU-@bB e - }@VX5k0$W;6YfYجZqư-n5cfvC"N^n\=s9'7Kʹ\{mkcX4`j K&&]. "K ʒ0qw$S *2shapes/data/panm.dat.rda0000644000176200001440000000117214367226002014643 0ustar liggesusersBZh91AY&SYts4dEU#D@@@@@@S!jzBMFi M45dSFhh @j~LF0MAi&&A D 22 CɠzFSlĂB$Lh|]pTwiv.]8!)A$kJvmCg`"UCx;ܫZRhi:/dÃ>'j$h찹p׵v|Y9ʼӛ#UT_bi9kGI:t /)ˢ8ܬ%Yy&t"2QAf%83aN)8Ռ"y ㌺0 qI1P(2UbaXsP`f~[2YK> ͬly\iVp<+T6j_Cuo6>CW>c5uhWg\9߸0CRL,s,C0(~C(//fJq ;6M5/=˱'N3>z$Т.Yh Y(- gJB&UćZ{אDAǼRspEh9q~(Xmu\G78ku̘,L4\3Au۩jDv'Ke,`=5X^C:#W?*K#e叵I#>,:M@QY꜉{"J6$N ̢=JWbṄQyT of_6!eqW1"zyڀ`>Uc@4rXCGS` 7![5cvA|̰^}7F`3M]kDiG8eU<|e6"pzJSb$rQ>X R߁B!i%26a`=_vIGT=uIsH8jy[KX!+5\ Ӓ7a`y+&@~4 Q* G$/ 04_۳ GjV+ x󙇏pwjWΊGU&bˮ< *1aA~ ӰD 댓{?iUco wjGM'\=1Hd~vC,nc{/v,wneZz&.Ð% (׻%;xTm^n +щmgx5ՙ8SĕӬdƜ8g05cXu2it9%#YxP;H0+_lL/Q®Jy^tQx9F7TCOs`qcd9q8KB.Ye.5Š_u~鿟:F PL3,6ozv}5vl6Iޫ fmDy=vsn?ėUʷF1/P4Cpg'S;{ǢoC`nб L1U(HbPr,kg&*+zg ہ*^_{luuNnR_,5JMb „C+˞ck'WYFSb:Dq!N/T=8ԗltI/uX so XW֙oښXê [5f ڤ&eVt ' &I@"Py9 },:ˏbV p&B%$J*HnF','@A\8߃oȝN,E웮 -U;ZON8TjH [ y"$M2Xр[-_pZt4nat0ۨ̈́h,ݒ f9!cI 4x$`0\rEW"L9322# Jbd+wDLf_뽽Ej/T\ܻ|!T?٩\KS]g:mV&&zu.́uc3Wa Jd:c]θG$ssA` &t(uts}qr6X~6"tÌ_ծd(cGxPhri"txI O,Y"zs5=V'*hF+^鏡D*LtLC( 1p2پ#HQUmGϩ+;pC[JՍۜFN݅ `L9] 9fՃ塽ImM=(Ldb*:;C/"ݯ?UJG+_yNiiO&tLLLY'W-xptvsP)!BWi ih~qP?A`h ̞_Kx &B=\fJЅ~}<@XLZ)<B]:*fQUzy9Seʹ06dO%Q{$HAp69ڪ~~9G>`M6G s6 pPY %HX< KqjԠ> {]W޸1dAyY dN85ârE 8{m1UHE0!S2w9W+THs,y7p Rx el`9&r祝EVTM}[꣞FnD;X7E~S9hθ͡/b6n 9~>G_qdX @ v=n2]4D%n  VÞFhYp@ iۆDg tҤ3H &eʠpZ_Ѓ>@9Vqz5< #=iG"^ٴS*6YSn8-r L6yk;\Ty}`%MQM :>kh2U[ 'v l/'Ni^BXmp<%Cv, ">Y.5T3)UO \B1 +d9"wrΞ_)Uç2;#a:TA]XGelwT+, tvD&ׁ5]4$̊ KlR\KucQCGo 1Nu tt/ bK$إ_.+kfL|HSiP~ǥՋ$Yne9BG cPRoEۓ/qvlg-Q-{2;. n WFqO k`۽MO!3}$ f޻"ZcA:mA1RYW3iDf=7Tpejuq#?g>fo/3):>wњxx&Lu&>c/aRWҦ |:{Kc͜dvG^9LkIZڎJU-,6{;O`}[vK`%$7B(re_>')# ixS>>SPӕwȑ- )"J?3\Vđ_5&T%J< c]ҋ?/ ^@S(pdG}77Mz߰D{p6Ìّr#vB;J{|ja]N~@D](K#\__ّ m޹F2u{Q%3UκM-}#H0 I։q\@ *+>PD \$e9n>&^t 3*ZoCEXg J^ĮEj>l>Ƞ$_*+< + ;TNzDf*]_wf!o𠨡(+^y*L]QWBm}\ҁ|:xi*mR+*'v FZI+8KY<:\o>p큆ntv)=+<Z q1)A:# gg}0#z{bL:A/ψz%9Rf?Taw1'tWIhti4S}[?Pv* 3Dcr uJS3 cH8:D{ζrȪKnŴ`2A+TGK097#͍:JoM~[Zh)Og Z(@-a]zfbƣipOyp|TZѾ?up6EQ5guя"JR~cOᦉ:tkގ]`ӑ|d\9f~JgZ(hCl;_r4ܮ)sOij#aH#dMDV q+Pۈ-k}5#"BExᒴ e6tdm/aB(T\^e{۶ 2DxQ^hW h+Gj N&`EjAYmO^KW"RpBzʲ2L)U}:kNGfizXͣ>k#2o @qM/{)m{?La3O.wZc_mc^$3$ \v&]Wm0!X޼`ǻ˄/&/x[w]@,/ޓ!(P5fKoꔿ&ɥ 8PX\9!i Ub!|~( P]`EY]@ A}*1ʁ-5e#-CŒWR-l,Yɦ{Lޭyھh_9$[J!cHڅ|[1 UU /5 qhFQ=LPapۆ!m4 yw\!Td:L,vA}@>uFRL!CubxMQ߅h߭dh4Ԕ)M]g7"c` $ TYr<7Ն&6iG1(}.h[H'''eZm:ǭ"g݃97$͊KggLBQϖQ0̶؏Tݰ7li@˜v)1 pq^Kln'^lF ɼ~-}9~*z.VѸNζtzcd`η 0c6o [^Hs R&kt){ռՒO* vĨjG!БʼnI 2Ɓp a2nh8rn<{ GfM0Vpp mH,m &GS>&Lɋ4LjUO̊)gw>e≐3úHa'FZt>_>y~!?8u uʁROdDChU~SwI^Qy$^g uA}>9W|^]aPF"Ha&%8ϋ :RN1r?p/S4׊FsLz}:KKZ*ݶYn-Pk'==2GPw*m:V{u$i=RսQ}024 bNw;aCVl8$AG:J(qgJQb;ϕGֳcBGOs^iozrΥJLߧ gRU֭OŊG@c?sV\w̓UiMްb>ᾅ plےɸ|)O9׳N! UV]ن4Wb^u1.ŕG]=;NWL_UUTX_"2,5ɜ*e ?&T@S \2N,FĀ/M5x-"[H:g3nEc걏 JxXiz[K]yILݶ@!iyY\m@EBƿuetoOL+Ty :mԙzL%n!GM)rOr)S7aƶ҃f>ܻS|{2"3<ଌryBT85?KboN*x\!$we/q 1f"QK;뼅j +lWjg9?{C߳aY[8,a$@5CO'r]MQJ1j0vZ !Iu_ vnkٱ3EWk:R62/qVsRVsrB+9˾IO3: %EYΜed  B5!aV悱6@r0_f'"f^ʑܼaE`<#Pe|Y mޤPDʦL3twM{ e[g1ZIG%Iyz7lhV dr6H> twU4IyM ج"ůj2lXq[JΗ}G`&"l-)Yǰ[%kx@sYXm_] ?зe}vPydmUrĕ7JF6Kg*K>ѢOx{j'c}?_!XzN|T/l|YnLoߒbyo]Faqp>ʙJ.j戏:=?'!{> Z;F,y,) akeGnj #mA^& QeޤCPn#{R컎EWBS؏sNDj_I# FLo6$ۢ!.Iqy?Y-}4_#cJ 5߬Z & QۀX2jWX $IK@qkV15VrۻznrcFLte'_k)XT{08g@T{P`y=QQ:J$_1bL zQeYL:>zFkӉڕBru%CS۪0k!]@Z1gPs*B~}ռ/C=~"ũ2ze|AT@ֳ zf8_C}q"+̝I6SvyiEY/'Ia9EE(3&e^bODAUW@Z$/q؇H{' QSp/瀑1ӂ8_~(z4IX5(a%Y]tzŕa`-TElx3*Y嘟 H35~L,.-C`n(ʝ`{!Ԝ?=q9k3CƁ!vPMt)yՃok8۬DiJ[)3JkBZKo>TVWN6}2怾'BZD<A93!lq.k"kX*tWcmCe5FE '2+X5Ƥ?j cZ)f_Hr7SE>/t*S cOTD&Vm6 `AC@KI`>5ꨱ6±M5f--Z@tœǫH%4'ӢOl;Rdw% "h(>7]0e%>ga("GϡdqNzsu :hYISkڛ[Lerޑv`Kn)5!54?_ 8ΣUZ q'@>=]>o΋8'W`~++žˬ<UV=%껜KZw.t@r]." .D;7uv8 "aH'8sR?dD\]PQ_aEq5xmT4, ERvG0/Y Vt]; s- o'@E}j <<$Uj/^<¯j@ta"ZܥcwZ@<~Vpw\CmS¤rkj!}ԯiU\?Rǃ ~!S(@֙:0Ofb=l3:$=.Qa#΋z؇'WIb:/^U\wB8Aƕ.,[m|p9)BfJgo?L}՛SaDvn[aM5r:cřXcHʗwE*~Y W!|Lb"`^ŅS6y UQnѬZP /eTĝߵ(+u >(ŘNΞ 22zy"&$u&Cöx[=<+Y?УەA0R#TsL KK`, ~&gqGH%`uAnF%n0gAM!>H v8:^HMlƨl$yi5.0%a.3E$ONG' /N$9WF{F 7+>EvFT%ǜEyh)seK^w9=o[ &P&/++;bYJcYc!VxVNGZ 5d$GpNG?qSe.-lc@,s de"R? > 2w%MkK=*3}Jd-TDظZ#G@S5ɚU-*G]ca b F'A[&=ݧ( qlf/qIZ1o+d.f$4]ȮO#rYbX[ T^&;UH':V7E+qKB@y:\7Xч%`7*۲Un%k*5(̘b|ӼٿbS*[0!2cI")ovL|= qZƜjg! ۚtڒvGu00>h?| }ܶhBv8')QlЇAp'l ǥCW/Y'nfx'4fE a?~66BQѐJ!sZs9SK'vv`2['\¬wE|&\D&w.uq |vERmб\CV jRe>;Zι2a<[9g1 Qhsb<ĜNHԪyah ,R,'*<\>`E<=q?Ϻ+)Fb~=<ֵ# yŤib{ 9(`JPm̶ŏ+DK@҉X )aXyrHͬEx#QooOgvVTCwoFy)'ۃ0֟I1jZH>. E>KfH'$#A5R J%JS/k~K[>\j4򚙍hz b՜W5'N0?P tӺ^&ô`Z2.F>l~rp.LSRʱժʎ/E:3M~XBJcz,ץȖ{WDd3;h &PHT8sgLGlvoziAѱ+t? fĔv C@dHX_S/UB٭bׯagBa IeKQ'e%ڱiKqtJ$ԦrNps;Hx>D 4GoZZ,vݽp<)81C70K2 -՘Skf#5f'弋}4:+ַ["݈N.4lrvLoB+XFjSpB‡Fx7K zwRmwuQ!1aA3索pR ߤH\@*W"eTu)Φ2RZGHǸ2;K,쭙( [)|j+:?pZKxoк %]<k3MSXHkZl>N o_ 3koo?'s4uf2DO~`b FGw^o,R^>A]S%D]hdۋ+cŚFGM4"%CHuݑ3SOpQ@IM]KDsPd-ϗ쎻f^u]􄓸or4*"ܟ2?K{vf{&q\D<8KI0opƛ%.;Iid]"[\?G칞FkfB !7jVbe[^4:a|[Ti4[(3lȽ4f#nqr9)ھIbcΆ9}[`.dsQҊh\eLw hvYэ (,FCn{T*Zy4QAQ1tkXO~0ЎE2xf]Sh)"2N^"()P8\_D7ObSs\7<`)-t,w۱uGo":͜THj@Z"oaj]>LĒRHBvm)((s\Ik[Nlx,EֱWF@0rYPu`~*yMDOV&5X]]_97b:kYyGkWiIϐq1ܵrИ:NO__ٖx`yu0w3.ͨT.d+IYypiGE(]홟k2bI3?ѓ?qf?8SS=^7ҏy&sZ҅'5zh2C ^4JtT5QPWZ}o֒"xpTRq̸,ݼw҅fZ›pA8[*> f"0(&DH%)jm HڎHl.hF1BH_= {|l߄i<2 µ=}##ΚNM[͠i hySmVz*A/.WDKtyfymg#F>Q`G'oiڄg>dz `IW[2۽=Eykúx)[5"BlBjZՈ@% nuާKP{kn7?牞]J1H@D10dt#ZZ~el0 ;皢 ҵ">L5'(=N 휓+.5>mπi7^29g!Y_EM'$Č-8%j?TRn~"AXk'3"T$ZǻPn#H^(]"* -FB,f$DN|qAFr^JrT&&B\=Ezǂ\2|pw]io,Q靶vĠ؇b8t)8[_'3y8;mQPV#z՘b2#54n6B.uU*I?%<_^?k!d=6>saZ4DȱBfT@ɠQ ؁٬s|g60y%d 71q:xY/̆^AO`,ͺ[Mјd3/&=85Xׄt\2Er{r؃HyKNX 'KH倜I(3i}fC{l:O䃬ݡмy,@W+[A4HPviNɤcrljQ3]B0Vap<2L0ޛQf/i.rޝ`~KXnNBËѵ-8qՖDY76rݮ aU$/CL^V(AEL~gC Iru|cv h.b(5E]#'zvQҘ5) %({]!/@޸wzl73̻t[0,Z ˫aP#\11$Ԍ-.ՀC+T_,ք$ H0i!a%t>͕ lc5*@ۛ2BQvpV?ePX5+G_|7AJo3OVaa.'XK d;Aӆe{mM5⁻(eF4xm8[e_q uzc{46 J)k)i{Y %ĒBgɨ7-NbG!vn~Oq.2ҫPD }tq_|0rڥ07OFQ[g*$~w$~5[v"m W-<o9免tư?ՄQA/ZOop\ hYstge@='M/n3"L.2bp>xJ|@(#>6 d[Ar wx4~^dB\7HuɟZF,(Wbް?cf8ɑ.b/=]`%-WG-.{Q3j9kdk.y:۝C_z1^ ^;zBжrGaȫ4|bDF|Wr(h^ɨFMhv-F+ Nuc z|h.-!i+Iȏ,.k=G%:@H7XSAxL 9'៏rh??w:JL \(WHG9zDȿH jLG<:`EHjE`C I9(FT<;zumoDn_дpXbnd"Jznk^MCʰïpA f7n/tBklNw7t=s+z%mZjdr{r6j8%k['C rE#1V .67T po|"jUe0G;sA_"؝5Ť%N_-1#ScebJAsxWQ*rbmF`7HzU0ǖar$ߌ,eCxҚvASM@ xFx@nj$@PTӡ0e##9'j֘yR`掰zVҡC^9fizL?:Nf`R1RA f`Md v OB\=P.5ƁrDxrEb/A!gT4L-wΟflERs,3/ 6PdBs L"08FdO٩< Օ|Er>0 YZshapes/data/pongof.dat.rda0000644000176200001440000000116414367226002015201 0ustar liggesusersBZh91AY&SY`(stTUU@@@@@r85OSFLjz2i &M$Thh UH M h%M2A!@F r5 8%Ԣ6Z2@$AT(RI N!0LAB(B"Jf͟>p5& *UKwT|6e6pC=uwlc]$(ejֆh1ִ mREׯ B67[W#}>$%Z[r)JybvaJV`(3BV%B+c!1 % (kI̟" |IT [ċA ψ0L }.`a e8C V@}H4e(Y"mp$` %p6Z!hA E DU*"1* *b"XPXQb P.Вe P*GN@G gݝvkV"@o-VmJ]L=QvoJtZ@OUJWD_"**DPxNJ""q(ww$S >shapes/data/gorf.dat.rda0000644000176200001440000000132314367226002014643 0ustar liggesusersBZh91AY&SYf$stEUU?g@@@@@@N" #LdQSzQ0M 4"Pꪣ&# LM2`a0QiMC#F!ѓLDMnc9 V%8C3TgUU%DҢESU!& C@ jtj."NtNmŽz"w_V͝5@SZ`y4:m&iW--0dž{z2fDk<lC ]@ĈA*)&/֣UguuqX ih]jg Kwxѽ|u|0%5DKXė2T$ 2BH)d'uKFgk, #AF/VۧnmdL$~E|#퐿n hBb!a m )]Z)YAQQ(e6,S)* JDR%"! D(IA( *U(T@RR((0$@XNO !4 r^}}$2 7lcqjI]yl[pcW:qƾXXd~X}~qP0LRcS"D0bIPugyRY*e_ q]B@G!shapes/data/pongom.dat.rda0000644000176200001440000000133714367226002015212 0ustar liggesusersBZh91AY&SY!stEU~@@@@@@51M!5y=OT=M7ySOP22!T2hɦF qddd#F C@*SRhɠ  ` =!/rZUBj",i4`‚*Ђ;%G!h"Ғ)RF62l 40bɵ7=I4mfbW|tǞv<٫߯^;[-uuh}Al?ԝd)\Jƞga2gI {OuI_ۀU^n(W مA،D@6 4|*U\Iw.gV:?ts`J((>frKg[G?;6ڎh,iw9xͨ101FANiDZ8+YJLسd.|JYfh"BXha(&Jb("K@t& a Q+@>T njNAd)@(,;ϘQW_SOkN SVxI rxgFOA9y2r]$F`}\̳|M9rM ^L~U߉t!A96a]5?tTmR4̵c.p!R shapes/data/gels.rda0000644000176200001440000000030414367226002014067 0ustar liggesusers r0b```b`a@& ⤧%l pH9@(].@: |]:j'̼( sP+ɀړBPs >@ 0BU.b@7T$] –9%3H@ ~shapes/data/cortical.rda0000644000176200001440000040556014367226002014752 0ustar liggesusers7zXZi"6!X])TW"nRʟ$T~u}}XM;06%pnyԯHEqAPi8}^?l38FD yb b 'yCTtUfWN?Q,C] 5_0#H\9,%4jQ}=Ϩzmٞ3U:X5 Ǧ&8;`[^ӵM_SZ2Y"[&[6:">yJyچ|]C `}9}_L@ ?]JGSrm|0F6Hf.%U|ex@( 5 Oh: ?y&w0/[=ht|'.EMš˪X0vpI ~H=JamrD4fqv4 BCZܠ^s?9e {[\5ܲ6&=orRE6ck9.F`ؗ!RСz jۖ-#[U/xk3#ݹ1'A9Qivm㻟JdJ7܎13s 9 B|.ae `SGdi:IxC> XbO_ Yux`u}ȩsn5D `QMW ދ-dS噰+ -\-6"^Lc7CeFNL+qJ w}QZ MRm{?vgV4]r Ea iG+c 1ȑE.k˳`Ge7=nDѵp%={~| A"v?ԛY6+@4ں@U];@8 ηb(V,3jZ+dt|"3>m&ڳnr**f.ZG]@r[횗VI7"(kgR71Ec˪Fߠp1VJUHc}>(: FnU)cQ @gJ˧fRS.)]=&G'`'Ƈn%Bmdѱ˱#J7k"}rSvlF+4Eh#u N3o<,QSnNC9|lFW:Aj]f7&>r<Ug,KzD3З]GP&$=QSUDZUp?'1:0&h9;bQBmE4k ;KJق_~j#M!|g:׿fZq|D`U%d5ѹNS * O5w@6@ʔf\W3"Q- ᳋6͠ղʣM$tA&{+t,9E>ܶ*fGAT3=YnG)o9 zOu'$s,:6}?鼠g͓FPdPwU2]`vEpЇ?՟#6dYFM8=޾8gSPlnӪ7 |OoV-%f㩾v FOU>ĭMsd Gr{8 BKȬwǕ,Pך]4DiV^+ٴ/UQE ۥ~s5 z5Lm:ga8bֶ `ZTޞdYpEJ;i=@.a%c8iN+U=D?zȒp^Y+7>ѧa I. ǁ̞{ ?n(\1i ; ĪFJ#%F+MvW i)~w -XWȭ6GbF.꡿(}7OW7t5v pt"7iM.p,RjJτ M'ePhEZ`j?Zl#hQܪ| }U95묝ňU a?mdOo,LBȕUՕխvEqiwbgGI-s#֗GɩטWS%=c-e?f]41&!rJJ[l|٤/4(kUP-`{ OC32ipYu6>ٚD9 -|M4xJք+vFϭuWCIz\Tªd0S ~ɚ 3bm[Vvp;.ZOH{Hm䡟g߿,b WitN%nNҡE"1zdk-eU{\|q_~*:=) ;-RN u;n@b-ܧ\KԍfEfV'D'c0a c[V4Xt&b`9][G3IIzC(,➠jCL?F  c:=9=_Sc W IjdPcZ"Ii55*Rm8ތ$cĊv^,k/a)-*TlJΚw>o7|ĄmsTUcsTH~je(& Q)pr^8Zɛc?.m*FH圏Ge(MR46:2zcst rhZ4.5沫vt'Ӏ;n/Ɯ̽jDa  3̊"r$Na&-VxM3ۀҏ~|&VbEp.Ǯ!{m su$Cۚ䒐=$aAv( bG cM!c(h l/鉱XaneDW+{yM&e8dWvdJ8k. )2%xjxd*O iMOs X+F[n/#0\D!ƥT9,r)MTӨL\-DƖWaUG`4ba{GqǔQlL-[O糆 I AnM|{t7:K|ۦ fK]zj{;>z7^W*2XàUu,D!KӈK|+8664Oj+V^(7+ 5&큸PL4˗ G!Te'=㠉!b<Ⰸp;lL +>|MtJoBl&%W_Ap ;d!N#*}% m2SK f_=p&HP6k V d"Lxyn="F$~SQUDG&/rBs˕[}ȗ*V(|n-k6mv`hq?1_pUKQik5L~4H@E^ 혚'8>IUɔc7@:}wtkxv[)BR=*WHì砱b4p>JpLk#. lS8|)- Vg9vԾyDE靻VN4?)arQӻ`+.~ي͹UTDD[T;em`'x~ j^+y\$BEWI\LY1FRo=x% 01UG _Ϯ1o5_!HNN룉 K]P||:Μ2ʱRBeԓ+ J~?uq%OԀ*>P;>l1"SS*=e>!v(M4Ri"Pxfҵ+j66lf|E^m~+9,67jCKoev(̃I4n!2/]KȫVs"qNkMd) p)heV>A?Xގ&va N5X/4nTI$ G@vUa &NBF_-'A.Hn i6Pȋg[&(-С׹7R7Hf*?Im&=րo`j{ ,乳CYs$%y(Ν_jR`JƵVЖWgdW>$`l`UXmG@qt+NpA1t xDnNţW&cF_l; @b߾^={h  Hw\^M F0!}KSԨ1xy3An?.Ә.w]/S)Ȓn<~ #h~`̕J?6 ?-maaYln g"^(G}ɛohW~w<|D,GN9D[>w1Lg#T#o>\ɳ8˥OV[)!c"i[W%?up@<3;uTԄp( uUn^ $WJP@_9-_^xn|KHȟwf:Rg >ms;F^a'J U]m1)3]; ;4f mRp'q۽=zO.?l1d`SͮLrțn'ٯKg8;;N q5q[Z,L@ +^3Î4uJeRO/1E6.N->v,?sȄW?(a%>ss@!D\UOO[5'8S\UYu2beX7{BxitR5O\oOp]:(/0]E8 ӣ GJS*=MbrUezٮOPS(=% <8{ q:GQ$.Ӗva8Ϛ/^Pm2+͒es$kU%dZ1XkNg 2 Iۄ@ҿ4N't]Yw^`6qZs1Wk&LXf"kY)64zg 9,JlCu[0ti V [S3 .*go @J1ޡ |pc8OHJ|v9E+(mqJl .G`AOgO#؅٧9J) ;M&[ɞAdc-TDWEed࠹Nsq~"jm5?0aۛ]i=oVYA/1dk'sGt 2Ş8*$+n&}QV/q2z0x{C>Iȅ,,Nlzumh{RG54t o l sI(>ѓr_uip%2H(iWv)U#YWcS$nTIS²MFCvWW$ ˎIUXTdLtdo$5_9M3s^8w~YxaDJ/—![lh9(5BQPC0UóGK6պzp@QnL{TmHodqdae~,/OcE 3S%[8+`ܶE9:S< YG)L7#ȚYYCW3@b-В1=k UҥO/ʵEhnG#\+|hiUv|Dky=G$ɦB`4߿2$K])N{Lyw0__DZ{ZmDW&zQsbS-RY' 57R`sG_pHx}*w8gi樢M!"57R1.I POIL4)J 5ZN`6#t0b岮n!Qyik+=#gҁ䏉vױ2Hf& ʎ@Oݪ[uHlS"}`<ZIq~('sԲRZ /`ѯiΫǠrNݜUEW iB2^ ]eD3=|!9LR=@KR^HhMsqjjxʼ4#MԭɺEgU>Uis9To 0i5gZaBP=jf!Ӆ{q WT5~i+s\:/W( pc*V{'v"VSDL֚p%JIs-E1ty97 K$oǴxDeZ~/||=y ;7% ;B';D2)}G⧷<'Vob '2&PTe!ǟB.Č-G2c/e":@<'T-e 8GBT DpJ]y8`+xUpA[vPt <ޑkN|Fbq79!CCEky͇uS*dJmAR{$eR o%1kGl@7/ǂ]}9;?()4TТ'ΦuB&5v+ҧ1^&xWnBtr+jAU&ӓk(`B-R{igBY+)҅%[xIJ%t47C{4$N+Yf6-3 } uijt(Փf.vsc'¾ Lv{%߂vF-.vp"루^VSަ$ ? )Ιȭ0427tcbab1IR$@[h) %,7onj" Ii\fEfu@D؈fBPVQ*©qùʛy +M,;ٗm:ۍID2EE[y;?d5`JqR2,s2B0A^Q٨LjE΋‡.!crێ>9@.z 0ݒb "*Wv͠q.g@ O*XAЇ0q m~\bPȆ<Ҽmԏ6k ͂\ؓZmt\ZEMR)1󅝸Sx%P֫I2 k?L"w,8}c-[Fzi[Z]T\"ڍ5` `h ?tB֎,f[^Pesf*{^gIqeWK/deA (@Ҧq*V"__fbMT-m5G2Va5+H?ɚAIϝ}?D 5c`vQ3R7Ů]Vr+{xS3)|"7#ڢ,ZK +fm @pnG3%~~#c+P`0Biĩ03W!lvGgC=:pQnt`;TJvB#&uɈHUmIXBG uSBc#?Oy0R`eM-{dž)d#x" (xצDƃi,;,:iIi }Hl.صa.0Ơ,N?Pxi59Zcژ 'ć)).j>"_-WIO*N2hъNf|׷s fO#Dj.аx sy[8eU. m~& c Td: VYC!# {-9zT -N! Cw#d&Ǻ‹C+>KG( x^aC;-SJ.GGכ!G.Z :T&?q@\=!{fGjAǃx[3XƎ>aZT+miP#l >B0v멧Y  + R\+}5eiaf%n#uaCp/ziDl:ج;K`T=Hƶ+t7CSVL\antmm*+a'{;PU.!.ACO`.L~i#JCJs]p a\LkV/Ǚ} 'woRbA8_=_4C#Qo$%qnq_AQdtJ\5̥-Au8wCgqCƱ!Qf'tk "}W71֛6g`^m/e"mʪOg\nr(^mF$5m5wNO3r\B^X"W}>Cfm6fd?u1TG*xk%ݽоҴ[}bJUvfUg+SG9Zsr"O'gA!SF0$OтX!WY`20=!yv3&?Ф݈c86a`wJX핈*F\25H+;"֞ D ft䚞e%Ug/H/D<ֽ[c3qk>so`1ksKI;cw@J@_FdlF6lI-)JhDjt8Sr]لtxՏ+]Իg 6ۑt7n5kj\Ўޚ  Ų4d$&Nkzb(R3n/yeçtYajnš <9q4eIFP]6Lˋ> tWcځ3~[J":SANաb*T<-g\:OC7Zlq5$y:Κ(}o.y[ &A Drw',r!dv F]t_ȏ:>5?E!T7C2*lupge \һ+^h"qތW~t\Hhg/@eM[*z#*Ӳ> ez/f}U옞 h^tQ;+̿nXNg.@0wStK&%l:)V-*uw~ 7=J@=o A. 5 "Yi*ъժBfg5ͲRE气lK2vkسbCmGWOd%T*\F9A(12i!Y:cLBi_X$BV<8C'oƘ\7 {1B~(_ ! {H8ϩoˆĨ Ҵ;\7"{5>p+̒+eD^pb2_xдh`}k>oϦ?7/(IdWA>.O:UZM=0fГ;or5GnI{d }&O d<Q/Fe^ΝTTk)i|YC1,'ٚd/fL j yLnU8JI4zrQoُq!@ B>+ {k: yc]KV_yvv+U,]6q FH>[<=0=9t?茓 ?J}[O`ZCD8Ҧټ[ů >XII@ [/21=Lr&q&+N{^Y]}:W!qu$EPf 5zew`),ASJT" O#MI]X)`:2{L?Vcٚl/t-rc؞ "븚ȩ8ke{i н*i䔧k%<Tt[GɫC^:`Zbώߙq]z@`̄MkEʠ1^؋;(ֳv* `q+ȳDsGR#s>}ZCE ,LL/ Saƞ(i"@Y>Gc*~%U`=SMP "v ɟ9oa0̷ V'L4@ѷ8it5.tp) IR35a9eEFC؋־/P_$8>/8,41POQP=&ÂKBO+{G.{\#M\,o9%5% !41"D^3_!?+W7~`웶#Xc \$]k2Ѐɹ!G5olKהD>as9C\3E 0FbZUKCJC؊@с-f"|)-(c!9EV!ԸgJ 41"͝KDT܌#n^:vx]Q u mIy3(+(ܗ'o5n3͞Yה:' =B._`nLRDAdnMgo]{"z=!Z7s,sih@rC&T;ԭ3,>Ǔ! ye4Aٶ@-*~T͉IzsAxR/Hӏ::kV0!'U=+_m{aՂz.m=~szD6zwYƽ5B\)#I˞voPw U_W@Ү,=0E5q'MatA?mvUϾ+RRð6N=;O )e(,rSL8CB.ҡ5/56C8]?aayDi ]ʈH4B+a )E|GKJUUÔƩ۬M-v3`|8=]_>=UF2%Y_ 6Q7k}%QB;z:_5=ͬi S0J(#ZǞVLaH YH0lⲖךn1M>| ASkKydfу+Q>$J 9_3B Gnq&#_M D8\9ϼ6>wY!}i֟BF0 a}.C*H7#EbhB}yGp m m3} ]}Z4FS#qI&K|bEq"fc]- fEٴvrc/D@BF^<4j3ٛ*#G*3;ݩ_#0lO\]ˢ>aEP낫zjV# |=3WvMVC[=Wt+d&*q^|ë|UWkM 0&wg}R<^' }|+_ d Aa9 <;UfO1juI/g즁Uh ASJoC~dJ,ݺ2yW݇Aom$M~HX_iVB7$ui=#}4@Z) '0L-2vJ 0mC5-+r;rY&w#q< Kם^5ok/2K!oě9wY?T?QȶrJꆘZPg] b9֪2n.E68P۟*z{CRΘ&(Urh \ߒ'JO<3zAsL]S򻡀v~-\N- IQ2-ǯz᝿Df|'AE+YfPT^>7a>ήsC *4H^ڽgm0x+*])\ R@6H75>}%th愵t.| $>Doq5Jn9І 8x#jE+m%OYc@: 8j{H~\IOF.%ߘ UƵc2~LViMQH"?j<,HTKYdKQBFvD=}b[("XjEGȨsې3d4$pTD['"}BGn빗_R)bEɏ~n*o)N؜ ”(ߢ As$.qIQ?v5h(&UgRK%AF]zN85SM_ R~H4H&D"dyr H% [ևxEȳSC0RE>Y##t\q8f Jh+u*E$[ ɸ0 <,aJyD%1=$coUcHNsHS _@k1ռ۽ >RHVLןEg_顒lvAφ88imsS=5V+`6r\!<f3,_,#O% iJYԙHtA Ha$g.+O6 Jd˃oS# e`B[|h _X]OiEQI`nI#"!.5 h5m.uLe_m(/nJb޷50 gfS[˳{K['ӻi b#Iu m@aw80 {h~tu1߸(Dkͺٿi>__'8y8޹Z ~/Ple T#n,U[0Eֲ*] YsDKIg xZzz̃jU {ڕ9C!2'KωJ9c]O&:3~'xQ@8EN-d 8 -GlfEm#Lyu(ҘĒ54B7)啷8NrAtax*L׷|bݣ[m- -O oAˆX I;S# gS`1ً1}D5Z{bFޭjI~|S"FX)+Vo!NVIh/57{D|Y3(sS .ԎR{ޱLbz=.sU14<_Zob^5A&kP)ո!5a2Ӄ^֝Nƌ0:?$m{lbgF;OXꬩ.c csVŃI ⃧ݐV9:sk2jMWMMr,M-q~ s~3!CbQ GPޅOjq(l7WǛnyGpIg|L f | WX/[voF&' <\"&pZ?|JZ]bvx5tm#aqb:$o9\hI Y+]jdEqM1ALsb`VK6΄MF-(].3Yf  Xq3N뻩ϯ~^0fб}OQ~]?פ`Sȯ2Sǩ ߮RIDa/06a0as%bm,Yql\~>Q ;4>&1f/HQAِuĤ[ y+DPVA`~t@[{' NjZ͟#]=ڗ{QB|'_P={3bGv1=ffj48bd6?YKGKC9^"SUƄ5yzo{@';+ rYiQ4|n粼8"_ܪF3,0CdVAW4J^yORH\@eo3*0&3sd0Cctdb܇P&lOKm -Tv,=5DMT s\>)zKђ&wT :y-Lvhہrft:QެC Y (.?hG?m\ .1A˳EjL-d;ړR+Ie_}%R1r竂+u_O oшB1r#YLȶS -fl$`9RWU.(}>":GwiQ FH@*%ԚJ_ەXCZ,d̀j.Isqⳕ$D \$bЖlP'"7J5{b o ˯iORoË1Ⱥ*~ݴR!ks)lQXw oG.]GrYWYO )|t-,PFֻx@ά纚3 Gdц͏r3N7 EV":9$Jw LU*\7uYLуtR@ I3̓dͼt[^ i6' ORgګeCξ៷[ӷ,\i=X&b]RZ&MԳ1sTesq=t\&{`m>|pQP*[5 Yl;S"Ûn\g3qcDD1٬\˸yFRG\Ӹ} K^WQSD+i,|G:Ϫ12 |05},7LSX^:uћ, VT|oHiY+cǛ< 5k8$^,Uɜ2|esM$%.uHSlI6f6j͟RE3ߙ|JW˝+J%ǹBkI  mxe4Mw^i>q8>z* !HNY fAOΈ&3H*;hp1 ce[zGⰌhX*-d7H۠@eSOJ Q(J4r;dOPS?m>S*˱-P&pZ|aF +'rƭTN~`f&٨V0 E8ďGd|_)g91B ovk]ik]tgi._tmW fW=Rp x}';uZfo>=^("Z3\8IkI, 1F4vW^/?b _0-AфED͌?>O3uN>B_[tHXkؿUp+Q*)VJ""e&vԅ} l>5 ST`VݲҦ Qز 3FNFHfSjzwopd6K7 "^ȾDjp={=Uj/K@sp<\~9sSGT*Rz}/hmk&2G*R Ņo* yghyE6`M=<TdO~06ƨ/D,.FsOȥu0ל$HnVqkVͣI mrUyg ,^ tjxD-%g\gNPR;УG<¯$q43MR, ReJ4A.m qUcb`߼f;(a e#x6l"zyNdw !'RY(;SqA꯱^C}|ߋa9 ,<:F•[vUq ;l=ҥXƨ2sYBtUАGWO'gpSwuoidb`U\G%5lר[3,X ]&43 afɏang23ݵ@ppfHzZ*tHaY:I"Yj.,DҽRDrҥ7 oEt6!};{rsoŕOv)_{8t8d$Ä>;qeX[cGT2W"ҏvyQ nD{%^[!eD65PK>;tzϧhB%bVuLU$ЉDV|?NX |'%dT%sf'£-_򠗫IL ZCGwnVqgXQ s/`wg"yQkA=l5$o$/̢Ϳ64*P-6u 4dM`[ߠbF'.Y)T}!@q\嬻0jyjbdh/(7k[eJBA$V2 K>B8*~7;W]?suGA&EOKE1q=5\i~xjl 9/f (TͬY斁B)dr* "E~0OKI\Yc_bm&E>A\%[&oRR!7+E4\X U@̽i!c ժg6;QmhЩy~5>=`%b1yFe"ks? pBx^k#ٗ> ͉#~L`b邌ݥNPʪEԊG%=b67p"Gyo$'M-&ذ8ڊkj}_W}^s Gևޡ[0t0,}n)TDHi$HDqi-Fxl QBR, Mո,/H=F>xRj2MoQ)i2{@0eإIrKnɩ֧YSK+󛎯Iˍ)p.)f֛ t:GT܅JfO*ˆ:r~9g -Pu-vm^ ?D(ܲW)fb%bԱ$jIˊT Y@(bͱ+  S} T5+%kٝ --!T=xU ,XqMCVA3:f)e fsbM.RNa@Tg@]ᆭ<֣$v>e!Onpd 8f^߅nsܖ |:Hj;^%SX*|\R7'CzC.y"[ s'$(HgL2cO]L*~ FE="WsI=Sŷ 3n >&Q5gQ rӶR'x9/pn>bpILw6DѥEЮ=I eĤ_Beo} Fs1d{ǫvsCQlhxHVvj-rj1D܅BGyHW 1Po,ÛS1)[ 0x /T?_&߭f#Z A5&"u9(A YNiD46 Y٤oУ|hg2-Ulcڤq733_r:h(~bv{*"[F bh/a>wnmd|J'962ϔPd~ۛlG\&\G5M#aj}\7CȲbD0?wX^ؤSWck֧ k%jys(du|5\r#&>9*@(֑A"cqwԮr7$.-a7`rSČ~ƒ O7€'m o:4Rj/L},9" d2dtdtnVK;-S)oDr ;9V# p}ރ%Ž #7"@z( ip7zR 7 c".&E&i3BT$,0?6e刞i!v8"O_8l | Qd}:77׃mm g}倇_>~P7-qDx<WWq{$QԲk,Z/D4(U/Rxsoh7aK [hP!_}8~j*(eEmn~sVagəKE\Zx0,;U ZmQNRK#Ҙ-S b(đVg d?x| ޙVwZVyG5eGB:9t7TOK% 8cjtXqI,p*Im,bO t9ia{Hya8FOd$Eţ?]$VU0Y`T>`^htCA>,r00[W9#j&O?%Ÿkk\18/M i.@ifV=]z>ʓL3ȶUI^^!sҘX#S_Uŵz8Ec ̻\x -J\0p"e"KLBLr]J(@X6 TBnDoA;gB;ޢ$A %p‘ddpO&Yb,>sVv8vcΟ.' +k)l@ [ɝpzjS1?7͆qR3|T3\$EFb Gl#`lpsK}gH$ iuyi"DaQ@J[{=FG8p~UP?j.T؝\HCvL3dno, y1[M;+IF.)^d[jN@7U0\ N"V,Y27!;LVuJE #"D">hhV\ ;KR6j+&--î1#-G6h*#FUwxG{}7{Vٹ|ڈ@){zI(j]e _gyx{;q^Wl~{cmi߇%L; ǗVTI:.YMvJeԔн%ߔЬûaYdRC{ MV/_ӥby1QX|[o-{LYY+t:<;{F\; :ٲȉsM ITL  YrU_Dé>upwF7K I-:NC/,7/HQdLo͟H܏ˣ$ [o\p ZfwrGZ"h!nȖ zG^KqpE0[-cX(UXDn%Tm Ww"nM`\S@< v:/"A &YR_U~OvXio0xXt?h&'LF7$YdX.8QBFlx5 `ar8Ln3ð巼wW=c4ᅢ*Gr")qsf`2 ;hOxnldQWʆO&'R|D,uwZՃ`TGpN>qZY.ڼi-Rmo!Jpm䛣+@aCR6OO6Gv&Bےd@z Yh5H?NVW`;~{vY"o9#8 xX ݞSrdHq؀aqCe?*9MTUޒ(;?5$I) g8#!Y>&j6"UWV ;+FUkȤ1VtwH-@4z lǍsU}1 '"J" lk~8~zZF'uTY9L5G!d,â(JXy:=<(:Mb(G=N=MȄ룳UMV/+]C#]6,H Zfɋ+INsiKȒp޸@ɂY+>`89ΐ˹@,񥊾QAL#r&Mq~ΤPtvC"H;Mv/`5F{MΎX*{at^"G9^MQ>z,;d+z< 8=44n0xwy2~=C-֋ w0hmLlyǜW8!-djV"p'7ZBVoot4bę16̚2oitQ|\oչ}uNy$(n/a,KN@Z=2pZsjUE,V&́m^ G !QWBފA/|"`<)REn~PX_% Ȏ:r'sK9k:=3hp(AciQJ9j̞Zar&xMdi"|;^45pW-e)Me+κȯmz@:v`L]xE=Z31sY‘$nnۍgnԏތ"p XJ}Id5aSJ#sKoGwm?' ՎG`өcTUWjzج/O%iaJ#kAcRKh%X&0z+8~ S'mx 6ϔ}&_i!uQB[lZ e.*dTܸ6nQGO 9}zs${KFɳ]R [*K3/ͤk얀b&I ex~vŔxP &P5xiy]t7&^PFTJG1X"'+n50݁ILR_DɰO!G-tAUQlc7̤!eq(jw_+LUPOؑnB5aj[<]F & 9fk>|]ۈY%sҬ8i2/ú9!7nx'd4(\.榕 o8?s*hן:bsT%{ʚ &MyL_XKQrz+vt/B:XfA9{n7ϋ'Gޓ)];4:)$OYLx#r/PsҤ$#'.T:"liCqѼɽf[(PRYsxȴ^MpA]4՜ʨpdB* 7JhtiU>5wEƿg|^@ NX5=#/T aBtыbb]^Dw.wo~w|5t]%40U=#U9*P\ \23)EߏA" {QjNX)e!f0b#1omou*pvT&TB  ̬b~RJfb6&("2 .~h_B:;)rjŹ~O mB1AM/VvV>Bf dݣ…+%܈mÝm|v*@^f_dǦ'z \Lm C@I=7xG-IMMٲ#Va{Xt^@3=kKxz`zS-@ m6ѪP)Kqh_I&LHP ,7&W>PI0I ֍y`5֖kjM:v;lBDZEłŀ|1pKO>h%Mjˆ)X~3= >˫tlE8jyjZ!+mhK*M9BJ^ctϖS&QJN4r!1Ob dMXdXҁALA.ܜI{\!-\LNpH&Rdg}6pK&M*8hHi%5ZCS1SVxM34J})]Gdk5l8_u9'T8ru\}gl!"_&']aD,U2v+cQi>ߖ,b Q:2at"Y53n2P?"aV23i-*A5%1,9&%êUB O'53)EWW':[+ʔD_>KCd~TF`s" 'l;VQk89=/|g!H2~'( v/-:`ӳ&4E*:1SqMP'۟%mC90`R՝ba@Vo|p8=XEQONJ>*8!箪 KxXP߁5gcy&Pf8ЊfZ=4Hrv p*bџƷ((WUoI-u>øN2^od0UwՎ Z}jM+oѺu[-ZҐUMuӾyɎ!uq]C0L[NeK̈em+Q7lϴ”a7UIa3/jX L?s/& %, É.4CSяN.iwI:,fm*b3g5BKN7"_@ `yrov),k-/L1Evj*˒) {V)N\Rar+gcƬq)G<;#tH :! *e(q)ny a11  s7xPށUe"e lpXk/F-'=Xmbo5^jH锠sFՖ43 b$ DR92$Àا,.V~ MTPs, )#нIhȦuqTɻT~X$Wm+mT*@ ^cMӓ vo>VTOBb7YoӨg )ZRnݓF)AhKGa as#)+:nQTq,kB{1$~ueJ# ԗW &h.HɰoQbc_m` p/sq* oiPx),-7ŗ3HRޤfY0Ҹz˿P:AƊJR>+,N^̅<>Dx}d Râ|[h|z 5 Oo3g.,~u:\BQQD?2$GsHxzut Vz5\E*-K/_뎣Lpɭ܆k%]i1!-cyF,?MrnOs 86^sUCξUٌ`vLn`uݗ׸_mP)&Hs͡Y RA ܇#$I֕H`1$g{k k긁hqۍFtc݂+<} V `6GfNwİ_1_'>ga\^OFLAUOYAIT9J*Q0 oґĤDͩma^7}I9xm$: ޏ :Ʌ1<gb,VdBiÃ2kv>U8y'gPf(l}[4a!D{f֒C&Ul!E[.$xX_jf]c|!Hw, ) ]j, DI. vi,ߙe9BE0pKİ^4g.m VF.qc4Wø w9-[HcJ2:Б[1NPzUp 㰕zB D8|JP4b63CHx vOI*@4tSg!~DWNh d: G{G \490? tr:f^uhʨd- 5`τP-f:*_fkM)HVBq:kǭŸ85[uyI-؁`V F S}Cy-8p |ҁZS9ו!S-(:r#ڀx3̈_}~7qΔA3ТfdU Wypf~Fֽ YMF]ꌤ oLlefB|R< :~XkE1<ˤLD|gQ M0^ G6kT%{5LU8U8^̘ ,kN]RgIM uM LsZ?n#aUƉb~@Бmry5mM|Ln+>j8:Fr@:Λ3?t8ىOIo~^jX$oQ/{*ic'hKnōaX<'à\ƆCDZ>؀UEIy/ŒENʢyAlż%Y\!K9m2$f!6z#k̡̀%*4 V;]jR>EO]x]5qM7ՐQ8իwXbylRfPh5!g$q{/DM`T F0ktH+=eQ[A&cL :փ* 8ucD3<57b|p}=̺hdG{Zr_>;Iz(Oxdc^[R9؆H/q٫ ŌwxRUYMo֡Ǫt-M牒6\Ts`0w1VNN!LvoR:p ^]­;zݫ~jv7]<=eOU']q+\n9pc'2 ƃ8{ ~b+XuN^+A_ Y;E+e&ܷnc+k']ta|;xݮq]qo%MHoY[ XDlB!JmY^#]>%ohj:Bm#T-Ƚ; pNy.3IwZx5.]Sڶ]YmV*Ql7,@*-OPY/ )CYc_Y4jkLg]+63WnIw5 teSN57*Ӎ n7z=-ԙ:jQ̷Vz)Kv}j~;;]9۲;nny+񫟏x,1 \`+n%!DRj ӵw伖?qE<ó7[pOe׮0<{0RRD+ h 4]Bxn:f M,2Y#0K$<|:KW/lrI4`IeJQ'~&v:~Cayp-^ścWb#M<sU/P@|[VYMJjyØ`xܼK76 0G-5Ƀ 5WdEj.=_g9_^Srkoϝ],m$ol&Bټo~X;wX} He G2?j˷cza.FRLH+{Ə}j7rDm b7R(\VԸƽ¸+fxĩCj֍+G RT(gS $sG#/E-K ?͇B盱w$ވ~KUڽw%BeǦoltGzYI:orc QNH' K4CRCRJrh~|,߬9Z> ^I^w_t\f< Ĩ9fIx ]zA CvlWY5IjByk^>wݔ?TP\ ^Xx9oX'A_BŗcSWP pR4K8SP"T#KÏVa؅C~:k\`; Za+-eWVR3?R[H+`ٍwbڨPe Lg,Fky +;୑No50y${76Y97FNx;f$䔁ꫂ=ZG1M(1K j F^.+@+]w[P^ނ@m"E@!JgZ~,p;ҷN0M~CyʋՋx}^Mnfi ~&%ob.mֹz}VZWz\|OzZ86 :Ζpose4i|]Sm8C(vBІ'Guyj_J%p/@qlm , w {+7L7Ikr0"dgy"pr֊{+QM,]k OŮĊi$^Y[JSYFbz)%!e[`p]\Sei2yT_Naa*%F'^F2v ؃8>Gڝ%} YYH*`5/4м U?6KdG`X{k,C 4&hx'7Wwӗr(Ya&/a}0=CwQ><Đ|Jtc6q _gYȴuĢ(+L?80t/:NMyo^LjU7)c8^ ]׵nxEE^ џz£ $%3{T'.Qċ"c'OdmJ\Y>t9,Q_y@n?Ov$+'rcu0唳iF(im+궾~67iEL9a~Ȇ)4WB8Q<#kZooݳDA(?OrS0eD 0O+΋:0!rSq? ҿdB)i5&BXeMmcWB&3lٟP4]$.V}dBՁȶq9X}dL;40܇$(9= |jZȋk;r2aF8[*f W7><#PWf2tC88JtG *!:49fG`2#ހ~`Yo# H٦>՞Ho8H`u{v!ZF(؍+7R6$h$9g(?“J%:I2R L/W!̿4Pe&8L<)r(>r~TLnKgQ$Gm&gbJ h@Ӕ-vŌD _k6Uoߔ矏}Ⴑ+cKsd(IѩFwDMNJ1݄Go(M ¥q`|65c+0@O+_PcYfh%qEwsE>w.i|ځ70iia1I7 %$O7PG@ xWlȣB@H$Q5hN+{YV;V orсoI/i~/SHŜal;)oRT:}g R\hw_n8Ȝ@ݏhWX܅9%d^`.A(qgk0QPBX;ץs=v;A1Y }-M%[VϞy3".I%^cU2t=C[8}vu`=m&+UiGgHw uZJc`o7Q lfsp7%%$ _9'} U'HtMӅT{PQŕt ='`%{9B‣wf $>iܺ:c/U>w9. ۢ`D\j-THDK2IGݜaw^Ga;}U& X;s4nxSIMW28v8i̜[b JMύ 5U;xCG(/xX2hyCFKI @HP|3;Mz9uB4OSbM$vV=m\xR?*{[%d,F)\\lyPQqmR[&Qͨ$9E(!05e. hP)v,q3)A]< Eض=yLa<7nG/ d 򇴍WM5[U#1Dc?{R8n( QxbARy?o%c2@Le8CLM%hIJ5XBɷWekb;gٶB4!u[3Eu bBϺe[V"ќ8 wYSȆh /~-)q`[gu[Z5UI)jVv.,ӍF EƉ(3Hu#<I =t+3)`nс5^q;+eNM`^< E2uarҽ6qYW %ȸ/}F/[ƺN%3ӭZsB}%ah*'N8'V5lgr9;8!96!L1j^Ѵ[j}n=h@'|SIsQk?H@.+}`;O /Z[L?&J|4\:-%yu  JA&&&Q}ISSBtC5""Q](hƽ+!f95_BKA*Zh _-8(W))-+TE;tk|X}_O|<(թJ(=:U HUd [}dHgܮZt2oӐFl!Vj s˯Rz<}n.3&-07Nr_oOڊz"V|%V#KVU21?TŕM?ʼ}ў1ngtŤ["%5opm 2\@ο;Y$CW]XA+4Eh.옰Ce"j$-sZ(L{ %l%ZA x[#-욓z/M|癃Fӌt]gM bgb z*\meڔc=5~ uމ[3 c> Z -U.ΰ&yo5U?k\8Y %6bRH^*$Ǥe~J rW/s:&r]fdoҞWsb'Amx~+Ϻm҅*.{N\=E N9'"s+ڤ@H$4Zd+BtNhJm2*no-+Jn_ud0S&O7s@lAV6sܴ$eі UJ66iikNLEv. wRJ]WFRh@VQ`}T:HJRJr#uWAnrJf2fseS:0Cᑯ}}I(PEU?gDdRZ{V[=Fk=ةV*:dAפּ U 'ѥxi7sj/_Ra]:s6GBQ]S3 ^ÆM0 V1,*%2MoDٰ|p+A$a0(BX>DF>uaJYvF}-lQ*c!qath i(.;x  \ \]Ug4%_MH[n_&{>-Gt(5C8m|҅8[Yʼ3hKCJ"A,|Ο(<\DPPnAXG'DtʙLUezsw4vԋpbYŁawz9}=R`ǸCV'p:[lnx[p+\yT5wՅ"(9+"z?w߃4'uYH{!cp4T1Aޛ{5ٿ%'BY#)}~jNuI\"[F;{䪣o@#=׿|16-SS~ҞsnZj_ϯ^|.)-"Flc(.iN*r Hcq9Kf UC%0x܂e5h#V#k/hFԱ&bX8Nbߏ'\|=r"U+0/*VDM9/9M:T4-r0Eı0mGU!A|׎̉$2\& NğYtAAnoS"Ǚ{Q@5N6 C.|cI2d{ֿ;MP|@Dgމd=@ hiTa6x WcxMj/G%K9ny 6o)Ŭ[3"QwDPO#0zý0O"D™ `ň Rj,C2+IM?-Zᮮ@M (.-J|YQ~ Şdeg1'آ=E_zeeu F.Q9_׎f}f&M\d%A_MozT%:R(6@jDQo͂^}qB(WR LȞcX:1PUB|-]OpR1/E:u:}zŅCА 1D]@'Oϣt>Nb.6\:D@7>ŅgBr@#wfW[A%[Da6WZBѧ#%Q)C@2M# CDL0@Uub@(>s {zjfMNAVaTYщڮ o}p|6 EܒρLE5'ER nEt]x3o)[dLf#FR !0Y0?^2`;+.Ա• %O.6 UJϰS ia2F1h]* jcƕ. nS4̢yj{Zzy*mc4,k11Ƶ=0/H?$(__xX̬Z[sc]%3`̐jm;-Ov=gAWzL #VB~! CLO#ip8Sr!x=htaG!l(7X[Oǎ~)XYWdaK;)P܅XV oS=[3'?igsYA9-n8 ѱbzq g JlXMI`Wq[G?7׼=I%귾qe[L)I rYFWEYzm; (ui)˷'K@ =zv+#TӀ8D Z.})ȿоB>#`ȡll1{xy",jPA_n u9 <:@KI5= V/xo+|cg.b`sR <-);_JyAΪp;js{8W/sMV&X̍ ǚ[`;0 ^C4%ϻ6 duփÚ?NKd6V$a?9HJOFiC_ZШ ^ >vx$p8N qtt["ԡSC|mPv!>TM`d?1 awZ"DO%p!drtҍu 6)6-?GzK9 CHj%bM hO pgRIOP+ҞY֚|L.w2;L<r.#[4M,'&vvTO of2v_o7ٓ3 -hZS:Q-K%gj>gV|VHXeV%LFMD^ף#*(?>MÌe,b6/ i+h cT Nٜ{)iY%6^ 4#y 8x4ߠ=ZXp޾mnSx;xOҾwḒ)A|тF9C5}JU56;<-ӷUt-鹎#X^˹7pǒaj 2xk;ɑVn.]pϭ6cHSj r/eZ#t!ɣ"MnsrXP9MS|Tnqv96TY){n-~ĺp,gpAtN]0+[;ٙl!5}+")(-o) tI>!,}$spPY."(w#}eۉeؐLoU0Y,PI&My_EϥGR(|a_?q*:EF7ڦ K8Id9\]ވ\avss71׺X ߰6Fz] D# (ѡ *EJ:<F#֦]l$I 4/I>3ZqEwJt|if4ȓ@ mř/ |XKr9z/P i:%}M9$$Sda9-iid#$o`&y+O޶~-mPb*օq]ڒodʐiH4lk d'eDK6)ttDwP1$m 闃`=yh)RA@o߇X貢.Һ FO8cmu7S<04L (.%Έ{懯ʫ9v_nOwyU5c9Ëzt-n]Tl[$fcE -W1CǨY,6A|gV>QAoYd5 BL,loP6@}Ui=lF`oxkꐛt0 {\RkAè_CkӲ9Ov[~{6X}B_yRJf~HMxςLo8R&V>r b4z>^a6f}"JG<;F̅c[Z3LHz|֬5㖙sy EFd4Yf(SͶ9"k: żN7;Ļ#HC81Y[k{OZs>(5y?IBz_@{$B&Jx8OTFiDp4ܱv|u, e\`bD6hk+k5\SJU;󾭭I0?~r۟h"v0eH,jW &8| ,um;Z>\݊(B{B¨[%?>Zrj. d/(ä%ʮ (QZMy)"i8 ?Ķ<~OI)R,TڲCdt'l|!$D3}/}Mdmzz=N}NxK?NII`t=pcߤ#S#q`ju!f?]͕pϥbЌk9{Bd!oT%_Cs4YULF0z^K!33`Xwy԰ VuzRA`BjgE$SE}[U,6}K GJFˈS EU('3n.R[( zZn 8tk"]+4y2GƲ/ǸBHhh79ڔ @ .Xyg̒5Sj6>+L4i lF^ȴG>&0;s6[%uk E)n"áV 87 >u5+,茳էY}A(<8i]HlNMms̶l$NIBn/9 |aJtgC1OyTk Aca@Γ0X!WgѴczҳrUVGl>-Mf.q|>ꝐоR,C=Pd=.#[#pPhᕺPC=˓X)iG@tU*5HcJ{ a"*4iރ1 х9hƘ7Lf]dt򆉪+ 5SX[Aghďwv2 ֵʚrKnzVT5.8^N-͕3a׼q_NkbZ%v~!*N{IgyY6 [ьz _(]nrYz>BJcK=qYyUu{ߔjRT!KfiJh$AMQUj;s%#5H5#QwrX0brLC}JM-:/a %KðnBp;n6גIHkYVh>Rf%%莻 ?G շMmQ6PloJ9JheЕbרO[qd sR@ek Gז˸/ G7&3G|0ۯnz4N^ Q 9Ro=qSI^+ر]GFNQ\HD t(nTxwۮjY@O{WJc*+]$h k0xd6k*<y|@T%;UB5G>THέ~ʞֽ'49a94ZrP4aQJP*:Bx4-EȈnjm+S!34k3vQ3Wp&ZNi-lYTkTj΃K4f=y;|𣳬 _YzlLqdQW~%(vۯv^r'#j 3/t#3A1mL%<&6'aGrxzē1Pb1XԌ$&d#&T5PZVú?m!BG̫87lX`]]LѤFpZt]a%  ?; `7Oq =ʪvDjC]v&~ Vrd\n8$YFa~P9 '³]v&!::BF6"aHDEU7Q(Xm|tF%!b5oRCˈuG$,T9/j <3D:>g5ؙ\pUH%JrnZ/& !?^_8,3[jSf@1k i ד\0ؔLڃ*Y^wKx@>7 NT %l 5ڟ#9A0{b?5y&Nɗ(#lYco)e-zM5{X9MZ~X'QO޾z`|ms̛xw <[KhK)J TGܸ~]O*ds_i`$.!:o)N잫\G~ŧ#lR?ֵ[uc+e_.qHF7TaW#%#n=Z8l4Rlb{ Bx ~R4LܞQDM&`/RHњoV5u!γ ^k|j{hs}/\e1@H0S <2(>CK.*w*T Bygd;CFU;EZ>Wb]L9Y/9u(aYnWI_nއS @)͜)J4 SܒGPǵ]uU)jyF揁|y[C3 T?|ݧb~:/Z%yDN@MHrjsn')ˍA*:y>NC`/UҌ9Ea0顷" :+eiR ' (ԃ׾AGҫ4 ]22W@-[G0-HoƇchGuk{cȨڑYD1+h4v|ݪᠩ4Ƕ/VȌI gxdP ;?±Ӓ?5OB鬛J&{Y A?ku,dW s?k)|gʧ/Z ZBqoj\Rt>$#o4OHn[ T>z$M@jf<so8] v^4)*(ýu+82 G QLx[ xSH/mU_c>Ojv2ޣWR\;'/k=̻Û2Eƴr`NU˶aX3 st٘^ʽ/˒ nBAiԌm:UߢH!ôxtEF?)L+ǚz$oVy_ #UMmJؾ 1 B0^B/ܒx8&$ mQl&Y]M7BGK&B |!WN~V盗.8{mjqR?GoTRrѫ.dNCa\xLƕ~oxWѝDK+g4UGSE#BD5Ĝ̒fe6 fA\"%2=MlB a+U?yiCcqiOS֝W=41bM',zڣZI<"N v3WP?1D ^`a{M6{F6zs}0&gMD\Gk^J#;=I*Vjɦf\u-%1NϷn@թ7fyу9T&м#ꗧP:9[<#}ҮFlӖJeRQ.\]bSD vD$Y̷~ڊK )%9T\zI?1ݪ]wrqBN̐ 1v]|8)(FcODٛ=S*lBDg,lFZ!BK& zxŨWn\ŷ0!Y `er^c~tgOg̷7Y|?K}?I.+7֨:|d(.vA(h0e?9>,N?ؤةvSrEX@[~󮽽y@_ѿG3F$a}"U?~ s8,I/Ҳ'Kij8 Ny]tKTG$BM(FB&S.q⤡7ChSP(%cCI"{0J,Shl`:Nu7_%@sōt_e=X2\zTبFצ 94)[bHÁVX;1VNABL4(XO~ؘ5k*nYF(fipF bMTC_B ` C0xdK !yq=j~ANSP;1iv.PuNT E_I~od݉hk2, ѳ}Mw~*]~nH(tG=\RPؓCfbЉK@z [Jqm'{aaq\Cw7ĮypA-j=sؚ٩..ZD>Xo#5}Z-^!5 y/ٴIT-4"C:8C?RR] ^5QE 1Ud"%46Dx5DKp"D8"' :c봕 pQ1\Iv?Hѭ Om'/߾1e<@ڎAL|&Ki3NH눿 %H;($ Dy*ElN֡M9"|+œ \[@:V2 Ǟ}}<֒e۽:?ԟXFuCJIě0FZqC{0wwȷ5EcX 36J1@a耧d2GKc">W ,s7H7,^[8. |F,IXmwt*~N/( {#H꒗!їޝV$;?ܛ:8Ug_f5uez-͉2 #UݫDL= tE}駅7m_NFsQDQ'<.m \ ;CX.v$Zl}T75 n-C@h(廵 v/O"4g1sԏGwyX/-ƘW(tC+~%b}saدͲĴݟҤW$iS3WPU|hM>Z./QDc$^z#XҖ@VLҒy 7RY'w)wB+gTaT1  uKC4"'a~ļӢFvZx7C__s1:&;` ClSy|bĵ^bHŸOt$7.Ok}#z`Oa3 f2yL:\ןJ j}r4&<ƾ_k1'+:r$&M:|XUaK<9tiJyMQ)_mP6lJ?r^;G"R,?\{YAM,NGlMA°wfqqSv:|oG玺-vDҡ%2p4C샕ߋX`e#D䱾  :Wޢp&x%z+ +~A+ݡ3u6Ga?54Ce5 H~DhL.7FB\M'3cB'@Eg$p; >,_+'xǩVLjsSWCkQ^>8NyP\剛Qk[{B=c:>UNGJov 1yds2ĵ:f*WzU$b;H_¼RĨoڨ-YvRn#?NBӁM"9X&OP&20U0];B3%!|wAF7FvʼzAc=<;<@K ;֔M.%s#ݟ_XeC?çJo\WQ0*ueLzEjlOpp"h `#c1;(<|FSzG?6(:\ϲQ510')XI27X<$_Ww&kP:9IX=t7Qa,Gdt_evd4H0*/ACF3V=8J!{&Aڑƴ\{SenvC9ʤ\dGцZg'<D &3j/Nrd ZM jC^D3qEۤa5gB.Fp[hkØo3ٶP> AgX"s,9j^h  JnZaxZQ.>$ QC]T.q܍Tw2!lЖpOw5Ieq1+Y7w-)ʁTjq)17'' j Y&L "wgc3 ƀ< 0I3xVS4:ebad]5| ej)wQĔ ZiBh# ˀKҘv:XX1O Cp5ނ+oң D?ʒ9)ҿ.wfvM_vSKGR_wX}-I4^xx"a.m$YF>8S-Ϲ:+Mn<ksDž.!Yi'[V).! MTRՊXW/ VnlBx4V@\fSnHi%¿ݦpƩ}gZ4xiqS:6•d7`&~ ̐B"l"<*|~qkBdQXr̚+;H(;Gs/ď"Q?iPǮ ,9%a 'A>i i6y޴'YsR:Wc|H<|0VX@L-1 "Jw3s ʡ*͒5MwbS 8e42و. <m"PGl(p7qۑlA}!NqCH<^T"l;uS^F`* kŹa$"}gnq|DGo?!ˉ+D$z<)N0As$5tXi]BNlfpdB < +nzu!t{OPudŸ\ S}kk 7bQ>جN] Ri̼iJ})"T&[#k'&:$hi0VKK0*O;zvS)D w3q@!n@n$c#IzpMӠ=.6eŽ9y `3Ѽ9V˫SWpʫD7q^f@ @/dI1!@,:œ&.x̥u3B*)VZ4F6vwe_ {>mIa#.S_shc7J V"waj҇uT-<%X @ QUУ~i(tddK| m zu֧~[C?[uJeH(m[f5p^Ou ]=GgSNkzYIdk55сm$ S=f9j\;A.eR1OgYtY|ro؍{Flbi LB<n-W$pH ?bF"Z? ~?_HY55B o9BWqse*cr8?u4%fMu[ kASw+Y.2hS٠ 2[|oF?n"$PQ$˞qv;pZwt=`źSIkzi Ld9xmn E;d-M;Mr(rs,K۷Jp{]b$㴡h#0l!OV1l=;R[Esos-F 6 v.hW!-tDNy"iȋ{R%m~ 0͐i+8t,*WV#o5;ɠI5:Y08Q #~VXCB!+!;4v,/`Hގ5''lʀ/𒾐*ݪ{~O&knOn-*⑎X̊<^=M&N;؂{}q8va˺e`zM+/ggYMlϓnHH%W#2Q(p$bQYbbIZ٥9gD4@'om\#ǡ򓿾*mvϓ'Ӓ3p7 "Me`׸bd !tن.2M: yIK h.PhFF[ 5gQ<6L 7oa2։_N0l]z ޮ/ mX/r ѳ끣 rlpE9p=v`qZnRL7Bd`i@-Sni,fdp{҉yާf;|t PlI8Y˓0-_9wO #F݄oUЙ_ @nߙ?+B(t9-~# _KG r!)A/l1rP/i4mjA0Bb&"t,HQ-{`ٜ#Nm(ux5c!4&z8{erpIDSجܯq-X. o6Pf*H # &mZoy9d'yA/ >O mW.sᢺԫ<h܀=Tl7DݰI0ݲdPQuzOS_㤘!5eLW5w+!fVG >.w);DUsw27S Y`(=Fcq񋉊wկzr?~!@| YP06*:&ԟNa/(l#7&:0?±gb0X5RQlCp}3Xa|_p[TDF^iЛJ >0Z0I"aB} (_'RfYOmp 'URBKDRA:! ,9%fݺX&b+"K.J罣  #-bYZ~zR2C4k5r_* )Kj xG7#8;5)E.Ӯk8-PL?aL̪_y;2 lP_؝8pǥ2/ ]Lj b&5m ~3Z1]/4z>Tr Byıw{PC)bvxպ%ZG; {]*'L5.uVF_/(REu[= oD၌sou+Z zS@ e,>' He!8udfا5І { kf5㠉Y&O8q9ѣfpNjRR\;?fρ6$n wFa'w NI!T7Vtst708J^ve x&'릾0Dәk#\<;-P9j ;יH<Wel8A#>L_Xy Bȋ tୂB)+LbĦ0$n,; cjEY \rq &G$߫U͜ԳdA+X<+ ۠EZ@ǨnC#S>C ;/ո] lWrJ"!O5 HǟEiM[7$~fW$5ScǞ7*uRP^:.gj?eʣ~o٨ 2edkľ?6<:ͫe 9 ㊪ bCi es ]@S5߽7z'-/6\+OzGh7R=(Ae]dtG(5Ȩ-abku|1Dp~5_>ӭ]SJh2"00;i,֚\a[>" HS7ޔ5_Q1ڜײƉX, [g jeP^\vE䃔.1nS"14C@O(j@5|⓫g^R"\5ݤkz b1XC`d,rOܞ-5c䱜 3Zg_!K.Z6(!._~|N݅>497E56*Voo`Xs'l@NI-B6Qx#1_jρ<гJo3mx$jre٢a K3F0x}8:2Yшf@#䬃Vyv9( U0IV d32_HqD-%m GqY9'D-CɨiVpCs/gjꙥ I+_(]Fi|ԗIPd%`ՎfXQoB!OAtlPnu^7:<Mij -ni3l-v@^־h +~v}0-%F5Iݽ35. +qY +ד6b&cVqozWj7>ףNk2zew"؇R=*?o aye{xE )H`4w+Ͽ2 %37ևZa.Ƥ>K!AvezuԀc=չT#-;Nfbp[NzwrWjU۴Nyp;'VherbΝ?ӿz4&i?Q آ9v 0"K2v4֘дz',RMց4/8ʡǯ*i5[I=2`or{b` ?[F,@MBXZԂ&Ҁq΅-ArB9.=) = t̫ ̾ D`5' ] +AS,$* 3XO/ȁVe-=srbplCs: *8I/gl5c1}zgxU`RUʼn@ eZUӥƇ( ǀƲ {/(Egh= v\ A5!>m+H4%j^2 rP-Ev$Oѷn5PԬ.H)11ފE27O!+`ީ:$,?.a]Rf7j?Rc,uƝohq>9Kx BbM_ n-`{7OԠ:5t7ғ㬉VXB@Uf=*3!$z8#J%А ,w$ ǒjf|Ebڵm9 9HW${Ĉz,<\H=[ԯ ; - [@JXVe̚˰Qx FUq Mtvݚb˧ ;&K!:b5KC ɠ&D檈Et[ɻt4 D'DC!QqH._[Y*Tj0CmgXqgT a:оBtKxiTIo]~d)]V{_Wn7rӴ`g>z1q;@%j'JQ#CKXHP~fu䋍CAIVܕCuYųŌkW4O@J \yn-6o2@ 53.%cd .H8 @o%29.Ϳ)E<wC>GV-56@]sR7cFʾc648`$VHʲzrr;&=LγJ^Y)z"J68vZ= ~S ΄ƚ\dyVT۞րpֱ'7rp9CBHJJ]%v Ye2|WTEJKה`diSA"'VD!mk/(? 04O(q*"l GJ:qյ](fS5M ȏ8R䳔~s9ڎC+Z>ڛw` 0>diMWTt'JX:݄+m! IJJa)b@i MZa_1rߴX6!^`bL OOD|RW-5{qccȔY;k@߇/J>`B~PQ ' Pyt;ϐr NJ6{0^ۘMέ aW[8 m\(j@ΎB|_4ak K\`Xr-B.Ra܋Ւ$&GtpeK1&%UABX\=gvh- @rn~N#W3^0SV)zSWlXg#O{Z4ׄf s ix)ʨϦCzO ,ͧϚP[I;=BJ6e0G#*¥6OkE X3i`kOcE"FF$ d/(Jj8B\7eq;Y6ƥM\+zJf΅&8A2C3Z<6 8xF?&<].47Ea%'kQ (]击 jś:.ͰP]-DNts;MQ@"}@Y 3?KpJo->'z˿)@F4 ujnB Hlgëoy.'YED~m 5 Pb4#YEo+ "[SJ{ }4io}?dȋ±&p^+G0hƝn;y-axu9I`X<r"04m bY8GzSY' :0[ "el9 -VܝG:\Jڙ9x*<|@2lYTGQ7&wJ/ d@$|Ř]E:UUt;bSɨ0:nr#n yPs[Ao4aEڀD Gk˟~< &5885&YL\\d'&|WoW H(70$xTK}S_n1~1ڶFˎ((oY!c?zaAL~D0/[6t~rP["[NǒyeC 2$nqۤj;Y)T9 c<ÔN۶ϽGő~!ZR3'xF=[۫ .O%yTD:btʇp\3k Hhx H*[YXE7a˺}]cOTrd1;cI]3/S`v>w!dsmzV0,^N!2*@ؕrGMZi#C&Ӷ>;~k\y6˫LS|Y`{_VOeJ 1&)fzE*:l] KYuMHJ[4=vrA+G3_ƫ}Ops1ۏíɝK"̀}*$GPx1S*V- +9t'F/*t^b${(ٝnKVG3z qĘυ XnܴN@yis8+/_[hmw2ݝ!p?cI:T$MQ\oV9 :)gEv);VԵ>r> UM;f^-"u8;kȜ4j./Q=:q$ε p ghIQ nx͖k7L(lʚދENiRj zFxda##4^b_͕s:]Pm>Z("RB\v ~쳉jDO_&& d oiX qAR?I#s#u@X C>5)Oz-p {T@)-/:ZB-Hb!t Mߗj&i18p3PΟ˶[kmFs:W1U5/#@<f'L8PΓ?t v e%H^5nZ`ڀ^m.%}7mGŠ"}1u㡎4ӤYTuk,Ġ'~ |vhlUU%C^6}>d)؃2 1 07.U"`1:d&,k-Rg=N+^/$ $d$IC>3Eff6 <3G$˨xm%9 t}oy}G"&|.gckX<\'@rFvqU޳T Γ8e]v}m!2 TH|\}O*Idӊew.Ly>XCn%2˳ytyeh<Ҫ DԏXܮ$CC &Etj;_| +.ဂ`KJ}B';l KUT9۪O];皊(dt? X\oT{#&G!Rv-2 zb_ sb4W@cC?lullŊIJ+̚_Đn ߰wy:;\i/ĠNè0mdg^w<W42BfSn ,JY̆ 3J/4a 42VOgHʐZʻfhLV];s8Vg?h|GcuG}8CʤŔV+ѹY vS?a є5HVDH09yިwxZVAk,] kb(Uj#jE_4""}@==v4+L awΤBavWAw€׬{_gPivj ~sBZ J]Cy<4RO{I勅?$N, ĪP/x:h. NN8u5Z&b,R*QC̩6#i?zN)7io;Mbr\6bm_LqZH`?G_l\>VaA dK ~ia-ivK,Η!|ʎ8L`1x._<H">,幵+>WKц'H:wߓ sVW@ͳ|9ٲ6xÏْ@>Ɛ-dyˌc!.ximLK!a!x!筊-r?zeXü~OUR)e쇼Vگ1G잞- }7 f/:%qX4*A4Rv6vmo3Ƕ9U _bFCnD쿺ƕ?ߘ3@&xQ F~־NJAng7pѲ;g⅖I\/*C:nXFan\[Kr@xQ>&M]0=>LZmZ{J5x0ߝ#]X$BJBwmUC.0G7Ȑ ]%N"QƈBxaW&} AڒHNc쇈rŐ"n&o}+'+psUx?c^ctm9آUub~y|$f'Qh7S{9s4(*(Base_qNz 韝A&sSJ[Kfp9j]eҦgde؁rT3Bmid<`WS>Fc~ B$9A 3@ 傞sE>hBE"`*mҺ5!ʽj-J?6/x F MpW'MB?Ds sdOa>t:́8)vsv}3t: K'^%sD2X/c/n*,2ZZdFkN/9ʐe릭x螠,&嘓A^N Q_E+߃(bl]fG&dzz`OXzk)ÈHd0u!P=,xz(1cyRQNgF/I7.b|Kv*kzTQδZOHYs"ʓVLmeh]Fo`bMv!(ӑwAٜddjb#̞{%qE鏥Ft&c dA'0} lfx; ղӊ%7$ANUE="|so| v'W6N)"mTsdȯ!ށ]*jrWd%wGb.00ˋiK<(3UJGx 'Ǜ`,-V̙l[> ,T>1gǜ{l? * n [YeZ#^BA^PU%DxYeXsOةaZ$rl+]Ǭ_Z=X\k)*v(mעZe˂YSPP%WI/=?P;oEsێ5nW #Z'N*L?i.GݬHL#Pinb/Ye631 LײQ=ˇX-N/d}fHQX)| hGYbEcF~Y`sܐ8Ϋ.Pu)&d72ڱ&8zԘ"5zf**YMM=4c *<~Kpyet3E8^u0,&MLp ײVZQIb!pM<+`M寁ۑ]_~dj+s?}0'iM>v3{T,HBO{ӗ,F(,g}m|,ˎvOQmXǦO I sWvk(ߡQFeB ~}Gp3,So3u[q >toܬdNG9<0,Y J0:G&TO?}`B>ocyNLz,a _i[4$'S>ngA[3ȑv[r^R*)'f?Q-:j{pVti.LhҖѯΰv0-*keh{ q;N P~(JX~M e„K,Ķ/=/D,Нx8:}\nJIGc7ۈbgn_ MU~M^X:uG^WD6Ry U.h&f7݇JDP{|6;n#fԝ]\P_:3q,Elb*u9ʒ do/_5d{\P*&Gz >~'`KC*,Vx yA <3vJi /X24^-epgVL!׹ߟMa:4s¾߲W+lYJB9I,[&49=Sr\D\I.|\Gɤ;w-71^~8]zq舳G&o);%P s3}"w$gѰ?V}#;ܶtaGW$Lؿr•NJ0ڡuZraT]ԘNRs9;QM) t%ӁG o6Ë}2e4z]jxx|B5Sze~4,XfA9`lJ8.D\6"іˆjbI3 CZN [j]*^%˽hnŒ#C`m# mD.),>>yΚYPhB\UlP Eˏic~D 5&5/s_fV- ey+XoˠzM40@ҭ9rhW Zd>9y`ȦxLȦ0߷F.k-'S2#ln[ A$xK \ {kc]\hbm?*Z=B"X%m?!&6qrv :o0Z+7gNW zݧ/)qKQy61-YƘ8;E'k UGߣwQ8愂_C@N]Vƞ){s@@yKP6SC'87iFAE&/vbjwcXuM셲$ؔ]:nW9 lt5^kBgWxŞ 7L@Sخ7X֦V'ϢlWc sC2\Is^@kg' 3=/# s n*yx{'iA)koÃU^$j 1&C]#V@vy-J^y[sS~ᮯ0?8i5J&D&, v[lCot;Cw$,s q_>y|W]޲AyAþ=jlD9AkA2 TZ8$2FB"d?j SHQ'/' ςlLbd!To,7).Qn>/Læw2& g/3WDL(7 5^g)E1և̰v&Rr_037 beo3`Sc+&&$t>L^a:ps8\$k6(VJ mjڕp3-ep[P P r91 g¤ҭX8ݍ0?8m+mguNZ3+?;s7D 㪤ҌNutUm-tW'[@]-%^9~)&pYK!ڃr=ݢS[+l\ΣPk?I0ٮaP@ߜkCamܜ%kTADi0 ؞: 拿 /3U tڐ$q>WJi*2<1xtL#%~[,(sYiU2X;h*J`6묪)V24(lø<&]CY(Q}_e w`ߑˡ۴^sҵ^U Qu2ZF c]&{h@ =S]|ErJF6 z6-r_K|C\,D>lgd(%%-7ZQR(!!&MԥEaɫ 8YLځձC )Ǜ* YQY)-Nߕ uJ5Wq/䊏B{)l{ Y#}$Vy/4#RhA qL83E"TLR=Ma:i߹(kUpn O.>Xd]Azw:dQK?M)?S/#Y6w}9.G.A,gB/X$}F~*guz펙4`fܲ;oK0U[o%NB 5J c7HVҁN ]xN*ƅV Ybfܕ!al#Ҳz2.IMBRXaX.)h@WV0II'DTcYą)HD;ӫ]Sf | ܪRtڈ嗣.6m8^Xs&2NK锰 po-v7CK[i~[jY[iTZDժv 4A=hN \Sf̜ܩOjKrWT ⤀s}m~8Ám-ggP2yT$:j'!wt0z\&YK.66 pE",ݥ="vaIK(=,PlWu,K_d.W-ဍך7m/ ' #rNYfM>ͰF4l𳑦>$)hrGE' *oP qKGbuQO0mxµVVf/\VT>=jGjqah}WT)d.hv7C5TQI#VdAEO? u >(v)귫x&Kb`sr[+ͣ2=;ڌG}Yu(q0ɭǸV!,FCLvto2 cJ?6, m7l̬*gW"b>~V^Z|5cg'},  (8r,k\x _]Xs7/)>(nj6XOCٝ8%gLe?*f{ht 7N28)scs/NA:6D{Tso" JFyVK}Q,5c{ݣN#6wwǒEU̳>uj(b,\^7TY1Jv\#ˍ~ʱ \2d3d1LاUHG-9Zj/5t~&A8\KQ\7_D~߫k359'Zv(DaSsG!r;{DdGkIYlf$gwT n\U VP56fH[M6PLG@YxzGmȺc՛Ը8'y3 QU;蛌KK 0 w1wi Cu4}ܑNAD2YÞ-4mҞѦCKr;@C TЕO0-@[q$4@xSgJ0VO1 8$!L@%9VL qrhl'\e.FUb%ask}e(EũY!5UXxm8)W\5-ǽ?~]^k[)p:Y;{Q}?Μ=t szGYK6 0}kzQYRwTg{CW>ԲP-HÙcfH6s<D”FŮ­Xq3d){B?Ez`!2wvݔlۣkH($k hӃa;J?$p8}_-lN5 O  b/ڳ:W}9$Ja5jhAΪSrSkNGq|&(E$ul`TpDw7gu(8u$1&'iِbm6~_{ 5rȲ r;P;1w@AI%Y~-.M|}noэec,EE[)]>яL63x-ߑ>BY:\"ޘy`JRV-K/ gb>)RފWtתhCB%(fJ>t7aJo[ä˒S kԠs riQq+GK勎۞LVyɒ7yT}s\٧pf,GbN6^VSᡣ-CFmH>V 1S(bKβ.VB٪3}jhh'^oEl _w1:`ǻ5`ѹ-wDd+nE$Bл d$H]HwXYT`׎,?4oS({n!F:6Ny=:F!ŠtR&kNє*d_ \Usw3gco3op$򿎎"z _y4R`HlDp4҈)Ҥ .n2Ü7eZ҂l2!4d|;[t{)Do2V8.dɗܮ,dC/dcW,?҆8gE)79atr8?! C}]"_43|qU0N1 @)]:~eN7ȝQd2;z@h-Դ5w*?{PҢ/9~{;D'䧹. *1h؃c ȷo(x!oo5x<c YaEU QJlGA+n?\*TY6LL$G~U'L oB ˫-[.%ӱ}HAsq`~tkثgH*6u1O]=2 Ap%>Xp tN=Te"q TIptPz Jh_gn>Z8״CmO ǭJ>9~gx-?+o\YFݕ-͐ŸrZӛ ~KswdaqgGk aC^@(R~/YfQ. s[HgKR}B<U87m-CO~qr͂(oЗ$Nt k:?wUc5򰼇׍]u䃅4}goI!9|u%q.`oD+жsH_/-S1WIV]۪+O`B=VEE&|a zb8/8P/أ`/"&e#JMD=g|moe~j+/o2s HҰ$fKjHеROI83xѺsl[g-2P/ kEb UWj $a(ܱQbj[m~l2KiOm?oy>V9Tg,k9/6Ǽdz7۴R΃ƪ 'oP!ޖ 懟K3g*:y"QwDo4+ w!tD[:#L JB 6l7l|r* S%dYcoPT> im$?FuSTÂJ r(pduD#sE䠧:I~vuX/RDIfN"1Ô݈_/=YC #sW[<{Z`7g a`-*rl,a{~y]M!^wIv8$Ǩ&FG{ͫRM~C*V @$J_7o.$3®3&]FD!֍K z3J3Gi5bEZY 4脧<3ƶ#}o܏FAF)lśC/sl`6PQ}ׁz*|-\+K51J~C'W3F>!- tfǠ͵(M7$G2^BE]- Dk[hud+:Nđ|^=z; swbR|=(!:ݧy1>ml0 鬼 r$/25#.Z.+f@'CM8 j8Aĩ4hi*Tf1.θ*r҃,Ͳb@a9m7s43h>21hcSJs/b EA$~4@뷛B@-UzDOYTA\'3e+ϳ nz_~t-E[&Ag$}W]Z L{mAY[i(79nϘ2ks(v 6}\I?Ʀ 4?ϺXUiS;+ DdP[SÞkIݗyM#<$Rjs0oSJPQNkmVmƝ"gi{_?t7F☈5 -8\Rr̬+A EZk:`, |qΞrl`0' @r.A$Obip9]w{䶁hWA6W8=0 *'s;ͪD4B>If!r^fdQc)R"%]Z*&SEP'WpI]cv;lP(`ǯڷIP]I# 7J, $_&ENU)7^+D&jOF5K\1uV~ A]hińX ķ곇4p6`):{cbĺ}6HP éey'T2"29EW%~W7"mH,% 8D3/;t|~)4<(NA)}@Lef!V QjlCYuxKHZ \4'ӥA>\QƩr`qѻ~ iW̄5\a`gn[Ӝ2QxUo? r]j=:DFLjwO1'3бe6Cftia .x}A*:elҘm dKݖ͚YKK~({:;Q7yQu[^< t(1[iV&)IUA,;A>H.-+[fg@qFoZ4ڹCHohO]Sz|VHR%ԇg^F i T'\Ayc}j#J8cLz\nAۙrB> NVD3٥D`/gp^`t7VʔWHȱ+BohNx4?I4ARfIS7 ;:y_5`ǙH,_˔D!{-Dzӄg1xqh0E5B\ V IxLFl !B{AF@$e_Ln =n~I,yҠ}PFX; Dspx[tA҆>HI"`RZ ,%KxuD'U`X L"0,%j; 輋(Q_:,h‹{{;h#dH۞O,18xm,X':rMn-HHqɨ?g~ގqэ|r)|7GgbhJ^̻㻒\7 JM ^zM,ytḳ2Tp{HHgRZs|l-j;ƈY)PtX%I OaB-xi;9Z6> S-f/Zsxs#0ϓb 94@4ua P8+ža2x.О?x#}ܗ9#mjd4w.j},ؚ0)6K֩kL5 mwk苀peؑ21MVڢ3ߑBd#UcY{>fұq˔]@Ne(Jkeia70au57V| شt&I  DM{[9-D馄V$vAop0J^f\&Y|x: %ѓy #r*AC jJ7ëIIqu): lۛ&ҬBIՎ['l)S[u %='^>ӵ.~*їf5s*3Hc9092Tkob\=SPr:|/DAUU;o hUzPJO CT CI Ur) !LO(xm6nf5M2 "u 6zd5*.*)`8&t2S^ ; q^÷FJqmp&~;>N\//*^2ZG/GIAPO:aWn8r G 0 ͰF%A(GxW8tECM>SGZc WZQvq7+Qr:G a "8Ru,B2s˜VZ,",K\m~N\*k@^VhU%ɴ=3BOaquߝ&uJ.+'ZjA!&k8DGX0."ϯ2cUu}LvwƬ{?-*$˟W-*J(~й]"w:"/ʾ:\@X @Ua@-Q 8zyezV!<ڐ~ 9:Kѝ'&j`i ŋPp2F .z{Ġ厇1Jy%vOl$\lft.cwω$7&T @'uט`ˏS?OlJ >]:at(&'H|rȶg-X%C!YnyY#t)bX{BC2/Fr;T*<ԧ{Aϵ}hT3^.0fl ^ |/k:I$4A ~fb<N9gXtVޢ:8zkᵜ;,@ Atr2s5qN$e~$Ȼ:[r"t7h; ܢqf`YUC+*n>MhElt}a8qKiC| 6c6H\CE*j>2i>YfԴ1}U(xoSlmy;xi4])}'׮UL-)l1KG}]K0ŝd[O1~Hj N=~\ADYcH o].XGj ƟNV7rDߜivr,'Ȼ9oV]w&?tr;Vbڐ?B-؈$R0X fvw>lr@ry6cJXQ-/hJż#:yMk;i<]܍w˝ew'#Owt?oV5>=l׿974qŒϴ$]NW |P(fh,d! H3j> GބB!Y uz}@sQ ofrm0sEA8t;C^o8.wU*Bݖ gc٠sy6o`~ڦhOLU. .U&Sg:I9 |y2eoHesqEf$]i[̧9z,/ :PrL],Zt\ei'bQ-?׬>G,+д@Q"GJ/`o+c U`[G?C_ww@|S#\S~(y5źS޴Rv0z|yaXiJ鲐ƺDNyxFC52.nV*t)b9ж>D%|\Y<%Cj.XW8uN߲%=n͓ j+Ǔ,MM#z 0?cUg]acH8IYq`/Q{p#zSJ X<=hq-1 UnN͊Flrd^9?+ I%d)՞pCQl/ iDŽ9a?q_Oi\jrUF9̼k,68ì5 *mg.\V{,ktc:~Q øHaXĚLlZ-@oCSy-'H (NQ5Z֭S6ѕsJJEJ_2r vv S?EpTlw&y>$>&1`$Ր1@W7LaFuCQF\p::ٳH@1W򬺶q+1#{R*wa@El( fы ninS[4AʴT[WGNF:*;6WK]dI{-N m|C`D[:IBM%+9;g#.ge22ֲtz9<1N=0(Ã>; ܀|vy-Z>[0 38['A˛HhCx5S Fv.M\XZ*P:]ڞOPCn v(-y,K+έh.%% Ƒt em㰴weks3Y&XثvZުَ30u2tl/ =ÛU_޶%]fdPm%La[_"7zF_(#8#JE&Wvwɽ @$ k Q4\ʆA? $>3_YKgtQdl]r[Hip v\m>[a&W{94&!i\h{*c{ q;/ŻJ◜gۉcdi`qka猰քv67xЅ͏mNl\zg?w '{O ;)r+Đݚx{N0.O#Vm-Ե΀PWnRhTZ<+(Nӟw&L֑O* djTt P[8gDb'RMg΁91cv@:39aHw6sѭ(/2gpҪ[(i+] qHkBWDn3LG}RAKɐ~ zfރD,P泭<цKF+}yA4h" Fϩ1mR@/2xT(647&nVN=QZ5=*Mb28ᱲApYBmɼ`p}~T Æ&T'i̦=( }43 uySo O KD^aqCvO\DC! CB mq },I]ho;N&rt,Vwluޭε6V+,L@[aZA2 #vWCDrEis@*Ԍг3G&*x {>EѶ㨣GI5OZ{:&=7OLAH5GB\$vtk,'R5ҏo@7f/;82thsܑ2 WMEWVL-'P|Lۥ/hS28DBRuظ/K9b.J&%rX=J[F}8cGqixZt2[(fOHÚSs1lijfSYGI )#~!^! &R|^ODO}wymDƯ̚!r 0Yrpk|^OND}J$ jyp}lqh0ZR[cKT/]/ɱ2+ ;Ҳ d#XMk|U9f"|b 0 9]7h-Vv1).cminr}BFEiIb8&k@޼f9 ~{>Rԛ2_ cDWcCJv5\vEШ}%k)Vf } CAY=2%ZBEl#6NA@O{Rxl-_VNJ ;ׁ>&l{-': yEy|c0+@JjB:R,US_JvӪV:ZUӲI WvT"c!+S,E2)T1i`M :-˚r^XBY D;%ipKF6¦CGch=Y_r-꿕9ύvjgI᎘>9՝ Xc8:{YjD#l ld^y [Z&t7mͷ~J̹D.ҽ<·tTbA CϙhiCgMH%=/:̓Y&N2oTqn,] òO鿞K)w;lC_}葊)vnm`,=i+bƪO6rh&,``L6m"6 [ CXvxђ {\Fj"FO3#U7&sYG4UUCdmR Svo-Q6ylRF.g]5X ̢i0+j=W,b$ux]o `2rbaM%&Tu:9/ "|siYb|@ 3Ykdߩa׃ J`ÑN%8= b6V7LlYECܑB*|*lT4qz>G/`(\?!3BOe7ҮWRB !|-t!aTU ɠJGZ8qbRP8I4vO޾oR] DkL(#&3f/(hȌZ@DT%è{e-Mm—ޱ61*l O ZQB}؟F[]wpR 5_j%9s7~˗g{G3-~ qHn1T8K)Hđ^~7ʆ8.,}w j]qAyQ7!n;>IF@:@ʁĿv 0@dg7O+ H/7a樸:^j!W^_~te."r9Ee%רrqjYFt?KV%fgEPj%$ȓ449tY(- [z jm;7+gNVe]zTMqq9fǙb,6 @-@ҮBzhe`6\r؞%\m(YOFEirIO'-? hu#yҒ ՄKb_*!xt\yf: %˕ԀX\12i @/3!?U'\Ddk_r&Hє,er0NsrWBݚ',fU`-oA&p(tQeg^?ڔ\bhB!!: T5|)qA-@o7ЛlPsϔx4x_EَY֬`].\N#eTDVjJ3o~{~3;5{sQ2Dn`vUf|,?t)u/tA:AOZCɐKCw70aRMj(ުtyUf{hk)_USǒo5-Zћ3y8Ha1eUZt,:0dGזНXԏj|fsY>QcrPܥ7IYtld=$.ίe^/fuEz9KDY~[|&(X述+/2M30C£阻aJzWyQnJ&c|6;Ah 0BCC}s!f.vLw&ϩZB@sʢYЇ,l4Cn CxD_$ ;&sr "iT:Dz-9z8S| Ԣ0e˜ÂtHjNϻ46pBt,ԀwCXx*%NPVu?},dE[["amB4+vy`]t+ #hjV-dzI??ipAFU까{S-'9BC/2RRTUƠB>&+{K^΃R\SU;-WRh$Oޕ։ dw\[4e_>x{yQaW<0;kJ9u~@F@\Gfˍ7~Kqm0hc5ҧa$V~ԡ_S.dpᕄ$*ixW}{3 i qX_¢ Djz WL4P%i]1ol<(I M%$q+Lkz>_m }cGn4BxшIGd8b ,ǧpf^1,J]FhEASuYM5"מAN*!'>Xm-DHd9܉ѢT(zy\ 0kvc/\Qݐ ^D]ZX~P%x_#a1WW=XIZ8+oZz::jN΅#x`G~\^eJ$ _f$DП磬xz}%]? !f|{5ّú\Sa1_y:^tMLtwNp,DʼnoW/ў I19|_tGTF?65Q JV#f紒q8AMVv0}S{^깂{B˔)껊RoCzAɣtN0VL%< .2\qQY|=xů"M#4*_봈#=NgA'$H\:M)suB$9l)U68 V }I9qqxT/L@/\.0){0ec}x@zAҎ;Vƨqڇ^21ƲgEhf|ј{H+B|JCF@dx9*<1دCl5 Mz!epLbrhvpsu1{wD1**2TC*~G c P}WddWqӞ_5 4HO|up,Zbm-xXԺR;p,_ܰ7 MQ+Hs]_5R |dN 1s9&G`j- [SWә{6 Cr D{gt kVz98 `L}/dOK͑c2ACg'Hcť &槢LVv0I6ʅͪf:>!O>j3%UJ%1 "fH"k>LSO۲:މ`#[#<9-+b(^w\ιo1c/$ }ty}д֭EfGVe$ts~5n'F}kG1!#۬ҏB[M:feigU+ bJ?S/ [#7B#(0%+ؚ*LR"Qf"dwZ*+#N'C",Ί{)D"C(/ 4+H41nFGdJ_G f= GZhY҈‡9mѾpE Ax-Pkze 1k0tsb+?G!Vڸ\C-IyI[#B˘K^7v[A,Vi?fpk@(f m=\>GS|˂vPbeKbB@diۈ2 HF ׷gmӛ~:d$kOǗNlBD!bHӲAE0~JN{ )]<{7$o"vӜ+V5/4CFD.i%FUvd|kzeHrF67 >^^R^ 1f5;(inVz5N}ܧ'߰HD`?^UHKpl:VCfOac;e7P*̻Wmkb5m`jSJQQn m`|9p叾zCST2ɖP h4'7%|.cÿ >4{xZf@خ"ςY9.'{İdCGf,͎OrhMo]Ip7#uA,bryt=htkHTi4xLs@WAn鵦s 3@"R$DV7o+sWtJDz|+ihF&?'(-Q==y (A|LNQ}~43&xΖ :Zy4;Tx̅yoFΘL$WO?8P}#|21lezwFxqMh$#f?>omw4, It7'P{Lya98#nV0ÕRG:Ud~rhqF*E Y:Div$4ýO>7t~CX >M%V/PO,(KUrY[QȷwM0!;A̍B)O3c>JNɢYԖ:^7wLx#9ؼ]" 8DH&ڴh6)~P+r?fo߼\.鏑BjUD-O&a5CT$9M}^XggWACЛ ş(6 xEP."(0MݾwiW:Y;${Ad 3\c F;: kA7ZX m ,suM,9^roHeH- i 8͐ i M%ăqvfS& kA\ 3YKtB;W .jI!b.r#p9mށtI\^nS-G _!#2d*?k(Ln%o]co'4'Ffm0jS]j ]&gR$qⴁ0JĠ}uũLmi(NBEste3L{铂|jqED*(qjvO-M-} p~vhC"ii5&SkoZo>^`Z&򃢕5<_7``e;} /^l4|$EX$_n j&PpJG9kF9)U)oH$BR k6Vg,wAb1?]_ϕ2{()`fҨxR,:W,:I`49G,EGFzIGa|̈́w`gVep 鱖57&䱗Gx/Gz2 <#˵Bj Ow H<7pmwB {[X dZWoNXb`ip-AIԻp]3I#bc6b<6;q>>.B:{@2pY^y{VDQn8nEDm巬[ڱKLep>>W ]A{Cb#U%0[p )jhm<s /'3Sl+Mn&zh-ҕ}cwDEVƄx(-Ĝ|{ w7 K rK2J ]T!`ZF R-iJZ2O-DvA^^Kd' ځ|eJ4_zԣG(oYikh tp(e̍!W *E$P~óӈgxW7$Z^b|uSl:M%OC*Uh3DRzfƭfq>n6% %F )Nn=A 3ԍNƒ0rLL[29Dqb#Qo"z V(^̳tUY0dt3^sxͫb/ށ>Xe:9 L"L!*W?9)5'u9}i-y,T]~aF2}S89VZƿ)?}F执yby\%H4yPag@?qQŌ)YJpbfepDaAD6S;f䍃hJ+N)ɟx>|ܻv,??s5Jfb:cɌƢP" |@C-Տ h+Y (|&Q) rz`57 _w69r>޺`WJDWy5hQшjq hG4X"zX#?8N$jnVa6(2` WⴴR|Z"G| Ta7sGmvJmn. X*C;;|!wW#/'f-?o Z]40(EZ2qfz^n⺾9+|.HE_I.lQj5- k#3uMJ4xjZVx锅Ǡ!4G>%Jp2f(i ;|A,޾l-Y (z”ԵdD^h>`.{&}k|@(uX`{Р,޿i Z~GNobM WnV-;T]5,AaR{( TVFj49#B~(jLslجX sx Hwl5b( ,x`)u(B|z?r #m3;ZXgΫn&@!7NHc& [9j ѠE +u\w$t saf?PfJ2vb{ѭƹ߸;1R'YI# K [F y%\1 ȝ2 i)ND\@~Nnܨb [tOnW4'3J(Ry1(5*DrЛ6,"CiGjVMC7t]L(` At գht`ahgWf Up0wm nJ!=d~OikWfK@d~9誃 U !K1Q$TQv/\2Zf܍AqD4Wߧ}-N{ci뽬IcנEC\%ʋihC]mUb-lMv^!#FdE^BAK?݈{[TèdE<u g7j2)NqfDB*j)9EkfpF!ldQdY2pJ ĽT˗ OA0zÎX״P=ڇzUT͕ EQǯ 1DNM1ۿ(og4%yMI<:(*8PöfypNPb Pbw>Ccz?DDӺ\עK+ϐO]ҡ$ߑ6CtFq ç7]O[lfbH$9 ,x,5b[9;D̪L)?NN\4OP`eɗGB@}tWoWhx,Ll#:g+sU?.FUߚ44;wFNs*˙EXsC,i- -oY nIE۫> [i.H-w \ =/v0eZ\{h=c7[(D%\ܘ.uX|+QĎms]tOS~xli-_}x^]Guھ~Nުq.R(4FZE`h vM0կUtEmdKM(!Oͷju'Q0lJ}rA{5ܒqJy ! Bew~b:Jz1#;ɰp6aCUxq$&s^ (;$2q+,LWFJ_g'0ݜs@IT~_$NR~m%\dx]%ևhliFf2j,FLR kş,qCxq!镅5eҁ74T`G ~}r9pa( |R<n $Gn<6ߝ ޿j4m\{>Rq9 riP1M)X]hF_FYms y`h}Ҍ*A&vbl.\{ ޝQ5Kݻ<Nl9}SI4A= 7| `~t$kc I`tM2P0+4yjc 8IwmS':Ë!qDk7ot5I~ׁG=ƽDaUrֱS$Bʏᐅo_q(>J~.:|1= vK4:, goR,jW)[h\,`L=:74\LE*vdϥ0&fԆ(F@D:%p`d9 2|OP3 !͜>S- XlF܅֏}7XO k{R c5k^ IW+¢cvk<=:h*In(f BDT7L%{NP! j 0-/Tu=a蘦- Lz+GW&xy/}!e@:exA:QcVcP6Q ^@V·_Quy9%ػ0TI &\;` װ`u Mt8m3Z \xO!uaJ`5EH hCtU՟Q:?I9BbSۂ.q _%=@)RhEwafbI<4C>(/’j"x~cd0"~_44fqЖe X}C'm4VVxiԆi>% r5'`!$Ѓh@j/Wfx;bɼSO;C$}#g0KjgI+jUr6}CVE 6BƛsT̙]Nٙ|VJme6B=r;?fǃ9eB(Xw |%o!RR}R:O .ɱr5l*9<E84FM*\ᆌfUtpdf?˛Ȗ(݀ UX$Z哧p܌#݌lt`̵wa݃PޞR8Я>m}v*pT%/AaX ^"lK|ԐyCfa Lt:sr (In-z t4z>z(3W$oXu+QxEڝ6 CY8$aG~ zUn9WL7G1dg ,~ mb𶎌)3!)'5a]mQH+\X߸#š2wŒ ;[)yȗ@*Y%51}|-m+=lAYuS!Xn 6K\Δ K?pӍA?ꍍߘ҅9 .H m%,GƁ>*{\ b4 nLw=ݐE27ɓoj6M.JgVrsCkLMR=Ro*^/a? Va3 ]AK)tV-QJH4eEBqNZ4bG;aC3< <v%١a=gt1SWc3~ d7(VeԽʷ.@7Mm^wD#fafsp&kX#;΅ @e7#g}eZ\ԜZ^c2n1tg#n hEMƩo/Ȋr|QROO6ػHU yY9-5a'2pf rSE{5'BM'6nJ6#!\>I$t V 3G|v>AgXxE@YN jbdwȏT8T]H.E-[za=lJ)N:!d5KM_RjJ\%õO7~{3wa1^ S~t}.w~!T'okimE',(ppe_Q+9oP@X:99*yP-iN )/ ņ:'? |K]?VK!{A8hAԲaĐT Cl@ s/n̙p>ökdspc < 'ŊèuQGW"eb)TwEq*\` u&KCbVfalST' ȧ46 w/YZ;Nfh/@)ɀ0Ec<* |%L9TS1߅7rϐq@Ǭ~^Zmk )/|w J&:|=EGVO/}2?]LJ6*[yay3 , ($e,QN5c8/4G1A39_ov$c+5;G[]waC}6.kv< ACVX s~{)w+'RP p!wbMsсp{x*7ܚ}e$%b :KdbYpӶ(xDB=9$GKlt^!? (L{CF93 O-o"kɺM2viE ,%!pg41h9m1i@;& q0C/Q@p#MXiKațL_J+r*Ôi7P;z؅^JuLJC5#^D$[оq:D^ٔ~7Tـi^І$a)fe]$<>?SFJ_X [䧠t c/%*cKkITUlV=R:/ՙA[7(tvVַIVJNDrb2_BY9Z%Η"+!7 Y:ae఻ lΪBdT]rWojgYJZ.a~ ב'sn#z%.G0nH9x4]ݭ+V)2. 4,ܱ&knT>*|c5g k%#!Ff+"TT;ЮVs+ {b!'9F[*&pvI˘r1m#{՗r,[x=hr藳l7hSb3cv)#s]nӄ@ho6[3P3D#8r7`/Pyek4Rd t# 2GWD mbxDU'ق1U`E𛝺xɄ"?E2ydCC/YO/#cz ws⠉2`,KΨ4\ԊH^<^'o`by@RAD"DP1˚F3|KmidσkGw HQch2RQH)5ab%h@bx_ Hޕm?t^ WVVW&m[ yz֧lw'7JMMQ13&gnTw:-tmѻ{+ |aoB}Sof}>>ګ7 r-<އ;/ѠF\`R@ 30g1D >;t)Aoxz",l='U V+\D Q'eS!|*:Mn:-ϤPڣp% E&vES dgI&0ќ#YB Q^0_9긪&ʼZNj83֣|* x񆄾"%wP7l%P( F#Ӗ]>U&S@( 2pNt"2fW@EȜfck(Lh2R@[εiAB'j{A9ӡB8d6̑p5̩~%\`CC70+a_IZH eW9RI=ʖ8{q\.x8 DU܋R\^s:Tav+@]eDDf>~/hjMהwhͤ/jްP%ـ +m̹{?t)_Ž<+k|m ֚P~X *`xST&+$Oyq$dM;R5bL;Ij.net3Ge@7hCGU޴AǼЖI )+ YW}HL &OD5P xX&#hq&vKI܌%Eه"I[).1"I3nHf4DfN]\{%=_-}DaRBXx= 3k; KA9螇NVaչtOUKp;L|kXf$MwHJR6krN5q:^ OVu&l끜"Nw-z#UfE:R|MY\D$8XɅAeK !,:֝t;U9K(뷌Qbr2ͪu@Ot_*a='a I[ݤ/]>G/؋km R[YoW;I$PxFad)d7R>:=S_L@f#yE)ͮX'#J% t9jpfzl>GPT0,3g"#of 1-j>hɺ"o<.r+Oף&uukW} qxڔe( J\JVwTb|3ܽZ,9d†+|t ]TdH.nMA':·c.ZeI+9}+sͰ"F"/皈`W[o!g7*qd N61cgAzƿl5Y{ZI2%B!)J;e} N|aF`a4!9ֶzi[ o?:J8lןrf tEȗ *NU]x^ MT&*`gtPz;hw/a{LD^+j9֡m+a1Hj׾޶Ψq}+vh/Mjφ6zl\e~\ 8J#U ;аKݑ Z_}TKJczFTWt$#O2_Q0:* V1ߏ}jPc}y^#UP $s]6% (vb gPm9Z_ܹH0{|XQ1`Y6AyڰL/@cEl_%z>?bli ߘf~ X;AKf=v+#1f+Om1}ՇFPBF{05F^Yz`U>([))#Y1s( ~D|G:-IrQqRF5H89rpexWzwMk!S3cSo9%Ř|{zc¼5~_hvÓKn<VO quoK#ې(R9դaKW, ةS !4.7K cpfDDLaS턕BQGzsK>qg5:8-#'fAt璭"-Մ© xk۰K}CC›>~- 5Ę/wlQN#UU_ow!f!(߶ލ%z}<.rb3YVbv!KB13fmVeJӺ2N}7ͼLsq=JCs&|kd"GR,$o1Y0=vg);;wCÃ:yxi8PSSυͳEe$;T5$ > 3Q+yng`őOUmhI&}#msz_9`!U*vA.l0L\;$/`%L }.Y:dgk[8w$,(UIi/>Y۔j;=ظs5uXdu(ǖdVmm lPe9[ }s\964k^ ݠ\@7G[XINJM?4z>qg?Gu_(ɑ&8V0&s?ϿV3ig QBARsyuStr잒8V]{V/^9x=y%jd0- ,hǡx_nrQZmP]O ǡLCo#0:ٛK5|FS7y+ُxͅq@Pӧ%p^u%ANةHwn|0(ԥ,j^2_#dlaJ%mALH :)Ï3K:S_#Q|*n} &Gd2;eɮTa%BӐu ߹KBJ"\]%fV|TH@rx8c)5*rAtº0Tu~lhCJ{ (6Fc>kL=1H7wE)FF# 녵I H%~iljPO|BwƻZyϠ}⒉F݉T@ODq>=/K7m9 *߼#O H{TUC{1R!ꅩs - "Σ|.Zr-84Kߓ|c4H^%>|4";&}^'tqv3[JTf$G1p`ɽNy \cȄri`U.e 2f r$)[|k: P`L)՘zMNP$D;D+ KIDz$n݅t m EH0Ͻv'"v3:AŗFaķN ލB~PEΞ 0ȸϛR#.  /u&[Ne3!@,Wj{ I ĻcWBE'=Iwݮ4ۼ0Ji7~ܫko-2)b~A gV~q-)KDyG_8 _BR H>5=tؾe|g$SiFOV :wÄo'_-Z\jNӚz: aU 0N^Pxiө]JIӽZ0ߖR^]$]|"6w 3/"LozVb3_LCNS+P+ ڈ *Tqri!9;wi+E_īꚲ[vܦ@Vvsyg1qHA&o?A{٨9-llܐJ3s]:’T=_'x{o1ͶMx"L 6~p^F[oW^Yhu4 pT;gٙ9rqu؜r[rz;>ϻZ3ֈz &hqteo&|GF!> ~KiN ¢(3*aPON uR,A>^ȉVkՒňhlwfϔ Rh4kr ,N~_Gov|s@fypߊحqU`W-G] T=4nj2wQŪFJCKmL;6ߏ?]ϜEˆqie-~綦GY^iؒ9-}yl$7o@2iϐ.xNUi 6)/IiZ]7ͺ$2:/K'VDKq She16Ė`M~ F}*GZR~1";Á)ȡ*OD"VߥtʞkO!4x/}CrStyʧG#T[)kȄ(.`{bC/ZBcGځs(R]#hԓbSyLW|uWMN)- Xgpv"X\ɱ5OPnI (Li27L;\*=h| mcyn,",A}x'go3O /ϫG#6EoVupA*~PF062|,Lb$ܥv;."3}hQM@ 4U?aKn#-q.hqv M?J=S4cP[A懈:5 o6+h^no@ݔ:y&쳊GeqA0&r) h͟ ¶b ¶`L+\sxhA5T@N1 3Fpg%=V~]?>dy%~\ h,ATEVapf "Gـ/ú 226J$_LgB$ ~kMZwK|{1}z T薖;($T5&)T?H47>ES:96cݵ99~/;ZN;Jֹ~x[*=\"~XzԨVˈߛXkm;d,>2\d`E{-4w fAƌh(X؇WxQn^K-V̂v%*2a2K2Pv?0 G!T+.u~_/(RY!6᛿RV9[ݏfP?ZzɁ*_ʤ\-oxU"e[fy 7)?xX|6Y]FJSADM"J"&^vs<6ً3^[.hsrks,wTCabS1{`4F5 `񆩀{VЋk<~ P;6Gmsn *-{\0}{Y7XA3=iE zYL[ cP^ I!)YFtl΅I,O{4]6}xjZR`z:R"XF(3gFG# ʩI[He`'{B9Fxc,n٣Bo3=%!_Odld֪z',ȉ2;/]Z;PBW:)@&_D,^hKeG)*q 7V`"GBuo\,"h&˂v"# p퐇bvk$f\_\oY"l_*%USAˑ+|-/9R?傆:޷TR1{3§#c&De*F67juBMLز>+6{5(Q$cgXBbT<ȹgl+q\ ɲ+7nEorþrMf{|ci#vQnvD%쌺ϚEof${§'QdW5/(qIb9],䩬7R`VvQlUD,ynԁ+)^G3)g!abBrq@p@[!,tD{q%5]NJ /}nH][#|IߙocY'-/=遯(Eulq/<b81Zޯx<#4`o0,R*4Hk+дrE_D?e 5 Lw}30Qde>{dCE$}6n()QNR4ƎCuw~cڶu>Dw.JW#C&'bӷBga (mn Wf(hC#7d6G'mg9Ti `mC>c[̩Ld{ZБf" 8W6xSD=ȧf,x**I.H)1ذ96]>VL.@WYsxD?=fq/!&"wӬFQ ɴ[u:[f̜ KW^n ԃ:G=(,,w}NB%|`~ If sh ZQ=2m/i87C"lؕ^2FWL!tvv[O{izhnW$H &d8H>{׳R_ldn *vcEʱu L\=my[w8#[#c:AN74n`\ ]NS0w;Z~}PM·e^wIffyB Z]{]1ƫZM|bsf!CrGi KbDacnbS:CJd HΐgWVu8l?>%0&&8O-D?$$e >ޙM#TUS--`ftAok-0oWPCAts1{%_TJM ~cBbwZvX*zI>Y؍t6iJmgq7 aO"UT${gb _AYQղ`:.gX|Û&F-nԘ-j^jl94H'LNB 0Un1qǗ[.MKl3C![BpX⻒Q'-lҀW,FW(Ջ* ;&_-c=hwҔ%@b?d{c:bJX=h E8F1% %>oe[Q.NrEW|'N`OVTn-5 EU:j=# ]rnc9ҒZ´ :zx&i?Lql]iL^fCt U@5ɎW&Pm ЛѠzXTyzʐfؠsFkô!g؆J?bBYvTUA3meE9ִik…M*<1/q/ L%6s!,|`ɾ# :WgO (=תuB,m; zhC oߴ@V˚ Bvi^nIӞ+$C\[WXrzj@{ͪsnI \}Tw Awqxn, }#?4,-(Q`\mwjr$F8T:q,d*enB}&~׫F5KhAKqF,7 DW{~$ H{ƬbGD2KO\"/s8+maݙ>)4$xgB_ž3?y;ap3b'-?TJx +)h-֛ց&&UOZqǚ$mjgⅨBw,pҢJ:/MqCK/󛵨wNRWRV$ V[)AJ4Bck8nIGlx(LV}r^yPM*nZ)o u@Ȝj}*u2ǝlfK*&ԻV@G J0,b-? /`ѓ2yo NhAm;/@s1V=-Q4}OtAGQ˸.VqmsϟH WQ3%f=Rl9h 4JmwJ-H]Ǡ"ix 0fa!9SW}3j) Ic?N.",u5T8b L>q{~!˴ *A$Wtw0j:g2n'5|K+I_!8k҅ؿLܰ[5:>-LC) {7]#@7U? p2T ɥ8cfĄSnHD[ GA6Ht(PXEs6ECdx>C`k=(!_Vax1_5kR~:_S Z$ufOiI2+V! Γ=b!co=8}q`XXL;6#L&U^Ql6-ۂ>,[q{GC3X|Gb_|Ohl.0هҗ(յlv;Uv#X"b+*085y #huٛ_z,7$(8q5~iZuCIgzaNU,&@DykjjPCx2 {H 7NLvrJ1/yM,)Y&fYRCV[aÊ^]D<&SWRԣSbEL q;mݹo6L-|(3 rU+C'#^\qTuٽG{0bz lo,kɕ0_OEFJ<8ie@t !˫/NagN~ԕH/4`nL,+P;8B>k$c6HؾE QV1/Oɺnuc;w@iܙNã]DnO˒Pz\>li_argpbOWgNo!*Fo|vO צä2mTSO<Ǧ@Տe,i+IIs8TK7ڏ' Y6(9]CMXvow㠑gJ_bQ v@ q~??@iw5opqz>ϣZs]G[="νJ^)]6X^ٯ|*HͧTfC/F?~X8rDӺꃥTC2Dc2"N.7I9v]Cj:߿K:mʷ#!\ן[A$oVf?ءЍѥS# -Rim#L`p*:yK;&5nڙ9h[hfzN==1˳X%(k'+R鯱|lAGgr_머jy3.gOJS(v;5<u*bgq.aOmG?#WE\I~NuǶZxm![&X˓.)ǎ=hgSÝSo^LI&AK7^)nZSSFpLԑ+[<߭eǁH TBCP^YFf lބI(-M}@4; mk!I4QX'gsԨ>%CYv~>ΣPsgwϏ+uͽ2ݹ=P%?P\~Jʖk V#,3o{[rpvz[>5?7ZOU2Y#Hi n VhKaon \ gL cEN߁o ~v F 8NI6Vf3>4P$d@~ $7iOIVKXҊ44a)/3Q-InQI7~B<|RT@P)x+ꃓ_nˍk#?ɏ~>& ( muFn'H.BX )T!7]8@lvKXk& {^Ǩ91Wc;+=eC)/Bbْ79% (vMNp@'cp[ rg="Ux@jkH\|?NQ[ڦsiS]:Ff$z?Ȳ rrB(#BLO'Nx?WVZq҉՗,gfÔt $jsl8I&ZJg[2P;_CfȾ4B3w6 `7$*jwJx2HS.+=e !!Ϙd9&L,j5G7]@Ar[3FDG1h,\JVY8$& Z8Eu =Y2}@kmV~ZWoΏ:grrnjI `ˣD@vM6GC0٧]?`v_ij,vqUO1 Ϝcika}udy0>d?6\j7ϋy c3tM zs2 D#=CL=X١J47T$چj}Ņ:W<ƍkCDf;ޥY?11`&JږZU bcy|rz"ζ{#OmYeDTr* C !g,V2qFoûuhI;Yiy˫~3PRChۉGDiN # $\+WB&jT3Л@ն7giSω<1 Qܽ@0bpbݒ(t ¿ í}Qf=8t ",Nw(c&!=8+{щY<UnyvGW=WYN4iv7 nݫ[-Q2$pV}ߧ7, ޮ^$qAiz\Y1^f a%fe.;CLzd\'dd_ o.[0 ]CAǒQ.CEYͯv5[=]ϰdކt)/l妨{vM8Fn\~|3sͮ*6.Uvڙ#:$YgG=CB%Iކ~K D+~?3SM6 tٹ[S -C⪸m{`>1% ހ)ě$wf\.>2ސjCG֞^$p$*bC9s[Zq%{5Z&]եՇwz9òxrFU ˦AU7I9Qlv E.dZ5 0CEV^0蔀iOί=elt"'5 .P_E۽T4"58)*Slяm&Ҙ=B2s?h5[walq?ZSoZ$ 5۬ lCޏuHqOȩH)b[Xogt'd6:PͶO N .Ͱ ,f+y@*;՗|`V*PJ|ZJH'_%W^I{!`zUφrޖz|÷WeMB*h~8eI_-6ОI=~809$ 3\14XFՒfZHɵ2-<ب%B?Q<*$TpS*4.hƾ3nOx:K͹s{Α,w Pa.C[e]IDHZcv/rڇ|2@CN$k'uERpg7 .;PLݧRb+*݉m'b>[="BS;?vlBs-TTQɫƇ4>ؿJ+"cAKf2 wX,$`V7lGpCG,sS|Gmy7@;t+xVk+絍&0Яԇ(ɂ;\j^c1`E7I" dlzǘ[ 0l>q+ջibȶD=U]Pf[zxыORN)p ;1u['we,7SXY뛍0&[=c#o@2Cx*\8Au1>3^Ul֬zRDm.CgzXr'QH~Na@*3˥O+ x+ч>/jk)F8Tn E^9}fP`nܖR.Jh]>|)Q_^<8k}{ ka$f"`W-d~ Jt)f!Guq`3ylwN` ~kΦ{ uu'Lrġ@~? PDA~se/ˎ.Ura/5 _uWյaTUu8 X<g"P#ذ|$% v_~䮰fBĎJydw_oYT  I~a(Fyf9<"aC`naMl =uS6?q+1l(sK"_)\!tfW&߽.#ioႫ2 />#+?e h,0dNV[(+d;~ Oy/t:iSy^!-<,rDi={aS1YI.DַRǀ2,}2OX.fiբ?$C٤~ VtV ! ڛA*ݦz`W˕M牬>d- h8~\%R s\YZGބRbW YO>'f ]p ݳL()L҆${jGG^TqͲv`7*= (},.R[^UlZ DL~*yoq W,vilnP"d2"ϓaHS ޣ*Qi'jZO<9WIqEXtOr;l%MÅm0R9;QXo5`O Q#nqXzX_NhAo~9p)S}HO~9G h <^\rqQ۹\2k=ZWXt-e鲕lzB\\/tKJ%nrBFQ愻H-Í}YU. ZA7^jۉ k네V Cx'#S*gHK+@[h'T5~NBI  lWP4Ӻ;Hc1O#m$#9Y"SCr=P)%0ޝ>)efYNc O"AM\nAnHOnip e=(A77lyoGɤ 2T6QA[k8L*5YeDnV|v)hJpΆ(.p,ү[UmD2h20R˭xbT }EK/r5К`*QiA=Ƕ>euU]4 | Q:!˃Vrt$ڥR;/ Z~"-&^3{[4m~)XFܜ:L;@V2=@A]u-cW TUը6 XO'p&_k@^qZxud'W&|ŚJdA眯͟6rRZ")>z8և@{YE~1*9 ́khzu㰕n'^\Vx$hT$XG3VD㲁B2QDr Wh*fBI&\KHh+ŮJߨ` KO+8| ٜLvtdadD@V"@iɄNxS:d͟h7䉧rETT*lMI~t~"SdtK0ѡ"ϲ."!4_ߨ}-@V4dl@T;̰u}hj\n84xշǛ!4)%}!7]O# ll`Y 90@uGFiv."IiՁޭ[ C%f-81oVRHX!<`Ы_,o5ݦ*blbڬa{! Lo>R.sXPUl񬽁LIlFSNz-Z85 ek, [3xcboGLP?w]2F4M4 9NP<$[!2f /-2OÁnĚ.S\0j62z)Q~92*Qo[eFk#?3F_Jytɖ19y/>0 YZshapes/data/dna.dat.rda0000644000176200001440000001540614367226002014457 0ustar liggesusers]ceǗtXff۔fܴIrs73f@RDDXWD.ERR[A Ҿd|<ٙ${sl뭱fZq+v]f0kYw_W[cKv޿:ݟk`ԥC6ۮؖZ߾u߹:_;ʿnmvIWys ߺś6 _GO8Vo䁟s_ss̚Gz|}{_-h:9{}^g-=&i]Nn`5~]]u5\o6|R?zїz{ԥu-UrucOmfsG3{Nf\uvvdwɟ6q_W}7^vr~:1Ωm/M}z ŽbkO }N^gqo9I8:݆ޱO,٭zHת=kKݺǍ٧|@=t}׺kv :]WCU?/lo YRLr/x{˨Zycmɹ?]J[sqoyYw~ҿn{3n_p{.M̚cqݸͿ>tK~s/:2v9Gcىc9G/uj~k>}mNIjY~`_N]f˦ݍms+nt]pYMqU_L{^>lVֿw9_>WֺJ7N朞_~}W} ;\vx-EbSI'?Q3CGݾ[zWlW(>g)n#^w?+insyA]ct^'3|5Gׄ5ʙo?r}v;jEE35w7ɮA sW"~9k7{{z0&_7?*.s#(/7BF.x56~}]~^E~E4Xo[f|{z|m-[{7^y[4()a6M9w|}v6C)~؜mzx"W##+U'p}<4:Oa&lPYO0Clѹj "@y,2M+^]vܮ;OO?'"^˯Σ~⵹0P![YdŜ䋃eoKWA~]$FoQAX{O+ ?eBlu նn^6"?M_e+-Zo$o Ժn1?^sυ{?̍:\;~W+_5#gus?D=4Pʱ/ߓ=)^)f#p_TVvb-lkk68;E>&vOn/co >|~.-{(?L\_~VoevYSU߁'//*1st}6v]Υ'^ߍpQ+ԭ&- hYc-9<[G>"܈S'$jީ:"oqpb=[3_Ku%:/ie5$>W3ue*?+<V{}w/)y`52x|rx\JZH+*kOcϨ)>Ts~ /؇>72+_+P^4`3ux1)~[ km]_,w$cO}6@=^>]8.sߑ:ħڟu79z n{tk3Sz}g>rO#1~n%_)KAy߷s_΋)3†5\ϠSo3NsPG E]H>UG'Q0(>G_c+x5śp Xi=ea8u&3jyp6{#?_z74DS~֚}NA>LsdI.%_@O;K'N]Fa#ⁿD̬}np 5܁_"\CfTv6)NEwn qq8q? w[H5taxD%KPJs7=n39xVU&VYq:agxt~?}9it={8\>RuQAߋ}Ѽoq9pb&>|G0Nox&(?({x/ˎHׂ cyĮG#[T'l"~ׄ7}tV4V|~NRy={oP}Hpл?G<4K\yHl4Ke~!(./C/;7E?3 _h!LuT^U>\Gb|Hf~.}]TCzk{ /ùcFb=:?/~U"?d#QxZ>-x)nv>_q.ۣYIq;B~^y>FgO=gg/scUO_5ΥS9Zgx"@O.-~0B\ԯyOxSXnS4³r|'txX>^ZAkו:n?輯Df'wfD95=˛3C ؁"zzeF!$<^]81I0PDɢ?5a?- G 'q$ ɣ}2<+.5B~IN>Q9777O|3XDN@8A}J)K;S/o׷Ou[w 7~gKԳ.&i5IK~$ӟ'o8_"}@~Y= Z>u'g pv\J< x^CA3[CB8,(/1d9EMc}Lr)p4kğRG_I'˾N6/>!r@)+ߣ]"3>r퟊?vߜN)lÃ&WVwg'v 2/;,Cԓ}u~So \"7+?:uP\i>덓7}JK!nyNA/B$c~80=.?̣WV?Fҏa8\ը' tkMɃc:O--v~0soRGs_3X;zf9p.<<@<[cD j{ fC\OPˀӣ̟ k ~ +p7DOWR MUcQ^2W!-#JK#+EΓ66.'aٵ~Y<3`K~anGȏ ^U%xm4Fx~z9쯀]+*󉆼`Oǔ?d1 "s xcyC=}|h g$t2<4cGiW~Q:g_˥rQ]2"W'[VkG:uzJSyta{c wѱbہh.>M[+F~cn=kO~7C2[OeǏx –tC}̱&ёMݧL?7cBh2]yB|0ߤq9W:Tc<҃e- ʋt~{Mj~&CT?y!E_9_  TWHtǀ9%s>#Q]32Sa|Wy4d7ENEoS/$ѻ"|tu(/.$_%{r5>}tqAΣCG{@/Zu;1Y&i}T\ظ8~o?m(p.<0yޢ_ ݷ< هNG9]9J\0Q'y[&(= 1;y pݥ,s5t:A}"[7t4uz:q ?Vg.հ?{爨]Yq2ҥ\H\Fy;8Czcn<^m32HnFߕtxp, _SPDϩE6>oMCu*٧>ӛ*os Q7ȡ7q&u} cFL[ܷέs4K}?M@jy櫣y=>\gk"Ko?!gι%́Vxv Fk҇wyfY3shapes/data/panf.dat.rda0000644000176200001440000000114014367226002014627 0ustar liggesusersBZh91AY&SY>Ҩ]stTUU#D@@@@@r2L&hLA2h4ɵzdbj{R*@@M #C!B z@2P F|0rxEItjjaq `ɨ'*XƘ1 Dd)j&P6 ha6ڹ}7+0`m2DQbmxu.zsWUSLcryV'(}3}!{NfEf=a؂hjŹFXMZ&-d|/ ˌ4j\ڸG>AQ :HUHE Cӄ|l`dL4D$Hc&m{T5+*ְLE݈X6&:NC(P9i5 S`$0CI)?R. &*f&bab* J( +N\Pxuwy9Hw+iB@hbM SI5d@0zjOD@jQDSB@vLI! [^jpZ*'1dzZf`ۅb.;O8)9#YIs{.u{r)T%oq嵛xQkM{x8@ܦn0[8[XQS 2ٸq6 $$lӶ%: DUB5#!ږG1 qp4&8V#[&`1lZf j@l*7TU 8Z/HC àu2XUͻIrhYp8@LhQ3F|9$]SkT2{bw;7B[׌$m i4u=M=ZtVϗ$T= ,30M9"7K:NtOe15HD@TP;NRSu%hGn3{&ʇ`QT/!LlBNy@ Ȋ2+DdM̌te XN 5 Nu*!^=6 ‚~i$9ah˞n'C;4xˢÅ?H0Z[Q:XIWV@KZ9&^Jf = (NyBaG0?x y!6{z;p}yOߢEc.瞐 0{ kBcqL<'ѐm)V彧7C{A4W./{27/a[Sz@( ;xFDiGuHpb,X;{ bY2>ۆR)?D8_}IeA8T/pŏLFU@ hOӏt߶#cGB65[swS_OVUg,B%C7uj|u`}Ӧ("ԥOW\ZiH~὆cQ@TҪhk-QE h\$PEd*+6mJھCSggV_|=;e"*_&æJۑA/[ q"|ت4B08WT%2Ֆbĉēbv4:2ahdjb jZWJnSj`x[Q Ҋ:5Pl7<<\2qp*3Ěܻyh֥~WWAB)4ί3+YCYx N9ΩJ!#Śngw(xXNuPF8zk%۶ BOdfB6v`b ҄܍׷46udʏ1J DfA! A@ Lg)φiL$DCVBɐ1̕c"s`(0HŎf?=WuU+1CH@<|T=+֥s&U4]‹# J.2'{ww"*<'dq$L7YǤZ^It *n]MyHclj.VN R*{W[M9ziTs,xig)G߯-37ikT2@FoqF߸vߊߐc{mlm׷׾3lV*,Fe$3(# $Rff&FĠl44d$&d2 eDHf5FLC1IPhԘ)4FI Dh AfdZ5RcQQ&,hƈ4TQ(Aj&Xƒ *  Q4EPY%6-BZ"5$Z,`,QhX̤ԛUhؒ*ьUjXآ ZLFJ5Dm,m%Q6UFUT@!QS-b6ƨѶZFbƴkb+j5EhƨmF*H b2,Ȥ5hŌmEъlmQhţkb֋EXMmcmF-%5%6#U4VXV hh؋Q)5FŢF-Fڱ+TXѭFmkkDYYQ!$D$IE@/C&\يVkj k-LxTN,N ê5!:ATTVY&;B KKvӷuȟ%DH#M|8'#rwv["B/8sVES~-ES~M/tƓC[ӂw-8mtpU7Q] 5bCTFdԹз`΋+ةux1h{;VWte en taXYU{D5T0U;՛3x;O3t{h"qnܡBWCpv 3$ϞQU3<;lˮYD{H r5u nx"U*;zTp{;c7dLX&/'+(y*HTGѠawSlv wN:x\EݽCrقԀ`ڥ5dZj:I5VE@GWG^.J~G߬ki ǰ#%G\ kH8nt$;x\ٸJ{+7CW!Zˊo;IW h̠PpQEq91%RT, BBמ>ֻԮJh5΂\Wy}9ϠMeiA{XG`׏J2/eO 70T=2;5>Lmss׹ƴmgaˎEƾe|Oy-yJcRkQe+կl/ĈYML&O68!$G`꣍xzbm4{z9 8J$)xLR&U &VVr˸;Qf薒 % գ(oG9X&Ͻ%(Q(t[D&5ֆ_O[bG NU 4BEi::anāzs-ԬaxpxݽKF7)8_mŽ(hc&[5ovvo BA1x^sxA63྅z~K|V,.{"0LQZytXi,V!+EC Y ~| +mnE|s4  @ gk 99T@e| 8uw4㥃̸&Ũ# Fy\a's>&TJjvs^!nHf%>\Zk2-8r*4q(abyS%Fw~^vw6P6ŵV{mlh f:Nި1ڼ—#gD*#`; FIixo7TI詻䪓.p%#H;k n8.>L?K"(H shapes/data/rats.rda0000644000176200001440000000464514367226002014122 0ustar liggesusersBZh91AY&SYv`s|DUE~aiw@@@@@@@@@@@@A` r* LdSSD"M&  hj DL@LfPChhѣChAd$Ijx)yMC@FjzOS@zm5O;ػLO/4`Mt Ԭ\ |IL].!kcikɤDcȶ,TDgJiZa=ܝX{lg^aX|/$W:%`+)f%$Pj A!Nl1lXqUVfT "3swKLLsiۀbY|U !]sD _*cr6vF" eQF .ͩmp᪜ Dȧ/MXf`ZfR  ek_nUIUX3K_r%4vAX*m`[u7`àsJmVg 6⪘-8TIjv@>6g(Xd5$gN`. RQJFT>pA0Rjf2| G`r=g] #[d ̀3.)lmQ-TU֥X(PVړ^N9/'gwk{^~v_>BQ |No;4F,`U < Qo8Zl2"TL5 RuJNcACő#LCJgt M7EQ49 j{xy6(_vrǔ5'U/8 f@7R8Q2Ty!G uĥ׀)xzҚ * Iw;~3z8s!bq_P9Q"fb7R`/oFtzvVQeżzmew>.g T ICA([0!4)M+TҔ"v$!4'Nq!taz&ےx(LiF2h'u˻!BGnnǙX1,RTy =X6)tF:u wֆCs6E:tRvP Iǖn΋ :@xy ֵq3\Z4:tO F`!bbB`cҰ@D@!" ` !`Cqj>V`R$("yފꇻ˜ " !m͝gJ@;Ȉp.BHx3mnIS6-rĩ:q$l\D'vE%1hr G9 Gd̡HÕr==C:a~< 'dT=SD.RK" E8myrBRUE(R,KQICE#AR B4U A!2xаRVkZa BAb*JS3ѫZe)nV#5f3&fc*FVW0*6QZ%r:Iպd^K2i +nCR2hl$:`ka-J%i-(h[(0Aa1! \ .Z0+!Z*E$Ld3)( AJPThi(T )8S'#xFM0Uֳl 4Mcw_,xlu: ;vfTߡY0b]9UQSp3q6 +&, W3|N(bS `^A'T;"(H;jm0shapes/data/humanmove.rda0000644000176200001440000000325114367226002015140 0ustar liggesusers]WklSe.\6d/ 0.†8̱]f6`=uccK(wA5fjIBd@ 3 Dy?$7P?%kv={OCkY7 77NUӍ_ L3Y߅Dݸ}Onsǿ z6գPJ*ig7@yQ=B}ɷ#$}f"Qo]_FV/f+D&ޫ?V+EJ+h<:(14*q\ǂAK_򱜏a/I] .@ܔ}N|Rj<"6?w>Pz_{+ pţ9(`( Gvq\sҞADJ+>{1f>'.0'W9gAU]WbSLBI Of)΄Zg9'[.>Z_ae~ ĝsoi$iӆزԉ=yP[qo~k=񛈺K8`쓗lo\ Gd8Wܭ?J{x(~Cԩ/ J>~>JF=)sT/g=|̛lg AA41Q FŨѤ*FQ"V$Q)QH ԚhqIv{ϼ=9sfR:JJΊ[ɏEx;.x]9اg?i-CG:K57&7TdSKEsfbŪw$M((Q?]ʝݟ+Nlt諪?=l?23ѹR3ĩs<܇uб/f_ٯ\ ɥF>npq쾗U )M_13S<4S)^&O#knc'YCcv{x{c,<<'ɻN=[}:pyZ\\Cgx }=<*c E\ ~^~wv[+.gE}ݭJ?x[y!: AUq>n'gto<7L(OgQJ |Ip<|飺Ļ0C't.H?|z:T%< gBr_[ {Sw%?gey6?Ǯʼp"̙&{ +u7>n}G=2ߖHt <_ÆC΀́`.I=#bm]$9|u /y.J眄#ӾR8$̧.Ql~'%;uɋa[[CN1x>C3qkgVY]̺jyH< bmuɼ xNUynk?&q22{cH~pM_fϻB~Ӣx?_J]I>OC shapes/data/sooty.dat.rda0000644000176200001440000000062214367226002015064 0ustar liggesusers r0b```b`a@& 9K*RK|@<@4=B# "=-BwH@j4]{5 tqڪH m~¡3(Fơk˪̈gwhOM;@c6_ t>ļz-;0<ɝ&N˪igfij}?7UCt#39<=aǰ9ۧ:]n<'gΞaLM=1kq؁lɖ^;0* 4mʛT[n8a|Da͢`.xġ¯C>iG$^>а&fEsJf.1jͤAshapes/data/macaques.rda0000644000176200001440000000436014367226002014742 0ustar liggesusersW 8kR$HPdnؗo1!,rTBH^iURBZt9qi_sư>ŧ1-} A*0--jIY:{iۣӄDD"Ƿގۤ'"W蛯 Tn_In`wma^ 7ZiKp|jl=P/F &G*(B5DdjyVX-B?-7vmA³|j rҺ8z~9x:]U򺱴 :j/+agCO +zWVZ_ة桰rx| XT|$ӟ/&D5|j89 ~g>  0r]yLߒ> OeYcVƃ౹bIS[U+atO+0~s ōzZ[ȓGZOJ\m🮯vLjC*%xtvؑygp7yU;_`1 j %Y5Kk3665e@#0CI4:w.>8Wr) קK̫e՛r)pS<*dݏLv]pg!S V稏s\svY\~ZGeQ^93ςq9S* <ՑX-~a w"Ϥ#0XUf\OJHF7sj6$>xU3x), !l`Y ۯ. qgkafd~+iFy,{$Ї廁\ ^'Cv%gw<a\ii:nk)*} #r^X/SLI7:vu!ZE* ͼz,xkfН IS XIȥQxw\IgmzrqG8Jz͏* (xݔd.Z0ܞ'x0B9&GPƬ'p"{GEV/m}K'r_' 9Q_7Q0j:"@7=by !dP ^#k217hyKvvرvЍV}A*b?S.D}S/} RV2oV[m`4Cac}6ef!4oG{ iˡ CJlӱ[5Èw*л滼S< +#n;tw% Aq -ox=5\S95Er\HKڣhˑT<{Z]3l s(~z%]re0cOwhwK'xhShJ1G;ye[vF9=[&F<`*)GÃp=걃k~\ԉdhyI'_1d7zT܌V;`Y %E4B\S+&zm; AP>Elkk^N8G0rz-[u&Q cO y5]/44Ec*RscHx Z.,duH R?'߭ /1"×GCkOEGƮ6/| shapes/data/protein.rda0000644000176200001440000003541014367226002014623 0ustar liggesusers7zXZi"6!X:])TW"nRʟ$T~u}}XM;0^Z;8+ bΐv>Ɵ.lIAL!4/ wwnOuAJXfGgO6#75wiv \]+zEo8N i{$Xxs/Da{n "Xʷ v-< gn;gRJj(ۥQ,Oq2l jFzD z_ v8|YO_$`bN%7y7T v F49T&}=?#ndG:H20A065D7țz lO߇dw }=|s &)pvxLI/XEgUѾ2t} ͽn6c(Rf% B^aѕKN4F-Q>-k?>/m;zGj9GFVdi aj=6Ios)I'Fl=._!yL><(_IuMܮI Ga&[רh1&Ɩ`N2yDk"Ta 7D_^ @CqKSwn.z" ^d]_Lbt+) bĤi5 p}qIEMo(ؕrW?+(Y/oR{4:2UTr&mOgfAʔg3Fj {OݭܻH:^*GWY;jeƂ#5$Ȁj nvFoqDFfoیpVbeOd.!V(v^K |U_W((\Lyrnp&ε 3ѨU^NDBA1(3}awE~ .!G]2]fw ҝ^U4']`֗hB9P! a^,MrmsxKLpIRW~e^iOqI܆2M_^̷3ə?JuC;FH3Apnc) wm!u?j8mIwb̾6>}`\<1lukfŇRgq d6.KGM#SxK&%Ľtu.<^[r(YI% MDbv9F ; иQK0΋? >u,̥eGFaSb%qH͂\IW[%α!qA#IwK(GU@"&e v(޲/xɜ=SDhhA3 ^]"zk,pnWvʗ.|<,a)a+vv5{h#e=%)u*>I07(v3d{߬SGUmbI2vwΣxg,b}cMEs]ȅ$ U:zJTCHVCR}i*,[22e]JDbIkᩛ;+4*&dk/6g#`Hkgjp_ MT&l^jk1~Y陽hHN=]L4JZ hrW:akTGՇNS(T[ebT!G1w="z`빥cM/n~ǀU,Iq0*q"(1;#3>zNjAhvq@9??g6q|Mx2f@W>E#=>W97e #z29wFs^ d&F! Jvf= YIZԍj8 1 c 7܁-E%QU&7fu?͂&H_[qV{<޿ &{ddBG\}q0WXlvii1HMK- Yy?QLs^bMw3H9afo"TIV${Q ߱)S1SR[<xH*E4`x:?Ie>W'XwO^H{|DlmSo&!R" N6m,U&Yd~  ݝ`mQTn [WvY:[seN$4ؘhI{3+VNnW#>;ڢe(t~0 gJr m Sd$Ѫkk)]NL"R&Ɨ8q>_ <|"DEώ17$g{.R=7CF{搷'i3Mʯ dm.{n?ti{ Qg O,Z+ߠܘZ #4*V@-7Z-Tf̞]c7n9\ }LY#@1yKi}4]rVARmJOڑlI}()~]I= t_ xw6Sתvw3œ̲zX° n)R/osO\kl/н{ `vr䋣weP CXK4 t5]D "0|S.XBK o}x"еD Vǵ8 mP;{?G|Q"׹.kAW*sB1`qMv-#]]U ,H#*H 툗=Z9/#K'p:T͵H}eAS zX8q v&rv?"p9!3jZ`\K9Rivak/'(L)j[~Ņ ѢQUo %7Mg Zu=lJ! iL5L ~UG\Ξ7B79q_SfBP lx3\jN;}_`He` 98'`P|onD z$:$3LflJ\kA6>ь(f4$*aw2+-y@C}6zeUlhtze W_F-yZ 94cˠ+LE?fViD` wU]YUQfBnIw)VO'VڨŐ{z޿bV"#r1l NV#jRKsT5F aH0Oem,ݘ5IEw:gS|+{&-ۡe$+uR/x[o:fSˢRx46,rm4u+4qLHL[ .@`ePV}S(=$)IfV~ٛlɀswSU|js\ɉ/ ?C]PW.EП˖.s_3pEk^:Y{+1zNz:,oY,*Zur~;G?b4KGY03dEwC ܴ,y޽m/ڟ,@Io۲<~s193Ccs/YG-.&bA>sXw4x33j9n|8ċ*j'O͡zŧHQIo+*#(஠O)mB`IbsKXka"*D&A ᗲrL0"治2\wq|82ȓLt˓w?Mvd5"lqB2T6:m)({G~:k+'New.G) לFp"B\s$=uvaХ1 &x8:# #F͊2g9Ot&cb#6+VDU=o2n(6VI gچE 2cZ|MT%lW%2O%+u4I3WNI[uif ym [&ra:.O:)r[w2@e=rޜAh[mږ(u}oQ?yH˭6Bg^ny8b$">1?"H@|z6/P dƴh;u?pwzy,B]D&|`2\5poA$NsF~ }aa69";p5a4 De/Սj M=r@P_Xvˉ@76,?DACS#Vr/,F u)k/]H'p~ٳ6 2W^1`n<K# 'wX.n ӤG,xATϱou5z8prhg(F!9qdb& NBy0^>5H)I:0c6gl쬉-C;`9Ze Tg_}g4('ARpR*Df˯ "b"\gY?CKC(pg;J0 3hT(C~[例~4 g2n&lTcjC+w;Lp&޸Hx 8K4h?[&fm-[ $H5߈xeQ#7Kb^Vul/k"]lIM52UBj\]wԳAW+, j Р{>46nuc*aOy>|Ni߰c 7-j(骓!ť~%7ȨތzSZeQ|)ǯӗG oɂ(s^?Pb T`B8Jc ׿%7u]< A)1ơgFL̿')FQz?cb,cnWþ|gxuy$ D$#E9 Xҟ-̀ lPaOC- tU{P%?a ԼW㭱X(a=7|pB? uKy\ep4/_s *d$]v%AIcRx)ۍ[Sf*OWROofQ髇35z:o$sJE4KSsfeu;;MB]kd ڄ.~@oθ+?v9æ[UFGZ2-i]S$HM#L\Q`};8YQ?Z| -؞NvݏɘX"_S7*ഇ]߲J<\<`5|IDZ"$m8Z>7_QۍGc+;?](AI_nY-kB]zIX` eCJF-Cha F/%z7&ߥ0">ŭIX\YX時n[D,X؁8,EO\5jGP.Х-gI]KEWC>3c2/"_2{}^vB 2Pݣ;WOyŨtqW=oJ3jC,\` ՂJZi\Tx5Wcٯ ЬO`j;Qv{u\`* m ĬׇddC?wGLN e4o* ѫ^S`4TIMRB9Q''~'2"ep,o*m܂#Ro0hTP" a!R7 Pzn=Ny?C5™I٘W@ބ:Z>GŕKujjM$PE?zGP{Ut'!\$2Y#!r$n36c1|٫Db?cm $P1 f.G 4ι3 -r.ߕo]|- Z]?0gjg,$0ҴR!/&iH1uD&TV[;[Mq%|6~F0hrk5'zDH.62޶2]p^F{Dz}W9*d#i'yڛד-d4R6@(" RԊᇇ\2^RR:#~6'(S^SrmgyX1bnZS%9$P\}e {06dө@3Q3MB ~ZՊIU(UlȃN֦cY8ҳlE,Mtr3f.-ʰ\Jer Ld&\jZ,"[3 t!*s/7M {E ˁqT,v|8x|a~r&tqX:C[%7{sG|Ʉ/\e>Bac/4FEfZ*-:s} 2=Z5<NV*j0>q;j2N@ nNYN92գnGIO[W)0ՐT?Ek:T6mdD!/S:ޚevbn FoG XXVK9I#K0"xj9u$⾉-8vV}*{Qy /W )Eqx}rIdR2]Qò vEX;m̨ƴznZs@??.Z5֩CMx҂s"lQ.Lg'¬_t w2LĕZBN~Ȣt°qs4w goiJNL6.tӥ"6nWwB*?&3;4g\oOs=hˁ;TӍKY Z߁³[Hڽt?f`R(sJ`w]a. R4hPpmA:-B[>LPڡ@װTdkerCijhq%I@`>;~.m7c +JLVJP{ӞЛ8p*>AdU}͊ļJLOZ>WVLA9l!<84-[k\?Q v赣s;߿u&/uӤeY贵AS䗈F9.Elar1w p;3eӎ5K58@=BT'ey6FV`j8_1C=yHK_$sБt4BD &sĴex\L:S!M|ݓ7e}E40BAE}>K[3 ̣U J jz{8gfe'\3ݎUmOLE)‰OH¥b8řk2"Wԯ{pΚ} t:CeMMa?:Dud=X$<{yvvC=TO-.6X֔;>7F#Q"McA@D*RDW1y~p3ƌqJS]"x磈齥gIF]Nq2WqK7BxtW82{1Y&Md+d@ǘHc+I]=TK*>k9{R^4C1Xxe}ѷF%^˱z)tDz`:#/:c#WZ.^HN|6`}P|Qf7?"̂VV8.)`'yȇ4Vb9IBCrnI?Dǵ{!}郤 kU5{\e]V wFB͵d#nO(7 +R-/ hlh,cʐܤ/ʡY1Dt:/9/r^,_S ]M^r7 :SxnYUfe5X'k୅V46g bFhg&: \o nj'zf353SX|˩T$n/Weor*^kpWv᎐tULɀK|QaEk&菬8,upMTVdG]0\8"t7`w,bz+ΆW?u~m$P|;i_P\5+uenՠbMxiW1nZGx4&jTW/1^WjK21,51wW:C$IG4ȧW**@yy.Flƪ<_< s;kvaw0pu ~ (,c!:v-ɛz+B@SzwK/ (VM,6(a|:#u4j#L#S2bώjir2ӀǬޯ`يPɵn8"}gyeAK_p*]bov LXuFӔ@8-[5\10 䑤 gbr=y/:ZݰȰptk񦇕 (Π怈=X"⛌n|t Wc pF<ߝ_3%)F3"2&Ig 5V r |a_0ZR.U1=Ń*kٖrJYb|NٌUoφT5z'w4"PL; wdp6ΖSiI ZB-ʠ4 Brlܙю0ֽ\5=xX?Hϛat;=$ԻIiz]!sJf'kPᤶ(ľt)9& Gkx$#<W pqT}n˙RVuL6V-ܖ.ꛎ̓ ^ !Y1 w f !}d$xW2P,Q7`1+|*G,t󠒹=hOvH2a@PQkSIX;5}= "}E/ Jz&8;LbtTIs$ 6J5(D<5Z>j͈i~TdZ/oj4lEYFFb{s =ز`p_ W#}:RX|Mv~뛀>8{^ d< 䧃T]:?zZayM6-U" jon$ |iraJAkwG]{D{?t>Ɔ8K2"ڥ3Wj yAw?n, #sDDʭE TU $ W7g0fX~hzVT0S Ѩ3qZ;u΍TY@aICF64к %Sv~x5Fffm߃Hz/ .|tcS!jyw #Xa8cSbx cSV> /8 W'1}q-t2Ԕqm4 x*N%EoV ʐ?1.;Ou暷?XVB^H3XgdGӡQ ӧXRJ#sn\kFh:>j'QsxYVUWc\G#_[l;I pbVFwkN-LU ( Jt,8d#;)M.ѹ$Q/z+wtjx\-[ϸ8 &]7lQmv`KJ=g47u -@@NKzs)A٤5V`M8n@ U+*΍ővgX;?K9ٲ;9l{s^%zR čQ"1h/$lHNikG p?Ç1WV"T'w+E8{"ScY}|~c<r o·A;;ehcc悮/3̟ lZ_jبb:ȓxXI6l^*yvh+6fn50&,W?*0a J@F~*ǻsoйa U '@^7SFۈ~$ϡ?H5N|(UHH|ZOɌqNJ[ L&PWK 1L~ĝ#Gàr7~ { WD)\UF*껷2A'95<19O"C1CTg|ǯh^dB?Bh3Rh|xѡc@XhA/2(ͮ$әy/^ 7.^#; ə0K@Ǝzw4T/ջ'wPvPttM/F) Xpc_5lvh!c\4M3x<˄;1rQZsŦ_k<Öॱn[_H&?+So?+KJߙ*NE8Xj)arjEh釯r9v.\|>(`j40T;ca(Uڟ`\a!"tlj߇FR ^-76cq:z]jᡁfupl *Zh> ܇i넉EF[1d8NSk$"z0 YZshapes/data/gorm.dat.rda0000644000176200001440000000132514367226002014654 0ustar liggesusersBZh91AY&SY? spFUUw@@@@@@Ў3qA&x('H3S4m#@i Oj"BdM0d22M2iUST4CA a102 hM@ OQhd^mvtnmCBtȊV)WIEl* vLiNhc*0n]]EK˕ˣɺ󲳰wCRRKWP0)Bg2 Q5~&Qj޶۟jsr 9 B@{C!LbѤ4deކC_Gx;gd""!)%]%;BWmDa?` F1Ri#قt*BMjmM.آiڠ9[qx/mv-'`p}6Wq=] % ~X I530p88[ a0 XN E$(K !"ED% TU,)) HBYTXHHDƓ9KUa" "cI bJV\@BN&cӷA5/AuG=p̀fÊSfi*s!1aFȅN@EFKUhuv*J`m ہ2G"mF!YxAU]Թw֛cLi, # &".p ~7shapes/man/0000755000176200001440000000000014367226001012311 5ustar liggesusersshapes/man/tpsgrid.Rd0000754000176200001440000000515613204274452014267 0ustar liggesusers\name{tpsgrid} \alias{tpsgrid} %- Also NEED an `\alias' for EACH other topic documented here. \title{Thin-plate spline transformation grids} \description{Thin-plate spline transformation grids from one set of landmarks to another. } \usage{ tpsgrid(TT, YY, xbegin=-999, ybegin=-999, xwidth=-999, opt=1, ext=0.1, ngrid=22, cex=1, pch=20, col=2,zslice=0, mag=1, axes3=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{TT}{First object (source): (k x m matrix)} \item{YY}{Second object (target): (k x m matrix)} \item{xbegin}{lowest x value for plot: if -999 then a value is determined} \item{ybegin}{lowest y value for plot: if -999 then a value is determined } \item{xwidth}{width of plot: if -999 then a value is determined} \item{opt}{Option 1: (just deformed grid on YY is displayed), option 2: both grids are displayed} \item{ext}{Amount of border on plot in 2D case.} \item{ngrid}{Number of grid points: size is ngrid * (ngrid -1)} \item{cex}{Point size} \item{pch}{Point symbol} \item{col}{Point colour} \item{zslice}{For 3D case the scaled z co-ordinate(s) for the grid slice(s). The values are on a standardized scale as a proportion of height from the middle of the z-axis to the top and bottom. Values in the range -1 to 1 would be sensible.} \item{mag}{Exaggerate effect (mag > 1). Standard effect has mag=1.} \item{axes3}{Logical. If TRUE then the axes are plotted in a 3D plot.} } \details{ A square grid on the first configuration is deformed smoothly using a pair of thin-plate splines in 2D, or a triple of splines in 3D, to a curved grid on the second object. For 3D data the grid is placed at a constant z-value on the first figuure, indicated by the value of zslice. For 2D data the covariance function in the thin-plate spline is $sigma(h) = |h|^2 log |h|^2$ and in 3D it is given by $sigma(h) = -| h |$. } \value{ No returned value } \references{ Bookstein, F.L. (1989). Principal warps: thin-plate splines and the decomposition of deformations, IEEE Transactions on Pattern Analysis and Machine Intelligence, 11, 567--585. Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 12. } \author{Ian Dryden} \seealso{procGPA} \examples{ data(gorf.dat) data(gorm.dat) #TPS grid with shape change exaggerated (2x) gorf<-procGPA(gorf.dat) gorm<-procGPA(gorm.dat) TT<-gorf$mshape YY<-gorm$mshape tpsgrid(TT,YY,mag=2) title("TPS grid: Female mean (left) to Male mean (right)") } \keyword{multivariate}% at least one, from doc/KEYWORDS \keyword{hplot} shapes/man/humanmove.Rd0000754000176200001440000000125012563137647014614 0ustar liggesusers\name{humanmove} \alias{humanmove} \title{Human movement data} \description{Human movement data. 4 landmarks in 2 dimensions, 5 individuals observed at 10 times. } \usage{data(humanmove)} \format{ humanmove: An array of landmark configurations 4 x 2 x 10 x 5 } \source{ Alshabani, A. K. S. and Dryden, I. L. and Litton, C. D. and Richardson, J. (2007). Bayesian analysis of human movement curves, J. Roy. Statist. Soc. Ser. C, 56, 415--428. } \references{ Data from James Richardson. } \examples{ data(humanmove) #plotshapes(humanmove[,,,1]) #for (i in 2:5){ #for (j in 1:4){ #for (k in 1:10){ #points(humanmove[j,,k,i],col=i) #} #} #} } \keyword{datasets} shapes/man/brains.Rd0000754000176200001440000000147212054347444014072 0ustar liggesusers\name{brains} \alias{brains} \title{Brain landmark data} \description{24 landmarks located in 58 adult healthy brains} \usage{data(brains)} \format{A list with components: brains$x : An array of dimension 24 x 3 x 58 containing the landmarks in 3D brains$sex : Sex of each volunteer (m or f) brains$age : Age of each volunteer brains$handed : Handedness of each volunteer (r or l) brains$grp : group label: 1= right-handed males, 2=left-handed males, 3=right-handed females, 4=left-handed females } \references{ Free, S.L., O'Higgins, P., Maudgil, D.D., Dryden, I.L., Lemieux, L., Fish, D.R. and Shorvon, S.D. (2001). Landmark-based morphometrics of the normal adult brain using MRI. Neuroimage , 13 , 801--813. } \examples{ data(brains) # plot first three brains shapes3d(brains$x[,,1:3]) } \keyword{datasets} shapes/man/shapepca.Rd0000754000176200001440000000464613204275144014401 0ustar liggesusers\name{shapepca} \alias{shapepca} %- Also NEED an `\alias' for EACH other topic documented here. \title{Principal components analysis for shape} \description{ Provides graphical summaries of principal components for shape. } \usage{ shapepca(proc, pcno = c(1, 2, 3), type = "r", mag = 1, joinline = c(1, 1), project=c(1,2),scores3d=FALSE,color=2,axes3=FALSE,rglopen=TRUE,zslice=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{proc}{List given by the output from \code{procGPA()} } \item{pcno}{A vector of the PCs to be plotted} \item{type}{Options for the types of plot for the $m=2$ planar case: "r" : rows along PCs evaluated at c = -3,0,3 sd's along PC, "v" : vectors drawn from mean to +3 sd's along PC, "s" : plots along c= -3, -2, -1, 0, 1, 2, 3 superimposed, "m" : movie backward and forwards from -3 to +3 sd's along PC, "g" : TPS grid from mean to +3 sd's along PC. } \item{mag}{Magnification of the effect of the PC (scalar multiple of sd's)} \item{joinline}{A vector stating which landmarks are joined up by lines, e.g. joinline=c(1:n,1) will start at landmark 1, join to 2, ..., join to n, then re-join to landmark 1.} \item{project}{The default orthogonal projections if in higher than 2 dimensions} \item{scores3d}{Logical. If TRUE then a 3D scatterplot of the first 3 raw PC scores with labels in `pcno' is given, instead of the default plot of the mean and PC vectors.} \item{color}{Color of the spheres used in plotting. Default color = 2 (red). If a vector is given then the points are colored in that order.} \item{axes3}{Logical. If TRUE then the axes are plotted in a 3D plot.} \item{rglopen}{Logical. If TRUE open a new RGL window, otherwise plot in current window.} \item{zslice}{For 3D case, type = "g": the z co-ordinate(s) for the grid slice(s)} } \details{The mean and PCs are plotted. } \value{ No value is returned } \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 7.} \author{Ian Dryden} \seealso{procGPA} \examples{ #2d example data(gorf.dat) data(gorm.dat) gorf<-procGPA(gorf.dat) gorm<-procGPA(gorm.dat) shapepca(gorf,type="r",mag=3) shapepca(gorf,type="v",mag=3) shapepca(gorm,type="r",mag=3) shapepca(gorm,type="v",mag=3) #3D example #data(macm.dat) #out<-procGPA(macm.dat) #movie #shapepca(out,pcno=1) } \keyword{hplot} \keyword{multivariate} shapes/man/frechet.Rd0000754000176200001440000000406613204275654014237 0ustar liggesusers\name{frechet} \alias{frechet} \title{Mean shape estimators} \description{Calculation of different types of Frechet mean shapes, or the isotropic offset Gaussian MLE mean shape } \usage{ frechet(x, mean="intrinsic") } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Input k x m x n real array, where k is the number of points, m is the number of dimensions, and n is the sample size. } \item{mean}{Type of mean shape. The Frechet mean shape is obtained by minimizing sum d(x_i,mu)^2 with respect to mu. Different estimators are obtained with different choices of distance d. "intrinsic" intrinsic mean shape (d = rho = Riemannian distance); "partial.procrustes" partial Procrustes (d = 2*sin(rho/2)); "full.procrustes" full Procrustes (d = sin(rho)); h (positive real number) M-estimator (d^2 = (1 - cos^(2h)(rho))/h) Kent (1992); "mle" - isotropic offset Gaussian MLE of Mardia and Dryden (1989) } } \value{A list with components \item{mshape}{Mean shape estimate} \item{var}{Minimized Frechet variance (not available for MLE)} \item{kappa}{(if available) The estimated kappa for the MLE} \item{code}{Code from optimization, as given by function nlm - should be 1 or 2} \item{gradient}{Gradient from the optimization, as given by function nlm - should be close to zero} } \references{ Dryden, I. L. (1991). Discussion to `Procrustes methods in the statistical analysis of shape' by C.R. Goodall. Journal of the Royal Statistical Society, Series B, 53:327-328. Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. Kent, J. T. (1992). New directions in shape analysis. In Mardia, K. V., editor, The Art of Statistical Science, pages 115-127. Wiley, Chichester. Mardia, K. V. and Dryden, I. L. (1989b). The statistical analysis of shape data. Biometrika, 76:271-282. } \author{Ian Dryden} \seealso{procGPA} \examples{ #2D example : female and male Gorillas (cf. Dryden and Mardia, 2016) data(gorf.dat) frechet(gorf.dat[,,1:4],mean="intrinsic") } \keyword{multivariate} shapes/man/mice.Rd0000754000176200001440000000230412054433320013511 0ustar liggesusers\name{mice} \alias{mice} \title{T2 mouse vertabrae data} \description{T2 mouse vertebrae data - 6 landmarks in 2 dimensions, in 3 groups (30 Control, 23 Large, 23 Small mice). The 6 landmarks are obtained using a semi-automatic method at points of high curvature. This particular strain of mice is the `QE' strain. In addition pseudo-landmarks are given around each outlines. } \usage{data(mice)} \format{ mice$x : An array of dimension 6 x 2 x 76 of the two dimensional co-ordinates of 6 landmarks for each of the 76 mice. mice$group : Group labels. "c" Control, "l" Large, "s" Small mice mice$outlines : An array of dimension 60 x 2 x 76 containing the 6 landmarks and 54 pseudo-landmarks, with 9 pseudo-landmarks approximately equally spaced between each pair of landmarks. } \source{ Dryden, I.L. and Mardia, K.V. (1998). Statistical Shape Analysis, Wiley, Chichester. p313 } \references{ Mardia, K. V. and Dryden, I. L. (1989). The statistical analysis of shape data. Biometrika, 76, 271-281. Data from Paul O'Higgins (Hull-York Medical School) and David Johnson (Leeds) } \examples{ data(mice) plotshapes(mice$x,symbol=as.character(mice$group),joinline=c(1,6,2:5,1)) } \keyword{datasets} shapes/man/procdist.Rd0000754000176200001440000000260513204273212014427 0ustar liggesusers\name{procdist} \alias{procdist} %- Also NEED an `\alias' for EACH other topic documented here. \title{Procrustes distance} \description{Calculates different types of Procrustes shape or size-and-shape distance between two configurations} \usage{ procdist(x, y,type="full",reflect=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{k x m matrix (or complex k-vector for 2D data) where k = number of landmarks and m = no of dimensions} \item{y}{k x m matrix (or complex k-vector for 2D data)} \item{type}{string indicating the type of distance; "full" full Procrustes distance, "partial" partial Procrustes distance, "Riemannian" Riemannian shape distance, "sizeandshape" size-and-shape Riemannian/Procrustes distance} \item{reflect}{ Logical. If reflect = TRUE then reflection invariance is included.} } \value{ The distance between the two configurations.} \references{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. } \seealso{procOPA,procGPA} \examples{ data(gorf.dat) data(gorm.dat) gorf<-procGPA(gorf.dat) gorm<-procGPA(gorm.dat) distfull<-procdist(gorf$mshape,gorm$mshape) cat("Full Procustes distance between mean shapes is ",distfull," \n") } \author{Ian Dryden} \keyword{multivariate}% __ONLY ONE__ keyword per line shapes/man/shapes-internal.Rd0000744000176200001440000001256314255152553015713 0ustar liggesusers\name{shapes-internal} \alias{sphere1.f} \alias{rgl.sphgrid1} \alias{sph2car1} \alias{pc2sphere2} \alias{pcscore2sphere2} \alias{preshape2shape} \alias{tangentcoords.partial.inv} \alias{multiply_by_transpose_of_helmert_implicitly} \alias{multiply_by_helmert_implicitly_3d} \alias{uji3_centroid.size} \alias{uji2_centroid.size} \alias{multiply_by_transpose_of_helmert_explicitly} \alias{multiply_by_transpose_of_helmert} \alias{multiply_by_helmert_implicitly} \alias{multiply_by_helmert_explicitly} \alias{multiply_by_helmert} \alias{uji_preshape} \alias{uji_centroid.size} \alias{uji_defh} \alias{uji_Enorm} \alias{uji_distProcrustesFull} \alias{uji_distProcrustesSizeShape} \alias{uji_distCholesky} \alias{uji_estSS} \alias{uji_estShape} \alias{uji_centroid.size.complex} \alias{uji_centroid.size.mD} \alias{uji_preshape.mD} \alias{uji_preshape.mat} \alias{uji_tanfigure} \alias{uji_tanfigurefull} \alias{uji_kendall.shpv} \alias{ild_preshape} \alias{ild_centroid.size} \alias{ild_defh} \alias{ild_Enorm} \alias{ild_distProcrustesFull} \alias{ild_distProcrustesSizeShape} \alias{ild_distCholesky} \alias{ild_estSS} \alias{ild_estShape} \alias{ild_centroid.size.complex} \alias{ild_centroid.size.mD} \alias{ild_preshape.mD} \alias{ild_preshape.mat} \alias{ild_tanfigure} \alias{ild_tanfigurefull} \alias{ild_kendall.shpv} \alias{ild_preshapetoicon} \alias{Enormalize} \alias{ExpNPd} \alias{LRTpval} \alias{LogNPd} \alias{PNSe2s} \alias{PNSs2e} \alias{Plot3D} \alias{Procrustes.dist.full} \alias{UNIFORMdirections} \alias{col2RGB} \alias{flipud0} \alias{geodmeanS1} \alias{get.data.subsphere} \alias{get.prinarc} \alias{get.prinarc.subsphere} \alias{get.prinarc.value} \alias{getSubSphere} \alias{mod} \alias{objfn} \alias{pc2sphere} \alias{pcscore2sphere} \alias{plotshapes3d.pns} \alias{pns.pc} \alias{project.subsphere} \alias{randvonMisesFisherm} \alias{repmat} \alias{rot.mat} \alias{rotMat} \alias{shape.pcscores} \alias{shape.pcscores.partial} \alias{sphere.jac} \alias{sphere.obj} \alias{sphere.res} \alias{sphere2pcscore} \alias{sphereFit} \alias{tangent.coords.partial} \alias{tr} \alias{trans.subsphere} \alias{vMFtest} \alias{ped} \alias{pedreg} \alias{sooty.dat} \alias{MDSshape} \alias{distCholesky} \alias{distEuclidean} \alias{distLogEuclidean} \alias{distPowerEuclidean} \alias{distProcrustesFull} \alias{distProcrustesSizeShape} \alias{rootmat} \alias{distRiemPennec} \alias{Enorm} \alias{estChol} \alias{estShapes} \alias{estEuclid} \alias{estLogEuclid} \alias{estPowerEuclid} \alias{estLogRiem2} \alias{distRiemannianLe} \alias{estCholesky} \alias{estRiemLe} \alias{estShape} \alias{estSS} \alias{Hessian2} \alias{iglogl} \alias{Lambdamin} \alias{nsa} \alias{protein} \alias{James} \alias{select} \alias{procWGPA1} \alias{rotatexyz} \alias{objfun} \alias{objfun4} \alias{bootstraptest} \alias{testmeanshapes.old} \alias{permutationtest2} \alias{Goodall} \alias{Hotelling} \alias{abind} \alias{tpsgrid.old} \alias{shaperw} \alias{BoxM} \alias{Goodall2D} \alias{Goodalltest} \alias{Hotelling2D} \alias{Hotelling2Djames} \alias{Hotellingtest} \alias{MGM} \alias{I2mat} \alias{TPSgrid} \alias{V} \alias{Vinv} \alias{Vmat} \alias{add} \alias{as.3d} \alias{banner1} \alias{banner4} \alias{bendingenergy} \alias{bgpa} \alias{bookstein.shpv} \alias{bookstein.shpv.complex} \alias{braincon.dat} \alias{brainscz.dat} \alias{cbevec} \alias{cbevectors} \alias{centroid.size.complex} \alias{centroid.size.mD} \alias{close1} \alias{cnt3} \alias{complextoreal} \alias{defh} \alias{defplotsize2} \alias{defplotsize3} \alias{del} \alias{dif} \alias{dif.old} \alias{dis} \alias{fJ} \alias{fcel} \alias{fcnt} \alias{fgpa} \alias{fgpa.rot} \alias{fgpa.singleiteration} \alias{fopa} \alias{fort.ROTATEANDREFLECT} \alias{fort.ROTATION} \alias{fort} \alias{fos} \alias{fos.REFLECT} \alias{ftrsq} \alias{full.procdist} \alias{genpower} \alias{goodall2d} \alias{goodalltest} \alias{graf} \alias{hotelling2d} \alias{hotellingtest} \alias{isodens} \alias{isologdens} \alias{isomle} \alias{isotropy.test} \alias{kendall.shpv} \alias{linegrid} \alias{loglikeiso} \alias{loglikeiso2} \alias{loneFone} \alias{mahpreshapedist} \alias{makearray} \alias{movie} \alias{msh} \alias{norm} \alias{objfuniso} \alias{oneFone} \alias{partial.procdist} \alias{partialwarpgrids} \alias{partialwarps} \alias{permutationtest} \alias{plot2rwscores} \alias{plot3Ddata} \alias{plot3Ddata.static} \alias{plot3Dmean} \alias{plot3Dpca} \alias{plotPDM} \alias{plotPDM2} \alias{plotPDM3} \alias{plotPDMbook} \alias{plotPDMnoaxis} \alias{plotPDMnoaxis3} \alias{plotpairscores} \alias{plotpca} \alias{plotpca3d} \alias{plotprinwarp} \alias{plotproc} \alias{plotrelwarp} \alias{plotshapes3d} \alias{plotshapestime3d} \alias{pointsPDMnoaxis3} \alias{prcomp1} \alias{preshape} \alias{preshape.mD} \alias{preshape.mat} \alias{preshapetoicon} \alias{prinwscoregrids} \alias{procdistreflect} \alias{procrustes2d} \alias{procrustesGPA} \alias{procrustesGPA.rot} \alias{procrustesgpa} \alias{project} \alias{read.array} \alias{read.in} \alias{realtocomplex} \alias{reassqpr} \alias{relwarps} \alias{rgpa} \alias{riemdist.complex} \alias{riemdist.mD} \alias{rotateaxes} \alias{schizo.dat} \alias{sgpa} \alias{sh} \alias{sigmacov} \alias{sim1} \alias{st} \alias{tanfigure} \alias{tanfigurefull} \alias{tanpreshape} \alias{testshapes} \alias{vec1} \title{Internal function(s)} \description{Internal function(s)} \keyword{internal} shapes/man/procGPA.Rd0000754000176200001440000001360313335566341014110 0ustar liggesusers\name{procGPA} \alias{procGPA} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalised Procrustes analysis} \description{Generalised Procrustes analysis to register landmark configurations into optimal registration using translation, rotation and scaling. Reflection invariance can also be chosen, and registration without scaling is also an option. Also, obtains principal components, and some summary statistics. } \usage{ procGPA(x, scale = TRUE, reflect = FALSE, eigen2d = FALSE, tol1 = 1e-05, tol2 = tol1, tangentcoords = "residual", proc.output=FALSE, distances=TRUE, pcaoutput=TRUE, alpha=0, affine=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Input k x m x n real array, (or k x n complex matrix for m=2 is OK), where k is the number of points, m is the number of dimensions, and n is the sample size. } \item{scale}{Logical quantity indicating if scaling is required} \item{reflect}{Logical quantity indicating if reflection is required} \item{eigen2d}{Logical quantity indicating if complex eigenanalysis should be used to calculate Procrustes mean for the particular 2D case when scale=TRUE, reflect=FALSE} \item{tol1}{Tolerance for optimal rotation for the iterative algorithm: tolerance on the mean sum of squares (divided by size of mean squared) between successive iterations} \item{tol2}{tolerance for rescale/rotation step for the iterative algorithm: tolerance on the mean sum of squares (divided by size of mean squared) between successive iterations} \item{tangentcoords}{Type of tangent coordinates. If (SCALE=TRUE) the options are "residual" (Procrustes residuals, which are approximate tangent coordinates to shape space), "partial" (Kent's partial tangent co-ordinates), "expomap" (tangent coordinates from the inverse of the exponential map, which are the similar to "partial" but scaled by (rho/sin(rho)) where rho is the Riemannian distance to the pole of the projection. If (SCALE=FALSE) then all three options give the same tangent co-ordinates to size-and-shape space, which is simply the Procrustes residual X^P - mu. } \item{proc.output}{Logical quantity indicating if printed output during the iterations of the Procrustes GPA algorithm should be given} \item{distances}{Logical quantity indicating if shape distances and sizes should be calculated} \item{pcaoutput}{Logical quantity indicating if PCA should be carried out} \item{alpha}{The parameter alpha used for relative warps analysis, where alpha is the power of the bending energy matrix. If alpha = 0 then standard Procrustes PCA is carried out. If alpha = 1 then large scale variations are emphasized, if alpha = -1 then small scale variations are emphasised. Requires m=2 and m=3 dimensional data if alpha $!=$ 0.} \item{affine}{Logical. If TRUE then only the affine subspace of shape variability is considered.} } \value{A list with components \item{k}{no of landmarks} \item{m}{no of dimensions (m-D dimension configurations)} \item{n}{sample size} \item{mshape}{Procrustes mean shape. Note this is unit size if complex eigenanalysis used, but on the scale of the data if iterative GPA is used.} \item{tan}{The tangent shape (or size-and-shape) coordinates} \item{rotated}{the k x m x n array of full Procrustes rotated data} \item{pcar}{the columns are eigenvectors (PCs) of the sample covariance Sv of tan} \item{pcasd}{the square roots of eigenvalues of Sv using tan (s.d.'s of PCs)} \item{percent}{the percentage of variability explained by the PCs using tan. If alpha $!=0$ then it is the percent of non-affine variation of the relative warp scores. If affine is TRUE it is the percentage of total shape variability of each affine component.} \item{size}{the centroid sizes of the configurations} \item{stdscores}{standardised PC scores (each with unit variance) using tan} \item{rawscores}{raw PC scores using tan} \item{rho}{Kendall's Riemannian shape distance rho to the mean shape} \item{rmsrho}{root mean square (r.m.s.) of rho} \item{rmsd1}{r.m.s. of full Procrustes distances to the mean shape $d_F$} \item{GSS}{Minimized Procrustes sum of squares} } \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. Chapter 7. Goodall, C.R. (1991). Procrustes methods in the statistical analysis of shape (with discussion). Journal of the Royal Statistical Society, Series B, 53: 285-339. Gower, J.C. (1975). Generalized Procrustes analysis, Psychometrika, 40, 33--50. Kent, J.T. (1994). The complex Bingham distribution and shape analysis, Journal of the Royal Statistical Society, Series B, 56, 285-299. Ten Berge, J.M.F. (1977). Orthogonal Procrustes rotation for two or more matrices. Psychometrika, 42, 267-276. } \author{Ian Dryden, with input from Mohammad Faghihi and Alfred Kume} \seealso{procOPA,riemdist,shapepca,testmeanshapes} \examples{ #2D example : female and male Gorillas (cf. Dryden and Mardia, 2016) data(gorf.dat) data(gorm.dat) plotshapes(gorf.dat,gorm.dat) n1<-dim(gorf.dat)[3] n2<-dim(gorm.dat)[3] k<-dim(gorf.dat)[1] m<-dim(gorf.dat)[2] gor.dat<-array(0,c(k,2,n1+n2)) gor.dat[,,1:n1]<-gorf.dat gor.dat[,,(n1+1):(n1+n2)]<-gorm.dat gor<-procGPA(gor.dat) shapepca(gor,type="r",mag=3) shapepca(gor,type="v",mag=3) gor.gp<-c(rep("f",times=30),rep("m",times=29)) x<-cbind(gor$size,gor$rho,gor$scores[,1:3]) pairs(x,panel=function(x,y) text(x,y,gor.gp), label=c("s","rho","score 1","score 2","score 3")) ########################################################## #3D example data(macm.dat) out<-procGPA(macm.dat,scale=FALSE) par(mfrow=c(2,2)) plot(out$rawscores[,1],out$rawscores[,2],xlab="PC1",ylab="PC2") title("PC scores") plot(out$rawscores[,2],out$rawscores[,3],xlab="PC2",ylab="PC3") plot(out$rawscores[,1],out$rawscores[,3],xlab="PC1",ylab="PC3") plot(out$size,out$rho,xlab="size",ylab="rho") title("Size versus shape distance") } \keyword{multivariate} shapes/man/procOPA.Rd0000754000176200001440000000477213204273243014116 0ustar liggesusers\name{procOPA} \alias{procOPA} %- Also NEED an `\alias' for EACH other topic documented here. \title{Ordinary Procrustes analysis} \description{ Ordinary Procustes analysis : the matching of one configuration to another using translation, rotation and (possibly) scale. Reflections can also be included if desired. The function matches configuration B onto A by least squares.} \usage{ procOPA(A, B, scale = TRUE, reflect = FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{k x m matrix (or complex k-vector for 2D data), of k landmarks in m dimensions. This is the reference figure.} \item{B}{k x m matrix (or complex k-vector for 2D data). This is the figure which is to be transformed.} \item{scale}{logical indicating if scaling is required} \item{reflect}{logical indicating if reflection is allowed} } \value{ A list with components: \item{R}{The estimated rotation matrix (may be an orthogonal matrix if reflection is allowed)} \item{s}{The estimated scale matrix} \item{Ahat}{The centred configuration A} \item{Bhat}{The Procrustes registered configuration B} \item{OSS}{The ordinary Procrustes sum of squares, which is $\|Ahat-Bhat\|^2$} \item{rmsd}{rmsd = sqrt(OSS/(km))} } \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. Chapter 7.} \author{Ian Dryden} \seealso{procGPA,riemdist,tpsgrid} \examples{ data(digit3.dat) A<-digit3.dat[,,1] B<-digit3.dat[,,2] ans<-procOPA(A,B) plotshapes(A,B,joinline=1:13) plotshapes(ans$Ahat,ans$Bhat,joinline=1:13) #Sooty Mangabey data data(sooty.dat) A<-sooty.dat[,,1] #juvenile B<-sooty.dat[,,2] #adult par(mfrow=c(1,3)) par(pty="s") plot(A,xlim=c(-2000,3000),ylim=c(-2000,3000),xlab=" ",ylab=" ") lines(A[c(1:12,1),]) points(B) lines(B[c(1:12,1),],lty=2) title("Juvenile (-------) Adult (- - - -)") #match B onto A out<-procOPA(A,B) #rotation angle print(atan2(out$R[1,2],out$R[1,1])*180/pi) #scale print(out$s) plot(A,xlim=c(-2000,3000),ylim=c(-2000,3000),xlab=" ",ylab=" ") lines(A[c(1:12,1),]) points(out$Bhat) lines(out$Bhat[c(1:12,1),],lty=2) title("Match adult onto juvenile") #match A onto B out<-procOPA(B,A) #rotation angle print(atan2(out$R[1,2],out$R[1,1])*180/pi) #scale print(out$s) plot(B,xlim=c(-2000,3000),ylim=c(-2000,3000),xlab=" ",ylab=" ") lines(B[c(1:12,1),],lty=2) points(out$Bhat) lines(out$Bhat[c(1:12,1),]) title("Match juvenile onto adult") } \keyword{multivariate} shapes/man/rigidbody.Rd0000754000176200001440000000200011171654551014553 0ustar liggesusers\name{rigidbody} \alias{rigidbody} %- Also NEED an `\alias' for EACH other topic documented here. \title{Rigid body transformations} \description{Applies a rigid body transformations to a landmark configuration or array} \usage{ rigidbody(X,transx=0,transy=0,transz=0,thetax=0,thetay=0,thetaz=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{k x m matrix, or k x m x n array where k = number of landmarks and m = no of dimensions and n is no of specimens} \item{transx}{negative shift in x-coordinates} \item{transy}{negative shift in y-coordinates} \item{transz}{negative shift in z-coordinates} \item{thetax}{Rotation about x-axis in degrees} \item{thetay}{Rotation about y-axis in degrees} \item{thetaz}{Rotation about z-axis in degrees} } \value{ The transformed coordinates (X - trans) Rx Ry Rz } \examples{ data(gorf.dat) plotshapes ( rigidbody(gorf.dat , 0, 0, 0, 0, 0, -90 ) ) } \author{Ian Dryden} \keyword{multivariate}% __ONLY ONE__ keyword per line shapes/man/qlet2.dat.Rd0000754000176200001440000000114613204275321014400 0ustar liggesusers\name{qlet2.dat} \alias{qlet2.dat} \title{Large T2 mouse vertabrae data} \description{T2 mouse vertebrae data - large group. 6 landmarks in 2 dimensions, 23 individuals } \usage{data(qlet2.dat)} \format{ An array of dimension 6 x 2 x 23 } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ http://www.maths.nott.ac.uk/personal/ild/bookdata/qlet2.dat Data from Paul O'Higgins (Hull-York Medical School) and David Johnson (Leeds) } \examples{ data(qlet2.dat) plotshapes(qlet2.dat) } \keyword{datasets} shapes/man/shells.Rd0000754000176200001440000000163512563415537014113 0ustar liggesusers\name{shells} \alias{shells} \title{Microfossil shell data} \description{Microfossil shell data. Triangles from 21 individuals. Lohmann (1983) published 21 mean outlines of the microfossil which were based on random samples of organisms taken at different latitudes in the South Indian Ocean. } \usage{data(shells)} \format{ shells$uv Scaled shape coordinates (Bookstein shape co-ordinates with base (0,0) and (1,0). shells$size Centroid size } \source{ Bookstein, F. L. (1986). Size and shape spaces for landmark data in two dimensions (with discussion). Statistical Science, 1:181-242. Lohmann, G. P. (1983). Eigenshape analysis of microfossils: a general morphometric procedure for describing changes in shape. Mathematical Geology, 15:659-672. } \references{ The data have been extracted from Fig. 7 of Bookstein (1986). } \examples{ data(shells) plotshapes(shells$uv) } \keyword{datasets} shapes/man/ssriemdist.Rd0000754000176200001440000000234613353165756015012 0ustar liggesusers\name{ssriemdist} \alias{ssriemdist} %- Also NEED an `\alias' for EACH other topic documented here. \title{Riemannian size-and-shape distance} \description{Calculates the Riemannian size-and-shape distance d_S between two configurations} \usage{ ssriemdist(x, y, reflect=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{k x m matrix (or complex k-vector for 2D data) where k = number of landmarks and m = no of dimensions} \item{y}{k x m matrix (or complex k-vector for 2D data)} \item{reflect}{ Logical. If reflect = TRUE then reflection invariance is included.} } \value{ The Riemannian size-and-shape distance d_S between the two configurations. (for the Riemannian shape distance use riemdist) } \references{ Le, H.-L. (1995). Mean size-and-shapes and mean shapes: a geometric point of view. Advances in Applied Probability, 27:44-55. } \seealso{procOPA,procGPA,riemdist} \examples{ data(gorf.dat) data(gorm.dat) gorf<-procGPA(gorf.dat,scale=FALSE) gorm<-procGPA(gorm.dat,scale=FALSE) ds<-ssriemdist(gorf$mshape,gorm$mshape) cat("Riemannian size-and-shape distance between mean size-and-shapes is ",ds," \n") } \author{Ian Dryden} \keyword{multivariate}% __ONLY ONE__ keyword per line shapes/man/steroids.Rd0000754000176200001440000000311012054717114014432 0ustar liggesusers\name{steroids} \alias{steroids} \title{Steroid data} \description{Steroid data. Between 42 and 61 atoms for each of 31 steroid molecules. } \usage{data(steroids)} \format{ steroids$x : An array of dimension 61 x 3 x 31 of 3D co-ordinates of the 31 steroids. If a molecules has less than 61 atoms then the remaining co-ordinates are all zero. steroids$activity : Activity class (`1' = high, `2' = intermediate, and `3' = low binding affinities to the corticosteroid binding globulin (CBG) receptor) steroids$radius : van der Waals radius (0 = missing value) steoirds$atom : atom type (0 = missing value) steroids$charge : partial charge (0 = missing value) steroids$names : steroid names } \source{ This particular version of the steroids data set of (x, y, z) atom co-ordinates and partial charges was constructed by Jonathan Hirst and James Melville (School of Chemistry, University of Nottingham). Also see Wagener, M., Sadowski, J., Gasteiger, J. (1995). J. Am. Chem. Soc., 117, 7769-7775. http://www2.ccc.uni-erlangen.de/services/steroids/ } \references{ Dryden, I.L., Hirst, J.D. and Melville, J.L. (2007). Statistical analysis of unlabelled point sets: comparing molecules in chemoinformatics. Biometrics, 63, 237-251. Czogiel I., Dryden, I.L. and Brignell, C.J. (2011). Bayesian matching of unlabeled point sets using random fields, with an application to molecular alignment. Annals of Applied Statistics, 5, 2603-2629. } \examples{ data(steroids) shapes3d(steroids$x[,,1]) } \keyword{datasets} shapes/man/transformations.Rd0000754000176200001440000000302313204274355016035 0ustar liggesusers\name{transformations} \alias{transformations} %- Also NEED an `\alias' for EACH other topic documented here. \title{Calculate similarity transformations} \description{Calculate similarity transformations between configurations in two arrays. } \usage{ transformations(Xrotated,Xoriginal) } %- maybe also `usage' for other objects documented here. \arguments{ \item{Xrotated}{Input k x m x n real array of the Procrustes transformed configurations, where k is the number of points, m is the number of dimensions, and n is the sample size. } \item{Xoriginal}{Input k x m x n real array of the Procrustes original configurations, where k is the number of points, m is the number of dimensions, and n is the sample size. } } \value{A list with components \item{translation}{The translation parameters. These are the relative translations of the centroids of the individuals.} \item{scale}{The scale parameters} \item{rotation}{The rotation parameters. These are the rotations between the individuals after they have both been centred.} } \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester.} \author{Ian Dryden} \seealso{procGPA} \examples{ #2D example : female and male Gorillas (cf. Dryden and Mardia, 2016) data(gorf.dat) Xorig <- gorf.dat Xrotated <- procGPA(gorf.dat)$rotated transformations(Xrotated,Xorig) } \keyword{multivariate} shapes/man/gorf.dat.Rd0000754000176200001440000000135413204275600014307 0ustar liggesusers\name{gorf.dat} \alias{gorf.dat} \title{Female gorilla data} \description{Female gorilla skull data. 8 landmarks in 2 dimensions, 30 individuals } \usage{data(gorf.dat)} \format{ An array of dimension 8 x 2 x 30 } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. O'Higgins, P. and Dryden, I. L. (1993). Sexual dimorphism in hominoids: further studies of craniofacial shape differences in Pan, Gorilla, Pongo, Journal of Human Evolution, 24, 183-205. } \references{ http://www.maths.nott.ac.uk/personal/ild/bookdata/gorf.dat Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(gorf.dat) plotshapes(gorf.dat) } \keyword{datasets} shapes/man/qset2.dat.Rd0000754000176200001440000000114613204275350014411 0ustar liggesusers\name{qset2.dat} \alias{qset2.dat} \title{Small T2 mouse vertabrae data} \description{T2 mouse vertebrae data - small group. 6 landmarks in 2 dimensions, 23 individuals } \usage{data(qset2.dat)} \format{ An array of dimension 6 x 2 x 23 } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ http://www.maths.nott.ac.uk/personal/ild/bookdata/qset2.dat Data from Paul O'Higgins (Hull-York Medical School) and David Johnson (Leeds) } \examples{ data(qset2.dat) plotshapes(qset2.dat) } \keyword{datasets} shapes/man/macm.dat.Rd0000754000176200001440000000075613204275446014304 0ustar liggesusers\name{macm.dat} \alias{macm.dat} \title{Male macaque data} \description{Male macaque skull data. 7 landmarks in 3 dimensions, 9 individuals } \usage{data(macm.dat)} \format{ An array of dimension 7 x 3 x 9 } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(macm.dat) plotshapes(macm.dat) } \keyword{datasets} shapes/man/panm.dat.Rd0000754000176200001440000000104610706112524014302 0ustar liggesusers\name{panm.dat} \alias{panm.dat} \title{Male chimpanzee data} \description{Male chimpanzee skull data. 8 landmarks in 2 dimensions, 28 individuals } \usage{data(panm.dat)} \format{ An array of dimension 8 x 2 x 28 } \source{ O'Higgins, P. and Dryden, I. L. (1993). Sexual dimorphism in hominoids: further studies of craniofacial shape differences in Pan, Gorilla, Pongo, Journal of Human Evolution, 24, 183-205. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(panm.dat) plotshapes(panm.dat) } \keyword{datasets} shapes/man/pongof.dat.Rd0000754000176200001440000000106411171646262014647 0ustar liggesusers\name{pongof.dat} \alias{pongof.dat} \title{Female orang utan data} \description{Female orang utan skull data. 8 landmarks in 2 dimensions, 30 individuals } \usage{data(pongof.dat)} \format{ An array of dimension 8 x 2 x 30 } \source{ O'Higgins, P. and Dryden, I. L. (1993). Sexual dimorphism in hominoids: further studies of craniofacial shape differences in Pan, Gorilla, Pongo, Journal of Human Evolution, 24, 183-205. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(pongof.dat) plotshapes(pongof.dat) } \keyword{datasets} shapes/man/shapes.cva.Rd0000754000176200001440000000254714035642324014647 0ustar liggesusers\name{shapes.cva} \alias{shapes.cva} %- Also NEED an `\alias' for EACH other topic documented here. \title{Canonical variate analysis for shapes} \description{Carry out canonical variate analysis for shapes (in two or more groups) } \usage{ shapes.cva(X,groups,scale=TRUE,tangentcoords = "residual",ncv=2) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{Input k x m x n real array of the configurations, where k is the number of points, m is the number of dimensions, and n is the sample size. } \item{groups}{The group labels} \item{scale}{Logical, indicating if Procrustes scaling should be carried out} \item{tangentcoords}{The type of Procrustes tangent coordinates to use (as for procGPA)} \item{ncv}{Number of canonical variates to display} } \value{A plot if ncv=2 or 3 and the Canonical Variate Scores} \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester.} \author{Ian Dryden} \seealso{procGPA} \examples{ #2D example : female and male apes (cf. Dryden and Mardia, 2016) data(pongof.dat) data(pongom.dat) data(panm.dat) data(panf.dat) apes <- groupstack( pongof.dat , pongom.dat , panm.dat, panf.dat ) shapes.cva( apes$x, apes$groups) } \keyword{multivariate} shapes/man/bookstein2d.Rd0000754000176200001440000000234613204273375015037 0ustar liggesusers\name{bookstein2d} \alias{bookstein2d} \title{Bookstein's baseline registration for 2D data} \description{Carries out Bookstein's baseline registration and calculates a mean shape} \usage{bookstein2d(A,l1=1,l2=2)} \arguments{ \item{A}{a k x 2 x n real array, or k x n complex matrix, where k is the number of landmarks, n is the number of observations} \item{l1}{l1: an integer : l1 is sent to (-1/2,0) in the registration} \item{l2}{l2: an integer : l2 is sent to (1/2,0) in the registration} } \value{A list with components: \item{k}{number of landmarks} \item{n}{sample size} \item{mshape}{Bookstein mean shape with baseline l1, l2} \item{bshpv}{the k x n x 2 array of Bookstein shape variables, including the baseline} } \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. Chapter 2. Bookstein, F. L. (1986) Size and shape spaces for landmark data in two dimensions (with discussion). Statistical Science, 1:181-242. } \author{Ian Dryden} \examples{ data(gorf.dat) data(gorm.dat) bookf<-bookstein2d(gorf.dat) bookm<-bookstein2d(gorm.dat) plotshapes(bookf$mshape,bookm$mshape,joinline=c(1,6,7,8,2,3,4,5,1)) } \keyword{multivariate} shapes/man/pns4pc.Rd0000754000176200001440000000354314040120153014003 0ustar liggesusers\name{pns4pc} \alias{pns4pc} \title{Principal Nested Shape Spaces from PCA} \description{Approximation of Principal Nested Shapes Spaces using PCA } \usage{ pns4pc(x, sphere.type = "seq.test", alpha = 0.1, R = 100, nlast.small.sphere = 1,n.pc=2) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{k x m x n array of landmark data.} \item{sphere.type}{ a character string specifying the type of sphere fitting method. "seq.test" specifies sequential tests to decide either "small" or "great"; "small" specifies Principal Nested SMALL Sphere; "great" specifies Principal Nested GREAT Sphere (radius pi/2); "BIC" specifies BIC statistic to decide either "small" or "great"; and "bi.sphere" specifies Principal Nested GREAT Sphere for the first part and Principal Nested SMALL Sphere for The default is "seq.test". } \item{alpha}{significance level (0 < alpha < 1) used when sphere.type = "seq.test". The default is 0.1. } \item{R}{the number of bootstrap samples to be evaluated for the sequential test. The default is 100.} \item{nlast.small.sphere}{the number of small spheres in the finishing part used when sphere.type = "bi.sphere".} \item{n.pc}{the number of PC scores to be used (n.pc >= 2)} } \value{A list with components \item{PNS}{the output of the function pns} \item{GPAout}{the result of GPA} \item{spheredata}{transformed spherical data from the PC scores} \item{percent}{proportion of variances explained.} } \references{ Dryden, I.L., Kim, K., Laughton, C.A. and Le, H. (2019). Principal nested shape space analysis of molecular dynamics data. Annals of Applied Statistics, 13, 2213-2234. Jung, S., Dryden, I.L. and Marron, J.S. (2012). Analysis of principal nested spheres. Biometrika, 99, 551-568. } \author{Kwang-Rae Kim} \seealso{pns, pns4pc, pnss3d, plot3darcs} \examples{ pns4pc(digit3.dat,n.pc=2) } \keyword{multivariate} shapes/man/schizophrenia.Rd0000754000176200001440000000315112054472361015453 0ustar liggesusers\name{schizophrenia} \alias{schizophrenia} \title{Bookstein's schizophrenia data} \description{Bookstein's schizophrenia data. 13 landmarks in 2 dimensions, 28 individuals. The first 14 individuals are controls. The last fourteen cases were diagnosed with schizophrenia. The landmarks were taken in the near midline from MR images of the brain: (1) splenium, posteriormost point on corpus callosum; (2) genu, anteriormost point on corpus callosum; (3) top of corpus callosum, uppermost point on arch of callosum (all three to an approximate registration on the diameter of the callosum); (4) top of head, a point relaxed from a standard landmark along the apparent margin of the dura; (5) tentorium of cerebellum at dura; (6) top of cerebellum; (7) tip of fourth ventricle; (8) bottom of cerebellum; (9) top of pons, anterior margin; (10) bottom of pons, anterior margin; (11) optic chiasm; (12) frontal pole, extension of a line from landmark 1 through landmark 2 until it intersects the dura; (13) superior colliculus. } \usage{data(schizophrenia.dat)} \format{ schizophrenia$x : An array of dimension 13 x 2 x 28 schizophrenia$group : A factor of group labels `con' for Controls and `scz' for the schizophrenia patients. } \source{ Bookstein, F. L. (1996). Biometrics, biomathematics and the morphometric synthesis, Bulletin of Mathematical Biology, 58, 313--365. } \references{ Data kindly provided by Fred Bookstein (University of Washington and University of Vienna) } \examples{ data(schizophrenia) plotshapes(schizophrenia$x,symbol=as.integer(schizophrenia$group)) } \keyword{datasets} shapes/man/dna.dat.Rd0000754000176200001440000000042111672137500014111 0ustar liggesusers\name{dna.dat} \alias{dna.dat} \title{DNA data} \description{Part of a 3D DNA molecule moving in time, k = 22 atoms, 30 time points} \usage{data(dna.dat)} \format{ An array of dimension 22 x 3 x 30 } \examples{ data(dna.dat) plotshapestime3d(dna.dat) } \keyword{datasets} shapes/man/pnss3d.Rd0000754000176200001440000000426314255111155014020 0ustar liggesusers\name{pnss3d} \alias{pnss3d} \title{Principal Nested Shape Space Analysis} \description{Approximation of Principal Nested Shapes Spaces using PCA: 2D or 3D data, small or large samples } \usage{ pnss3d(x,sphere.type="seq.test",alpha = 0.1,R = 100, nlast.small.sphere = 1,n.pc="Full",output=TRUE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{k x m x n array of landmark data.} \item{sphere.type}{ a character string specifying the type of sphere fitting method. "seq.test" specifies sequential tests to decide either "small" or "great"; "small" specifies Principal Nested SMALL Sphere; "great" specifies Principal Nested GREAT Sphere (radius pi/2); "BIC" specifies BIC statistic to decide either "small" or "great"; and "bi.sphere" specifies Principal Nested GREAT Sphere for the first part and Principal Nested SMALL Sphere for the last part. The default is "seq.test". } \item{alpha}{significance level (0 < alpha < 1) used when sphere.type = "seq.test". The default is 0.1. } \item{R}{the number of bootstrap samples to be evaluated for the sequential test. The default is 100.} \item{nlast.small.sphere}{the number of small spheres in the finishing part used when sphere.type = "bi.sphere".} \item{n.pc}{the number of PC scores to be used (n.pc >= 2)} \item{output}{Logical. If TRUE then plots and some brief printed summaries are given. If FALSE then no plots or output is given.} } \value{A list with components \item{PNS}{the output of the function pns} \item{GPAout}{the result of GPA} \item{spheredata}{transformed spherical data from the PC scores} \item{percent}{proportion of variances explained.} } \references{ Dryden, I.L., Kim, K., Laughton, C.A. and Le, H. (2019). Principal nested shape space analysis of molecular dynamics data. Annals of Applied Statistics, 13, 2213-2234. Jung, S., Dryden, I.L. and Marron, J.S. (2012). Analysis of principal nested spheres. Biometrika, 99, 551-568. } \author{Kwang-Rae Kim, Ian Dryden} \seealso{pns, pns4pc, plot3darcs} \examples{ ans <- pnss3d(digit3.dat, sphere.type="BIC", n.pc=5) #aa <- plot3darcs(ans,c=2,pcno=1) #bb <- plot3darcs(ans,c=2,pcno=1,type="pca") } \keyword{multivariate} shapes/man/distcov.Rd0000754000176200001440000000264612021403052014251 0ustar liggesusers\name{distcov} \alias{distcov} %- Also NEED an `\alias' for EACH other topic documented here. \title{Compute a distance between two covariance matrices} \description{Compute a distance between two covariance matrices, with non-Euclidean options. } \usage{ distcov(S1, S2, method="Riemannian",alpha=1/2) } %- maybe also `usage' for other objects documented here. \arguments{ \item{S1}{Input a covariance matrix (square, symmetric, positive definite)} \item{S2}{Input another covariance matrix of the same size } \item{method}{The type of distance to be used: "Procrustes": Procrustes size-and-shape metric, "ProcrustesShape": Procrustes metric with scaling, "Riemannian": Riemannian metric, "Cholesky": Cholesky based distance, "Power: Power Euclidean, with power alpha, "Euclidean": Euclidean metric, "LogEuclidean": Log-Euclidean metric, "RiemannianLe": Another Riemannian metric.} \item{alpha}{The power to be used in the power Euclidean metric } } \value{The distance } \references{Dryden, I.L., Koloydenko, A. and Zhou, D. (2009). Non-Euclidean statistics for covariance matrices, with applications to diffusion tensor imaging. Annals of Applied Statistics, 3, 1102-1123.} \author{Ian Dryden} \seealso{estcov} \examples{ A <- diag(5) B <- A + .1*matrix(rnorm(25),5,5) S1<-A S2<- B%*%t(B) distcov( S1, S2, method="Procrustes") } \keyword{multivariate} shapes/man/macf.dat.Rd0000754000176200001440000000076213204275414014265 0ustar liggesusers\name{macf.dat} \alias{macf.dat} \title{Female macaque data} \description{Female macaque skull data. 7 landmarks in 3 dimensions, 9 individuals } \usage{data(macf.dat)} \format{ An array of dimension 7 x 3 x 9 } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(macf.dat) plotshapes(macf.dat) } \keyword{datasets} shapes/man/sooty.Rd0000754000176200001440000000123713204275045013763 0ustar liggesusers\name{sooty} \alias{sooty} \title{Sooty mangabey data} \description{Sooty mangabey data skull data. 12 landmarks in 2 dimensions, 2 individuals (juvenile and male adult) followed by three individuals, female adult, male adult. The first entries are rotated, translated versions of the 3rd and 7th figure. } \usage{data(sooty)} \format{ An array of dimension 12 x 2 x 7 } \source{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(sooty) plotshapes(sooty,joinline=c(1:12,1)) } \keyword{datasets} shapes/man/digit3.dat.Rd0000754000176200001440000000113113204273562014533 0ustar liggesusers\name{digit3.dat} \alias{digit3.dat} \title{Digit 3 data} \description{Handwritten digit `3' data. 13 landmarks in 2 dimensions, 30 individuals } \usage{data(digit3.dat)} \format{ An array of dimension 13 x 2 x 30 } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ http://www.maths.nott.ac.uk/personal/ild/bookdata/digit3.dat Data from Cath Anderson } \examples{ data(digit3.dat) k<-dim(digit3.dat)[1] n<-dim(digit3.dat)[3] plotshapes(digit3.dat,joinline=c(1:13)) } \keyword{datasets} shapes/man/resampletest.Rd0000754000176200001440000001046613204275231015317 0ustar liggesusers\name{resampletest} \alias{resampletest} %- Also NEED an `\alias' for EACH other topic documented here. \title{Tests for mean shape difference using complex arithmetic, including bootstrap and permutation tests. } \description{ Carries out tests to examine differences in mean shape between two independent populations. For 2D data the methods use complex arithmetic and exploit the geometry of the shape space (which is the main use of this function). An alternative faster, approximate procedure using Procrustes residuals is given by the function `testmeanshapes'. For 3D data tests are carried out on the Procrustes residuals, which is an approximation suitable for small variations in shape. Up to four test statistics are calculated: lambda : the asymptotically pivotal statistic $lambda_min$ from Amaral et al. (2007), equ.(14),(16) (m=2 only) H : Hotelling $T^2$ statistic (see Amaral et al., 2007, equ.(23), Dryden and Mardia, 2016, equ.(9.4)) J : James' statistic (see Amaral et al., 2007, equ.(24) ) (m=2 only) G : Goodall's F statistic (see Amaral et al., 2007, equ.(25), Dryden and Mardia, 2016, equ.(9.9)) p-values are given based on resampling as well as the usual table based p-values. Note when the sample sizes are low (compared to the number of landmarks) some regularization is carried out. In particular if Sw is a singular within group covariance matrix, it is replaced by Sw + 0.000001 (Identity matrix) and a `*' is printed in the output. } \usage{ resampletest(A, B, resamples = 200, replace = TRUE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{The random sample for group 1: k x m x n1 array of data, where k is the number of landmarks and n1 is the sample size. (Alternatively a k x n1 complex matrix for 2D)} \item{B}{The random sample for group 3: k x m x n2 array of data, where k is the number of landmarks and n2 is the sample size. (Alternatively a k x n2 complex matrix for 2D)} \item{resamples}{Integer. The number of resampling iterations. If resamples = 0 then no resampling procedures are carried out, and the tabular p-values are given only.} \item{replace}{Logical. If replace = TRUE then for 2D data bootstrap resampling is carried out with replacement *within* each group. If replace = FALSE then permutation resampling is carried out (sampling without replacement in *pooled* samples).} } \value{ A list with components (or a subset of these) \item{lambda}{$lambda_min$ statistic} \item{lambda.pvalue}{p-value for $lambda_min$ test based on resampling} \item{lambda.table.pvalue}{p-value for $lambda_min$ test based on the asymptotic chi-squared distribution (large n1,n2)} \item{H}{The Hotelling $T^2$ statistic} \item{H.pvalue}{p-value for the Hotelling $T^2$ test based on resampling} \item{H.table.pvalue}{p-value for the Hotelling $T^2$ test based on the null F distribution, assuming normality and equal covariance matrices} \item{J}{The Hotelling $T^2$ statistic} \item{J.pvalue}{p-value for the Hotelling $T^2$ test based on resampling} \item{J.table.pvalue}{p-value for the Hotelling $T^2$ test based on the null F distribution, assuming normality and unequal covariance matrices} \item{G}{The Goodall $F$ statistic} \item{G.pvalue}{p-value for the Goodall test based on resampling} \item{G.table.pvalue}{p-value for the Goodall test based on the null F distribution, assuming normality and equal isotropic covariance matrices)} } \references{Amaral, G.J.A., Dryden, I.L. and Wood, A.T.A. (2007) Pivotal bootstrap methods for $k$-sample problems in directional statistics and shape analysis. Journal of the American Statistical Association. 102, 695-707. Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 9. Goodall, C. R. (1991). Procrustes methods in the statistical analysis of shape (with discussion). Journal of the Royal Statistical Society, Series B, 53: 285-339. } \author{Ian Dryden} \seealso{testmeanshapes} \examples{ #2D example : female and male Gorillas data(gorf.dat) data(gorm.dat) #just select 3 landmarks and the first 10 observations in each group select<-c(1,2,3) A<-gorf.dat[select,,1:10] B<-gorm.dat[select,,1:10] resampletest(A,B,resamples=100) } \keyword{multivariate}% at least one, from doc/KEYWORDS shapes/man/backfit.Rd0000644000176200001440000000260214255157466014221 0ustar liggesusers\name{backfit} \alias{backfit} \title{Backfit from scores to configuration} \description{Backfit from PNSS or PCA scores to a representative configuration } \usage{ backfit(scores, x, type="pnss", size=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{scores}{n x p matrix of scores} \item{x}{ An object that is the output of either pnss3d (if type="pnss") or procGPA (if type="pca") } \item{type}{ Either "pnss" for PNSS or "pca" for PCA } \item{size}{ The centroid size of the backfitted configuration. The default is 1 but one can rescale the backfitting if desired. } } \value{A k x m matrix of co-ordinates of the backfitted configuration } \references{ Dryden, I.L., Kim, K., Laughton, C.A. and Le, H. (2019). Principal nested shape space analysis of molecular dynamics data. Annals of Applied Statistics, 13, 2213-2234. Jung, S., Dryden, I.L. and Marron, J.S. (2012). Analysis of principal nested spheres. Biometrika, 99, 551-568. } \author{Ian Dryden} \seealso{pns, pns4pc, plot3darcs} \examples{ ans <- pnss3d( macf.dat, sphere.type="BIC", n.pc=8) y <- backfit( ans$PNS$scores[1,] , ans ,type="pnss") riemdist( macf.dat[,,1] , y ) #should be close to zero ans2 <- procGPA( macf.dat, tangentcoords="partial") y <- backfit( ans2$scores[1,] , ans2 ,type="pca") riemdist( macf.dat[,,1] , y ) #should be close to zero } \keyword{multivariate} shapes/man/pns.Rd0000754000176200001440000000526114255120564013411 0ustar liggesusers\name{pns} \alias{pns} \title{Principal Nested Spheres} \description{Calculation of Principal Nested Spheres } \usage{ pns(x, sphere.type = "seq.test", alpha = 0.1, R = 100, nlast.small.sphere = 1, output=TRUE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{a (d + 1) x n data matrix where each column is a unit vector in S^d and n is the sample size. } \item{sphere.type}{ a character string specifying the type of sphere fitting method. "seq.test" specifies sequential tests to decide either "small" or "great"; "small" specifies Principal Nested SMALL Sphere; "great" specifies Principal Nested GREAT Sphere (radius pi/2); "BIC" specifies BIC statistic to decide either "small" or "great"; and "bi.sphere" specifies Principal Nested GREAT Sphere for the first part and Principal Nested SMALL Sphere for last parts. The default is "seq.test". } \item{alpha}{significance level (0 < alpha < 1) used when sphere.type = "seq.test". The default is 0.1. } \item{R}{the number of bootstrap samples to be evaluated for the sequential test. The default is 100.} \item{nlast.small.sphere}{the number of small spheres in the finishing part used when sphere.type = "bi.sphere".} \item{output}{Logical. If TRUE then plots and some brief printed summaries are given. If FALSE then no plots or output is given.} } \value{A list with components \item{resmat}{the residual matrix (X_PNS). Each entry in row k works like the kth principal component} \item{$PNS}{= the list with the following components.} \item{radii}{the size (radius) of PNS.} \item{orthaxis}{the orthogonal axis v_i of subspheres.} \item{dist}{the distance r_i of subspheres} \item{pvalues}{the p-values of LRT and parametric boostrap tests (if any).} \item{ratio}{the estimated ratios. Now unavailable.} \item{mean}{the location of the PNS mean.} \item{sphere.type}{the type of method for fitting subspheres.} \item{percent}{proportion of variances explained.} \item{spherePNS}{The co-ordinates of the data points projected to the sphere in 3D (also plotted)} \item{circlePNS}{The co-ordinates of the 2D circle projections on the sphere in 3D (also plotted)} } \references{ Dryden, I.L., Kim, K., Laughton, C.A. and Le, H. (2019). Principal nested shape space analysis of molecular dynamics data. Annals of Applied Statistics, 13, 2213-2234. Jung, S., Dryden, I.L. and Marron, J.S. (2012). Analysis of principal nested spheres. Biometrika, 99, 551-568. } \author{Kwang-Rae Kim: R translation of Sungkyu Jung's matlab code} \seealso{pns4pc, pnss3d} \examples{ # out <- pc2sphere(x = gorf.dat, n.pc = 2) # spheredata <- t(out$spheredata) # pns.out <- pns(x = spheredata) } \keyword{multivariate} shapes/man/gels.Rd0000754000176200001440000000073312563416154013545 0ustar liggesusers\name{gels} \alias{gels} \title{Electrophoresis gel data} \description{Electrophoresis gel data. 10 invariant spots have been picked out by an expert on two electrophoretic gels. } \usage{data(gels)} \format{ An array of dimension 10 x 2 x 2 } \source{ Dryden, I. L. and Walker, G. (1999). Highly resistant regression and object matching. Biometrics, 55, 820-825. } \references{ Data from Chris Glasbey (BioSS) } \examples{ data(gels) plotshapes(gels) } \keyword{datasets} shapes/man/riemdist.Rd0000754000176200001440000000237613353166034014435 0ustar liggesusers\name{riemdist} \alias{riemdist} %- Also NEED an `\alias' for EACH other topic documented here. \title{Riemannian shape distance} \description{Calculates the Riemannian shape distance rho between two configurations} \usage{ riemdist(x, y, reflect=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{k x m matrix (or complex k-vector for 2D data) where k = number of landmarks and m = no of dimensions} \item{y}{k x m matrix (or complex k-vector for 2D data)} \item{reflect}{ Logical. If reflect = TRUE then reflection invariance is included.} } \value{ The Riemannian shape distance rho between the two configurations. Note 0 <= rho <= pi/2 if no reflection invariance. (for the Riemannian size-and-shape distance use ssriemdist)} \references{ Kendall, D. G. (1984). Shape manifolds, Procrustean metrics and complex projective spaces, Bulletin of the London Mathematical Society, 16, 81-121. } \seealso{procOPA,procGPA} \examples{ data(gorf.dat) data(gorm.dat) gorf<-procGPA(gorf.dat) gorm<-procGPA(gorm.dat) rho<-riemdist(gorf$mshape,gorm$mshape) cat("Riemannian distance between mean shapes is ",rho," \n") } \author{Ian Dryden} \keyword{multivariate}% __ONLY ONE__ keyword per line shapes/man/gorm.dat.Rd0000754000176200001440000000134713204275624014326 0ustar liggesusers\name{gorm.dat} \alias{gorm.dat} \title{Male gorilla data} \description{Male gorilla skull data. 8 landmarks in 2 dimensions, 29 individuals } \usage{data(gorm.dat)} \format{ An array of dimension 8 x 2 x 29 } \source{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. O'Higgins, P. and Dryden, I. L. (1993). Sexual dimorphism in hominoids: further studies of craniofacial shape differences in Pan, Gorilla, Pongo, Journal of Human Evolution, 24, 183-205. } \references{ http://www.maths.nott.ac.uk/personal/ild/bookdata/gorm.dat Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(gorm.dat) plotshapes(gorm.dat) } \keyword{datasets} shapes/man/centroid.size.Rd0000754000176200001440000000114213204273433015360 0ustar liggesusers\name{centroid.size} \alias{centroid.size} \title{Centroid size} \description{Calculate cetroid size from a configuration or a sample of configurations. } \usage{centroid.size(x)} \arguments{ \item{x}{For a single configuration k x m matrix or complex k-vector For a sample of configurations k x m x n array or k x n complex matrix } } \value{ Centroid size(s) } \references{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. } \examples{ data(mice) centroid.size(mice$x[,,1]) } \author{Ian Dryden} \keyword{multivariate} shapes/man/qcet2.dat.Rd0000754000176200001440000000115213204275274014373 0ustar liggesusers\name{qcet2.dat} \alias{qcet2.dat} \title{Control T2 mouse vertabrae data} \description{T2 mouse vertebrae data - control group. 6 landmarks in 2 dimensions, 30 individuals } \usage{data(qcet2.dat)} \format{ An array of dimension 6 x 2 x 30 } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ http://www.maths.nott.ac.uk/personal/ild/bookdata/qcet2.dat Data from Paul O'Higgins (Hull-York Medical School) and David Johnson (Leeds) } \examples{ data(qcet2.dat) plotshapes(qcet2.dat) } \keyword{datasets} shapes/man/testmeanshapes.Rd0000754000176200001440000000717413204274653015644 0ustar liggesusers\name{testmeanshapes} \alias{testmeanshapes} %- Also NEED an `\alias' for EACH other topic documented here. \title{Tests for mean shape difference, including permutation and bootstrap tests} \description{ Carries out tests to examine differences in mean shape between two independent populations, for $m=2$ or $m=3$ dimensional data. Tests are carried out using tangent co-ordinates. H : Hotelling $T^2$ statistic (see Dryden and Mardia, 2016, equ.(9.4)) G : Goodall's F statistic (see Dryden and Mardia, 2016, equ.(9.9)) J : James $T^2$ statistic (see Amaral et al., 2007) p-values are given based on resampling (either a bootstrap test or a permutation test) as well as the usual table based p-values. Bootstrap tests involve sampling with replacement under H0 (as in Amaral et al., 2007). Note when the sample sizes are low (compared to the number of landmarks) some minor regularization is carried out. In particular if Sw is a singular within group covariance matrix, it is replaced by Sw + 0.000001 (Identity matrix) and a `*' is printed in the output. } \usage{ testmeanshapes(A, B, resamples = 1000, replace = FALSE, scale= TRUE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{The random sample for group 1: k x m x n1 array of data, where k is the number of landmarks and n1 is the sample size. (Alternatively a k x n1 complex matrix for 2D)} \item{B}{The random sample for group 2: k x m x n2 array of data, where k is the number of landmarks and n2 is the sample size. (Alternatively a k x n2 complex matrix for 2D)} \item{resamples}{Integer. The number of resampling iterations. If resamples = 0 then no resampling procedures are carried out, and the tabular p-values are given only.} \item{replace}{Logical. If replace = TRUE then bootstrap resampling is carried out with replacement *within* each group. If replace = FALSE then permutation resampling is carried out (sampling without replacement in *pooled* samples).} \item{scale}{Logical. Whether or not to carry out Procrustes with scaling in the procedure.} } \value{ A list with components \item{H}{The Hotelling statistic (F statistic)} \item{H.pvalue}{p-value for the Hotelling test based on resampling} \item{H.table.pvalue}{p-value for the Hotelling test based on the null F distribution, assuming normality and equal covariance matrices} \item{J}{The James $T^2$ statistic} \item{J.pvalue}{p-value for the James $T^2$ test based on resampling} \item{J.table.pvalue}{p-value for the James $T^2$ test based on the null F distribution, assuming normality but unequal covariance matrices} \item{G}{The Goodall $F$ statistic} \item{G.pvalue}{p-value for the Goodall test based on resampling} \item{G.table.pvalue}{p-value for the Goodall test based on the null F distribution, assuming normality and equal isotropic covariance matrices)} } \references{Amaral, G.J.A., Dryden, I.L. and Wood, A.T.A. (2007) Pivotal bootstrap methods for $k$-sample problems in directional statistics and shape analysis. Journal of the American Statistical Association. 102, 695-707. Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. Chapter 9. Goodall, C. R. (1991). Procrustes methods in the statistical analysis of shape (with discussion). Journal of the Royal Statistical Society, Series B, 53: 285-339. } \author{Ian Dryden} \seealso{resampletest} \examples{ #2D example : female and male Gorillas data(gorf.dat) data(gorm.dat) A<-gorf.dat B<-gorm.dat testmeanshapes(A,B,resamples=100) } \keyword{multivariate}% at least one, from doc/KEYWORDS shapes/man/sand.Rd0000754000176200001440000000240412054346746013541 0ustar liggesusers\name{sand} \alias{sand} \title{Sand particle outline data} \description{50 points on 24 sea sand and 25 river sand grain profiles in 2D. The original data were kindly provided by Professor Dietrich Stoyan (Stoyan and Stoyan, 1994; Stoyan, 1997). The 50 points on each outline were extracted at approximately equal arc-lengths by the method described in Kent et al. (2000, section 8.1)} \usage{data(sand)} \format{A list with components: sea$x : An array of dimension 50 x 2 x 49 containing the 50 point co-ordinates in 2D for each grain sea$group : The types of the sand grains: "sea", 24 particles from the Baltic Sea "river", 25 particles from the Caucasian River Selenchuk } \references{ Kent, J. T., Dryden, I. L. and Anderson, C. R. (2000). Using circulant symmetry to model featureless objects. Biometrika, 87, 527--544. Stoyan, D. (1997). Geometrical means, medians and variances for samples of particles. Particle Particle Syst. Charact. 14, 30--34. Stoyan, D. and Stoyan, H. (1994). Fractals, Random Shapes and Point Fields: Methods of Geometric Statistics, John Wiley, Chichester. } \examples{ data(sand) plotshapes(sand$x[,,sand$group=="sea"],sand$x[,,sand$group=="river"],joinline=c(1:50)) } \keyword{datasets} shapes/man/groupstack.Rd0000754000176200001440000000270513204275545014776 0ustar liggesusers\name{groupstack} \alias{groupstack} %- Also NEED an `\alias' for EACH other topic documented here. \title{Combine two or more groups of configurations} \description{Combine two or more groups of configurations and create a group label vector. (Maximum 8 groups). } \usage{ groupstack(A1, A2, A3=0, A4=0, A5=0, A6=0, A7=0, A8=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{A1}{Input k x m x n real array of the Procrustes transformed configurations, where k is the number of points, m is the number of dimensions, and n is the sample size. } \item{A2}{Input k x m x n real array of the Procrustes original configurations, where k is the number of points, m is the number of dimensions, and n is the sample size. } \item{A3}{ Optional array} \item{A4}{ Optional array} \item{A5}{ Optional array} \item{A6}{ Optional array} \item{A7}{ Optional array} \item{A8}{ Optional array} } \value{A list with components \item{x}{The combined array of all configurations} \item{groups}{The group labels (integers)} } \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester.} \author{Ian Dryden} \seealso{procGPA} \examples{ #2D example : female and male Gorillas (cf. Dryden and Mardia, 2016) data(gorf.dat) data(gorm.dat) groupstack(gorf.dat,gorm.dat) } \keyword{multivariate} shapes/man/macaques.Rd0000754000176200001440000000134213204275477014413 0ustar liggesusers\name{macaques} \alias{macaques} \title{Male and Female macaque data} \description{Male and female macaque skull data. 7 landmarks in 3 dimensions, 18 individuals (9 males, 9 females) } \usage{data(macaques)} \format{ macaques$x : An array of dimension 7 x 3 x 18 macaques$group : A factor indicating the sex (`m' for male and `f' for female) } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. Chapter 1. } \references{ Dryden, I. L. and Mardia, K. V. (1993). Multivariate shape analysis. Sankhya Series A, 55, 460-480. Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(macaques) shapes3d(macaques$x[,,1]) } \keyword{datasets} shapes/man/plotshapes.Rd0000754000176200001440000000273511042043445014767 0ustar liggesusers\name{plotshapes} \alias{plotshapes} %- Also NEED an `\alias' for EACH other topic documented here. \title{Plot configurations} \description{ Plots configurations. Either one or two groups of observations can be plotted on the same scale. } \usage{ plotshapes(A, B = 0, joinline = c(1, 1),orthproj=c(1,2),color=1,symbol=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{k x m x n array, or k x m matrix for first group} \item{B}{k x m x n array, or k x m matrix for 2nd group (can be missing)} \item{joinline}{A vector stating which landmarks are joined up by lines, e.g. joinline=c(1:n,1) will start at landmark 1, join to 2, ..., join to n, then re-join to landmark 1.} \item{orthproj}{A vector stating which two orthogonal projections will be used. For example, for m=3 dimensional data: X-Y projection given by c(1,2) (default), X-Z projection given by c(1,3), Y-Z projection given by c(2,3).} \item{color}{Colours for points. Can be a vector, e.g. 1:k gives each landmark a different colour for the specimens} \item{symbol}{Plotting symbols. Can be a vector, e.g. 1:k gives each landmark a different symbol for the specimens} } \value{ Just graphical output } \author{Ian Dryden} \seealso{shapepca,tpsgrid} \examples{ data(gorf.dat) data(gorm.dat) plotshapes(gorf.dat,gorm.dat,joinline=c(1,6,7,8,2,3,4,5,1)) data(macm.dat) data(macf.dat) plotshapes(macm.dat,macf.dat) } \keyword{hplot} \keyword{multivariate} shapes/man/apes.Rd0000754000176200001440000000206313204273311013526 0ustar liggesusers\name{apes} \alias{apes} \title{Great ape data} \description{Great ape skull landmark data. 8 landmarks in 2 dimensions, 167 individuals } \usage{data(apes)} \format{ apes$x : An array of dimension 8 x 2 x 167 apes$group : Species and sex of each specimen: "gorf" 30 female gorillas, "gorm" 29 male gorillas, "panf" 26 female chimpanzees, "pamm" 28 male chimpanzees, "pongof" 24 female orang utans, "pongom" 30 male orang utans. } \source{ Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. O'Higgins, P. and Dryden, I. L. (1993). Sexual dimorphism in hominoids: further studies of craniofacial shape differences in Pan, Gorilla, Pongo, Journal of Human Evolution, 24, 183-205. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(apes) par(mfrow=c(1,2)) plotshapes(apes$x[,,apes$group=="gorf"],symbol="f") plotshapes(apes$x[,,apes$group=="gorm"],symbol="m") } \keyword{datasets} shapes/man/pongom.dat.Rd0000754000176200001440000000106010706112555014646 0ustar liggesusers\name{pongom.dat} \alias{pongom.dat} \title{Male orang utan data} \description{Male orang utan skull data. 8 landmarks in 2 dimensions, 30 individuals } \usage{data(pongom.dat)} \format{ An array of dimension 8 x 2 x 30 } \source{ O'Higgins, P. and Dryden, I. L. (1993). Sexual dimorphism in hominoids: further studies of craniofacial shape differences in Pan, Gorilla, Pongo, Journal of Human Evolution, 24, 183-205. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(pongom.dat) plotshapes(pongom.dat) } \keyword{datasets} shapes/man/procWGPA.Rd0000754000176200001440000000732313204273756014241 0ustar liggesusers\name{procWGPA} \alias{procWGPA} %- Also NEED an `\alias' for EACH other topic documented here. \title{Weighted Procrustes analysis} \description{Weighted Procrustes analysis to register landmark configurations into optimal registration using translation, rotation and scaling. Registration without scaling is also an option. Also, obtains principal components, and some summary statistics. } \usage{ procWGPA(x, fixcovmatrix=FALSE, initial="Identity", maxiterations=10, scale=TRUE, reflect=FALSE, prior="Exponential",diagonal=TRUE,sampleweights="Equal") } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Input k x m x n real array, where k is the number of points, m is the number of dimensions, and n is the sample size. } \item{fixcovmatrix}{If FALSE then the landmark covariance matrix is estimated. If a fixed covariance matrix is desired then the value should be given here, e.g. fixcovmatrix=diag(8) for the identity matrix with 8 landmarks.} \item{initial}{The initial value of the estimated covariance matrix. "Identity" - identity matrix, "Rawdata" - based on sample variance of the raw landmarks. Also, could be a k x k symmetric positive definite matrix.} \item{maxiterations}{The maximum number of iterations for estimating the covariance matrix}, \item{scale}{Logical quantity indicating if scaling is required}, \item{reflect}{Logical quantity indicating if reflection invariance is required}, \item{prior}{Indicates the type of prior. "Exponential" is exponential for the inverse eigenvalues. "Identity" is an inverse Wishart with the identity matrix as parameters.} \item{diagonal}{Logical. Indicates if the diagonal of the landmark covariance matrix (only) should be used. Diagonal matrices can lead to some landmarks having very small variability, which may or may not be desirable.} \item{sampleweights}{Gives the weights of the observations in the sample, rather than the landmarks. This is a fixed quatity. "Equal" indicates that all observations in the sample have equal weight. The weights do not need to sum to 1. } } \value{A list with components \item{k}{no of landmarks} \item{m}{no of dimensions (m-D dimension configurations)} \item{n}{sample size} \item{mshape}{Weighted Procrustes mean shape.} \item{tan}{This is the mk x n matrix of Procrustes residuals $X_i^P$ - Xbar.} \item{rotated}{the k x m x n array of weighted Procrustes rotated data} \item{pcar}{the columns are eigenvectors (PCs) of the sample covariance Sv of tan} \item{pcasd}{the square roots of eigenvalues of Sv using tan (s.d.'s of PCs)} \item{percent}{the percentage of variability explained by the PCs using tan. } \item{size}{the centroid sizes of the configurations} \item{scores}{standardised PC scores (each with unit variance) using tan} \item{rawscores}{raw PC scores using tan} \item{rho}{Kendall's Riemannian distance rho to the mean shape} \item{rmsrho}{r.m.s. of rho} \item{rmsd1}{r.m.s. of full Procrustes distances to the mean shape $d_F$} \item{Sigmak}{Estimate of the sample covariance matrix of the landmarks} } \details{The factored covariance model is assumed: $Sigma_k x I_m$ with $Sigma_k$ being the covariance matrix of the landmarks, and the cov matrix at each landmark is the identity matrix.} \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with applications in R (Second Edition). Wiley, Chichester. Goodall, C.R. (1991). Procrustes methods in the statistical analysis of shape (with discussion). Journal of the Royal Statistical Society, Series B, 53: 285-339. } \author{Ian Dryden} \seealso{procGPA} \examples{ #2D example : female Gorillas (cf. Dryden and Mardia, 2016) data(gorf.dat) gor<-procWGPA(gorf.dat,maxiterations=3) } \keyword{multivariate} shapes/man/estcov.Rd0000754000176200001440000000404412021403414014075 0ustar liggesusers\name{estcov} \alias{estcov} %- Also NEED an `\alias' for EACH other topic documented here. \title{Weighted Frechet mean of covariance matrices} \description{Computes the weighted Frechet means of an array of covariance matrices, with different options for the covariance metric. Also carries out principal co-ordinate analysis of the covariance matrices} \usage{ estcov(S , method="Riemannian",weights=1,alpha=1/2,MDSk=2) } %- maybe also `usage' for other objects documented here. \arguments{ \item{S}{Input an array of covariance matrices of size k x k x n where each matrix is square, symmetric and positive definite} \item{method}{The type of distance to be used: "Procrustes": Procrustes size-and-shape metric, "ProcrustesShape": Procrustes metric with scaling, "Riemannian": Riemannian metric, "Cholesky": Cholesky based distance, "Power: Power Euclidean, with power alpha, "Euclidean": Euclidean metric, "LogEuclidean": Log-Euclidean metric, "RiemannianLe": Another Riemannian metric. } \item{weights}{The weights to be used for calculating the mean. If weights=1 then equal weights are used, otherwise the vector must be of length n.} \item{alpha}{The power to be used in the power Euclidean metric} \item{MDSk}{The number of MDS components in the principal co-ordinate analysis} } \value{A list with values \item{mean}{The weighted mean covariance matrix} \item{sd}{The weighted standard deviation} \item{pco}{Principal co-ordinates (from multidimensional scaling with the metric)} \item{eig}{The eigenvalues from the principal co-ordinate analysis} } \references{Dryden, I.L., Koloydenko, A. and Zhou, D. (2009). Non-Euclidean statistics for covariance matrices, with applications to diffusion tensor imaging. Annals of Applied Statistics, 3, 1102-1123.} \author{Ian Dryden} \seealso{distcov} \examples{ S <- array(0,c(5,5,10) ) for (i in 1:10){ tem <- diag(5)+.1*matrix(rnorm(25),5,5) S[,,i]<- tem%*%t(tem) } estcov( S , method="Procrustes") } \keyword{multivariate} shapes/man/schizophrenia.dat.Rd0000754000176200001440000000276311171647350016233 0ustar liggesusers\name{schizophrenia.dat} \alias{schizophrenia.dat} \title{Bookstein's schizophrenia data} \description{Bookstein's schizophrenia data. 13 landmarks in 2 dimensions, 28 individuals. The first 14 individuals are controls. The last fourteen cases were diagnosed with schizophrenia. The landmarks were taken in the near midline from MR images of the brain: (1) splenium, posteriormost point on corpus callosum; (2) genu, anteriormost point on corpus callosum; (3) top of corpus callosum, uppermost point on arch of callosum (all three to an approximate registration on the diameter of the callosum); (4) top of head, a point relaxed from a standard landmark along the apparent margin of the dura; (5) tentorium of cerebellum at dura; (6) top of cerebellum; (7) tip of fourth ventricle; (8) bottom of cerebellum; (9) top of pons, anterior margin; (10) bottom of pons, anterior margin; (11) optic chiasm; (12) frontal pole, extension of a line from landmark 1 through landmark 2 until it intersects the dura; (13) superior colliculus. } \usage{data(schizophrenia.dat)} \format{ An array of dimension 13 x 2 x 28 } \source{ Bookstein, F. L. (1996). Biometrics, biomathematics and the morphometric synthesis, Bulletin of Mathematical Biology, 58, 313--365. } \references{ Data kindly provided by Fred Bookstein (University of Washington and University of Vienna) } \examples{ data(schizophrenia.dat) k<-dim(schizophrenia.dat)[1] n<-dim(schizophrenia.dat)[3] plotshapes(schizophrenia.dat) } \keyword{datasets} shapes/man/cortical.Rd0000754000176200001440000000223712563416116014412 0ustar liggesusers\name{cortical} \alias{cortical} \title{Cortical surface data} \description{Cortical surface data, from MR scans. Axial slice outlines with 500 points on each outline. 68 individuals. } \usage{data(cortical)} \format{ cortical$age ( age) cortical$group ( Control, Schizophrenia) cortical$sex ( 1 = male, 2 = female) cortical$symm ( a symmetry measure from the original 3D cortical surface ) cortical$x (500 x , y coordinates of an axial slice through the cortical surface intersecting the anterior and posterior commissures) cortical$r (500 radii from equal angular polar coordinates ) } \source{ Brignell, C.J., Dryden, I.L., Gattone, S.A., Park, B., Leask, S., Browne, W.J. and Flynn, S. (2010). Surface shape analysis, with an application to brain surface asymmetry in schizophrenia. Biostatistics, 11, 609-630. Dryden, I.L. (2005). Statistical analysis on high-dimensional spheres and shape spaces. Annals of Statistics, 33, 1643-1665 } \references{ Original MR data from Sean Flynn (UBC) in collaboration with Bert Park (Nottingham). } \examples{ data(cortical) plotshapes(cortical$x) } \keyword{datasets} shapes/man/plot3darcs.Rd0000754000176200001440000000354514031055254014665 0ustar liggesusers\name{plot3darcs} \alias{plot3darcs} \title{Modes of variation plots for PCA and PNSS} \description{Modes of variation plots for PCA and PNSS based on 3D views and arcs along a mode. c * sd : the extent along lower and upper principal arcs. The lower principal arc -> 0 -> upper principal arc has a total of 2*nn+1 configurations with: nn configurations along the negative principal arc to 0; one configuration at the PNS mean; nn configurations along the positive principal arc. } \usage{ plot3darcs(x,pcno=1,c=1,nn=100,boundary.data=TRUE,view.theta=0,view.phi=0,type="pnss") } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Output from pnss3d} \item{pcno}{The number of the PC/PNSS component. The default is 1, the first PC/PNSS} \item{c}{Number of standard deviations along each arc} \item{nn}{In total 2 * nn + 1 configurations: n configurations on arc from negative to 0; 1 configuration at 0; nn configurations from 0 to positive} \item{boundary.data}{Logical for whether to use boundary data or not. } \item{view.theta}{Viewing angle theta} \item{view.phi}{Viewing angle phi} \item{type}{"pnss" principal nested sphere mean and arc, or "pca" Procrustes mean and linear PC.} } \value{A list with components \item{PNSmean}{the PNSS mean} \item{lu.arc}{the configurations along the arc} } \references{ Dryden, I.L., Kim, K., Laughton, C.A. and Le, H. (2019). Principal nested shape space analysis of molecular dynamics data. Annals of Applied Statistics, 13, 2213-2234. Jung, S., Dryden, I.L. and Marron, J.S. (2012). Analysis of principal nested spheres. Biometrika, 99, 551-568. } \author{Kwang-Rae Kim, Ian Dryden} \seealso{pns, pns4pc, pnss3d} \examples{ ans <- pnss3d(digit3.dat, sphere.type="BIC", n.pc=5) #aa <- plot3darcs(ans,c=2,pcno=1) #bb <- plot3darcs(ans,c=2,pcno=1,type="pca") } \keyword{multivariate} shapes/man/panf.dat.Rd0000754000176200001440000000105210706112511014264 0ustar liggesusers\name{panf.dat} \alias{panf.dat} \title{Female chimpanzee data} \description{Female chimpanzee skull data. 8 landmarks in 2 dimensions, 26 individuals } \usage{data(panf.dat)} \format{ An array of dimension 8 x 2 x 26 } \source{ O'Higgins, P. and Dryden, I. L. (1993). Sexual dimorphism in hominoids: further studies of craniofacial shape differences in Pan, Gorilla, Pongo, Journal of Human Evolution, 24, 183-205. } \references{ Data from Paul O'Higgins (Hull-York Medical School) } \examples{ data(panf.dat) plotshapes(panf.dat) } \keyword{datasets} shapes/man/shapes3d.Rd0000754000176200001440000000242213204274123014311 0ustar liggesusers\name{shapes3d} \alias{shapes3d} \title{Plot 3D data} \description{Plot the landmark configurations from a 3D dataset} \usage{shapes3d(x,loop=0,type="p", color = 2, joinline=c(1:1), axes3=FALSE, rglopen=TRUE)} \arguments{ \item{x}{An array of size k x 3 x n, where k is the number of landmarks and n is the number of observations} \item{loop}{gives the number of times an animated loop through the observations is displayed (in order 1 to n). loop > 0 is suitable when a time-series of shapes is available. loop = 0 gives a plot of all the observations on the same figure. } \item{type}{Type of plot: "p" points, "dots" dots (quicker for large plots), "l" dots and lines though landmarks 1:k if `joinline' not stated} \item{color}{Colour of points (default color = 2 (red)). If a vector is given then the points are coloured in that order.} \item{joinline}{Join the numbered landmarks by lines} \item{axes3}{Logical. If TRUE then plot the axes.} \item{rglopen}{Logical. If TRUE then open a new RGL window, if FALSE then plot in current window.} } \value{ None } \references{Dryden, I.L. and Mardia, K.V. (2016). Statistical Shape Analysis, with Applications in R (Second Edition). Wiley, Chichester. } \author{Ian Dryden} \examples{ data(dna.dat) shapes3d(dna.dat) } \keyword{multivariate} shapes/man/rats.Rd0000754000176200001440000000132212551013461013546 0ustar liggesusers\name{rats} \alias{rats} \title{Rat skulls data} \description{Rat skulls data, from X rays. 8 landmarks in 2 dimensions, 18 individuals observed at 7, 14, 21, 30, 40, 60, 90, 150 days. } \usage{data(rats)} \format{ rats$x: An array of landmark configurations 144 x 2 x 2 rats$no: Individual rat number (note rats 3, 13, 20 missing due to incomplete data) rats$time observed time in days } \source{ Vilmann's rat data set (Bookstein, 1991, Morphometric Tools for Landmark Data: Geometry and Biology, pp. 408-414) } \references{ Bookstein, F.L. (1991). Morphometric tools for landmark data: geometry and biology, Cambridge University Press. } \examples{ data(rats) plotshapes(rats$x,col=1:8) } \keyword{datasets} shapes/DESCRIPTION0000754000176200001440000000147014367300611013250 0ustar liggesusersPackage: shapes Title: Statistical Shape Analysis Date: 2023-02-03 Version: 1.2.7 Author: Ian L. Dryden Description: Routines for the statistical analysis of landmark shapes, including Procrustes analysis, graphical displays, principal components analysis, permutation and bootstrap tests, thin-plate spline transformation grids and comparing covariance matrices. See Dryden, I.L. and Mardia, K.V. (2016). Statistical shape analysis, with Applications in R (2nd Edition), John Wiley and Sons. Maintainer: Ian Dryden Imports: minpack.lm, scatterplot3d, rgl, MASS Depends: R (>= 2.10) License: GPL-2 URL: http://www.maths.nottingham.ac.uk/~ild/shapes NeedsCompilation: no Packaged: 2023-02-03 15:45:05 UTC; pmzild Repository: CRAN Date/Publication: 2023-02-03 21:50:01 UTC shapes/R/0000755000176200001440000000000014367225040011741 5ustar liggesusersshapes/R/shapes.R0000644000176200001440000132744014367224111013360 0ustar liggesusers#----------------------------------------------------------------------- # # Statistical shape analysis routines # written by Ian Dryden in R (see http://cran.r-project.org) # (c) Ian Dryden # UoN, FIU. version 1.2.7 # 2003-2023 # # Includes contributions by many other authors, including # Mohammad Faghihi, Kwang-Rae Kim, Alfred Kume, # Gregorio Quintana-Orti, Amelia Simo. # ########################################################################### tangentcoords.partial.inv = function(v, p, R) { return(matrix(sqrt(1 - sum(v^2)) * c(p) + v, nrow = nrow(p)) %*% t(R)) } preshape2shape = function(z) { k = nrow(z) + 1 H = defh(k - 1) return(t(H) %*% z) } plot3darcs<-function(x,pcno=1,c=1,nn=100,boundary.data=TRUE,view.theta=0,view.phi=0,type="pnss"){ # points along principal arcs pns.out <- x k <- pns.out$GPAout$k m <- pns.out$GPAout$m n.pc <- dim(pns.out$resmat)[1] rad1<-sqrt(5/k)/50 rad2<-sqrt(1/k)/50 npts = 100 arc1 = t(get.prinarc(resmat = pns.out$resmat, PNS = pns.out$PNS, arc = 1, n = npts, boundary.data = boundary.data)) arc2 = t(get.prinarc(resmat = pns.out$resmat, PNS = pns.out$PNS, arc = 2, n = npts, boundary.data = boundary.data)) arc3 = t(get.prinarc(resmat = pns.out$resmat, PNS = pns.out$PNS, arc = 3, n = npts, boundary.data = boundary.data)) PNSmean = pns.out$PNS$mean GPAout = pns.out$GPAout { # cat("stdev of PNS1 score:", round(sd(pns.out$resmat[1, # ]), 4), "\n") # cat("stdev of PNS2 score:", round(sd(pns.out$resmat[2, # ]), 4), "\n") # cat("stdev of PNS3 score:", round(sd(pns.out$resmat[3, # ]), 4), "\n") } rng = c * sd(pns.out$resmat[1, ]) val = c(seq(-rng, 0, length = nn + 1)[-(nn + 1)], 0, seq(0, rng, length = nn + 1)[-1]) lu.arc1 = t(get.prinarc.value(PNS = pns.out$PNS, arc = 1, res = val)) rng = c * sd(pns.out$resmat[2, ]) val = c(seq(-rng, 0, length = nn + 1)[-(nn + 1)], 0, seq(0, rng, length = nn + 1)[-1]) lu.arc2 = t(get.prinarc.value(PNS = pns.out$PNS, arc = 2, res = val)) rng = c * sd(pns.out$resmat[3, ]) val = c(seq(-rng, 0, length = nn + 1)[-(nn + 1)], 0, seq(0, rng, length = nn + 1)[-1]) lu.arc3 = t(get.prinarc.value(PNS = pns.out$PNS, arc = 3, res = val)) scores.arc1 = sphere2pcscore(x = arc1) scores.arc2 = sphere2pcscore(x = arc2) scores.arc3 = sphere2pcscore(x = arc3) scores.PNSmean = sphere2pcscore(x = t(PNSmean)) scores.lu.arc1 = sphere2pcscore(x = lu.arc1) scores.lu.arc2 = sphere2pcscore(x = lu.arc2) scores.lu.arc3 = sphere2pcscore(x = lu.arc3) U1 = matrix(0, npts, nrow(GPAout$pcar)) U2 = matrix(0, npts, nrow(GPAout$pcar)) U3 = matrix(0, npts, nrow(GPAout$pcar)) for (i in 1:npts) { for (j in 1:n.pc) { U1[i, ] = U1[i, ] + scores.arc1[i, j] * GPAout$pcar[, j] U2[i, ] = U2[i, ] + scores.arc2[i, j] * GPAout$pcar[, j] U3[i, ] = U3[i, ] + scores.arc3[i, j] * GPAout$pcar[, j] } } U.mean = matrix(0, 1, nrow(GPAout$pcar)) for (j in 1:n.pc) { U.mean = U.mean + scores.PNSmean[j] * GPAout$pcar[, j] } tan.lu.arc1 = matrix(0, nrow(lu.arc1), nrow(GPAout$pcar)) tan.lu.arc2 = matrix(0, nrow(lu.arc2), nrow(GPAout$pcar)) tan.lu.arc3 = matrix(0, nrow(lu.arc3), nrow(GPAout$pcar)) for (i in 1:nrow(lu.arc1)) { for (j in 1:n.pc) { tan.lu.arc1[i, ] = tan.lu.arc1[i, ] + scores.lu.arc1[i, j] * GPAout$pcar[, j] tan.lu.arc2[i, ] = tan.lu.arc2[i, ] + scores.lu.arc2[i, j] * GPAout$pcar[, j] tan.lu.arc3[i, ] = tan.lu.arc3[i, ] + scores.lu.arc3[i, j] * GPAout$pcar[, j] } } shapes.arc1 = array(NA, c(k, m, npts)) shapes.arc2 = array(NA, c(k, m, npts)) shapes.arc3 = array(NA, c(k, m, npts)) H = defh(k - 1) for (i in 1:npts) { # to convert from in expo map to partial tangent coords and then to icon configuration rho<-Enorm(U1[i,]) shapes.arc1[, , i] = preshape2shape(tangentcoords.partial.inv(v = U1[i, ]*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m))) rho<-Enorm(U2[i,]) shapes.arc2[, , i] = preshape2shape(tangentcoords.partial.inv(v = U2[i, ]*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m))) rho<-Enorm(U3[i,]) shapes.arc3[, , i] = preshape2shape(tangentcoords.partial.inv(v = U3[i, ]*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m))) } rho<-Enorm(U.mean) shapes.PNSmean = preshape2shape(tangentcoords.partial.inv(v = U.mean*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m))) shapes.lu.arc1 = array(NA, c(k, m, nrow(lu.arc1))) shapes.lu.arc2 = array(NA, c(k, m, nrow(lu.arc2))) shapes.lu.arc3 = array(NA, c(k, m, nrow(lu.arc3))) for (i in 1:nrow(lu.arc1)) { rho<-Enorm(tan.lu.arc1[i,]) shapes.lu.arc1[, , i] = preshape2shape(tangentcoords.partial.inv(v = tan.lu.arc1[i, ]*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m))) rho<-Enorm(tan.lu.arc2[i,]) shapes.lu.arc2[, , i] = preshape2shape(tangentcoords.partial.inv(v = tan.lu.arc2[i, ]*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m))) rho<-Enorm(tan.lu.arc3[i,]) shapes.lu.arc3[, , i] = preshape2shape(tangentcoords.partial.inv(v = tan.lu.arc3[i, ]*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m))) } h <- defh(k - 1) zero <- matrix(0, k - 1, k) H <- cbind(h, zero, zero) H1 <- cbind(zero, h, zero) H2 <- cbind(zero, zero, h) H <- rbind(H, H1, H2) if (dim(GPAout$pcar)[1] == (3 * (k - 1))) { pcarot <- (t(H) %*% GPAout$pcar) GPAout$pcar <- pcarot } if (pcno == 1) { shapes.lu.arc <- shapes.lu.arc1 } if (pcno == 2) { shapes.lu.arc <- shapes.lu.arc2 } if (pcno == 3) { shapes.lu.arc <- shapes.lu.arc3 } if (type == "pca") { open3d() par3d(windowRect = c(20, 30, 800, 800)) view3d(view.theta, view.phi) plot3d(GPAout$mshape, type = "s", col = rainbow(k), radius = rad1, add = TRUE) lines3d(GPAout$mshape, col = rainbow(k), lwd = 5) pcu <- GPAout$mshape + c * GPAout$pcasd[pcno] * cbind(GPAout$pcar[1:k, pcno], GPAout$pcar[(k + 1):(2 * k), pcno], GPAout$pcar[(2 * k + 1):(3 * k), pcno]) pcl <- GPAout$mshape - c * GPAout$pcasd[pcno] * cbind(GPAout$pcar[1:k, pcno], GPAout$pcar[(k + 1):(2 * k), pcno], GPAout$pcar[(2 * k + 1):(3 * k), pcno]) spheres3d(pcu, radius = rad2, color = "black") spheres3d(pcl, radius = rad2, color = "grey") for (j in 1:k) { lines3d(rbind(pcl[j, ], pcu[j, ]), col = rainbow(k)[j]) if (j > 1) { lines3d(rbind(pcu[j - 1, ], pcu[j, ]), col = "black") lines3d(rbind(pcl[j - 1, ], pcl[j, ]), col = "grey") } } } if (type == "pnss") { open3d() par3d(windowRect = c(20, 30, 800, 800)) view3d(view.theta, view.phi) plot3d(shapes.PNSmean, type = "s", col = rainbow(k), radius = rad1, add = TRUE) lines3d(shapes.PNSmean, lwd = 5, col = rainbow(k)) for (i in 1:k) { lines3d(t(shapes.lu.arc[i, , ]), col = rainbow(k)[i], lwd = 1, lty = 2) spheres3d(head(t(shapes.lu.arc[i, , ]), 1), radius = rad2, color = "black") if (i > 1) { lines3d((shapes.lu.arc[(i - 1):i, , 1]), col = "black") } spheres3d(tail(t(shapes.lu.arc[i, , ]), 1), radius = rad2, color = "grey") if (i > 1) { lines3d((shapes.lu.arc[(i - 1):i, , 201]), col = "grey") } } } out <- list(PNSmean = 0, lu.arc = 0) out$PNSmean <- shapes.PNSmean out$lu.arc <- shapes.lu.arc out } ######## pnss3d<- function (x, sphere.type = "seq.test", alpha = 0.1, R = 100, nlast.small.sphere = 1, n.pc = "Full", output=TRUE) { k = dim(x)[1] m = dim(x)[2] n = dim(x)[3] if (n.pc =="Full" ) { n.pc=m*k-m*(m-1)/2-m } if (m==2){ tem1 <- array( 0, c(k,3,n) ) tem1[,1:2,]<-x x<-tem1 m<-3 } #if (n < ((k - 1) * m)) { # print("Note: n < (k - 1) * m.") # jj<- round( (k-1)*m/n + 0.5) # print("Adding extra copies of the data") # tem<- array(0,c(k,m,jj*n)) # tem[,,1:n]<-x # for (i in 2:jj){ # for (j in 1:n){ # tem[,,(i-1)*n+ j ]<-x[,,j] + 0*matrix( rnorm(k*m), k,m) # } # } # x<-tem #} k = dim(x)[1] m = dim(x)[2] n = dim(x)[3] out = pc2sphere2(x = x, n.pc = n.pc, output=output) spheredata = t(out$spheredata) GPAout = out$GPAout pns.out = pns(x = spheredata, sphere.type = sphere.type, alpha = alpha, R = R, nlast.small.sphere = nlast.small.sphere, output=output) pns.out$percent = pns.out$percent * sum(GPAout$percent[1:n.pc])/100 if (output){ print("Radii of spheres") print(pns.out$PNS$radii) print("PNS percent explained") cat(c(round(pns.out$percent,2),"\n")) print("PCA percent explained") cat(c(round(GPAout$percent,2),"\n")) } pns.out$GPAout = GPAout pns.out$spheredata = spheredata return(pns.out) } pc2sphere2<-function (x, n.pc, output=TRUE) { k = dim(x)[1] m = dim(x)[2] n = dim(x)[3] GPAout = procGPA(x = x, scale = TRUE, reflect = FALSE, tol1=1e-8,tangentcoords = "partial", distances = TRUE) if (output){ cat("First ", n.pc, " principal components explain ", round(sum(GPAout$percent[1:n.pc]),2), "% of total variance. \n", sep = "") } H = defh(k - 1) X.hat = H %*% GPAout$mshape S = array(NA, c(k - 1, m, n)) for (i in 1:n) { S[, , i] = H %*% GPAout$rotated[, , i] } T.c = GPAout$tan #- apply(GPAout$tan, 1, mean) out = pcscore2sphere2(n.pc = n.pc, X.hat = X.hat, S = S, Tan = T.c, V = GPAout$pcar) return(list(spheredata = out, GPAout = GPAout)) } backfit <- function( scores, x , type="pnss", size=1){ npc <- length(scores) if (type=="pnss"){ PNS.object<-x PNS<-PNS.object$PNS GPAout<-PNS.object$GPAout z1 <- PNSe2s(matrix(scores,npc,1),PNS) pcscores<-c(sphere2pcscore(x=t(z1))) #note the PC scores are from the inverse exponential map tangent coordinates mu <- GPAout$mshape k<-dim(mu)[1] m<-dim(mu)[2] H = defh(k - 1) U<- GPAout$pcar[,1]*0 for (j in 1:npc) { U = U + pcscores[j] * GPAout$pcar[, j] } # to convert from in expo map to partial tangent coords and then to icon configuration rho<-Enorm(U) xout<-preshape2shape(tangentcoords.partial.inv(v = U*sin(rho)/rho, p = H %*% GPAout$mshape, R = diag(m)))*size } if (type=="pca"){ GPAout<- x pcscores<-scores #assume partial tangent coordinates mu <- GPAout$mshape k<-dim(mu)[1] m<-dim(mu)[2] H = defh(k - 1) U<- GPAout$pcar[,1]*0 for (j in 1:npc) { U = U + pcscores[j] * GPAout$pcar[, j] } xout<-preshape2shape(tangentcoords.partial.inv(v = U, p = H %*% GPAout$mshape, R = diag(m)))*size } xout } #================================================================================== # PNS The Principal Nested Spheres code (PNS) for spheres and shapes has # been written by Kwang-Rae Kim, and builds closely on the original matlab # code for PNS by Sungkyu Jung #================================================================================== #================================================================================== pns = function(x, sphere.type = "seq.test", alpha = 0.1, R = 100, nlast.small.sphere = 1, output=TRUE) { n = ncol(x) k = nrow(x) PNS = list() if (abs(sum(apply(x ^ 2, 2, sum)) - n) > 1e-8) { stop("Error: Each column of x should be a unit vector, ||x[ , i]|| = 1.") } svd.x = svd(x, nu = nrow(x)) uu = svd.x$u maxd = which(svd.x$d < 1e-15)[1] if (is.na(maxd) | k > n) { maxd = min(k, n) + 1 } nullspdim = k - maxd + 1 d = k - 1 if (output){ cat("Message from pns() : dataset is on ", d, "-sphere. \n", sep = "") } if (nullspdim > 0) { if (output){ cat(" .. found null space of dimension ", nullspdim, ", to be trivially reduced. \n", sep = "") } } if (d==2){ PNS$spherePNS<-t(x) } resmat = matrix(NA, d, n) orthaxis = list() orthaxis[[d - 1]] = NA dist = rep(NA, d - 1) pvalues = matrix(NA, d - 1, 2) ratio = rep(NA, d - 1) currentSphere = x if (nullspdim > 0) { for (i in 1:nullspdim) { oaxis = uu[, ncol(uu) - i + 1] r = pi / 2 pvalues[i,] = c(NaN, NaN) res = acos(t(oaxis) %*% currentSphere) - r orthaxis[[i]] = oaxis dist[i] = r resmat[i,] = res NestedSphere = rotMat(oaxis) %*% currentSphere currentSphere = NestedSphere[1:(k - i),] / repmat(matrix(sqrt(1 - NestedSphere[nrow(NestedSphere),] ^ 2), nrow = 1), k - i, 1) uu = rotMat(oaxis) %*% uu uu = uu[1:(k - i),] / repmat(matrix(sqrt(1 - uu[nrow(uu),] ^ 2), nrow = 1), k - i, 1) if (output){ cat(d - i + 1, "-sphere to ", d - i, "-sphere, by ", "NULL space \n", sep = "") } } } if (sphere.type == "seq.test") { if (output){ cat(" .. sequential tests with significance level ", alpha, "\n", sep = "") } isIsotropic = FALSE for (i in (nullspdim + 1):(d - 1)) { if (!isIsotropic) { sp = getSubSphere(x = currentSphere, geodesic = "small") center.s = sp$center r.s = sp$r resSMALL = acos(t(center.s) %*% currentSphere) - r.s sp = getSubSphere(x = currentSphere, geodesic = "great") center.g = sp$center r.g = sp$r resGREAT = acos(t(center.g) %*% currentSphere) - r.g pval1 = LRTpval(resGREAT, resSMALL, n) pvalues[i, 1] = pval1 if (pval1 > alpha) { center = center.g r = r.g pvalues[i, 2] = NA if (output){ cat( d - i + 1, "-sphere to ", d - i, "-sphere, by GREAT sphere, p(LRT) = ", pval1, "\n", sep = "" ) } } else { pval2 = vMFtest(currentSphere, R) pvalues[i, 2] = pval2 if (pval2 > alpha) { center = center.g r = r.g if (output){ cat( d - i + 1, "-sphere to ", d - i, "-sphere, by GREAT sphere, p(LRT) = ", pval1, ", p(vMF) = ", pval2, "\n", sep = "" ) } isIsotropic = TRUE } else { center = center.s r = r.s if (output){ cat( d - i + 1, "-sphere to ", d - i, "-sphere, by SMALL sphere, p(LRT) = ", pval1, ", p(vMF) = ", pval2, "\n", sep = "" ) } } } } else if (isIsotropic) { sp = getSubSphere(x = currentSphere, geodesic = "great") center = sp$center r = sp$r if (output){ cat( d - i + 1, "-sphere to ", d - i, "-sphere, by GREAT sphere, restricted by testing vMF distn", "\n", sep = "" ) } pvalues[i, 1] = NA pvalues[i, 2] = NA } res = acos(t(center) %*% currentSphere) - r orthaxis[[i]] = center dist[i] = r resmat[i,] = res cur.proj = project.subsphere(x = currentSphere, center = center, r = r) NestedSphere = rotMat(center) %*% currentSphere currentSphere = NestedSphere[1:(k - i),] / repmat(matrix(sqrt(1 - NestedSphere[nrow(NestedSphere),] ^ 2), nrow = 1), k - i, 1) ########### if (nrow(currentSphere) == 3) { PNS$spherePNS = t(currentSphere) } if (nrow(currentSphere) == 2) { PNS$circlePNS = t(cur.proj) } ############################# } } else if (sphere.type == "BIC") { if (output){ cat(" .. with BIC \n") } for (i in (nullspdim + 1):(d - 1)) { sp = getSubSphere(x = currentSphere, geodesic = "small") center.s = sp$center r.s = sp$r resSMALL = acos(t(center.s) %*% currentSphere) - r.s sp = getSubSphere(x = currentSphere, geodesic = "great") center.g = sp$center r.g = sp$r resGREAT = acos(t(center.g) %*% currentSphere) - r.g BICsmall = n * log(mean(resSMALL ^ 2)) + (d - i + 1 + 1) * log(n) BICgreat = n * log(mean(resGREAT ^ 2)) + (d - i + 1) * log(n) if (output){ cat("BICsm: ", BICsmall, ", BICgr: ", BICgreat, "\n", sep = "") } if (BICsmall > BICgreat) { center = center.g r = r.g if (output){ cat(d - i + 1, "-sphere to ", d - i, "-sphere, by ", "GREAT sphere, BIC \n", sep = "") } } else { center = center.s r = r.s if (output){ cat(d - i + 1, "-sphere to ", d - i, "-sphere, by ", "SMALL sphere, BIC \n", sep = "") } } res = acos(t(center) %*% currentSphere) - r orthaxis[[i]] = center dist[i] = r resmat[i,] = res cur.proj = project.subsphere(x = currentSphere, center = center, r = r) NestedSphere = rotMat(center) %*% currentSphere currentSphere = NestedSphere[1:(k - i),] / repmat(matrix(sqrt(1 - NestedSphere[nrow(NestedSphere),] ^ 2), nrow = 1), k - i, 1) ########### if (nrow(currentSphere) == 3) { PNS$spherePNS = t(currentSphere) } if (nrow(currentSphere) == 2) { PNS$circlePNS = t(cur.proj) } ############################# } } else if (sphere.type == "small" | sphere.type == "great") { pvalues = NaN for (i in (nullspdim + 1):(d - 1)) { sp = getSubSphere(x = currentSphere, geodesic = sphere.type) center = sp$center r = sp$r res = acos(t(center) %*% currentSphere) - r orthaxis[[i]] = center dist[i] = r resmat[i,] = res cur.proj = project.subsphere(x = currentSphere, center = center, r = r) NestedSphere = rotMat(center) %*% currentSphere currentSphere = NestedSphere[1:(k - i),] / repmat(matrix(sqrt(1 - NestedSphere[nrow(NestedSphere),] ^ 2), nrow = 1), k - i, 1) ########### if (nrow(currentSphere) == 3) { PNS$spherePNS = t(currentSphere) } if (nrow(currentSphere) == 2) { PNS$circlePNS = t(cur.proj) } ############################# } } else if (sphere.type == "bi.sphere") { if (nlast.small.sphere < 0) { cat("!!! Error from pns(): \n") cat("!!! nlast.small.sphere should be >= 0. \n") return(NULL) } mx = (d - 1) - nullspdim if (nlast.small.sphere > mx) { cat("!!! Error from pns(): \n") cat("!!! nlast.small.sphere should be <= ", mx, " for this data. \n", sep = "") return(NULL) } pvalues = NaN if (nlast.small.sphere != mx) { for (i in (nullspdim + 1):(d - 1 - nlast.small.sphere)) { sp = getSubSphere(x = currentSphere, geodesic = "great") center = sp$center r = sp$r res = acos(t(center) %*% currentSphere) - r orthaxis[[i]] = center dist[i] = r resmat[i,] = res cur.proj = project.subsphere(x = currentSphere, center = center, r = r) NestedSphere = rotMat(center) %*% currentSphere currentSphere = NestedSphere[1:(k - i),] / repmat(matrix(sqrt(1 - NestedSphere[nrow(NestedSphere),] ^ 2), nrow = 1), k - i, 1) ########### if (nrow(currentSphere) == 3) { PNS$spherePNS = t(currentSphere) } if (nrow(currentSphere) == 2) { PNS$circlePNS = t(cur.proj) } ############################# } } if (nlast.small.sphere != 0) { for (i in (d - nlast.small.sphere):(d - 1)) { sp = getSubSphere(x = currentSphere, geodesic = "small") center = sp$center r = sp$r res = acos(t(center) %*% currentSphere) - r orthaxis[[i]] = center dist[i] = r resmat[i,] = res cur.proj = project.subsphere(x = currentSphere, center = center, r = r) NestedSphere = rotMat(center) %*% currentSphere currentSphere = NestedSphere[1:(k - i),] / repmat(matrix(sqrt(1 - NestedSphere[nrow(NestedSphere),] ^ 2), nrow = 1), k - i, 1) ########### if (nrow(currentSphere) == 3) { PNS$spherePNS = t(currentSphere) } if (nrow(currentSphere) == 2) { PNS$circlePNS = t(cur.proj) } ############################# } } } else { print("!!! Error from pns():") print("!!! sphere.type must be 'seq.test', 'small', 'great', 'BIC', or 'bi.sphere'") print("!!! Terminating execution ") return(NULL) } S1toRadian = atan2(currentSphere[2,], currentSphere[1,]) meantheta = geodmeanS1(S1toRadian)$geodmean orthaxis[[d]] = meantheta resmat[d,] = mod(S1toRadian - meantheta + pi, 2 * pi) - pi if (output){ par( mfrow = c(1, 1), mar = c(4, 4, 1, 1), mgp = c(2.5, 1, 0), cex = 0.8 ) plot( currentSphere[1,], currentSphere[2,], xlab = "", ylab = "", xlim = c(-1, 1), ylim = c(-1, 1), asp = 1 ) abline(h = 0, v = 0) points( cos(meantheta), sin(meantheta), pch = 1, cex = 3, col = "black", lwd = 5 ) abline( a = 0, b = sin(meantheta) / cos(meantheta), lty = 3 ) l = mod(S1toRadian - meantheta + pi, 2 * pi) - pi points( cos(S1toRadian[which.max(l)]), sin(S1toRadian[which.max(l)]), pch = 4, cex = 3, col = "blue" ) points( cos(S1toRadian[which.min(l)]), sin(S1toRadian[which.min(l)]), pch = 4, cex = 3, col = "red" ) legend( "topright", legend = c("Geodesic mean", "Max (+)ve from mean", "Min (-)ve from mean"), col = c("black", "blue", "red"), pch = c(1, 4, 4) ) { cat("\n") cat( "length of BLUE from geodesic mean : ", max(l), " (", round(max(l) * 180 / pi), " degree)", "\n", sep = "" ) cat( "length of RED from geodesic mean : ", min(l), " (", round(min(l) * 180 / pi), " degree)", "\n", sep = "" ) cat("\n") } } radii = 1 for (i in 1:(d - 1)) { radii = c(radii, prod(sin(dist[1:i]))) } resmat = flipud0(repmat(matrix(radii, ncol = 1), 1, n) * resmat) if (d>1){ if (output){ ### plot points on the 3D sphere (red), with 2D projection (blue) rgl.sphgrid1() sphere1.f(col="white",alpha=0.6) sphrad <- 0.015 spheres3d(-PNS$circlePNS[,2],PNS$circlePNS[,1],PNS$circlePNS[,3],radius=sphrad,col=4) spheres3d(-PNS$spherePNS[,2],PNS$spherePNS[,1],PNS$spherePNS[,3],radius=sphrad,col=2) } yy <- orthaxis[[d-1]] xx <- c(-yy[2], yy[1] , yy[3]) c1<-Enorm( c(xx[1],xx[2],xx[3])- c(-PNS$circlePNS[1,2],PNS$circlePNS[1,1],PNS$circlePNS[1,3])) costheta<- 1 - c1^2/2 angle<-(1:201)/(200)*2*pi centre<- xx*costheta A<- xx-centre B<- diag(3)-A%*%t(A)/Enorm(A)**2 bv<-eigen(B)$vectors b1<-bv[,1] b2<-bv[,2] cc<- sin(acos(costheta))* ( cos(angle)%*%t(b1) + sin(angle)%*%t(b2) ) + rep(1,times=201)%*%t(centre) if (output){ lines3d(cc,col=3,lwd=2) } ###### if (output){ lines3d(cc,col=3,lwd=2) sum<-0 for (i in 1:n){ sum=sum+ ( acos( cc%*%c(-PNS$circlePNS[i,2],PNS$circlePNS[i,1],PNS$circlePNS[i,3])) )**2 } mean0angle<-which.min(sum[1:200])/200*2*pi meanpt<- sin(acos(costheta))* ( cos(mean0angle)%*%t(b1) + sin(mean0angle)%*%t(b2) ) +t(centre) spheres3d( meanpt, radius=sphrad * 1.5,col=7, alpha=0.8) } ########### } PNS$scores = t(resmat) PNS$radii = radii PNS$pnscircle <- cbind( cbind( cc[,2],-cc[,1]) , cc[,3]) PNS$orthaxis = orthaxis PNS$dist = dist PNS$pvalues = pvalues PNS$ratio = ratio PNS$basisu = NULL PNS$mean = c(PNSe2s(matrix(0, d, 1), PNS)) meanplot <- c( -PNS$mean[2],PNS$mean[1],PNS$mean[3] ) if (output){ spheres3d( meanplot, radius=sphrad*1.5,col=7, alpha=0.8) } if (sphere.type == "seq.test") { PNS$sphere.type = "seq.test" } else if (sphere.type == "small") { PNS$sphere.type = "small" } else if (sphere.type == "great") { PNS$sphere.type = "great" } else if (sphere.type == "BIC") { PNS$sphere.type = "BIC" } else if (sphere.type == "bi.sphere") { PNS$sphere.type = "bi.sphere" } varPNS = apply(abs(resmat) ^ 2, 1, sum) / n total = sum(varPNS) propPNS = varPNS / total * 100 return(list( resmat = resmat, PNS = PNS, percent = propPNS )) } #high-res sphere plot #from stackoverflow answer (Mike Wise) sphere1.f <- function(x0 = 0, y0 = 0, z0 = 0, r = 1, n = 101, ...){ f <- function(s,t){ cbind( r * cos(t)*cos(s) + x0, r * sin(s) + y0, r * sin(t)*cos(s) + z0) } persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, ...) } #adapted from the package "sphereplot" to remove text and axes (Aaron Robotham) rgl.sphgrid1 <- function (radius = 1, col.long = "red", col.lat = "blue", deggap = 15, longtype = "H", add = FALSE, radaxis = TRUE, radlab = "Radius") { if (add == F) { open3d() } for (lat in seq(-90, 90, by = deggap)) { if (lat == 0) { col.grid = "grey50" } else { col.grid = "grey" } plot3d(sph2car1(long = seq(0, 360, len = 100), lat = lat, radius = radius, deg = T), col = col.grid, add = T, type = "l") } for (long in seq(0, 360 - deggap, by = deggap)) { if (long == 0) { col.grid = "grey50" } else { col.grid = "grey" } plot3d(sph2car1(long = long, lat = seq(-90, 90, len = 100), radius = radius, deg = T), col = col.grid, add = T, type = "l") } if (longtype == "H") { scale = 15 } if (longtype == "D") { scale = 1 } # rgl.sphtext(long = 0, lat = seq(-90, 90, by = deggap), radius = radius, # text = seq(-90, 90, by = deggap), deg = TRUE, col = col.lat) # rgl.sphtext(long = seq(0, 360 - deggap, by = deggap), lat = 0, # radius = radius, text = seq(0, 360 - deggap, by = deggap)/scale, # deg = TRUE, col = col.long) if (radaxis) { radpretty = pretty(c(0, radius)) radpretty = radpretty[radpretty <= radius] # lines3d(c(0, 0), c(0, max(radpretty)), c(0, 0), col = "grey50") for (i in 1:length(radpretty)) { # lines3d(c(0, 0), c(radpretty[i], radpretty[i]), c(0, # 0, radius/50), col = "grey50") # text3d(0, radpretty[i], radius/15, radpretty[i], # col = "darkgreen") } # text3d(0, radius/2, -radius/25, radlab) } } sph2car1<-function (long, lat, radius = 1, deg = TRUE) { if (is.matrix(long) || is.data.frame(long)) { if (ncol(long) == 1) { long = long[, 1] } else if (ncol(long) == 2) { lat = long[, 2] long = long[, 1] } else if (ncol(long) == 3) { radius = long[, 3] lat = long[, 2] long = long[, 1] } } if (missing(long) | missing(lat)) { stop("Missing full spherical 3D input data.") } if (deg) { long = long * pi/180 lat = lat * pi/180 } return = cbind(x = radius * cos(long) * cos(lat), y = radius * sin(long) * cos(lat), z = radius * sin(lat)) } #================================================================================== pns4pc = function(x, sphere.type = "seq.test", alpha = 0.1, R = 100, nlast.small.sphere = 1, n.pc = 2) { if (n.pc < 2) { stop("Error: n.pc should be >= 2.") } out = pc2sphere2(x = x, n.pc = n.pc) spheredata = t(out$spheredata) GPAout = out$GPAout pns.out = pns( x = spheredata, sphere.type = sphere.type, alpha = alpha, R = R, nlast.small.sphere = nlast.small.sphere ) pns.out$percent = pns.out$percent * sum(GPAout$percent[1:n.pc]) / 100 pns.out$GPAout = GPAout pns.out$spheredata = spheredata return(pns.out) } pns.pc = function(x, sphere.type = "seq.test", alpha = 0.1, R = 100, nlast.small.sphere = 0, n.pc = 0) { k = dim(x)[1] m = dim(x)[2] n = dim(x)[3] if (n.pc == 0) { GPAout = procGPA( x = x, scale = TRUE, reflect = FALSE, tangentcoords = "partial", distances = FALSE ) spheredata = matrix(NA, k * m, n) for (i in 1:n) { spheredata[, i] = c(GPAout$rotated[, , i]) } pns.out = pns( x = spheredata, sphere.type = sphere.type, alpha = alpha, R = R, nlast.small.sphere = nlast.small.sphere ) resmat = pns.out$resmat PNS = pns.out$PNS npts = 200 prinarc1 = get.prinarc( resmat, PNS, arc = 1, n = npts, boundary.data = FALSE ) prinarc2 = get.prinarc( resmat, PNS, arc = 2, n = npts, boundary.data = FALSE ) prinarc1.ar = array(NA, c(k, m, npts)) prinarc2.ar = array(NA, c(k, m, npts)) for (i in 1:npts) { prinarc1.ar[, , i] = matrix(prinarc1[, i], nrow = k) prinarc2.ar[, , i] = matrix(prinarc2[, i], nrow = k) } scores.prinarc1 = shape.pcscores.partial(PCAout = GPAout, x = prinarc1.ar) scores.prinarc2 = shape.pcscores.partial(PCAout = GPAout, x = prinarc2.ar) out = pns.out out$GPAout = GPAout out$scores.prinarc1 = scores.prinarc1 out$scores.prinarc2 = scores.prinarc2 } else { pns.out = pns4pc( x = x, sphere.type = sphere.type, alpha = alpha, R = R, nlast.small.sphere = nlast.small.sphere, n.pc = n.pc ) GPAout = pns.out$GPAout resmat = pns.out$resmat PNS = pns.out$PNS npts = 200 prinarc1 = get.prinarc( resmat, PNS, arc = 1, n = npts, boundary.data = FALSE ) prinarc2 = get.prinarc( resmat, PNS, arc = 2, n = npts, boundary.data = FALSE ) scores.prinarc1 = matrix(NA, npts, n.pc) scores.prinarc2 = matrix(NA, npts, n.pc) for (g in 1:npts) { size1 = acos(prinarc1[1, g]) size2 = acos(prinarc2[1, g]) scores.prinarc1[g,] = prinarc1[2:(n.pc + 1), g] / (sin(size1) / size1) scores.prinarc2[g,] = prinarc2[2:(n.pc + 1), g] / (sin(size2) / size2) } out = pns.out out$scores.prinarc1 = scores.prinarc1 out$scores.prinarc2 = scores.prinarc2 } return(out) } #================================================================================== rotMat = function(b, a = NULL, alpha = NULL) { if (is.matrix(b)) { if (min(dim(b)) == 1) { b = c(b) } else { stop("Error: b should be a unit vector.") } } d = length(b) b = b / norm(b, type = "2") if (is.null(a) & is.null(alpha)) { a = c(rep(0, d - 1), 1) alpha = acos(sum(a * b)) } else if (!is.null(a) & is.null(alpha)) { alpha = acos(sum(a * b)) } else if (is.null(a) & !is.null(alpha)) { a = c(rep(0, d - 1), 1) } if (abs(sum(a * b) - 1) < 1e-15) { rot = diag(d) return(rot) } if (abs(sum(a * b) + 1) < 1e-15) { rot = -diag(d) return(rot) } c = b - a * sum(a * b) c = c / norm(c, type = "2") A = a %*% t(c) - c %*% t(a) rot = diag(d) + sin(alpha) * A + (cos(alpha) - 1) * (a %*% t(a) + c %*% t(c)) return(rot) } #================================================================================== ExpNPd = function(x) { if (is.vector(x)) { x = as.matrix(x) } d = nrow(x) nv = sqrt(apply(x ^ 2, 2, sum)) Exppx = rbind(matrix(rep(sin(nv) / nv, d), nrow = d, byrow = T) * x, cos(nv)) Exppx[, nv < 1e-16] = repmat(matrix(c(rep(0, d), 1)), 1, sum(nv < 1e-16)) return(Exppx) } #================================================================================== LogNPd = function(x) { n = ncol(x) d = nrow(x) scale = acos(x[d,]) / sqrt(1 - x[d,] ^ 2) scale[is.nan(scale)] = 1 Logpx = repmat(t(scale), d - 1, 1) * x[-d,] return(Logpx) } #================================================================================== objfn = function(center, r, x) { return(mean((acos(t( center ) %*% x) - r) ^ 2)) } #================================================================================== getSubSphere = function(x, geodesic = "small") { svd.x = svd(x) initialCenter = svd.x$u[, ncol(svd.x$u)] c0 = initialCenter TOL = 1e-10 cnt = 0 err = 1 n = ncol(x) d = nrow(x) Gnow = 1e+10 while (err > TOL) { c0 = c0 / norm(c0, type = "2") rot = rotMat(c0) TpX = LogNPd(rot %*% x) fit = sphereFit( x = TpX, initialCenter = rep(0, d - 1), geodesic = geodesic ) newCenterTp = fit$center r = fit$r if (r > pi) { r = pi / 2 svd.TpX = svd(TpX) newCenterTp = svd.TpX$u[, ncol(svd.TpX$u)] * pi / 2 } newCenter = ExpNPd(newCenterTp) center = solve(rot, newCenter) Gnext = objfn(center, r, x) err = abs(Gnow - Gnext) Gnow = Gnext c0 = center cnt = cnt + 1 if (cnt > 30) { break } } i1save = list() i1save$Gnow = Gnow i1save$center = center i1save$r = r U = princomp(t(x))$loadings[,] initialCenter = U[, ncol(U)] c0 = initialCenter TOL = 1e-10 cnt = 0 err = 1 n = ncol(x) d = nrow(x) Gnow = 1e+10 while (err > TOL) { c0 = c0 / norm(c0, type = "2") rot = rotMat(c0) TpX = LogNPd(rot %*% x) fit = sphereFit( x = TpX, initialCenter = rep(0, d - 1), geodesic = geodesic ) newCenterTp = fit$center r = fit$r if (r > pi) { r = pi / 2 svd.TpX = svd(TpX) newCenterTp = svd.TpX$u[, ncol(svd.TpX$u)] * pi / 2 } newCenter = ExpNPd(newCenterTp) center = solve(rot, newCenter) Gnext = objfn(center, r, x) err = abs(Gnow - Gnext) Gnow = Gnext c0 = center cnt = cnt + 1 if (cnt > 30) { break } } if (i1save$Gnow == min(Gnow, i1save$Gnow)) { center = i1save$center r = i1save$r } if (r > pi / 2) { center = -center r = pi - r } return(list(center = c(center), r = r)) } #================================================================================== LRTpval = function(resGREAT, resSMALL, n) { chi2 = max(n * log(sum(resGREAT ^ 2) / sum(resSMALL ^ 2)), 0) return(pchisq( q = chi2, df = 1, lower.tail = FALSE )) } #================================================================================== vMFtest = function(x, R = 100) { d = nrow(x) n = ncol(x) sumx = apply(x, 1, sum) rbar = norm(sumx, "2") / n muMLE = sumx / norm(sumx, "2") kappaMLE = (rbar * d - rbar ^ 3) / (1 - rbar ^ 2) sp = getSubSphere(x = x, geodesic = "small") center.s = sp$center r.s = sp$r radialdistances = acos(t(center.s) %*% x) xi_sample = mean(radialdistances) / sd(radialdistances) xi_vec = rep(0, R) for (r in 1:R) { rdata = randvonMisesFisherm(d, n, kappaMLE) sp = getSubSphere(x = rdata, geodesic = "small") center.s = sp$center r.s = sp$r radialdistances = acos(t(center.s) %*% rdata) xi_vec[r] = mean(radialdistances) / sd(radialdistances) } pvalue = mean(xi_vec > xi_sample) return(pvalue) } #================================================================================== geodmeanS1 = function(theta) { n = length(theta) meancandi = mod(mean(theta) + 2 * pi * (0:(n - 1)) / n, 2 * pi) theta = mod(theta, 2 * pi) geodvar = rep(0, n) for (i in 1:n) { v = meancandi[i] dist2 = apply(cbind((theta - v) ^ 2, (theta - v + 2 * pi) ^ 2, (v - theta + 2 * pi) ^ 2), 1, min) geodvar[i] = sum(dist2) } m = min(geodvar) ind = which.min(geodvar) geodmean = mod(meancandi[ind], 2 * pi) geodvar = geodvar[ind] / n return(list(geodmean = geodmean, geodvar = geodvar)) } #================================================================================== PNSe2s = function(resmat, PNS) { dm = nrow(resmat) n = ncol(resmat) NSOrthaxis = rev(PNS$orthaxis[1:(dm - 1)]) NSradius = flipud0(matrix(PNS$dist, ncol = 1)) geodmean = PNS$orthaxis[[dm]] res = resmat / repmat(flipud0(matrix(PNS$radii, ncol = 1)), 1, n) T = t(rotMat(NSOrthaxis[[1]])) %*% rbind(repmat(sin(NSradius[1] + matrix(res[2,], nrow = 1)), 2, 1) * rbind(cos(geodmean + res[1,]), sin(geodmean + res[1,])), cos(NSradius[1] + res[2,])) if (dm > 2) { for (i in 1:(dm - 2)) { T = t(rotMat(NSOrthaxis[[i + 1]])) %*% rbind(repmat(sin(NSradius[i + 1] + matrix( res[i + 2,], nrow = 1 )), 2 + i, 1) * T, cos(NSradius[i + 1] + res[i + 2,])) } } if (!is.null(PNS$basisu)) { T = PNS$basisu %*% T } return(T) } #================================================================================== PNSs2e = function(spheredata, PNS) { if (nrow(spheredata) != length(PNS$mean)) { cat(" Error from PNSs2e() \n") cat(" Dimensions of the sphere and PNS decomposition do not match") return(NULL) } if (!is.null(PNS$basisu)) { spheredata = t(PNS$basisu) %*% spheredata } kk = nrow(spheredata) n = ncol(spheredata) Res = matrix(0, kk - 1, n) currentSphere = spheredata for (i in 1:(kk - 2)) { v = PNS$orthaxis[[i]] r = PNS$dist[i] res = acos(t(v) %*% currentSphere) - r Res[i,] = res NestedSphere = rotMat(v) %*% currentSphere currentSphere = as.matrix(NestedSphere[1:(kk - i),]) / repmat(matrix(sqrt(1 - NestedSphere[nrow(NestedSphere),] ^ 2), nrow = 1), kk - i, 1) } S1toRadian = atan2(currentSphere[2,], currentSphere[1,]) devS1 = mod(S1toRadian - rev(PNS$orthaxis)[[1]] + pi, 2 * pi) - pi Res[kk - 1,] = devS1 EuclidData = flipud0(repmat(PNS$radii, 1, n) * Res) return(EuclidData) } #================================================================================== randvonMisesFisherm = function(m, n, kappa, mu = NULL) { if (is.null(mu)) { muflag = FALSE } else { muflag = TRUE } if (m < 2) { print("Message from randvonMisesFisherm(): dimension m must be > 2") print("Message from randvonMisesFisherm(): Set m to be 2") m = 2 } if (kappa < 0) { print("Message from randvonMisesFisherm(): kappa must be >= 0") print("Message from randvonMisesFisherm(): Set kappa to be 0") kappa = 0 } b = (-2 * kappa + sqrt(4 * kappa ^ 2 + (m - 1) ^ 2)) / (m - 1) x0 = (1 - b) / (1 + b) c = kappa * x0 + (m - 1) * log(1 - x0 ^ 2) nnow = n w = c() while (TRUE) { ntrial = max(round(nnow * 1.2), nnow + 10) Z = rbeta(n = ntrial, shape1 = (m - 1) / 2, shape2 = (m - 1) / 2) U = runif(ntrial) W = (1 - (1 + b) * Z) / (1 - (1 - b) * Z) indicator = kappa * W + (m - 1) * log(1 - x0 * W) - c >= log(U) if (sum(indicator) >= nnow) { w1 = W[indicator] w = c(w, w1[1:nnow]) break } else { w = c(w, W[indicator]) nnow = nnow - sum(indicator) } } V = UNIFORMdirections(m - 1, n) X = rbind(repmat(sqrt(1 - matrix(w, nrow = 1) ^ 2), m - 1, 1) * V, matrix(w, nrow = 1)) if (muflag) { mu = mu / norm(mu, "2") X = t(rotMat(mu)) %*% X } return(X) } #================================================================================== UNIFORMdirections = function(m, n) { V = matrix(0, m, n) nr = matrix(rnorm(m * n), nrow = m) for (i in 1:n) { while (TRUE) { ni = sum(nr[, i] ^ 2) if (ni < 1e-10) { nr[, i] = rnorm(m) } else { V[, i] = nr[, i] / sqrt(ni) break } } } return(V) } #================================================================================== trans.subsphere = function(x, center) { return(repmat(1 / sqrt(1 - (t( center ) %*% x) ^ 2), length(center) - 1, 1) * (rotMat(center)[-length(center),] %*% x)) } #================================================================================== get.prinarc.value = function(PNS, arc, res) { d = length(PNS$orthaxis) n = length(res) prinarc = matrix(NA, d + 1, n) for (g in 1:n) { newres = matrix(0, d, 1) newres[arc] = res[g] T = PNSe2s(newres, PNS) prinarc[, g] = T } return(prinarc) } #================================================================================== get.prinarc = function(resmat, PNS, arc, n, boundary.data = FALSE) { d = nrow(resmat) if (boundary.data) { mn = min(resmat[arc,]) mx = max(resmat[arc,]) } else { mn = -pi * tail(PNS$radii, arc)[1] mx = pi * tail(PNS$radii, arc)[1] } prinarcgrid = seq(mn, mx, length = n) prinarc = matrix(NA, d + 1, n) for (g in 1:n) { newres = matrix(0, d, 1) newres[arc] = prinarcgrid[g] T = PNSe2s(newres, PNS) prinarc[, g] = T } return(prinarc) } #================================================================================== get.prinarc.subsphere = function(resmat, PNS, arc, n, subsphere = arc, boundary.data = FALSE) { if (subsphere < arc) { stop("Error: subsphere >= arc.") } if (subsphere < 1) { stop("Error: subsphere >= 1.") } prinarc = get.prinarc( resmat = resmat, PNS = PNS, arc = arc, n = n, boundary.data = boundary.data ) d = nrow(resmat) prinarc.sub = prinarc if (subsphere < d) { for (i in 1:(d - subsphere)) { prinarc.sub = trans.subsphere(x = prinarc.sub, center = PNS$orthaxis[[i]]) } } return(prinarc.sub) } #================================================================================== get.data.subsphere = function(resmat, PNS, x, subsphere) { if (subsphere < 1) { stop("Error: subsphere >= 1.") } d = nrow(resmat) x.sub = x if (subsphere < d) { for (i in 1:(d - subsphere)) { x.sub = trans.subsphere(x = x.sub, center = PNS$orthaxis[[i]]) } } return(x.sub) } #================================================================================== mod = function(x, y) { return(x %% y) } #================================================================================== repmat = function(x, m, n) { return(kronecker(matrix(1, m, n), x)) } #================================================================================== flipud0 = function(x) { return(apply(x, 2, rev)) } #================================================================================== sphere.obj = function(center, x, is.greatCircle) { di = sqrt(apply((x - repmat( matrix(center, ncol = 1), 1, ncol(x) )) ^ 2, 2, sum)) if (is.greatCircle) { r = pi / 2 } else { r = mean(di) } sum((di - r) ^ 2) } #================================================================================== sphere.res = function(center, x, is.greatCircle) { center = c(center) xmc = x - center di = sqrt(apply(xmc ^ 2, 2, sum)) if (is.greatCircle) { r = pi / 2 } else { r = mean(di) } (di - r) } #================================================================================== sphere.jac = function(center, x, is.greatCircle) { center = c(center) xmc = x - center di = sqrt(apply(xmc ^ 2, 2, sum)) di.vj = -xmc / repmat(matrix(di, nrow = 1), length(center), 1) if (is.greatCircle) { c(t(di.vj)) } else { r.vj = apply(di.vj, 1, mean) c(t(di.vj - repmat(matrix(r.vj, ncol = 1), 1, ncol(x)))) } } #================================================================================== sphereFit = function(x, initialCenter = NULL, geodesic = "small") { if (is.null(initialCenter)) { initialCenter = apply(x, 1, mean) } op = nls.lm( par = initialCenter, fn = sphere.res, jac = sphere.jac, x = x, is.greatCircle = ifelse(geodesic == "great", TRUE, FALSE), control = nls.lm.control(maxiter = 1000) ) center = coef(op) di = sqrt(apply((x - repmat( matrix(center, ncol = 1), 1, ncol(x) )) ^ 2, 2, sum)) if (geodesic == "great") { r = pi / 2 } else { r = mean(di) } list(center = center, r = r) } #================================================================================== tr = function(x) { return(sum(diag(x))) } #================================================================================== Enormalize = function(x) { return(x / Enorm(x)) } #================================================================================== sphere2pcscore = function(x) { n = nrow(x) p = ncol(x) scores = matrix(NA, n, p - 1) for (i in 1:n) { size = acos(x[i, 1]) scores[i,] = (size / sin(size)) * x[i, 2:p] } return(scores) } #================================================================================== pcscore2sphere = function(n.pc, X.hat, S, Tan, V) { d = nrow(Tan) n = ncol(Tan) W = matrix(NA, d, n) for (i in 1:n) { W[, i] = acos(tr(S[, , i] %*% t(X.hat))) * Tan[, i] / sqrt(sum(Tan[, i] ^ 2)) } lambda = matrix(NA, n, d) for (i in 1:n) { for (j in 1:d) { lambda[i, j] = sum(W[, i] * V[, j]) } } U = matrix(0, n, d) for (i in 1:n) { for (j in 1:n.pc) { U[i,] = U[i,] + lambda[i, j] * V[, j] } } S.star = matrix(NA, n, n.pc + 1) for (i in 1:n) { U.norm = sqrt(sum(U[i,] ^ 2)) S.star[i,] = c(cos(U.norm), sin(U.norm) / U.norm * lambda[i, 1:n.pc]) } return(S.star) } pcscore2sphere2 = function(n.pc, X.hat, S, Tan, V) { d = nrow(Tan) n = ncol(Tan) W = matrix(NA, d, n) if (n.pc > min(d,n) ) { stop("Error: n.pc must be <= min(n,d)") } for (i in 1:n) { W[, i] = acos(tr(S[, , i] %*% t(X.hat))) * Tan[, i] / sqrt(sum(Tan[, i] ^ 2)) } lambda = matrix(NA, n, d) for (i in 1:n) { for (j in 1:n.pc) { lambda[i, j] = sum(W[, i] * V[, j]) } } U = matrix(0, n, d) for (i in 1:n) { for (j in 1:n.pc) { U[i,] = U[i,] + lambda[i, j] * V[, j] } } S.star = matrix(NA, n, n.pc + 1) for (i in 1:n) { U.norm = sqrt(sum(U[i,] ^ 2)) S.star[i,] = c(cos(U.norm), sin(U.norm) / U.norm * lambda[i, 1:n.pc]) } return(S.star) } #================================================================================== pc2sphere = function(x, n.pc) { k = dim(x)[1] m = dim(x)[2] n = dim(x)[3] if (n.pc < ((k - 1) * m)) { stop("Error: n.pc must be >= (k - 1) * m.") } GPAout = procGPA( x = x, scale = TRUE, reflect = FALSE, tangentcoords = "partial", distances = FALSE ) cat( "First ", n.pc, " principal components explain ", round(sum(GPAout$percent[1:n.pc])), "% of total variance. \n", sep = "" ) H = defh(k - 1) X.hat = H %*% GPAout$mshape S = array(NA, c(k - 1, m, n)) for (i in 1:n) { S[, , i] = H %*% GPAout$rotated[, , i] } T.c = GPAout$tan - apply(GPAout$tan, 1, mean) out = pcscore2sphere( n.pc = n.pc, X.hat = X.hat, S = S, Tan = T.c, V = GPAout$pcar ) return(list(spheredata = out, GPAout = GPAout)) } #================================================================================== rot.mat = function(Y, X, reflect = FALSE, center = TRUE) { svd.out = svd(t(X) %*% Y) R = svd.out$u %*% t(svd.out$v) if (!reflect) { if (det(R) < 0) { u = svd.out$u v = svd.out$v if (det(u) < 0) { u[, dim(u)[2]] = -u[, dim(u)[2]] } else if (det(v) < 0) { v[, dim(v)[2]] = -v[, dim(v)[2]] } R = u %*% t(v) } } return(R) } #================================================================================== Procrustes.dist.full = function(x1, x2) { m = ncol(x1) z1 = preshape(x1) z2 = preshape(x2) Q = t(z1) %*% z2 %*% t(z2) %*% z1 ev = eigen(Q)$values sign = ifelse(det(t(z1) %*% z2) >= 0, 1,-1) dF = sqrt(abs(1 - sum(sqrt(abs( ev[1:(m - 1)] )), sign * sqrt(abs( ev[m] ))) ^ 2)) R = rot.mat( Y = z2, X = z1, reflect = FALSE, center = FALSE ) scale = sum(svd(t(z1) %*% z2)$d) return(list(dF = dF, R = R, scale = scale)) } #================================================================================== tangent.coords.partial = function(x, p) { k = nrow(x) m = ncol(x) if (abs(norm(p, "F") - 1) > 1e-15) { print("||p|| is not 1. Normalised one is used.") p = Enormalize(p) } tmp = Procrustes.dist.full(x, p) R = tmp$R scale = tmp$scale pre.p = preshape(p) pre.x = preshape(x) ident = diag(k * m - m) tan = (ident - matrix(pre.p) %*% t(c(pre.p))) %*% c(pre.x %*% R) tan.scale = (ident - matrix(pre.p) %*% t(c(pre.p))) %*% c(pre.x %*% R * scale) return(list( tan = c(tan), tan.scale = c(tan.scale), R = R, scale = scale )) } #================================================================================== shape.pcscores = function(PCAout, x, tangentcoords = "partial") { if (tangentcoords == "partial") { if (abs(norm(PCAout$mshape, "F") - 1) > 1e-15) { print("||PCAout$mshape|| is not 1. Normalised one is used.") mshape = Enormalize(PCAout$mshape) } else { mshape = PCAout$mshape } if (abs(norm(x, "F") - 1) > 1e-15) { print("||x|| is not 1. Normalised one is used.") x = Enormalize(x) } opa.out = procOPA(mshape, x, scale = FALSE) matched = opa.out$Bhat tan.out = tangent.coords.partial(matched, mshape) mean.tan = apply(PCAout$tan, 1, mean) scores = t(tan.out$tan - mean.tan) %*% PCAout$pcar scores.scale = t(tan.out$tan.scale - mean.tan) %*% PCAout$pcar return( list( rotated = matched, tan = tan.out$tan, tan.scale = tan.out$tan.scale, scores = c(scores), scores.scale = c(scores.scale) ) ) } } #================================================================================== shape.pcscores.partial = function(PCAout, x) { n = dim(x)[3] scores = c() for (i in 1:n) { s = shape.pcscores(PCAout, x[, , i], tangentcoords = "partial") scores = rbind(scores, s$scores) } return(scores) } #================================================================================== plotshapes3d.pns = function(x, type = "p", col = "black", size = 5, aspect = "iso", joinline = TRUE, col.joinline = "#d4d2d2", lwd.joinline = 0.5, tick = FALSE, labels.tick = FALSE, xlab = "", ylab = "", zlab = "") { k = dim(x)[1] n = dim(x)[3] aa = c() bb = c() cc = c() for (i in 1:n) { aa = c(aa, x[, 1, i]) bb = c(bb, x[, 2, i]) cc = c(cc, x[, 3, i]) } xlim = range(aa) ylim = range(bb) zlim = range(cc) plot3d( x[, , 1], type = "n", xlab = "", ylab = "", zlab = "", box = FALSE, axes = FALSE, aspect = aspect, xlim = xlim, ylim = ylim, zlim = zlim ) for (i in 1:n) { plot3d( x[, , i], type = type, col = col, size = size, add = TRUE ) } if (tick) { axis3d( edge = 'x', labels = labels.tick, tick = TRUE, pos = c(NA, 0, 0), cex = 0.6, lwd = 0.5 ) axis3d( edge = 'y', labels = labels.tick, tick = TRUE, pos = c(0, NA, 0), cex = 0.6, lwd = 0.5 ) axis3d( edge = 'z', labels = labels.tick, tick = TRUE, pos = c(0, 0, NA), cex = 0.6, lwd = 0.5 ) } else { } r = cbind(xlim, ylim, zlim) pos = r[2,] + apply(r, 2, diff) / 20 text3d(pos[1], 0, 0, texts = xlab, cex = 0.8) text3d(0, pos[2], 0, texts = ylab, cex = 0.8) text3d(0, 0, pos[3], texts = zlab, cex = 0.8) if (joinline) { for (i in 1:n) { lines3d(x[, , i], col = col.joinline, lwd = lwd.joinline) } } } #================================================================================== Plot3D = function(x, type = "s", col = "black", size = 1.2, aspect = "iso", joinline = FALSE, col.joinline = "#d4d2d2", lwd.joinline = 0.5, tick = TRUE, tick.boundary = FALSE, labels.tick = TRUE, xlab = "", ylab = "", zlab = "") { n = nrow(x) plot3d( x, type = "n", xlab = "", ylab = "", zlab = "", box = FALSE, axes = FALSE, aspect = aspect ) plot3d( x, type = type, col = col, size = size, add = TRUE ) if (tick) { axis3d( edge = 'x', labels = labels.tick, tick = TRUE, pos = c(NA, 0, 0), cex = 0.6, lwd = 0.5 ) axis3d( edge = 'y', labels = labels.tick, tick = TRUE, pos = c(0, NA, 0), cex = 0.6, lwd = 0.5 ) axis3d( edge = 'z', labels = labels.tick, tick = TRUE, pos = c(0, 0, NA), cex = 0.6, lwd = 0.5 ) } if (tick.boundary) { tks = pretty(x[, 1], n = 10) axis3d( edge = 'x', labels = labels.tick, tick = TRUE, at = c(tks[1], tks[length(tks)]), pos = c(NA, 0, 0), cex = 0.6, lwd = 0.5 ) tks = pretty(x[, 2], n = 10) axis3d( edge = 'y', labels = labels.tick, tick = TRUE, at = c(tks[1], tks[length(tks)]), pos = c(0, NA, 0), cex = 0.6, lwd = 0.5 ) tks = pretty(x[, 3], n = 10) axis3d( edge = 'z', labels = labels.tick, tick = TRUE, at = c(tks[1], tks[length(tks)]), pos = c(0, 0, NA), cex = 0.6, lwd = 0.5 ) } r = apply(x, 2, range) pos = r[2,] + apply(r, 2, diff) / 20 text3d(pos[1], 0, 0, texts = xlab, cex = 0.8) text3d(0, pos[2], 0, texts = ylab, cex = 0.8) text3d(0, 0, pos[3], texts = zlab, cex = 0.8) if (joinline) { lines3d(x, col = col.joinline, lwd = lwd.joinline) } } #================================================================================== col2RGB = function(col, alpha = 255) { n = length(col) out = c() for (i in 1:n) { out[i] = rgb( red = col2rgb(col[i])[1], green = col2rgb(col[i])[2], blue = col2rgb(col[i])[3], alpha = alpha, maxColorValue = 255 ) } return(out) } #================================================================================== project.subsphere = function(x, center, r) { n = ncol(x) d = nrow(x) x.proj = matrix(NA, d, n) for (i in 1:n) { rho = acos(sum(x[, i] * center)) x.proj[, i] = (sin(r) * x[, i] + sin(rho - r) * center) / sin(rho) } return(x.proj) } ##############################################################end of PNS########### ##### Penalised Euclidean Distance Regression #================================================================================== ped <- function(X, Y, method = c("AIC")) { if (method == "AIC") { aicmin <- 999999999 for (lam in c(0.2, 0.5, 1.0)) { for (cofp in c(0.75, 1, 1.35, 1.5)) { out <- pedreg( X, Y, nlambda = 1, constc0 = 1.1, constc1 = cofp, lambdainit = lam ) if (out$aic < aicmin) { minout <- out mincofp <- cofp aicmin <- out$aic } } } out <- minout } if (method == "BIC") { bicmin <- 999999999 for (lam in c(0.2, 0.5, 1.0)) { for (cofp in c(0.75, 1, 1.35, 1.5)) { out <- pedreg( X, Y, nlambda = 1, constc0 = 1.1, constc1 = cofp, lambdainit = lam ) if (out$bic < bicmin) { minout <- out mincofp <- cofp bicmin <- out$bic } } } out <- minout } if (method == "khat") { aicmin <- 999999999 for (lam in c(0.2, 0.5, 1.0)) { for (cofp in c(0.75, 1, 1.25, 1.5)) { out <- pedreg( X, Y, nlambda = 1, constc0 = 1.1, constc1 = cofp, lambdainit = lam ) if (-out$khat < aicmin) { minout <- out mincofp <- cofp aicmin <- -out$khat } } } out <- minout } if (method == "CV") { n <- length(Y) cvmin <- 999999999 for (lam in c(0.2, 0.5, 1.0)) { for (cofp in c(0.75, 1, 1.25, 1.5)) { cverr <- 0 for (jj in 1:10) { subsample <- ((jj - 1) * 10 + 1):((jj - 1) * 10 + 10) out <- pedreg( X[-subsample, ], Y[-subsample], nlambda = 1, constc0 = 1.1, constc1 = cofp, lambdainit = lam ) cverr <- cverr + Enorm(Y[subsample] - out$intercept - X[subsample, ] %*% out$betahat) ** 2 } if (cverr < cvmin) { minout <- out minlam <- lam mincofp <- cofp cvmin <- cverr } } } out <- pedreg( X, Y, nlambda = 1, constc0 = 1.1, constc1 = mincofp, lambdainit = minlam ) } out1 <- list( betahat = 0, yhat = 0, lambda = 0, coef = 0, resid = 0 ) out1$intercept <- out$intercept out1$coef <- c(out$intercept, out$betahat) out1$betahat <- out$betahat out1$lambda <- out$lambda out1$delta <- mincofp out1$yhat <- out$yhat out1$resid <- Y - out$yhat out1 } ###########################function for PED##################### #================================================================================== pedreg <- function(X, Y, constc0 = 1.1, constc1 = 1.35, alpha = 0.05, LMM = 50, MIT = 10000, NUM_METHOD = 1, nlambda = 1, lambdamax = 1, PLOT = TRUE, BIC = FALSE, lambdainit = 1) { # NUM_METHOD = 1 = L-BFGS-B # LMM = Parameter M in L-BFGS method 1 # MIT = Max iterations for optimization p <- dim(X)[2] n <- dim(X)[1] constc <- constc0 Ymean <- mean(Y) Ysd <- sd(Y) Yinit <- Y pinit <- p ans0 <- rep(0, times = pinit) Xorig <- X Yorig <- Y vm <- rep(0, times = ncol(X)) vsd <- rep(0, times = ncol(X)) for (i in 1:ncol(X)) { vm[i] <- mean(X[, i]) } for (i in 1:ncol(X)) { vsd[i] <- sd(X[, i]) } #standardize to sphere X <- scale(X) / sqrt(n - 1) Y <- scale(Y) / sqrt(n - 1) X0 <- X Y0 <- Y lambdainit1 <- constc / sqrt(n - 1) * sqrt(sqrt(p)) / n * qnorm(1 - alpha / (2 * p)) if (nlambda == 1) { lambdainit1 <- lambdainit } METHOD1 <- "L-BFGS-B" xi <- -9999999 c1 <- 1 nlam <- nlambda betamat <- matrix(0, p, nlam) betamat.sparse <- betamat lambdamat <- rep(0, times = nlam) ximat <- rep(0, times = nlam) aic <- rep(0, times = nlam) bic <- rep(0, times = nlam) npar <- rep(0, times = nlam) selectmat <- betamat #cat(c("Lambda iteration (out of ",nlam,"):")) for (ilam in (nlam:1)) { #cat(c(ilam," ")) if (nlam == 1) { lambda <- lambdainit1 } if (nlam > 1) { c1 <- sqrt(n) + (ilam - 1) / (nlam - 1) * 1 / lambdainit1 c1 <- sqrt(n) + ((ilam - 1) / (nlam - 1)) * 1 / lambdainit1 * (lambdamax - lambdainit1 * sqrt(n)) lambda <- lambdainit1 * c1 } if (ilam == nlam) { x0 <- rep(1 / sqrt(p), times = p) } if (ilam != nlam) { x0 <- betahat + rnorm(p) / sqrt(p) } #x0<-rnorm(p)/sqrt(p) pedfun <- function(pars, Y = 0, X = 0) { p <- length(pars) pars <- matrix(pars, p, 1) ped <- Enorm(Y - X %*% pars) + lambda * sqrt(Enorm(pars) * sum(abs(pars))) ped } pedgrad <- function(pars, X = 0, Y = 0) { GM <- sqrt(Enorm(pars) * sum(abs(pars))) gradL <- rep(0, times = p) gradL <- -t(X) %*% (Y - X %*% pars) / Enorm(Y - X %*% pars) gradL <- gradL + matrix( lambda / 2 * pars / Enorm(pars) * sum(abs(pars)) / GM + lambda / 2 * sign(pars) * Enorm(pars) / GM , p, 1 ) c(gradL) } if (NUM_METHOD == 1) { repeat { #,ndeps=1e-3,factr=1e-5,pgtol=1e-5 res2 <- optim( par = x0, fn = pedfun, gr = pedgrad, method = METHOD1, control = list(lmm = LMM, maxit = MIT), X = X, Y = Y ) betahat <- res2$par if (res2$convergence == 0) { break } x0 <- rnorm(p) / sqrt(p) } } oldxi <- xi xi <- sqrt(Enorm(betahat) / sum(abs(betahat))) - sqrt(n) / (constc * c1 * p ^ (1 / 4)) dif <- (xi - oldxi) REGC <- 0.0001 betamat[, ilam] <- betahat / (Enorm(betahat) + REGC) lambdamat[ilam] <- lambda ximat[ilam] <- xi ximat[ilam] <- sqrt(Enorm(betahat) / sum(abs(betahat))) MM <- constc1 / (sqrt(n)) select <- (abs(betahat) / (Enorm(betahat) + REGC) > MM) selectmat[, ilam] <- select betamat.sparse[, ilam] <- betamat[, ilam] betamat.sparse[select == FALSE, ilam] <- 0 * betamat[select == FALSE, ilam] pp <- sum(select) npar[ilam] <- pp bic[ilam] <- log(Enorm(Y) ** 2 / n) * (n) + log(n) * (1) aic[ilam] <- log(Enorm(Y) ** 2 / n) * (n) + 2 * (1) if (sum(select) > 0) { aa <- lm(Y ~ X[, c(1:p)[select]] - 1) pred <- predict(aa) # Use AIC with finite sample correction aic[ilam] <- log(Enorm(Y - pred) ** 2 / n) * (n) + 2 * (pp + 1) + 2 * (pp + 1) * (pp + 2) / (n - pp - 2) # Use AIC/BIC bic[ilam] <- log(Enorm(Y - pred) ** 2 / n) * (n) + log(n) * (pp + 1) aic[ilam] <- log(Enorm(Y - pred) ** 2 / n) * (n) + 2 * (pp + 1) } } best <- 1 if (nlam > 1) { ###########################################choose best via AIC best <- c(1:nlam)[aic == min(aic)][1] select <- as.logical(selectmat[, best]) lambdaaic <- lambdamat[best] ###########################################choose best via Corollary 1 with khat best2 <- nlam if ((sum(ximat > 0.25)) > 0) { best2 <- c(1:nlam)[(ximat) > 0.25][1] } #################### biggest xi from Corollary 1 xism <- (ximat) if (sum(diff(xism) < 0.01) > 0) { best2 <- c(2:nlam)[diff(xism) < 0.01][1] - 1 } ############## biggest sqrt( Enorm(beta) / norm(beta)_1 ) best2 <- c(1:nlam)[ximat == max(ximat)] selectcor <- as.logical(selectmat[, best2]) lambdacor1 <- lambdamat[best2] if (BIC == FALSE) { best <- best2 select <- selectcor } } ################last part######estimate with reduced p########### if (sum(select) > 0) { X <- as.matrix(X[, select]) p <- sum(select) p14 <- sqrt(sqrt(p)) final <- c(1:pinit)[select] } ####### lambda <- constc / sqrt(sqrt(p)) / sqrt(n) * qnorm(1 - alpha / (2 * p)) if (sum(select) > 0) { x0 <- rep(1 / p, times = p) if (NUM_METHOD == 1) { repeat { res2 <- optim( par = x0, fn = pedfun, gr = pedgrad, method = METHOD1, control = list(lmm = LMM, maxit = MIT), X = X, Y = Y ) betahat <- res2$par if (res2$convergence == 0) { break } x0 <- rnorm(p) / p } } ans0[final] <- betahat } #ind<-which(abs(ans0/Enorm(ans0))<10^(-5)) #ans0[ind]<-0 out <- list(betahat = 0, yhat = 0, lambda = 0) out$betahatscale <- ans0 out$yhatscale <- c(X0 %*% ans0) if (nlam > 1) { out$lambdacor1 <- lambdacor1 out$lambdaaic <- lambdaaic out$betamat.sparse <- betamat.sparse out$betamat.rescale <- betamat out$betamat <- betamat for (i in 1:nlam) { out$betamat.rescale[, i] <- c(out$betamat[, i] / vsd) * sd(Yorig) } out$lambdamat <- lambdamat out$ximat <- ximat out$MM <- MM out$fmax <- res2$value out$npar <- npar out$selectmat <- selectmat } #use AIC out$aic <- aic #use BIC out$bic <- bic #use khat out$khat <- ximat out$lambdath3 <- lambdainit1 * sqrt(n) out$lambda <- out$lambdacor1 if (BIC == TRUE) { out$lambda <- out$lambdaaic } if (nlam == 1) { out$lambda <- lambdainit1 out$constc1 <- constc1 } sol <- sd(Yorig) * c(ans0 / vsd) inter <- drop(mean(Yorig) - sd(Yorig) * (vm / vsd) %*% ans0) out$intercept <- drop(mean(Yorig) - sd(Yorig) * (vm / vsd) %*% ans0) out$betahat <- sd(Yorig) * c(ans0 / vsd) out$best <- best out$Yinit <- Yinit out$yhat <- Xorig %*% sol + inter out } ############################################################ # # FUNCTIONS FOR CALCULATING NON-EUCLIDEAN MEANS AND DISTANCES # OF COVARIANCE MATRICES # ############################################################ # Log Euclidean mean: Sigma_L #================================================================================== estLogEuclid <- function(S, weights = 1) { M <- dim(S)[3] if (length(weights) == 1) { weights <- rep(1, times = M) } sum <- S[, , 1] * 0 for (j in 1:M) { eS <- eigen(S[, , j], symmetric = TRUE) sum <- sum + weights[j] * eS$vectors %*% diag(log(eS$values)) %*% t(eS$vectors) / sum(weights) } ans <- sum eL <- eigen(ans, symmetric = TRUE) eL$vectors %*% diag(exp(eL$values)) %*% t(eL$vectors) } #================================================================================== estPowerEuclid <- function(S, weights = 1, alpha = 0.5) { M <- dim(S)[3] if (length(weights) == 1) { weights <- rep(1, times = M) } sum <- S[, , 1] * 0 for (j in 1:M) { eS <- eigen(S[, , j], symmetric = TRUE) sum <- sum + weights[j] * eS$vectors %*% diag(abs(eS$values) ** alpha) %*% t(eS$vectors) / sum(weights) } ans <- sum eL <- eigen(ans, symmetric = TRUE) eL$vectors %*% diag(abs(eL$values) ** (1 / alpha)) %*% t(eL$vectors) } # Riemannian (weighted mean) : Sigma_R #================================================================================== estLogRiem2 <- function(S, weights = 1) { M <- dim(S)[3] if (length(weights) == 1) { weights <- rep(1, times = M) } check <- 9 tau <- 1 Hold <- 99999 mu <- estLogEuclid(S, weights) while (check > 0.0000000001) { ev <- eigen(mu, symmetric = TRUE) logmu <- ev$vectors %*% diag(log(ev$values)) %*% t(ev$vectors) Hnew <- Re(Hessian2(S, mu, weights)) logmunew <- logmu + tau * Hnew ev <- eigen(logmunew, symmetric = TRUE) mu <- ev$vectors %*% diag(exp(ev$values)) %*% t(ev$vectors) check <- Re(Enorm(Hold) - Enorm(Hnew)) if (check < 0) { tau <- tau / 2 check <- 999999 } Hold <- Hnew } mu } # Hessian used in calculating Sigma_R #================================================================================== Hessian2 <- function(S, Sigma, weights = 1) { M <- dim(S)[3] k <- dim(S)[1] if (length(weights) == 1) { weights <- rep(1, times = M) } ev0 <- eigen(Sigma, symmetric = TRUE) shalf <- ev0$vectors %*% (diag(sqrt((ev0$values)))) %*% t(ev0$vectors) sumit <- matrix(0, k, k) for (i in 1:(M)) { ev2 <- eigen(shalf %*% solve(S[, , i]) %*% shalf, symmetric = TRUE) sumit <- sumit + weights[i] * ev2$vectors %*% diag (log((ev2$values))) %*% t(ev2$vectors) / sum(weights) } - sumit } # Euclidean : Sigma_E #================================================================================== estEuclid <- function(S, weights = 1) { M <- dim(S)[3] if (length(weights) == 1) { weights <- rep(1, times = M) } sum <- S[, , 1] * 0 for (j in 1:M) { sum <- sum + S[, , j] * weights[j] / sum(weights) } sum } # Cholesky mean : Sigma_C #================================================================================== estCholesky <- function(S, weights = 1) { M <- dim(S)[3] if (length(weights) == 1) { weights <- rep(1, times = M) } sum <- S[, , 1] * 0 for (j in 1:M) { sum <- sum + t(chol(S[, , j])) * weights[j] / sum(weights) } cc <- sum cc %*% t(cc) } #================================================================================== ild_estSS <- function(S, weights = 1) { M <- dim(S)[3] k <- dim(S)[1] H <- defh(k) if (length(weights) == 1) { weights <- rep(1, times = M) } Q <- array(0, c(k + 1, k, M)) for (j in 1:M) { Q[, , j] <- t(H) %*% (rootmat(S[, , j])) } ans <- procWGPA( Q, fixcovmatrix = diag(k + 1), scale = FALSE, reflect = TRUE, sampleweights = weights ) H %*% ans$mshape %*% t(H %*% ans$mshape) } #================================================================================== ild_estShape <- function(S, weights = 1) { M <- dim(S)[3] k <- dim(S)[1] H <- defh(k) if (length(weights) == 1) { weights <- rep(1, times = M) } Q <- array(0, c(k + 1, k, M)) for (j in 1:M) { Q[, , j] <- t(H) %*% (rootmat(S[, , j])) } ans <- procWGPA( Q, fixcovmatrix = diag(k + 1), scale = TRUE, reflect = TRUE, sampleweights = weights ) H %*% ans$mshape %*% t(H %*% ans$mshape) } #================================================================================== estRiemLe <- function(S, weights) { M <- dim(S)[3] k <- dim(S)[1] if (M != 2) print("Sorry - Calculation not implemented for M>2 yet") if (M == 2) { P1 <- S[, , 1] P2 <- S[, , 2] detP1 <- prod(eigen(P1)$values) detP2 <- prod(eigen(P2)$values) P1 <- P1 / (detP1) ^ (1 / k) P2 <- P2 / (detP2) ^ (1 / k) P1inv <- solve(P1) P12sq <- P1inv %*% P2 %*% P2 %*% P1inv tem <- eigen(P12sq, symmetric = TRUE) A2 <- tem$vectors %*% diag(log(tem$values)) %*% t(tem$vectors) logPs2 <- weights[2] * A2 tem2 <- eigen(logPs2, symmetric = TRUE) Ps2 <- tem2$vectors %*% diag(exp(tem2$values)) %*% t(tem2$vectors) P12s <- P1 %*% Ps2 %*% P1 tem3 <- eigen(P12s, symmetric = TRUE) P12sA <- tem3$vectors %*% diag(sqrt(tem3$values)) %*% t(tem3$vectors) Ptildes <- (detP1 * (detP2 / detP1) ^ weights[2]) ^ (1 / k) * P12sA Ptildes } } ##########distances################################# #================================================================================== distRiemPennec <- function(P1, P2) { eig <- eigen(P1, symmetric = TRUE) P1half <- eig$vectors %*% diag(sqrt(eig$values)) %*% t(eig$vectors) P1halfinv <- solve(P1half) AA <- P1halfinv %*% P2 %*% P1halfinv tem <- eigen(AA, symmetric = TRUE) A2 <- tem$vectors %*% diag(log(tem$values)) %*% t(tem$vectors) dd <- Enorm(A2) dd } #================================================================================== distLogEuclidean <- function(P1, P2) { eig <- eigen(P1, symmetric = TRUE) logP1 <- eig$vectors %*% diag(log(eig$values)) %*% t(eig$vectors) tem <- eigen(P2, symmetric = TRUE) logP2 <- tem$vectors %*% diag(log(tem$values)) %*% t(tem$vectors) dd <- Enorm(logP1 - logP2) dd } #================================================================================== distRiemannianLe <- function(P1, P2) { dd <- distRiemPennec(P1 %*% t(P1), P2 %*% t(P2)) / 2 dd } #================================================================================== ild_distProcrustesSizeShape <- function (P1, P2) { H <- defh(dim(P1)[1]) Q1 <- t(H) %*% rootmat(P1) Q2 <- t(H) %*% rootmat(P2) ans <- sqrt( centroid.size(Q1) ^ 2 + centroid.size(Q2) ^ 2 - 2 * centroid.size(Q1) * centroid.size(Q2) * cos(riemdist(Q1, Q2, reflect = TRUE)) ) ans } #================================================================================== ild_distProcrustesFull <- function(P1, P2) { H <- defh(dim(P1)[1]) Q1 <- t(H) %*% rootmat(P1) Q2 <- t(H) %*% rootmat(P2) ans <- riemdist(Q1, Q2, reflect = TRUE) ans } #================================================================================== distPowerEuclidean <- function(P1, P2, alpha = 1 / 2) { if (alpha != 0) { eS <- eigen(P1, symmetric = TRUE) Q1 <- eS$vectors %*% diag(abs(eS$values) ^ alpha) %*% t(eS$vectors) eS <- eigen(P2, symmetric = TRUE) Q2 <- eS$vectors %*% diag(abs(eS$values) ^ alpha) %*% t(eS$vectors) dd <- Enorm(Q1 - Q2) / abs(alpha) } if (alpha == 0) { dd <- distLogEuclidean(P1, P2) } dd } #================================================================================== ild_distCholesky <- function(P1, P2) { H <- defh(dim(P1)[1]) Q1 <- t(H) %*% t(chol(P1)) Q2 <- t(H) %*% t(chol(P2)) ans <- Enorm(Q1 - Q2) ans } #================================================================================== distEuclidean <- function(P1, P2) { ans <- Enorm(P1 - P2) ans } ################## #================================================================================== distcov <- function(S1, S2 , method = "Riemannian", alpha = 1 / 2) { if (method == "Procrustes") { dd <- distProcrustesSizeShape(S1, S2) } if (method == "ProcrustesShape") { dd <- distProcrustesFull(S1, S2) } if (method == "Riemannian") { dd <- distRiemPennec(S1, S2) } if (method == "Cholesky") { dd <- distCholesky(S1, S2) } if (method == "Power") { dd <- distPowerEuclidean(S1, S2, alpha) } if (method == "Euclidean") { dd <- distEuclidean(S1, S2) } if (method == "LogEuclidean") { dd <- distLogEuclidean(S1, S2) } if (method == "RiemannianLe") { dd <- distRiemannianLe(S1, S2) } dd } #================================================================================== estcov <- function (S, method = "Riemannian", weights = 1, alpha = 1 / 2, MDSk = 2) { out <- list( mean = 0, sd = 0, pco = 0, eig = 0, dist = 0 ) M <- dim(S)[3] if (length(weights) == 1) { weights <- rep(1, times = M) } if (method == "Procrustes") { dd <- estSS(S, weights) } if (method == "ProcrustesShape") { dd <- estShape(S, weights) } if (method == "Riemannian") { dd <- estLogRiem2(S, weights) } if (method == "Cholesky") { dd <- estCholesky(S, weights) } if (method == "Power") { dd <- estPowerEuclid(S, weights, alpha) } if (method == "Euclidean") { dd <- estEuclid(S, weights) } if (method == "LogEuclidean") { dd <- estLogEuclid(S, weights) } if (method == "RiemannianLe") { dd <- estRiemLe(S, weights) } out$mean <- dd sum <- 0 for (i in 1:M) { sum <- sum + weights[i] * distcov(S[, , i], dd, method = method) ^ 2 / sum(weights) } out$sd <- sqrt(sum) dist <- matrix(0, M, M) for (i in 2:M) { for (j in 1:(i - 1)) { dist[i, j] <- distcov(S[, , i], S[, , j], method = method) dist[j, i] <- dist[i, j] } } out$dist <- dist if (M > MDSk) { ans <- cmdscale( dist, k = MDSk, eig = TRUE, add = TRUE, x.ret = TRUE ) out$pco <- ans$points out$eig <- ans$eig if (MDSk > 2) { shapes3d(out$pco[, 1:min(MDSk, 3)], axes3 = TRUE) } if (MDSk == 2) { plot(out$pco, type = "n", xlab = "MDS1", ylab = "MDS2") text(out$pco[, 1], out$pco[, 2], 1:length(out$pco[, 1])) } } out } rootmat <- function(P1) { eS <- eigen(P1, symmetric = TRUE) if (min(eS$values) < -0.001) { print("Not positive-semi definite") } else{ Q1 <- eS$vectors %*% diag(sqrt(abs(eS$values))) %*% t(eS$vectors) Q1 } } ########################## #================================================================================== shapes.cva <- function(X , groups , scale = TRUE, tangentcoords = "residual", ncv = 2) { g <- dim(table (groups)) ans <- procGPA(X , tangentcoords=tangentcoords, scale = scale) if (scale == TRUE) pp <- (ans$k - 1) * ans$m - (ans$m * (ans$m - 1) / 2) - 1 if (scale == FALSE) pp <- (ans$k - 1) * ans$m - (ans$m * (ans$m - 1) / 2) pracdim <- min(pp, ans$n - g) out <- lda(ans$scores[, 1:pracdim] , groups) print((out)) cv <- predict(out, dimen = ncv)$x if (dim(cv)[2] == 1) { cv <- cbind(cv, rnorm(dim(cv)[1]) / 1000) } if (ncv == 2) { eqscplot(cv, type = "n", xlab = "CV1", ylab = "CV2") text(cv, labels = groups) } if (ncv == 3) { shapes3d(cv, color = groups, axes3 = TRUE) } cv } #================================================================================== groupstack <- function(A1, A2, A3 = 0, A4 = 0, A5 = 0, A6 = 0, A7 = 0, A8 = 0) { out <- list(x = 0, groups = "") dat <- abind(A1, A2) group <- c(rep(1, times = dim(A1)[3]), rep(2, times = dim(A2)[3])) if (is.array(A3)) { dat <- abind(dat, A3) group <- c(group, rep(3, times = dim(A3)[3])) if (is.array(A4)) { dat <- abind(dat, A4) group <- c(group, rep(4, times = dim(A4)[3])) if (is.array(A5)) { dat <- abind(dat, A5) group <- c(group, rep(5, times = dim(A5)[3])) if (is.array(A6)) { dat <- abind(dat, A6) group <- c(group, rep(6, times = dim(A6)[3])) if (is.array(A7)) { dat <- abind(dat, A7) group <- c(group, rep(7, times = dim(A7)[3])) if (is.array(A8)) { dat <- abind(dat, A8) group <- c(group, rep(8, times = dim(A8)[3])) } } } } } } out$x <- dat out$groups <- group out } ########################### #================================================================================== procdist <- function(x, y, type = "full", reflect = FALSE) { if (type == "full") { out <- sin(riemdist(x, y, reflect = reflect)) } if (type == "partial") { out <- sqrt(2) * sqrt(abs(1 - cos(riemdist(x, y, reflect = reflect)))) } if (type == "Riemannian") { out <- riemdist(x, y, reflect = reflect) } if (type == "sizeandshape") { out <- ssriemdist(x, y, reflect = reflect) } out } #================================================================================== transformations <- function(Xrotated, Xoriginal) { # outputs the translations, rotations and # scalings for ordinary Procrustes rotation # of each individual in Xoriginal to the # Procrustes rotated individuals in Xrotated X1 <- Xrotated X2 <- Xoriginal n <- dim(X1)[3] m <- dim(X1)[2] translation <- matrix(0, m, n) scale <- rep(0, times = n) rotation <- array(0, c(m, m, n)) for (i in 1:n) { translation[, i] <- -apply(X2[, , i] - X1[, , i], 2, mean) ans <- procOPA(X1[, , i], X2[, , i]) scale[i] <- ans$s rotation[, , i] <- ans$R } out <- list(translation = 0, scale = 0, rotation = 0) out$translation <- translation out$scale <- scale out$rotation <- rotation out } #================================================================================== iglogl <- function(x , lam, nlam) { gamma <- abs(x[1]) alpha <- gamma / mean(1 / lam[1:nlam]) ll <- -(gamma + 1) * sum(log(lam[1:nlam])) - alpha * sum (1 / lam[1:nlam]) + nlam * gamma * log(alpha) - nlam * lgamma (gamma) - ll } #================================================================================== procWGPA <- function(x, fixcovmatrix = FALSE, initial = "Identity", maxiterations = 10, scale = TRUE, reflect = FALSE, prior = "Exponential", diagonal = TRUE, sampleweights = "Equal") { X <- x priorargument <- prior alpha <- "not estimated" gamma <- "not estimated" k <- dim(X)[1] n <- dim(X)[3] m <- dim(X)[2] if (initial[1] == "Identity") { Sigmak <- diag(k) } else{ if (initial[1] == "Rawdata") { tol <- 0.0000000001 if (m == 2) { Sigmak <- diag(diag(var(t(X[, 1, ]))) + diag(var(t(X[, 2, ])))) / 2 + tol } if (m == 3) { Sigmak <- diag(diag(var(t(X[, 1, ]))) + diag(var(t(X[, 2, ]))) + diag(var(t(X[, 3, ])))) / 3 + tol } } else { Sigmak <- initial } } mu <- procGPA(X, scale = scale)$mshape #cat("Iteration 1 \n") if (fixcovmatrix[1] != FALSE) { Sigmak <- fixcovmatrix } ans <- procWGPA1( X, mu, metric = Sigmak, scale = scale, reflect = reflect, sampleweights = sampleweights ) if ((maxiterations > 1) && (fixcovmatrix[1] == FALSE)) { ans0 <- ans dif <- 999999 it <- 1 while ((dif > 0.00001) && (it < maxiterations)) { it <- it + 1 if (it == 2) { cat("Differences in norm of Sigma estimates... \n ") } if (prior[1] == "Identity") { prior <- diag(k) } if (prior[1] == "Inversegamma") { lam <- eigen(ans$Sigmak)$values nlam <- min(c(n * m - m - 3, k - 3)) mu <- mean(1 / lam[1:(nlam)]) alpha <- 1 / mu out <- nlm(iglogl, p = c(1) , lam = lam, nlam = nlam) #print(out) gamma <- abs(out$estimate[1]) alpha <- gamma / mean(1 / lam[1:nlam]) newmetric <- n * m / (n * m + 2 * (1 + gamma)) * (ans$Sigmak + (2 * alpha / (n * m)) * diag(k)) #dif2<-999999 #while (dif2> 0.000001){ #old<-alpha #lam <- eigen(newmetric)$values #out <- nlm( iglogl, p=c(1) ,lam=lam, nlam=nlam) #gamma <- abs(out$estimate[1]) #alpha<- gamma/ mean(1/lam[1:nlam]) #newmetric <- n*m/(n*m+2*(1+gamma))*( ans$Sigmak + (2*alpha/(n*m))*diag(k) ) #dif2<- abs(alpha- old) #print(dif2) #} } if (prior[1] == "Exponential") { lam <- eigen(ans$Sigmak)$values nlam <- min(c(n * m - m - 2, k - 2)) mu <- mean(1 / lam[1:(nlam)]) alpha <- 1 / mu gamma <- 1 newmetric <- n * m / (n * m + 2 * (2)) * (ans$Sigmak + (2 * alpha / (n * m)) * diag(k)) #dif2<-999999 #while (dif2> 0.000001){ #old<-alpha #newmetric <- n*m/(n*m+2*(2))*( ans$Sigmak + (2*alpha/(n*m))*diag(k) ) #lam <- eigen(newmetric)$values #mu <- mean(1/lam[1:( nlam)]) #alpha <- 1/mu #newmetric <- n*m/(n*m+2*(2))*( ans$Sigmak + (2*alpha/(n*m))*diag(k) ) #dif2<- abs(alpha- old) #} } if (is.double(prior[1])) { newmetric <- (ans$Sigmak + prior) } if (diagonal == TRUE) { newmetric <- diag(diag(newmetric)) } if (fixcovmatrix[1] != FALSE) { newmetric <- fixcovmatrix } ans2 <- procWGPA1( X, ans$mshape, metric = newmetric , scale = scale, sampleweights = sampleweights ) plotshapes(ans2$rotated) dif <- Enorm((ans$Sigmak - ans2$Sigmak)) ans <- ans2 cat(c(it, " ", dif, " \n")) } } if ((priorargument[1] == "Exponential") || (priorargument[1] == "Inversegamma")) { ans$alpha <- alpha ans$gamma <- gamma } cat(" \n") ans } #================================================================================== procWGPA1 <- function(X, mu, metric = "Identity", scale = TRUE, reflect = FALSE, sampleweights = "Equal") { k <- dim(X)[1] n <- dim(X)[3] m <- dim(X)[2] sum <- 0 for (i in 1:n) { sum <- sum + centroid.size(X[, , i]) ** 2 } size1 <- sqrt(sum) if (sampleweights[1] == "Equal") { sampleweights <- rep(1 / n, times = n) } if (length(sampleweights) != n) { cat("Sample weight vector not of correct length \n") } if (metric[1] == "Identity") { Sigmak <- diag(k) } else{ Sigmak <- metric } eig <- eigen(Sigmak, symmetric = TRUE) Sighalf <- eig$vectors %*% diag (sqrt(abs(eig$values))) %*% t(eig$vectors) Siginvhalf <- eig$vectors %*% diag(1 / sqrt(abs(eig$values))) %*% t(eig$vectors) Siginv <- eig$vectors %*% diag (1 / (eig$values)) %*% t(eig$vectors) one <- matrix(rep(1, times = k), k, 1) Xstar <- X for (i in 1:n) { Xstar[, , i] <- Xstar[, , i] - one %*% t(one) %*% Siginv %*% Xstar[, , i] / c(t(one) %*% Siginv %*% one) Xstar[, , i] <- Siginvhalf %*% Xstar[, , i] } mu <- mu - one %*% t(one) %*% Siginv %*% mu / c(t(one) %*% Siginv %*% one) ans <- procGPA(Xstar, eigen2d = FALSE) ans2 <- ans dif3 <- 99999999 while (dif3 > 0.00001) { for (i in 1:n) { old <- mu tem <- procOPA(Siginvhalf %*% mu , Xstar[, , i], scale = scale, reflect = reflect) Gammai <- tem$R betai <- tem$s #ci <- t(one)%*% Siginvhalf %*% X[,,i] %*% Gammai*betai/k #Yi <- Sighalf%*% ans$rotated[,,i] + Sighalf%*%one%*% ci #Zi <- Yi - one %*% t(one)%*% Siginv %*% Yi / c( t(one)%*%Siginv%*%one ) Zi <- Sighalf %*% Xstar[, , i] %*% Gammai * betai ans2$rotated[, , i] <- Zi } sum2 <- 0 for (i in 1:n) { sum2 <- sum2 + centroid.size(ans2$rotated[, , i]) ** 2 } size2 <- sqrt(sum2) tem <- ans2$mshape * 0 for (i in 1:n) { ans2$rotated[, , i] <- ans2$rotated[, , i] * size1 / size2 tem <- tem + ans2$rotated[, , i] * sampleweights[i] / sum(sampleweights) } mu <- tem dif3 <- riemdist(old, mu) } z <- ans2 z$mshape <- tem tan <- z$rotated[, 1,] - z$mshape[, 1] for (i in 2:m) { tan <- rbind(tan, z$rotated[, i,] - z$mshape[, i]) } pca <- prcomp1(t(tan)) z$tan <- tan npc <- 0 for (i in 1:length(pca$sdev)) { if (pca$sdev[i] > 1e-07) { npc <- npc + 1 } } z$scores <- pca$x z$rawscores <- pca$x z$stdscores <- pca$x for (i in 1:npc) { z$stdscores[, i] <- pca$x[, i] / pca$sdev[i] } z$pcar <- pca$rotation z$pcasd <- pca$sdev z$percent <- z$pcasd ^ 2 / sum(z$pcasd ^ 2) * 100 size <- rep(0, times = n) rho <- rep(0, times = n) x <- X size <- apply(x, 3, centroid.size) rho <- apply(x, 3, y <- function(x) { riemdist(x, z$mshape) }) z$rho <- rho z$size <- size z$rmsrho <- sqrt(mean(rho ^ 2)) z$rmsd1 <- sqrt(mean(sin(rho) ^ 2)) z$k <- k z$m <- m z$n <- n tem <- matrix(0, k, k) for (i in 1:n) { tem <- tem + (z$rotated[, , i] - z$mshape) %*% t((z$rotated[, , i] - z$mshape)) } tem <- tem / (n * m) z$Sigmak <- tem return(z) } #================================================================================== testshapes <- function(A, B, resamples = 1000, replace = TRUE, scale = TRUE) { if (replace == TRUE) { out <- bootstraptest(A, B, resamples = resamples, scale = scale) } if (replace == FALSE) { out <- permutationtest(A, B, nperms = resamples, scale = scale) } out } #================================================================================== testmeanshapes <- function(A, B, resamples = 1000, replace = FALSE, scale = TRUE) { if (replace == TRUE) { out <- bootstraptest(A, B, resamples = resamples, scale = scale) } if (replace == FALSE) { out <- permutationtest(A, B, nperms = resamples, scale = scale) } if (resamples > 0) { aa <- list( H = 0, H.pvalue = 0, H.table.pvalue = 0, G = 0, G.pvalue = 0, G.table.pvalue = 0, J = 0, J.pvalue = 0, J.table.pvalue = 0 ) aa$H <- out$H aa$H.pvalue <- out$H.pvalue aa$H.table.pvalue <- out$H.table.pvalue aa$G <- out$G aa$G.pvalue <- out$G.pvalue aa$G.table.pvalue <- out$G.table.pvalue aa$J <- out$J aa$J.pvalue <- out$J.pvalue aa$J.table.pvalue <- out$J.table.pvalue } if (resamples == 0) { aa <- list( H = 0, H.table.pvalue = 0, G = 0, G.table.pvalue = 0, J = 0, J.table.pvalue = 0 ) aa$H <- out$H aa$H.table.pvalue <- out$H.table.pvalue aa$G <- out$G aa$G.table.pvalue <- out$G.table.pvalue aa$J <- out$J aa$J.table.pvalue <- out$J.table.pvalue } aa } #================================================================================== permutationtest2 <- function (A, B, nperms = 1000, scale = scale) { A1 <- A A2 <- B mdim <- dim(A1)[2] B <- nperms nsam1 <- dim(A1)[3] nsam2 <- dim(A2)[3] pool <- procGPA( abind (A1, A2) , scale = scale, tangentcoords = "partial", pcaoutput = FALSE ) tempool <- pool for (i in 1:(nsam1 + nsam2)) { tempool$tan[, i] <- pool$tan[, i] / Enorm(pool$tan[, i]) * pool$rho[i] } pool <- tempool permpool <- pool Gtem <- Goodall(pool, nsam1, nsam2) Htem <- Hotelling(pool, nsam1, nsam2) Jtem <- James(pool, nsam1, nsam2, table = TRUE) Ltem <- Lambdamin(pool, nsam1, nsam2) Gumc <- Gtem$F Humc <- Htem$F Jumc <- Jtem$Tsq Lumc <- Ltem$lambdamin Gtabpval <- Gtem$pval Htabpval <- Htem$pval Jtabpval <- Jtem$pval Ltabpval <- Ltem$pval if (B > 0) { Apool <- array(0, c(dim(A1)[1], dim(A1)[2], dim(A1)[3] + dim(A2)[3])) Apool[, , 1:nsam1] <- A1 Apool[, , (nsam1 + 1):(nsam1 + nsam2)] <- A2 out <- list( H = 0, H.pvalue = 0, H.table.pvalue = 0, J = 0, J.pvalue = 0, J.table.pvalue = 0, G = 0, G.pvalue = 0, G.table.pvalue = 0 ) Gu <- rep(0, times = B) Hu <- rep(0, times = B) Ju <- rep(0, times = B) Lu <- rep(0, times = B) cat("Permutations - sampling without replacement: ") cat(c("No of permutations = ", B, "\n")) for (i in 1:B) { if (i / 100 == trunc(i / 100)) { cat(c(i, " ")) } select <- sample(1:(nsam1 + nsam2)) permpool$tan <- pool$tan[, select] Gu[i] <- Goodall(permpool, nsam1, nsam2)$F Hu[i] <- Hotelling(permpool, nsam1, nsam2)$F Ju[i] <- James(permpool, nsam1, nsam2)$Tsq Lu[i] <- Lambdamin(permpool, nsam1, nsam2)$lambdamin } Gu <- sort(Gu) numbig <- length(Gu[Gumc < Gu]) pvalG <- (1 + numbig) / (B + 1) Lu <- sort(Lu) numbig <- length(Lu[Lumc < Lu]) pvalL <- (1 + numbig) / (B + 1) Ju <- sort(Ju) numbig <- length(Ju[Jumc < Ju]) pvalJ <- (1 + numbig) / (B + 1) Hu <- sort(Hu) numbig <- length(Hu[Humc < Hu]) pvalH <- (1 + numbig) / (B + 1) cat(" \n") out$Hu <- Hu out$Ju <- Ju out$Gu <- Gu out$Lu <- Lu out$H <- Humc out$H.pvalue <- pvalH out$H.table.pvalue <- Htabpval out$J <- Jumc out$J.pvalue <- pvalJ out$J.table.pvalue <- Jtabpval out$G <- Gumc out$G.pvalue <- pvalG out$G.table.pvalue <- Gtabpval out$L <- Lumc out$L.pvalue <- pvalL out$L.table.pvalue <- Ltabpval } if (B == 0) { out <- list( H = 0, H.table.pvalue = 0, G = 0, G.table.pvalue = 0 ) out$H <- Humc out$H.table.pvalue <- Htabpval out$J <- Jumc out$J.table.pvalue <- Jtabpval out$G <- Gumc out$G.table.pvalue <- Gtabpval out$L <- Lumc out$L.table.pvalue <- Ltabpval } out } #================================================================================== bootstraptest <- function (A, B, resamples = 200, scale = TRUE) { A1 <- A A2 <- B mdim <- dim(A1)[2] B <- resamples nsam1 <- dim(A1)[3] nsam2 <- dim(A2)[3] pool <- procGPA( abind (A1, A2) , scale = scale , tangentcoords = "partial", pcaoutput = FALSE ) tempool <- pool for (i in 1:(nsam1 + nsam2)) { tempool$tan[, i] <- pool$tan[, i] / Enorm(pool$tan[, i]) * pool$rho[i] } pool <- tempool bootpool <- pool Gtem <- Goodall(pool, nsam1, nsam2) Htem <- Hotelling(pool, nsam1, nsam2) Jtem <- James(pool, nsam1, nsam2, table = TRUE) Ltem <- Lambdamin(pool, nsam1, nsam2) Gumc <- Gtem$F Humc <- Htem$F Jumc <- Jtem$Tsq Lumc <- Ltem$lambdamin Gtabpval <- Gtem$pval Htabpval <- Htem$pval Jtabpval <- Jtem$pval Ltabpval <- Ltem$pval if (B > 0) { Apool <- array(0, c(dim(A1)[1], dim(A1)[2], dim(A1)[3] + dim(A2)[3])) Apool[, , 1:nsam1] <- A1 Apool[, , (nsam1 + 1):(nsam1 + nsam2)] <- A2 out <- list( H = 0, H.pvalue = 0, H.table.pvalue = 0, J = 0, J.pvalue = 0, J.table.pvalue = 0, G = 0, G.pvalue = 0, G.table.pvalue = 0 ) Gu <- rep(0, times = B) Hu <- rep(0, times = B) Ju <- rep(0, times = B) Lu <- rep(0, times = B) pool2 <- pool pool2$tan[, 1:nsam1] <- pool$tan[, 1:nsam1] - apply(pool$tan[, 1:nsam1], 1, mean) pool2$tan[, (nsam1 + 1):(nsam1 + nsam2)] <- pool$tan[, (nsam1 + 1):(nsam1 + nsam2)] - apply(pool$tan[, (nsam1 + 1):(nsam1 + nsam2)], 1, mean) cat("Bootstrap - sampling with replacement within each group under H0: ") cat(c("No of resamples = ", B, "\n")) for (i in 1:B) { if (i / 100 == trunc(i / 100)) { cat(c(i, " ")) } select1 <- sample(1:nsam1, replace = TRUE) select2 <- sample((nsam1 + 1):(nsam1 + nsam2), replace = TRUE) bootpool$tan <- pool2$tan[, c(select1, select2)] Gu[i] <- Goodall(bootpool, nsam1, nsam2)$F Hu[i] <- Hotelling(bootpool, nsam1, nsam2)$F Ju[i] <- James(bootpool, nsam1, nsam2)$Tsq Lu[i] <- Lambdamin(bootpool, nsam1, nsam2)$lambdamin } Gu <- sort(Gu) numbig <- length(Gu[Gumc < Gu]) pvalG <- (1 + numbig) / (B + 1) Ju <- sort(Ju) numbig <- length(Ju[Jumc < Ju]) pvalJ <- (1 + numbig) / (B + 1) Hu <- sort(Hu) numbig <- length(Hu[Humc < Hu]) pvalH <- (1 + numbig) / (B + 1) numbig <- length(Lu[Lumc < Lu]) pvalL <- (1 + numbig) / (B + 1) cat(" \n") out$Hu <- Hu out$Ju <- Ju out$Gu <- Gu out$Lu <- Lu out$H <- Humc out$H.pvalue <- pvalH out$H.table.pvalue <- Htabpval out$J <- Jumc out$J.pvalue <- pvalJ out$J.table.pvalue <- Jtabpval out$G <- Gumc out$G.pvalue <- pvalG out$G.table.pvalue <- Gtabpval out$L <- Lumc out$L.pvalue <- pvalL out$L.table.pvalue <- Ltabpval } if (B == 0) { out <- list( H = 0, H.table.pvalue = 0, G = 0, G.table.pvalue = 0, J = 0, J.table.pvalue = 0 ) out$H <- Humc out$H.table.pvalue <- Htabpval out$J <- Jumc out$J.table.pvalue <- Jtabpval out$G <- Gumc out$G.table.pvalue <- Gtabpval out$L <- Lumc out$L.table.pvalue <- Ltabpval } out } #================================================================================== Lambdamin <- function (pool, n1, n2, p = 0) { censiz <- centroid.size(pool$mshape) tan1 <- pool$tan[, 1:n1] tan2 <- pool$tan[, (n1 + 1):(n1 + n2)] kt <- dim(tan1)[1] n <- n1 + n2 k <- pool$k m <- pool$m if (p == 0) { p <- min(k * m - (m * (m - 1)) / 2 - 1 - m, n1 + n2 - 2) } HH <- diag(k) mu1 <- pool$mshape if (dim(tan1)[1] == k * m - m) { HH <- defh(k - 1) mu1 <- preshape(pool$mshape) } if (m == 2) { mu <- c(mu1[, 1], mu1[, 2]) } if (m == 3) { mu <- c(mu1[, 1], mu1[, 2], mu1[, 3]) } dd <- kt X1 <- tan1 * 0 X2 <- tan2 * 0 S1 <- matrix(0, dd, dd) S2 <- matrix(0, dd, dd) for (i in 1:n1) { X1[, i] <- (mu + tan1[, i]) / Enorm(mu + tan1[, i]) S1 <- S1 + X1[, i] %*% t(X1[, i]) } for (i in 1:n2) { X2[, i] <- (mu + tan2[, i]) / Enorm(mu + tan2[, i]) S2 <- S2 + X2[, i] %*% t(X2[, i]) } sumx1 <- 0 sumx2 <- 0 for (i in 1:n1) { sumx1 <- sumx1 + X1[, i] } for (i in 1:n2) { sumx2 <- sumx2 + X2[, i] } sum1 <- apply(X1, 1, sum) sum2 <- apply(X2, 1, sum) mean1 <- sum1 / Enorm(sum1) mean2 <- sum2 / Enorm(sum2) bb1 <- mean1[1:(dd - 1)] cc1 <- mean1[dd] bb2 <- mean2[1:(dd - 1)] cc2 <- mean2[dd] A1 <- cc1 / abs(cc1) * diag(dd - 1) - cc1 / (abs(cc1) + cc1 ^ 2) * bb1 %*% t(bb1) M1 <- cbind(A1,-bb1) A1 <- cc2 / abs(cc2) * diag(dd - 1) - cc2 / (abs(cc2) + cc2 ^ 2) * bb2 %*% t(bb2) M2 <- cbind(A1,-bb2) G1 <- matrix(0, dd - 1, dd - 1) G2 <- matrix(0, dd - 1, dd - 1) for (iu in 1:(dd - 1)) { for (iv in iu:(dd - 1)) { G1[iu, iv] <- G1[iu, iv] + t((t(M1))[, iu]) %*% S1 %*% (t(M1))[, iv] G1[iv, iu] <- G1[iu, iv] G2[iu, iv] <- G2[iu, iv] + t((t(M2))[, iu]) %*% S2 %*% (t(M2))[, iv] G2[iv, iu] <- G2[iu, iv] } } G1 <- G1 / n1 / Enorm(sumx1 / n1) ^ 2 G2 <- G2 / n2 / Enorm(sumx2 / n2) ^ 2 # eva1 <- eigen(G1, symmetric = TRUE, EISPACK = TRUE) eva1 <- eigen(G1, symmetric = TRUE) pcar1 <- eva1$vectors[, 1:p] pcasd1 <- sqrt(abs(eva1$values[1:p])) # eva2 <- eigen(G2, symmetric = TRUE, EISPACK = TRUE) eva2 <- eigen(G2, symmetric = TRUE) pcar2 <- eva2$vectors[, 1:p] pcasd2 <- sqrt(abs(eva2$values[1:p])) if ((pcasd1[p] < 1e-06) || (pcasd2[p] < 1e-06)) { offset <- 1e-06 cat("*") pcasd1 <- sqrt(pcasd1 ^ 2 + offset) pcasd2 <- sqrt(pcasd2 ^ 2 + offset) } Ahat1 <- n1 * t(M1) %*% (pcar1 %*% diag(1 / pcasd1 ^ 2) %*% t(pcar1)) %*% M1 Ahat2 <- n2 * t(M2) %*% (pcar2 %*% diag(1 / pcasd2 ^ 2) %*% t(pcar2)) %*% M2 Ahat <- (Ahat1 + Ahat2) # eva <- eigen(Ahat, symmetric = TRUE, EISPACK = TRUE) eva <- eigen(Ahat, symmetric = TRUE) lambdamin <- eva$values[p + 1] pval <- 1 - pchisq(lambdamin, p) #print(lambdamin) #print(pval) z <- list() z$pval <- pval z$df <- p z$lambdamin <- lambdamin return(z) } #================================================================================== Goodall <- function(pool , n1, n2, p = 0) { tan1 <- pool$tan[, 1:n1] tan2 <- pool$tan[, (n1 + 1):(n1 + n2)] kt <- dim(tan1)[1] n <- n1 + n2 k <- pool$k m <- pool$m if (p == 0) { p <- min(k * m - (m * (m - 1)) / 2 - 1 - m, n1 + n2 - 2) } top <- Enorm(apply(tan1, 1, mean) - apply(tan2, 1, mean)) ** 2 bot <- sum(diag(var(t(tan1)))) * (n1 - 1) + sum(diag(var(t(tan2)))) * (n2 - 1) Fstat <- ((n1 + n2 - 2) / (1 / n1 + 1 / n2) * top) / bot pval <- 1 - pf(Fstat, p, (n1 + n2 - 2) * p) z <- list() z$F <- Fstat z$pval <- pval z$df1 <- p z$df2 <- (n1 + n2 - 2) * p return(z) } #================================================================================== Hotelling <- function(pool , n1, n2, p = 0) { tan1 <- pool$tan[, 1:n1] tan2 <- pool$tan[, (n1 + 1):(n1 + n2)] kt <- dim(tan1)[1] n <- n1 + n2 k <- pool$k m <- pool$m S1 <- var(t(tan1)) S2 <- var(t(tan2)) Sw <- ((n1 - 1) * S1 + (n2 - 1) * S2) / (n1 + n2 - 2) if (p == 0) { p <- min(k * m - (m * (m - 1)) / 2 - 1 - m, n1 + n2 - 2) } # eva <- eigen(Sw, symmetric = TRUE,EISPACK=TRUE) eva <- eigen(Sw, symmetric = TRUE) pcar <- eva$vectors[, 1:p] pcasd <- sqrt(abs(eva$values[1:p])) if (pcasd[p] < 1e-06) { offset <- 1e-06 cat("*") pcasd <- sqrt(pcasd ^ 2 + offset) } lam <- rep(0, times = kt) lam[1:p] <- 1 / pcasd ^ 2 Suinv <- eva$vectors %*% diag(lam) %*% t(eva$vectors) pcax <- t(pool$tan) %*% pcar one1 <- matrix(1 / n1, n1, 1) one2 <- matrix(1 / n2, n2, 1) oneone <- rbind(one1,-one2) vbar <- pool$tan %*% oneone scores1 <- matrix(vbar, 1, kt) %*% pcar scores <- scores1 / pcasd F.partition <- ((scores[1:p] ^ 2) * (n1 * n2 * (n1 + n2 - p - 1))) / ((n1 + n2) * (n1 + n2 - 2) * p) FF <- sum(F.partition) pval <- 1 - pf(FF, p, (n1 + n2 - p - 1)) z <- list() z$F.partition <- F.partition z$F <- FF z$pval <- pval z$df1 <- p z$T.df1 <- p z$df2 <- (n1 + n2 - p - 1) mm <- n - 2 z$T.df2 <- mm z$Tsq <- FF * (n1 + n2) * (n1 + n2 - 2) * p / (n1 * n2) / (n1 + n2 - p - 1) z$Tsq.partition <- F.partition * (n1 + n2) * (n1 + n2 - 2) * p / (n1 * n2) / (n1 + n2 - p - 1) return(z) } James <- function(pool , n1, n2, p = 0, table = FALSE) { tan1 <- pool$tan[, 1:n1] tan2 <- pool$tan[, (n1 + 1):(n1 + n2)] kt <- dim(tan1)[1] n <- n1 + n2 k <- pool$k m <- pool$m S1 <- var(t(tan1)) S2 <- var(t(tan2)) Sw <- S1 / n1 + S2 / n2 if (p == 0) { p <- min(k * m - (m * (m - 1)) / 2 - 1 - m, n1 + n2 - 2) } # eva <- eigen(Sw, symmetric = TRUE,EISPACK=TRUE) eva <- eigen(Sw, symmetric = TRUE) pcar <- eva$vectors[, 1:p] pcasd <- sqrt(abs(eva$values[1:p])) if (pcasd[p] < 1e-06) { offset <- 1e-06 cat("*") pcasd <- sqrt(pcasd ^ 2 + offset) } lam <- rep(0, times = kt) lam[1:p] <- 1 / pcasd ^ 2 Suinv <- eva$vectors %*% diag(lam) %*% t(eva$vectors) pcax <- t(pool$tan) %*% pcar one1 <- matrix(1 / n1, n1, 1) one2 <- matrix(1 / n2, n2, 1) oneone <- rbind(one1,-one2) vbar <- pool$tan %*% oneone # scores1 <- matrix(vbar, 1, kt ) %*% pcar # scores <- scores1/pcasd # F.partition <- ((scores[1:p]^2) * (n1 * n2 * (n1 + n2 - p - # 1)))/((n1 + n2) * (n1 + n2 - 2) * p) # FF <- sum(F.partition) # pval <- 1 - pf(FF, p, (n1 + n2 - p - 1)) ######### # ginvSw<- pcar%*%diag(1/pcasd**2)%*%t(pcar) ginvSw <- Suinv pval = 0 T1 <- sum(diag((ginvSw %*% S1 / n1))) T2 <- sum(diag((ginvSw %*% S2 / n2))) T1sq <- sum(diag(((ginvSw %*% S1 / n1) %*% ginvSw %*% S1 / n1))) T2sq <- sum(diag(((ginvSw %*% S2 / n2) %*% ginvSw %*% S2 / n2))) Tsq <- (t(vbar) %*% (ginvSw) %*% vbar)[1, 1] if (table == TRUE) { AA <- 1 + 1 / (2 * p) * (T1 ** 2 / (n1 - 1) + T2 ** 2 / (n2 - 1)) BB <- 1 / (p * (p + 2)) * ((T1 ** 2 / 2 + T1sq) / (n1 - 1) + (T2 ** 2 / 2 + T2sq) / (n2 - 1)) kk <- rep(0, times = 1000) for (i in 0:999) { alphai <- i / 1000 kk[i + 1] <- qchisq(alphai, df = p) * (AA + BB * qchisq(alphai, df = p)) } pval <- 1 - max(c(1:1000)[kk < Tsq]) / 1000 } ####### z <- list() z$pval <- pval z$Tsq <- Tsq return(z) } #================================================================================== tpsgrid <- function (TT, YY, xbegin = -999, ybegin = -999, xwidth = -999, opt = 1, ext = 0.1, ngrid = 22, cex = 1, pch = 20, col = 2, zslice = 0, mag = 1, axes3 = FALSE) { k <- nrow(TT) m <- dim(TT)[2] YY <- TT + (YY - TT) * mag bb <- array(TT, c(dim(TT), 1)) aa <- defplotsize2(bb) if (xwidth == -999) { xwidth <- aa$width } if (xbegin == -999) { xbegin <- aa$xl } if (ybegin == -999) { ybegin <- aa$yl } if (m == 3) { zup <- max(TT[, 3]) zlo <- min(TT[, 3]) zpos <- zslice for (ii in 1:length(zslice)) { zpos[ii] <- (zup + zlo) / 2 + (zup - zlo) / 2 * zslice[ii] } } xstart <- xbegin ystart <- ybegin ngrid <- trunc(ngrid / 2) * 2 kx <- ngrid ky <- ngrid - 1 l <- kx * ky step <- xwidth / (kx - 1) r <- 0 X <- rep(0, times = kx) Y2 <- rep(0, times = ky) for (p in 1:kx) { ystart <- ybegin xstart <- xstart + step for (q in 1:ky) { ystart <- ystart + step r <- r + 1 X[r] <- xstart Y2[r] <- ystart } } TPS <- bendingenergy(TT) gamma11 <- TPS$gamma11 gamma21 <- TPS$gamma21 gamma31 <- TPS$gamma31 W <- gamma11 %*% YY ta <- t(gamma21 %*% YY) B <- gamma31 %*% YY WtY <- t(W) %*% YY trace <- c(0) for (i in 1:m) { trace <- trace + WtY[i, i] } benergy <- 16 * pi * trace if (m == 3) { benergy <- 8 * pi * trace } l <- kx * ky phi <- matrix(0, l, m) s <- matrix(0, k, 1) for (islice in 1:length(zslice)) { if (m == 3) { refc <- matrix(c(X, Y2, rep(zpos[islice], times = kx * ky)), kx * ky, m) } if (m == 2) { refc <- matrix(c(X, Y2), kx * ky, m) } for (i in 1:l) { s <- matrix(0, k, 1) for (im in 1:k) { s[im,] <- sigmacov(refc[i,] - TT[im,]) } phi[i,] <- ta + t(B) %*% refc[i,] + t(W) %*% s } if (m == 3) { if (opt == 2) { shapes3d(TT, color = 2, axes3 = axes3, rglopen = FALSE) shapes3d(YY, color = 4, rglopen = FALSE) for (i in 1:k) { lines3d(rbind(TT[i, ], YY[i, ]), col = 1) } for (j in 1:kx) { lines3d(refc[((j - 1) * ky + 1):(ky * j) , ], color = 6) } for (j in 1:ky) { lines3d(refc[(0:(kx - 1) * ky) + j , ], color = 6) } } shapes3d(TT, color = 2, axes3 = axes3, rglopen = FALSE) shapes3d(YY, color = 4, rglopen = FALSE) for (i in 1:k) { lines3d(rbind(TT[i, ], YY[i, ]), col = 1) } for (j in 1:kx) { lines3d(phi[((j - 1) * ky + 1):(ky * j) , ], color = 3) } for (j in 1:ky) { lines3d(phi[(0:(kx - 1) * ky) + j , ], color = 3) } } } if (m == 2) { par(pty = "s") if (opt == 2) { par(mfrow = c(1, 2)) order <- linegrid(refc, kx, ky) plot( order[1:l, 1], order[1:l, 2], type = "l", xlim = c(xbegin - xwidth * ext, xbegin + xwidth * (1 + ext)), ylim = c( ybegin - (xwidth * ky) / kx * ext, ybegin + (xwidth * ky) / kx * (1 + ext) ), xlab = " ", ylab = " " ) lines(order[(l + 1):(2 * l), 1], order[(l + 1):(2 * l), 2], type = "l") points(TT, cex = cex, pch = pch, col = col) } order <- linegrid(phi, kx, ky) plot( order[1:l, 1], order[1:l, 2], type = "l", xlim = c(xbegin - xwidth * ext, xbegin + xwidth * (1 + ext)), ylim = c(ybegin - (xwidth * ext * ky) / kx, ybegin + (xwidth * (1 + ext) * ky) / kx), xlab = " ", ylab = " " ) lines(order[(l + 1):(2 * l), 1], order[(l + 1):(2 * l), 2], type = "l") points(YY, cex = cex, pch = pch, col = col + 1) points(TT, cex = cex, pch = pch, col = col) for (i in 1:(k)) { arrows( TT[i, 1], TT[i, 2] , YY[i, 1], YY[i, 2] , col = col + 2, length = 0.1, angle = 20 ) } } } # #================================================================================== rotatexyz <- function(x, thetax, thetay, thetaz) { thetax <- thetax / 180 * pi thetay <- thetay / 180 * pi thetaz <- thetaz / 180 * pi Rx <- matrix(c( 1, 0, 0, 0, cos(thetax), sin(thetax), 0, -sin(thetax), cos(thetax) ), 3, 3) Ry <- matrix(c( cos(thetay), 0, sin(thetay), 0, 1, 0, -sin(thetay), 0, cos(thetay) ), 3, 3) Rz <- matrix(c( cos(thetaz), sin(thetaz), 0, -sin(thetaz), cos(thetaz), 0, 0, 0, 1 ), 3, 3) y <- x n <- dim(x)[3] for (i in 1:n) { y[, , i] <- x[, , i] %*% Rx %*% Ry %*% Rz } y } #================================================================================== rigidbody <- function(X, transx = 0, transy = 0, transz = 0, thetax = 0, thetay = 0, thetaz = 0) { if (is.matrix(X)) { X <- array(X, c(dim(X), 1)) } m <- dim(X)[2] n <- dim(X)[3] Y <- X if (m == 2) { #xx<-as.3d(X) if (dim(X)[3] < 2) { xx <- array(as.3d(X), dim = c(nrow(X), 3, 1)) } else{ xx <- as.3d(X) } for (i in 1:n) { for (j in 1:m) { xx[j, , i] <- xx[j, , i] - c(transx, transy, transz) } } yy <- rotatexyz(xx, thetax, thetay, thetaz) Y <- yy if ((sum(abs(yy[, 3, ]))) < 0.000000001) { Y <- yy[, 1:2, ] } } if (m == 3) { for (i in 1:n) { for (j in 1:m) { X[j, , i] <- X[j, , i] - c(transx, transy, transz) } } Y <- rotatexyz(X, thetax, thetay, thetaz) } Y } #================================================================================== as.3d <- function(X) { k <- dim(X)[1] if (is.matrix(X)) { X <- array(X, c(dim(X), 1)) } n <- dim(X)[3] if (dim(X)[2] != 2) { print("not 2 dimensional!") } Y <- array(0, c(k, 3, n)) Y[, 1:2, ] <- X if (n == 1) { Y <- Y[, , 1] } Y } #================================================================================== abind <- function(X1 , X2) { k <- dim(X1)[1] m <- dim(X1)[2] if (is.matrix(X1)) { tem <- array(0, c(k, m, 1)) tem[, , 1] <- X1 X1 <- tem } if (is.matrix(X2)) { tem <- array(0, c(k, m, 1)) tem[, , 1] <- X2 X2 <- tem } n1 <- dim(X1)[3] n2 <- dim(X2)[3] Y <- array(0, c(k, m, n1 + n2)) Y[, , 1:n1] <- X1 Y[, , (n1 + 1):(n1 + n2)] <- X2 Y } #================================================================================== shapes3d <- function(x, loop = 0, type = "p", color = 2, joinline = c(1:1), axes3 = FALSE, rglopen = TRUE) { if (is.matrix(x)) { xt <- array(0, c(dim(x), 1)) xt[, , 1] <- x x <- xt } if (is.array(x) == FALSE) { cat("Data not in right format : require an array \n") } if (is.array(x) == TRUE) { if (rglopen) { open3d() } if (dim(x)[2] == 2) { x <- as.3d(x) } if (loop == 0) { k <- dim(x)[1] sz <- centroid.size(x[, , 1]) / sqrt(k) / 30 plotshapes3d( x, type = type, color = color, size = sz, joinline = joinline ) if (axes3) { axes3d(color = "black") title3d( xlab = "x", ylab = "y", zlab = "z", color = "black" ) } } if (loop > 0) { for (i in 1:loop) { plotshapestime3d(x, type = type) } } } } #================================================================================== plotshapes3d <- function (x, type = "p", rgl = TRUE, color = 2, size = 1, joinline = c(1:1)) { k <- dim(x)[1] n <- dim(x)[3] y <- matrix(0, k * n, 3) for (i in 1:n) { y[(i - 1) * k + (1:k),] <- x[, , i] } if (rgl == FALSE) { par(mfrow = c(1, 1)) out <- defplotsize3(x) xl <- out$xl xu <- out$xu yl <- out$yl yu <- out$yu zl <- out$zl zu <- out$zu scatterplot3d( y, xlim = c(xl, xu), ylim = c(yl, yu), zlim = c(zl, zu), xlab = "x", ylab = "y", zlab = "z", axis = TRUE, type = type, color = color, highlight.3d = TRUE ) } if (rgl == TRUE) { if (type == "l") { points3d(y, col = color, size = size) for (j in 1:n) { lines3d(x[, , j], col = 8) } } if (type == "dots") { points3d(y, col = color, size = size) } if (type == "p") { spheres3d(y, col = color, radius = size) } if (length(joinline) > 1) { for (j in 1:n) { lines3d(x[joinline, , j], col = 8) } } } } #================================================================================== plotshapestime3d <- function (x, type = "p") { par(mfrow = c(1, 1)) out <- defplotsize3(x) xl <- out$xl xu <- out$xu yl <- out$yl yu <- out$yu zl <- out$zl zu <- out$zu n <- dim(x)[3] for (i in 1:n) { scatterplot3d( x[, , i], xlim = c(xl, xu), ylim = c(yl, yu), zlim = c(zl, zu), xlab = "x", ylab = "y", zlab = "z", axis = TRUE, type = type, highlight.3d = TRUE ) title(i) } } #================================================================================== plotPDMnoaxis3 <- function (mean, pc, sd, xl, xu, yl, yu, lineorder, i) { fig <- mean + i * pc * sd k <- length(mean) / 2 figx <- fig[1:k] figy <- fig[(k + 1):(2 * k)] plot( figx, figy, axes = FALSE, xlab = " ", ylab = " ", ylim = c(yl, yu), type = "n", xlim = c(xl, xu) ) text(figx, figy, 1:k) lines(figx[lineorder], figy[lineorder]) for (aa in 1:9999) { aaa <- 1 } } ################################# #================================================================================== shapepca <- function (proc, pcno = c(1, 2, 3), type = "r", mag = 1, joinline = c(1, 1), project = c(1, 2), scores3d = FALSE, color = 2, axes3 = FALSE, rglopen = TRUE, zslice = 0) { if (scores3d == TRUE) { axes3 <- TRUE sz <- max(proc$rawscores[, max(pcno)]) - min(proc$rawscores[, max(pcno)]) spheres3d(proc$rawscores[, pcno] , radius = sz / 30, col = color) if (axes3) { axes3d() } } m <- dim(proc$mshape)[2] k <- dim(proc$mshape)[1] if (scores3d == FALSE) { if ((m == 2)) { out <- defplotsize2(proc$rotated, project = project) xl <- out$xl yl <- out$yl width <- out$width plotpca(proc, pcno, type, mag, xl, yl, width, joinline, project) } if ((m == 3) && (type == "m")) { # plot3Dmean(proc) # cat("Mean shape \n") # for (i in 1:length(pcno)) { # cat("PC ", pcno[i], " \n") # plot3Dpca(proc, pcno[i]) # } for (i in 1:length(pcno)) { cat("PC ", pcno[i], " \n") plotpca3d(proc, pcno[i]) } } ## correct length of tangent vector if in Helmertized space h <- defh(k - 1) zero <- matrix(0, k - 1, k) H <- cbind(h, zero, zero) H1 <- cbind(zero, h, zero) H2 <- cbind(zero, zero, h) H <- rbind(H, H1, H2) if (dim(proc$pcar)[1] == (3 * (k - 1))) { pcarot <- (t(H) %*% proc$pcar) proc$pcar <- pcarot } if (((m == 3) && (type != "m")) && (type != "g")) { if (rglopen) { open3d() } sz <- centroid.size(proc$mshape) / sqrt(k) / 30 spheres3d(proc$mshape, radius = sz, col = color) if (axes3) { axes3d() } for (i in pcno) { pc <- proc$mshape + 3 * mag * proc$pcasd[i] * cbind(proc$pcar[1:k, i], proc$pcar[(k + 1):(2 * k), i], proc$pcar[(2 * k + 1):(3 * k), i]) for (j in 1:k) { lines3d(rbind(proc$mshape[j, ], pc[j, ]), col = i) } } } } if ((m == 3) && (type == "g")) { if (rglopen) { open3d() } for (i in pcno) { pc <- proc$mshape + 3 * mag * proc$pcasd[i] * cbind(proc$pcar[1:k, i], proc$pcar[(k + 1):(2 * k), i], proc$pcar[(2 * k + 1):(3 * k), i]) tpsgrid(proc$mshape, pc, zslice = zslice) } } } #================================================================================== plotpca3d <- function (procreg, pcno = 1) { par(mfrow = c(1, 1)) out <- defplotsize3(procreg$rotated) xl <- out$xl xu <- out$xu yl <- out$yl yu <- out$yu zl <- out$zl zu <- out$zu k <- dim(procreg$mshape)[1] subx <- 1:k suby <- (k + 1):(2 * k) subz <- (2 * k + 1):(3 * k) evec <- cbind(procreg$pcar[subx, pcno], procreg$pcar[suby, pcno], procreg$pcar[subz, pcno]) for (j in 1:10) { for (ii in-12:12) { mag <- ii / 4 scatterplot3d( procreg$mshape + mag * evec * procreg$pcasd[pcno], xlim = c(xl, xu), ylim = c(yl, yu), zlim = c(zl, zu), xlab = "x", ylab = "y", zlab = "z", axis = TRUE, highlight.3d = TRUE ) title(pcno) } for (ii in-11:11) { mag <- -ii / 4 scatterplot3d( procreg$mshape + mag * evec * procreg$pcasd[pcno], xlim = c(xl, xu), ylim = c(yl, yu), zlim = c(zl, zu), xlab = "x", ylab = "y", zlab = "z", axis = TRUE ) title(pcno) } } } ############################## #================================================================================== Hotelling2Djames <- function (A, B) { z <- list(Tsq = 0, pval = 0) n1 <- dim(A)[3] n2 <- dim(B)[3] n <- n1 + n2 k <- dim(A)[1] m <- dim(B)[2] if (m != 2) { print("Data not two dimensional") return(z) } else { pool <- array(0, c(k, m, n)) pool[, , 1:n1] <- A pool[, , (n1 + 1):n] <- B poolpr <- procrustes2d(pool, 1, 2) S1 <- var(t(poolpr$tan[, 1:n1])) S2 <- var(t(poolpr$tan[, (n1 + 1):(n1 + n2)])) gamma <- realtocomplex(preshape(poolpr$mshape)) Sw <- (S1 / n1 + S2 / n2) p <- 2 * k - 4 # TT<-eigen(Sw,symmetric=TRUE,EISPACK=TRUE) TT <- eigen(Sw, symmetric = TRUE) pcar <- TT$vectors[, 1:p] pcasd <- sqrt(abs(TT$values[1:p])) ####### add small offset if defecient in rank if (pcasd[p] < 0.000001) { offset <- 0.000001 cat("*") pcasd <- sqrt(pcasd ** 2 + offset ** 2) } ####################################### pcax <- t(poolpr$tan) %*% pcar h <- defh(k - 1) zero <- matrix(0, k - 1, k) H <- cbind(h, zero) H1 <- cbind(zero, h) H <- rbind(H, H1) meanxy <- t(H) %*% V(gamma) realrot <- t(H) %*% pcar one1 <- matrix(1 / n1, n1, 1) one2 <- matrix(1 / n2, n2, 1) oneone <- rbind(one1,-one2) vbar <- poolpr$tan %*% oneone scores1 <- matrix(vbar, 1, (2 * k - 2)) %*% pcar scores <- scores1 / pcasd F.partition <- ((scores[1:p] ^ 2) * (n1 * n2 * (n1 + n2 - p - 1))) / ((n1 + n2) * (n1 + n2 - 2) * p) FF <- sum(F.partition) pval <- 1 - pf(FF, p, (n1 + n2 - p - 1)) ginvSw <- pcar %*% diag(1 / pcasd ** 2) %*% t(pcar) T1 <- sum(diag((ginvSw %*% S1 / n1))) T2 <- sum(diag((ginvSw %*% S2 / n2))) T1sq <- sum(diag(( (ginvSw %*% S1 / n1) %*% ginvSw %*% S1 / n1 ))) T2sq <- sum(diag(( (ginvSw %*% S2 / n2) %*% ginvSw %*% S2 / n2 ))) Tsq <- (t(vbar) %*% (ginvSw) %*% vbar)[1, 1] AA <- 1 + 1 / (2 * p) * (T1 ** 2 / (n1 - 1) + T2 ** 2 / (n2 - 1)) BB <- 1 / (p * (p + 2)) * ((T1 ** 2 / 2 + T1sq) / (n1 - 1) + (T2 ** 2 / 2 + T2sq) / (n2 - 1)) kk <- rep(0, times = 1000) for (i in 0:999) { alphai <- i / 1000 kk[i + 1] <- qchisq(alphai, df = p) * (AA + BB * qchisq(alphai, df = p)) } pval <- 1 - max(c(1:1000)[kk < Tsq]) / 1000 # z$F.partition <- F.partition # z$F <- FF z$pval <- pval z$Tsq <- Tsq # z$df1 <- p # z$T.df1 <- p # z$df2 <- (n1 + n2 - p - 1) # mm <- n - 2 # z$T.df2 <- mm # z$Tsq <- FF * (n1 + n2) * (n1 + n2 - 2) * p/(n1 * n2)/(n1 + # n2 - p - 1) # z$Tsq.partition <- F.partition * (n1 + n2) * (n1 + n2 - # 2) * p/(n1 * n2)/(n1 + n2 - p - 1) return(z) } } MGM <- function(zst) { nsam <- dim(zst)[2] k <- dim(zst)[1] Mhat <- matrix(0, k - 1, k - 2) lamhat <- rep(0, times = (k - 1)) Sighat <- matrix(0, k - 2, k - 2) kk <- k * 2 - 2 t1 <- reassqpr(preshape(zst)) / nsam # t2 <- eigen(t1,symmetric=TRUE,EISPACK=TRUE) t2 <- eigen(t1, symmetric = TRUE) reagamma <- (t2$vectors[, 1] + t2$vectors[, 2]) / sqrt(2) gamma <- Vinv(reagamma) muhat <- gamma for (i in 1:(k - 2)) { Mhat[, i] <- Vinv(t2$vectors[, 1 + (2 * i)]) } for (i in 1:(k - 1)) { lamhat[i] <- t2$values[(2 * i) - 1] } for (j in 2:(k - 1)) { for (l in 2:(k - 1)) { sum <- 0 for (i in 1:nsam) { zi <- preshape(zst[, i]) sum <- sum + st(Mhat[, j - 1]) %*% zi * st(zi) %*% Mhat[, l - 1] * st(zi) %*% muhat * st(muhat) %*% zi } Sighat[j - 1, l - 1] <- 1 / (lamhat[1] - lamhat[j]) / (lamhat[1] - lamhat[l]) * sum / nsam } } SR <- Re(Sighat) SI <- Im(Sighat) S1 <- cbind(SR, SI) S2 <- cbind(-(SI), SR) S <- rbind(S1, S2) offset <- 0 #es<-eigen(S,symmetric=TRUE,EISPACK=TRUE)$values es <- eigen(S, symmetric = TRUE)$values nn <- length(es) if (es[nn] < 0.000001) { offset <- 0.000001 #cat("Warning: test: small samples, lambda I added to within group covariance matrix \n") cat("*") } invS <- solve(S + offset * diag(nn)) invSR <- invS[1:(k - 2), 1:(k - 2)] invSI <- invS[1:(k - 2), (k - 1):(2 * k - 4)] invS <- invSR + 1i * invSI Mhat <- st(Mhat) MGM <- st(Mhat) %*% invS %*% Mhat MGM } #====================================================================================== resampletest <- function(A, B, resamples = 200, replace = TRUE) { A1 <- A A2 <- B B <- resamples k <- dim(A1)[1] m <- dim(A1)[2] nmin <- min(dim(A1)[3], dim(A2)[3]) ntot <- dim(A1)[3] + dim(A2)[3] M <- (k - 1) * m - m * (m - 1) / 2 - 1 if (M >= ntot) { cat("Warning: Low sample size (n1 + n2 <= p) \n") } if ((M >= nmin) && (replace == TRUE)) { cat( "Warning: Low sample sizes : min(n1,n2)<=p : * indicates some regularization carried out \n" ) } permutation <- !replace if (is.complex(A1)) { tem <- array(0, c(nrow(A1), 2, ncol(A1))) tem[, 1,] <- Re(A1) tem[, 2,] <- Im(A1) A1 <- tem } if (is.complex(A2)) { tem <- array(0, c(nrow(A2), 2, ncol(A2))) tem[, 1,] <- Re(A2) tem[, 2,] <- Im(A2) A2 <- tem } m <- dim(A1)[2] if (m != 2) { print("Data not two dimensional") print("Carrying out tests on Procrustes residuals") out <- testmeanshapes(A1, A2, resamples = resamples, replace = replace) return(out) } zst1 <- A1[, 1, ] + 1i * A1[, 2, ] zst2 <- A2[, 1, ] + 1i * A2[, 2, ] nsam1 <- dim(zst1)[2] nsam2 <- dim(zst2)[2] k <- dim(zst1)[1] LL <- (MGM(zst1) + MGM(zst2)) * (nsam1 + nsam2) LL1 <- cbind(Re(LL), Im(LL)) LL2 <- cbind(-Im(LL), Re(LL)) LL <- rbind(LL1, LL2) #Tumc<-min(eigen(LL,symmetric=TRUE,only.values=TRUE,EISPACK=TRUE)$values) Tumc <- min(eigen(LL, symmetric = TRUE, only.values = TRUE)$values) m1 <- preshape(procrustes2d(zst1)$mshape) m1 <- m1[, 1] + 1i * m1[, 2] m2 <- preshape(procrustes2d(zst2)$mshape) m2 <- m2[, 1] + 1i * m2[, 2] m0 <- preshape(procrustes2d(cbind(zst1, zst2))$mshape) m0 <- m0[, 1] + 1i * m0[, 2] d <- length(m1) H <- defh(k - 1) b <- m1 a <- m0 bt <- b * c((st(b) %*% a) / Mod(st(b) %*% a)) abt <- c(Re(st(bt) %*% a)) ct <- (bt - a * abt) # ct <- ct / sqrt(st(ct) %*% ct) ct <- ct / c(sqrt(st(as.vector(ct)) %*% as.vector(ct))) At <- a %*% st(ct) - ct %*% st(a) salph <- sqrt(1 - abt ** 2) calph <- abt Id <- diag(rep(1, times = d)) U1 <- Id + salph * At + (calph - 1) * (a %*% st(a) + ct %*% st(ct)) b <- m2 a <- m0 bt <- b * c((st(b) %*% a) / Mod(st(b) %*% a)) abt <- c(Re(st(bt) %*% a)) ct <- (bt - a * abt) # ct <- ct / sqrt(st(ct) %*% ct) ct <- ct / c(sqrt(st(as.vector(ct)) %*% as.vector(ct))) At <- a %*% st(ct) - ct %*% st(a) salph <- sqrt(1 - abt ** 2) calph <- abt Id <- diag(rep(1, times = d)) U2 <- Id + salph * At + (calph - 1) * (a %*% st(a) + ct %*% st(ct)) yst1 <- t(H) %*% U1 %*% preshape(zst1) yst2 <- t(H) %*% U2 %*% preshape(zst2) ybind <- cbind(yst1, yst2) zr1 <- array(0, c(k, 2, nsam1)) zr2 <- array(0, c(k, 2, nsam2)) zr3 <- array(0, c(k, 2, nsam1 + nsam2)) zr1[, 1, ] <- Re(zst1) zr1[, 2, ] <- Im(zst1) zr2[, 1, ] <- Re(zst2) zr2[, 2, ] <- Im(zst2) zr3[, 1, ] <- cbind(Re(zst1), Re(zst2)) zr3[, 2, ] <- cbind(Im(zst1), Im(zst2)) yr1 <- array(0, c(k, 2, nsam1)) yr2 <- array(0, c(k, 2, nsam2)) yr3 <- array(0, c(k, 2, nsam1 + nsam2)) yr1[, 1, ] <- Re(yst1) yr1[, 2, ] <- Im(yst1) yr2[, 1, ] <- Re(yst2) yr2[, 2, ] <- Im(yst2) yr3[, 1, ] <- cbind(Re(yst1), Re(yst2)) yr3[, 2, ] <- cbind(Im(yst1), Im(yst2)) Gtem <- Goodall2D(zr1, zr2) Htem <- Hotelling2D(zr1, zr2) Jtem <- Hotelling2Djames(zr1, zr2) Gumc <- Gtem$F Humc <- Htem$F Jumc <- Jtem$Tsq Gtabpval <- Gtem$pval Htabpval <- Htem$pval Jtabpval <- Jtem$pval if (B > 0) { Tu <- rep(0, times = B) Gu <- Tu Hu <- Tu Ju <- Tu cat("Resampling...") cat(c("No of resamples = ", B, "\n")) if (permutation) { cat("Permutations - sampling without replacement \n") } if (permutation == FALSE) { cat("Bootstrap - sampling with replacement \n") } for (i in 1:B) { cat(c(i, " ")) select1 <- sample(1:nsam1, replace = TRUE) select2 <- sample(1:nsam2, replace = TRUE) zb1 <- yst1[, select1] zb2 <- yst2[, select2] zbgh1 <- yr1[, , select1] zbgh2 <- yr2[, , select2] if (permutation) { select0 <- sample(c(1:(nsam1 + nsam2)), (nsam1 + nsam2), replace = FALSE) select1 <- select0[1:nsam1] select2 <- select0[(nsam1 + 1):(nsam1 + nsam2)] zb1 <- zr3[, 1, select1] + 1i * zr3[, 2, select1] zb2 <- zr3[, 1, select2] + 1i * zr3[, 2, select2] zbgh1 <- yr3[, , select1] zbgh2 <- yr3[, , select2] } LL <- (MGM(zb1) + MGM(zb2)) * (nsam1 + nsam2) LL1 <- cbind(Re(LL), Im(LL)) LL2 <- cbind(-Im(LL), Re(LL)) LL <- rbind(LL1, LL2) #lmin<-min(eigen(LL,symmetric=TRUE,only.values=TRUE,EISPACK=TRUE)$values) lmin <- min(eigen(LL, symmetric = TRUE, only.values = TRUE)$values) Tu[i] <- lmin Gu[i] <- Goodall2D(zbgh1, zbgh2)$F Hu[i] <- Hotelling2D(zbgh1, zbgh2)$F Ju[i] <- Hotelling2Djames(zbgh1, zbgh2)$Tsq } Tu <- sort(Tu) numbig <- length(Tu[Tumc < Tu]) pvalb <- (1 + numbig) / (B + 1) Gu <- sort(Gu) numbig <- length(Gu[Gumc < Gu]) pvalG <- (1 + numbig) / (B + 1) Hu <- sort(Hu) numbig <- length(Hu[Humc < Hu]) pvalH <- (1 + numbig) / (B + 1) Ju <- sort(Ju) numbig <- length(Ju[Jumc < Ju]) pvalJ <- (1 + numbig) / (B + 1) cat(" \n") out <- list( lambda = 0, lambda.pvalue = 0, lambda.table.pvalue = 0, H = 0, H.pvalue = 0, H.table.pvalue = 0, J = 0, J.pvalue = 0, J.table.pvalue = 0, G = 0, G.pvalue = 0, G.table.pvalue = 0 ) out$lambda <- Tumc out$lambda.pvalue <- pvalb out$lambda.table.pvalue <- 1 - pchisq(Tumc, 2 * k - 4) out$H <- Humc out$H.pvalue <- pvalH out$H.table.pvalue <- Htabpval out$J <- Jumc out$J.pvalue <- pvalJ out$J.table.pvalue <- Jtabpval out$G <- Gumc out$G.pvalue <- pvalG out$G.table.pvalue <- Gtabpval } if (resamples == 0) { out <- list( lambda = 0, lambda.table.pvalue = 0, H = 0, H.table.pvalue = 0, J = 0, J.table.pvalue = 0, G = 0, G.table.pvalue = 0 ) out$lambda <- Tumc out$lambda.table.pvalue <- 1 - pchisq(Tumc, 2 * k - 4) out$H <- Humc out$H.table.pvalue <- Htabpval out$J <- Jumc out$J.table.pvalue <- Jtabpval out$G <- Gumc out$G.table.pvalue <- Gtabpval } out } #================================================================================== prcomp1 <- function (x, retx = TRUE, center = TRUE, scale. = FALSE, tol = NULL, svd = TRUE) { x <- as.matrix(x) x <- scale(x, center = center, scale = scale.) if (svd == FALSE) { a <- eigen(cov(x)) r <- list(sdev = 0, rotation = 0, x = 0) r$sdev <- sqrt(abs(a$values)) r$rotation <- a$vectors r$x <- x %*% a$vectors } else { s <- svd(x, nu = 0) if (!is.null(tol)) { rank <- sum(s$d > (s$d[1] * tol)) if (rank < ncol(x)) s$v <- s$v[, 1:rank, drop = FALSE] } s$d <- s$d / sqrt(max(1, nrow(x) - 1)) dimnames(s$v) <- list(colnames(x), paste("PC", seq(len = ncol(s$v)), sep = "")) r <- list(sdev = s$d, rotation = s$v) if (retx) r$x <- x %*% s$v class(r) <- "prcomp1" } r } #================================================================================== defplotsize3 <- function(Y) { out <- list( xl = 0, yl = 0, zl = 0, xu = 0, yu = 0, zu = 0, width = 0 ) n <- dim(Y)[3] xm <- mean(Y[, 1,]) ym <- mean(Y[, 2,]) zm <- mean(Y[, 3,]) x <- Y x[, 1,] <- Y[, 1,] - xm x[, 2,] <- Y[, 2,] - ym x[, 3,] <- Y[, 3,] - zm mn1 <- min(x[, 1, ]) mn2 <- min(x[, 2, ]) mn3 <- min(x[, 3, ]) mx1 <- max(x[, 1, ]) mx2 <- max(x[, 2, ]) mx3 <- max(x[, 3, ]) xl <- -max(-mn1, mx1) yl <- -max(-mn2, mx2) zl <- -max(-mn3, mx3) width <- max(-2 * xl,-2 * yl,-2 * zl) out$xl <- -width / 2 * 1.2 + xm out$yl <- -width / 2 * 1.2 + ym out$zl <- -width / 2 * 1.2 + zm out$xu <- width / 2 * 1.2 + xm out$yu <- width / 2 * 1.2 + ym out$zu <- width / 2 * 1.2 + zm out$width <- width * 1.2 out } #================================================================================== procOPA <- function(A, B, scale = TRUE, reflect = FALSE) { out <- list( R = 0, s = 0, Ahat = 0, Bhat = 0, OSS = 0, rmsd = 0 ) if (is.complex(sum(A)) == TRUE) { k <- length(A) Areal <- matrix(0, k, 2) Areal[, 1] <- Re(A) Areal[, 2] <- Im(A) A <- Areal } if (is.complex(sum(B)) == TRUE) { k <- length(B) Breal <- matrix(0, k, 2) Breal[, 1] <- Re(B) Breal[, 2] <- Im(B) B <- Breal } k <- dim(A)[1] if (reflect == FALSE) { R <- fort.ROTATION(A, B) } else { R <- fort.ROTATEANDREFLECT(A, B) } s <- 1 if (scale == TRUE) { s <- fos(A, B) if (reflect == TRUE) { s <- fos.REFLECT(A, B) } } Ahat <- fcnt(A) Bhat <- fcnt(B) %*% R * s resid <- Ahat - Bhat OSS <- sum(diag(t(resid) %*% resid)) out$R <- R out$s <- s out$Ahat <- Ahat out$Bhat <- Bhat m <- dim(Ahat)[2] out$OSS <- OSS out$rmsd <- sqrt(OSS / (k)) out } #================================================================================== defplotsize2 <- function(Y, project = c(1, 2)) { out <- list( xl = 0, yl = 0, xu = 0, yu = 0, width = 0 ) n <- dim(Y)[3] xm <- mean(Y[, project[1],]) ym <- mean(Y[, project[2],]) x <- Y x[, project[1],] <- Y[, project[1],] - xm x[, project[2],] <- Y[, project[2],] - ym out <- list(xl = 0, yl = 0, width = 0) mn1 <- min(x[, project[1], ]) mn2 <- min(x[, project[2], ]) mx1 <- max(x[, project[1], ]) mx2 <- max(x[, project[2], ]) xl <- -max(-mn1, mx1) yl <- -max(-mn2, mx2) width <- max(-2 * xl,-2 * yl) out$xl <- -width / 2 * 1.2 + xm out$yl <- -width / 2 * 1.2 + ym out$xu <- width / 2 * 1.2 + xm out$yu <- width / 2 * 1.2 + ym out$width <- width * 1.2 out } #================================================================================== plotshapes <- function(A, B = 0, joinline = c(1, 1), orthproj = c(1, 2), color = 1, symbol = 1) { CHECKOK <- TRUE if (is.array(A) == FALSE) { if (is.matrix(A) == FALSE) { cat("Error !! argument should be an array or matrix \n") CHECKOK <- FALSE } } if (CHECKOK) { k <- dim(A)[1] m <- dim(A)[2] kk <- k if (k >= 15) { kk <- 1 } par(pty = "s") #if (length(c(B))==1){ #par(mfrow=c(1,1)) #} if (length(c(B)) != 1) { par(mfrow = c(1, 2)) } if (length(dim(A)) == 3) { A <- A[, orthproj, ] } if (is.matrix(A) == TRUE) { a <- array(0, c(k, 2, 1)) a[, , 1] <- A[, orthproj] A <- a } out <- defplotsize2(A) width <- out$width if (length(c(B)) != 1) { if (length(dim(B)) == 3) { B <- B[, orthproj, ] } if (is.matrix(B) == TRUE) { a <- array(0, c(k, 2, 1)) a[, , 1] <- B[, orthproj] B <- a } ans <- defplotsize2(B) width <- max(out$width, ans$width) } n <- dim(A)[3] lc <- length(color) lt <- k * m * n / lc color <- rep(color, times = lt) lc <- length(symbol) lt <- k * m * n / lc symbol <- rep(symbol, times = lt) plot( A[, , 1], xlim = c(out$xl, out$xl + width), ylim = c(out$yl, out$yl + width), type = "n", xlab = " ", ylab = " " ) for (i in 1:n) { select <- ((i - 1) * k * m + 1):(i * k * m) points(A[, , i], pch = symbol[select], col = color[select]) lines(A[joinline, , i]) } if (length(c(B)) != 1) { A <- B if (is.matrix(A) == TRUE) { a <- array(0, c(k, 2, 1)) a[, , 1] <- A A <- a } out <- defplotsize2(A) n <- dim(A)[3] plot( A[, , 1], xlim = c(ans$xl, ans$xl + width), ylim = c(ans$yl, ans$yl + width), type = "n", xlab = " ", ylab = " " ) for (i in 1:n) { points(A[, , i], pch = symbol[select], col = color[select]) lines(A[joinline, , i]) } } } } #================================================================================== BoxM <- function(A, B, npc) { #carries out Box's M test #(see Mardia, Kent, Bibby 1979, p140) #in: data arrays A, B #out: z$M M statistic # z$df degrees of freedom for approx distn of chi-squared statistic # z$pval p-value z <- list(M = 0, df = 0, pval = 0) n1 <- dim(A)[3] n2 <- dim(B)[3] k <- dim(A)[1] m <- dim(A)[2] if (m > 2) { print("Only works for 2D data at the moment!") } if (m == 2) { C <- array(0, c(k, m, n1 + n2)) C[, , 1:n1] <- A C[, , (n1 + 1):(n1 + n2)] <- B Cpr <- procrustes2d(C, 1, 2) p <- npc ng <- 2 n <- n1 + n2 S1 <- var(t(Cpr$tan[1:npc, 1:n1])) S2 <- var(t(Cpr$tan[1:npc, (n1 + 1):(n1 + n2)])) Su <- ((n1 - 1) * S1 + (n2 - 1) * S2) / (n1 + n2 - 2) S1inv <- eigen(S1)$vectors %*% diag(1 / eigen(S1)$values) %*% t(eigen(S1)$vectors) S2inv <- eigen(S2)$vectors %*% diag(1 / eigen(S2)$values) %*% t(eigen(S2)$vectors) logdet1 <- sum(log(eigen(S1inv %*% Su)$values)) logdet2 <- sum(log(eigen(S2inv %*% Su)$values)) gam <- 1 - ((2 * p ^ 2 + 3 * p - 1) / (6 * (p + 1) * (ng - 1))) * (1 / (n1 - 1) + 1 / (n2 - 1) - 1 / (n - ng)) M <- gam * ((n1 - 1) * logdet1 + (n2 - 1) * logdet2) df <- (p * (p + 1) * (ng - 1)) / 2 pval <- 1 - pchisq(M, df) z$M <- M z$df <- df z$pval <- pval } return(z) } #================================================================================== Goodall2D <- function(A, B) { #Calculates Goodall's two sample F test for 2d data only #in: data arrays A, B k x 2 x n data arrays #out: z$F F statistic # z$df1, z$df2 degrees of freedom # z$pval: p-value z <- list( F = 0, pval = 0, df1 = 0, df2 = 0 ) n1 <- dim(A)[3] n2 <- dim(B)[3] k <- dim(A)[1] m <- dim(A)[2] if (m != 2) { print("Data not two dimensional") return(z) } p <- 2 * k - 4 Apr <- procrustes2d(A, 1, 2) Bpr <- procrustes2d(B, 1, 2) top <- sin(riemdist(Apr$mshape, Bpr$mshape)) ^ 2 bot <- Apr$rmsd1 ^ 2 * n1 + Bpr$rmsd1 ^ 2 * n2 Fstat <- ((n1 + n2 - 2) / (1 / n1 + 1 / n2) * top) / bot pval <- 1 - pf(Fstat, p, (n1 + n2 - 2) * p) z$F <- Fstat z$pval <- pval z$df1 <- p z$df2 <- (n1 + n2 - 2) * p return(z) } #================================================================================== Goodalltest <- function(A, B, tol1 = 1e-07, tol2 = tol1) { #Calculates Goodall's two sample F test #in: data arrays A, B: #out: z$F F statistic # z$df1, z$df2 degrees of freedom # z$pval: p-value z <- list( F = 0, pval = 0, df1 = 0, df2 = 0 ) n1 <- dim(A)[3] n2 <- dim(B)[3] k <- dim(A)[1] m <- dim(A)[2] p <- min(k * m - (m * (m - 1)) / 2 - 1 - m, n1 + n2 - 2) Apr <- procrustesGPA(A, tol1, tol2) Bpr <- procrustesGPA(B, tol1, tol2) top <- sin(riemdist(Apr$mshape, Bpr$mshape)) ^ 2 bot <- Apr$rmsd1 ^ 2 * n1 + Bpr$rmsd1 ^ 2 * n2 Fstat <- ((n1 + n2 - 2) / (1 / n1 + 1 / n2) * top) / bot pval <- 1 - pf(Fstat, p, (n1 + n2 - 2) * p) z$F <- Fstat z$pval <- pval z$df1 <- p z$df2 <- (n1 + n2 - 2) * p return(z) } #================================================================================== Hotelling2D <- function (A, B) { z <- list( Tsq.partition = 0, Tsq = 0, F.partition = 0, F = 0, pval = 0, df1 = 0, df2 = 0, T.df1 = 0, T.df2 = 0 ) n1 <- dim(A)[3] n2 <- dim(B)[3] n <- n1 + n2 k <- dim(A)[1] m <- dim(B)[2] if (m != 2) { print("Data not two dimensional") return(z) } else { pool <- array(0, c(k, m, n)) pool[, , 1:n1] <- A pool[, , (n1 + 1):n] <- B poolpr <- procrustes2d(pool, 1, 2) S1 <- var(t(poolpr$tan[, 1:n1])) S2 <- var(t(poolpr$tan[, (n1 + 1):(n1 + n2)])) gamma <- realtocomplex(preshape(poolpr$mshape)) Sw <- ((n1 - 1) * S1 + (n2 - 1) * S2) / (n1 + n2 - 2) p <- 2 * k - 4 # pcar <- eigen(Sw,EISPACK=TRUE)$vectors[, 1:p] pcar <- eigen(Sw)$vectors[, 1:p] pcasd <- sqrt(abs(eigen(Sw)$values[1:p])) ####### add small offset if defecient in rank if (pcasd[p] < 0.000001) { offset <- 0.000001 cat("*") pcasd <- sqrt(pcasd ** 2 + offset ** 2) } ####################################### pcax <- t(poolpr$tan) %*% pcar h <- defh(k - 1) zero <- matrix(0, k - 1, k) H <- cbind(h, zero) H1 <- cbind(zero, h) H <- rbind(H, H1) meanxy <- t(H) %*% V(gamma) realrot <- t(H) %*% pcar one1 <- matrix(1 / n1, n1, 1) one2 <- matrix(1 / n2, n2, 1) oneone <- rbind(one1,-one2) vbar <- poolpr$tan %*% oneone scores1 <- matrix(vbar, 1, (2 * k - 2)) %*% pcar scores <- scores1 / pcasd F.partition <- ((scores[1:p] ^ 2) * (n1 * n2 * (n1 + n2 - p - 1))) / ((n1 + n2) * (n1 + n2 - 2) * p) FF <- sum(F.partition) pval <- 1 - pf(FF, p, (n1 + n2 - p - 1)) z$F.partition <- F.partition z$F <- FF z$pval <- pval z$df1 <- p z$T.df1 <- p z$df2 <- (n1 + n2 - p - 1) mm <- n - 2 z$T.df2 <- mm z$Tsq <- FF * (n1 + n2) * (n1 + n2 - 2) * p / (n1 * n2) / (n1 + n2 - p - 1) z$Tsq.partition <- F.partition * (n1 + n2) * (n1 + n2 - 2) * p / (n1 * n2) / (n1 + n2 - p - 1) return(z) } } #================================================================================== Hotellingtest <- function (A, B, tol1 = 1e-07, tol2 = 1e-07) { z <- list( Tsq.partition = 0, Tsq = 0, F.partition = 0, F = 0, pval = 0, df1 = 0, df2 = 0, T.df1 = 0, T.df2 = 0 ) n1 <- dim(A)[3] n2 <- dim(B)[3] n <- n1 + n2 k <- dim(A)[1] m <- dim(B)[2] pool <- array(0, c(k, m, n)) pool[, , 1:n1] <- A pool[, , (n1 + 1):n] <- B poolpr <- procrustesGPA(pool, tol1, tol2, approxtangent = FALSE) S1 <- var(t(poolpr$tan[, 1:n1])) S2 <- var(t(poolpr$tan[, (n1 + 1):(n1 + n2)])) Sw <- ((n1 - 1) * S1 + (n2 - 1) * S2) / (n1 + n2 - 2) p <- min(k * m - (m * (m - 1)) / 2 - 1 - m, n1 + n2 - 2) eva <- eigen(Sw, symmetric = TRUE) pcar <- eva$vectors[, 1:p] pcasd <- sqrt(abs(eva$values[1:p])) ####### add small offset if defecient in rank if (pcasd[p] < 0.000001) { offset <- 0.000001 cat("*") pcasd <- sqrt(pcasd ** 2 + offset) } ####################################### lam <- rep(0, times = (k * m - m)) lam[1:p] <- 1 / pcasd ** 2 Suinv <- eva$vectors %*% diag(lam) %*% t(eva$vectors) # check <- p # for (i in 1:p) { # if (pcasd[p + 1 - i] < 1e-04) { # check <- p + 1 - i - 1 # } # } # p <- check pcax <- t(poolpr$tan) %*% pcar one1 <- matrix(1 / n1, n1, 1) one2 <- matrix(1 / n2, n2, 1) oneone <- rbind(one1,-one2) vbar <- poolpr$tan %*% oneone scores1 <- matrix(vbar, 1, m * k - m) %*% pcar scores <- scores1 / pcasd # tem<-c(t(vbar)%*%Suinv%*%vbar) #(=Dsq)# F.partition <- ((scores[1:p] ^ 2) * (n1 * n2 * (n1 + n2 - p - 1))) / ((n1 + n2) * (n1 + n2 - 2) * p) FF <- sum(F.partition) pval <- 1 - pf(FF, p, (n1 + n2 - p - 1)) z$F.partition <- F.partition z$F <- FF z$pval <- pval z$df1 <- p z$T.df1 <- p z$df2 <- (n1 + n2 - p - 1) mm <- n - 2 z$T.df2 <- mm z$Tsq <- FF * (n1 + n2) * (n1 + n2 - 2) * p / (n1 * n2) / (n1 + n2 - p - 1) z$Tsq.partition <- F.partition * (n1 + n2) * (n1 + n2 - 2) * p / (n1 * n2) / (n1 + n2 - p - 1) return(z) } # Hotellingtest<-function(A, B, tol1=1e05,tol2=1e05) # OLD VERSION using $tan rather than $tanpartial #{ #Calculates two sample Hotelling Tsq test for testing whether #mean shapes are equal (m - Dimensions where m >= 2) #in: A, B the k x m x n arrays of data for each group #out: z$F : F-statistic # z$df1, z$df2 : dgrees of freedom # z$pval: pvalue # z <- list(Tsq.partition = 0, Tsq = 0, F.partition = 0, F = 0, pval = 0, # df1 = 0, df2 = 0, T.df1 = 0, T.df2 = 0) # n1 <- dim(A)[3] # n2 <- dim(B)[3] # n <- n1 + n2 # k <- dim(A)[1] # m <- dim(B)[2] # pool <- array(0, c(k, m, n)) # pool[, , 1:n1] <- A # pool[, , (n1 + 1):n] <- B # poolpr <- procrustesGPA(pool,tol1,tol2) # S1 <- var(t(poolpr$tan[, 1:n1])) # S2 <- var(t(poolpr$tan[, (n1 + 1):(n1 + n2)])) # Sw <- ((n1 - 1) * S1 + (n2 - 1) * S2)/(n1 + n2 - 2) # p <- min(k * m - (m * (m - 1))/2 - 1 - m, n1 + n2 - 2) # pcar <- eigen(Sw)$vectors[, 1:p] # pcasd <- sqrt(eigen(Sw)$values[1:p]) # check<-p ## checks to see if rank is reasonable # for (i in 1:p){ # if (pcasd[p+1-i] < 0.0001){ # check<-p+1-i-1 # } # } # p<-check # pcax <- t(poolpr$tan) %*% pcar # one1 <- matrix(1/n1, n1, 1) # one2 <- matrix(1/n2, n2, 1) # oneone <- rbind(one1, - one2) # vbar <- poolpr$tan %*% oneone # scores1 <- matrix(vbar, 1, m*k) %*% pcar # scores <- scores1/pcasd # F.partition <- ((scores[1:p]^2) * (n1 * n2 * (n1 + n2 - p - 1)))/((n1 + # n2) * (n1 + n2 - 2) * p) # FF <- sum(F.partition) # pval <- 1 - pf(FF, p, (n1 + n2 - p - 1)) # z$F.partition <- F.partition # z$F <- FF # z$pval <- pval # z$df1 <- p # z$T.df1 <- p # z$df2 <- (n1 + n2 - p - 1) # mm <- n - 2 # z$T.df2 <- mm # z$Tsq <- (FF * (mm * p))/(mm - p + 1) # z$Tsq.partition <- (F.partition * (mm * p))/(mm - p + 1) # return(z) #} #================================================================================== I2mat <- function(Be) { zero <- rep(0, times = dim(Be)[1] ^ 2) zero <- matrix(zero, dim(Be)[1], dim(Be)[2]) temp <- cbind(Be, zero) temp1 <- cbind(zero, Be) tem <- rbind(temp, temp1) tem } #================================================================================== tpsgrid.old <- function (TT, YY, xbegin = -999, ybegin = -999, xwidth = -999, opt = 2, ext = 0.1, ngrid = 22, cex = 1, pch = 20, col = 2) { k <- nrow(TT) if (xwidth == -999) { bb <- array(TT, c(dim(TT), 1)) aa <- defplotsize2(bb) xwidth <- aa$width } if (xbegin == -999) { bb <- array(TT, c(dim(TT), 1)) aa <- defplotsize2(bb) xbegin <- aa$xl } if (ybegin == -999) { bb <- array(TT, c(dim(TT), 1)) aa <- defplotsize2(bb) ybegin <- aa$yl } xstart <- xbegin ystart <- ybegin ngrid <- trunc(ngrid / 2) * 2 kx <- ngrid ky <- ngrid - 1 l <- kx * ky step <- xwidth / (kx - 1) r <- 0 X <- rep(0, times = kx) Y2 <- rep(0, times = ky) for (p in 1:kx) { ystart <- ybegin xstart <- xstart + step for (q in 1:ky) { ystart <- ystart + step r <- r + 1 X[r] <- xstart Y2[r] <- ystart } } refc <- matrix(c(X, Y2), kx * ky, 2) TPS <- bendingenergy(TT) gamma11 <- TPS$gamma11 gamma21 <- TPS$gamma21 gamma31 <- TPS$gamma31 W <- gamma11 %*% YY ta <- t(gamma21 %*% YY) B <- gamma31 %*% YY WtY <- t(W) %*% YY trace <- c(0) for (i in 1:2) { trace <- trace + WtY[i, i] } benergy <- 16 * pi * trace if (m == 3) { benergy <- 8 * pi * trace } l <- kx * ky phi <- matrix(0, l, 2) s <- matrix(0, k, 1) for (i in 1:l) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(refc[i,] - TT[m,]) } phi[i,] <- ta + t(B) %*% refc[i,] + t(W) %*% s } par(pty = "s") if (opt == 2) { par(mfrow = c(1, 2)) order <- linegrid(refc, kx, ky) plot( order[1:l, 1], order[1:l, 2], type = "l", xlim = c(xbegin - xwidth * ext, xbegin + xwidth * (1 + ext)), ylim = c( ybegin - (xwidth * ky) / kx * ext, ybegin + (xwidth * ky) / kx * (1 + ext) ), xlab = " ", ylab = " " ) lines(order[(l + 1):(2 * l), 1], order[(l + 1):(2 * l), 2], type = "l") points(TT, cex = cex, pch = pch, col = col) } order <- linegrid(phi, kx, ky) plot( order[1:l, 1], order[1:l, 2], type = "l", xlim = c(xbegin - xwidth * ext, xbegin + xwidth * (1 + ext)), ylim = c(ybegin - (xwidth * ext * ky) / kx, ybegin + (xwidth * (1 + ext) * ky) / kx), xlab = " ", ylab = " " ) lines(order[(l + 1):(2 * l), 1], order[(l + 1):(2 * l), 2], type = "l") points(YY, cex = cex, pch = pch, col = col) } # # #================================================================================== V <- function(z) { #input complex k -vector #ouput vectorized 2k vector of real stacked on imaginary components x <- c(Re(z), Im(z)) x } #================================================================================== Vinv <- function(x) { #input vectorized 2k vector of x1 stacked on x2 components #input complex k -vector of the form x1 + 1i*x2 nel <- length(x) / 2 zx <- x[1:nel] zy <- x[(nel + 1):(2 * nel)] z <- zx + (1i) * zy z } #================================================================================== Vmat <- function(z) { #as Vinv but input is a k x n complex matrix # output 2k x n matrix of stacked real then complex components x <- rbind(Re(z), Im(z)) x } #================================================================================== bendingenergy <- function (TT) { z <- list( gamma11 = 0, gamma21 = 0, gamma31 = 0, prinwarps = 0, prinwarpeval = 0, Un = 0 ) k <- nrow(TT) m <- dim(TT)[2] S <- matrix(0, k, k) for (i in 1:k) { for (j in 1:k) { S[i, j] <- sigmacov(TT[i,] - TT[j,]) } } one <- matrix(1, k, 1) zero <- matrix(0, m + 1, m + 1) # P <- cbind(S, one, TT) P <- rbind(S, t(one)) Q <- rbind(P, t(TT)) O <- cbind(one, TT) U <- rbind(O, zero) star <- cbind(Q, U) star <- matrix(star, k + m + 1, k + m + 1) A <- eigen(star, symmetric = TRUE) deltainv <- diag(1 / A$values) gamma <- A$vectors starinv <- gamma %*% deltainv %*% t(gamma) gamma11 <- matrix(0, k, k) for (i in 1:k) { for (j in 1:k) { gamma11[i, j] <- starinv[i, j] } } gamma21 <- matrix(0, 1, k) for (i in 1:1) { for (j in 1:k) { gamma21[i, j] <- starinv[k + 1, j] } } gamma31 <- matrix(0, m, k) for (i in 1:(m)) { for (j in 1:k) { gamma31[i, j] <- starinv[i + k + 1, j] } } prinwarp <- eigen(gamma11, symmetric = TRUE) prinwarps <- prinwarp$vectors prinwarpeval <- prinwarp$values ####need to rotate to compute affine components Rot <- prcomp(TT)$rotation TT <- TT %*% Rot if (m == 2) { meanxy <- c(TT[, 1], TT[, 2]) alpha <- sum(meanxy[1:k] ^ 2) beta <- sum(meanxy[(k + 1):(2 * k)] ^ 2) u1 <- c(alpha * meanxy[(k + 1):(2 * k)], beta * meanxy[1:k]) u2 <- c(-beta * meanxy[1:k], alpha * meanxy[(k + 1):(2 * k)]) u1 <- u1 / sqrt(alpha * beta) / sqrt(alpha + beta) u2 <- u2 / sqrt(alpha * beta) / sqrt(alpha + beta) Un <- matrix(0, 2 * k, 2) Un[, 1] <- u1 Un[, 2] <- u2 Vn <- Un Vn[, 1] <- cbind(Un[1:k, 1], Un[(k + 1):(2 * k), 1]) %*% t(Rot) Vn[, 2] <- cbind(Un[1:k, 2], Un[(k + 1):(2 * k), 2]) %*% t(Rot) Un <- Vn } if (m == 3) { meanxy <- c(TT[, 1], TT[, 2], TT[, 3]) alpha <- sum(meanxy[1:k] ^ 2) beta <- sum(meanxy[(k + 1):(2 * k)] ^ 2) gamma <- sum(meanxy[(2 * k + 1):(3 * k)] ^ 2) mu <- meanxy[1:k] nu <- meanxy[(k + 1):(2 * k)] omega <- meanxy[(2 * k + 1):(3 * k)] ze <- rep(0, times = k) u1 <- c(ze , alpha * beta * omega , alpha * gamma * nu) / sqrt(alpha ^ 2 * beta ^ 2 * gamma + alpha ^ 2 * gamma ^ 2 * beta) u2 <- c(alpha * beta * omega , ze, beta * gamma * mu) / sqrt(beta ^ 2 * alpha ^ 2 * gamma + beta ^ 2 * gamma ^ 2 * alpha) u3 <- c(alpha * gamma * nu , beta * gamma * mu, ze) / sqrt(alpha ^ 2 * gamma ^ 2 * beta + beta ^ 2 * gamma ^ 2 * alpha) u4 <- c(ze , ze , omega) / sqrt(gamma) u5 <- c(-beta * gamma * mu , alpha * gamma * nu, ze) / sqrt(alpha * gamma ^ 2 * beta ^ 2 + beta * gamma ^ 2 * alpha ^ 2) tem <- c(-gamma * beta * mu , ze, beta * alpha * omega) / sqrt(beta ^ 2 * alpha * gamma ^ 2 + beta ^ 2 * gamma * alpha ^ 2) tem2 <- tem - u5 * sum(u5 * tem) u4 <- tem2 / Enorm(tem2) Un <- matrix(0, 3 * k, 5) Un[, 1] <- u1 Un[, 2] <- u2 Un[, 3] <- u3 Un[, 4] <- u4 Un[, 5] <- u5 Vn <- Un Vn[, 1] <- cbind(Un[1:k, 1], Un[(k + 1):(2 * k), 1], Un[(2 * k + 1):(3 * k), 1]) %*% t(Rot) Vn[, 2] <- cbind(Un[1:k, 2], Un[(k + 1):(2 * k), 2], Un[(2 * k + 1):(3 * k), 2]) %*% t(Rot) Vn[, 3] <- cbind(Un[1:k, 3], Un[(k + 1):(2 * k), 3], Un[(2 * k + 1):(3 * k), 3]) %*% t(Rot) Vn[, 4] <- cbind(Un[1:k, 4], Un[(k + 1):(2 * k), 4], Un[(2 * k + 1):(3 * k), 4]) %*% t(Rot) Vn[, 5] <- cbind(Un[1:k, 5], Un[(k + 1):(2 * k), 5], Un[(2 * k + 1):(3 * k), 5]) %*% t(Rot) Un <- Vn } z$gamma11 <- gamma11 z$gamma21 <- gamma21 z$gamma31 <- gamma31 z$prinwarps <- prinwarps z$prinwarpeval <- prinwarpeval z$Un <- Un return(z) } #================================================================================== shaperw <- function(proc , alpha = 1, affine = FALSE) { rw <- proc if ((alpha != 0) || (affine == TRUE)) { k <- dim(proc$mshape)[1] m <- dim(proc$mshape)[2] n <- dim(proc$mshape)[3] if (dim(proc$tan)[1] == (k * m - m)) { if (m == 2) { He <- t(defh(k - 1)) Ze <- He * 0 HH <- rbind(cbind(He, Ze) , cbind(Ze, He)) proc$tan <- HH %*% proc$tan } if (m == 3) { He <- t(defh(k - 1)) Ze <- He * 0 HH <- rbind(cbind(He, Ze, Ze) , cbind(Ze, He , Ze) , cbind(Ze, Ze, He)) proc$tan <- HH %*% proc$tan } } nconstr <- m + m * (m - 1) / 2 + 1 M <- k * m - nconstr if (m == 2) { bb <- bendingenergy(proc$mshape) Gamma11 <- bb$gamma11 Be <- rbind(cbind(Gamma11, Gamma11 * 0) , cbind(Gamma11 * 0, Gamma11)) Un <- bb$Un Bedim <- 2 } if (m == 3) { bb <- bendingenergy(proc$mshape) Gamma11 <- bb$gamma11 Ze <- Gamma11 * 0 Be <- rbind(cbind(Gamma11, Ze, Ze) , cbind(Ze, Gamma11, Ze) , cbind(Ze, Ze, Gamma11)) Un <- bb$Un Bedim <- 5 } ev <- eigen(Be, symmetric = TRUE) evpw <- eigen(Gamma11, symmetric = TRUE) Beminusalpha <- ev$vectors %*% diag(c(ev$values[1:(M - Bedim)] ** (-alpha / 2), rep(0, times = nconstr + Bedim))) %*% t(ev$vectors) Bealpha <- ev$vectors %*% diag(c(ev$values[1:(M - Bedim)] ** (alpha / 2), rep(0, times = nconstr + Bedim))) %*% t(ev$vectors) evbe <- ev SS <- Beminusalpha %*% var(t(proc$tan)) %*% Beminusalpha ev <- eigen(SS) relw.vec <- ev$vectors relw.sd <- sqrt(abs(ev$values)) # ratio of eigenvalues of warps (quoted in book) rw$percent <- relw.sd ** 2 / sum(relw.sd ** 2) * 100 sgnchange <- sample(c(-1, 1), size = m * k , replace = TRUE) rw$pcar <- Bealpha %*% relw.vec %*% diag(sgnchange) rw$pcasd <- relw.sd rw$rawscores <- t(t(relw.vec) %*% Beminusalpha %*% proc$tan) sd <- sqrt(abs(diag(var((rw$rawscores) )))) rw$scores <- (rw$rawscores) %*% diag(1 / sd) rw$stdscores <- rw$scores rw$scores <- rw$rawscores ## partial warp scores n <- proc$n evbend <- eigen(Gamma11, symmetric = TRUE) partialwarpscores <- array(0 , c(n , m , k)) for (i in 1:m) { partialwarpscores[, i, ] <- t(t(evbend$vectors) %*% proc$rotated[, i, ]) } rw$principalwarps <- evpw$vectors[, (k - m - 1):1] rw$principalwarps.eigenvalues <- evpw$values[(k - m - 1):1] rw$partialwarpscores <- partialwarpscores[, , (k - m - 1):1] sumvar <- rep(0, times = (k - m - 1)) for (i in 1:(k - m - 1)) { sumvar[i] <- sum(diag(var(partialwarpscores[, , k - m - i]))) } rw$partialwarps.percent <- sumvar / sum(proc$pcasd ** 2) * 100 } if (affine == TRUE) { dimun <- dim(Un)[2] rw$pcar <- Un %*% diag(sgnchange[1:(dimun)]) pcno <- c(1:dimun) rw$rawscores <- t(Un) %*% proc$tan sd <- sqrt(abs(diag(var( t(rw$rawscores) )))) rw$pcasd <- sd rw$percent <- sd ** 2 / sum(proc$pcasd ** 2) * 100 rw$scores <- t(rw$rawscores) %*% diag(1 / sd) rw$rawscores <- t(rw$rawscores) ####### tem <- prcomp1((rw$rawscores)) npc <- 0 rw$stdscores <- tem$x for (i in 1:length(tem$sdev)) { if (tem$sdev[i] > 1e-07) { npc <- npc + 1 } } for (i in 1:npc) { rw$stdscores[, i] <- tem$x[, i] / tem$sdev[i] } rw$pcasd <- tem$sdev rw$percent <- tem$sdev ** 2 / sum(proc$pcasd ** 2) * 100 rw$pcar <- Un %*% tem$rotation rw$rawscores <- tem$x rw$scores <- rw$rawscores } rw } #================================================================================== bookstein2d <- function(A, l1 = 1, l2 = 2) { #input: A: k x 2 x n array of 2D data, or k x n complex matrix #l1,l2: baseline choice for sending to (-0.5,0),(0.5,0) #output: z$bshpv - Bookstein shape variables array (including baseline) # z$mshape - Bookstein mean shape (including baseline points) z <- list( k = 0, n = 0, mshape = 0, bshpv = 0 ) if (is.complex(sum(A)) == TRUE) { n <- dim(A)[2] k <- dim(A)[1] B <- array(0, c(k, 2, n)) B[, 1, ] <- Re(A) B[, 2, ] <- Im(A) A <- B } if (is.matrix(A) == TRUE) { bb <- array(A, c(dim(A), 1)) A <- bb } k <- dim(A)[1] m <- 2 n <- dim(A)[3] reorder <- c(l1, l2, c(1:k)[-c(l1, l2)]) A[, , ] <- A[reorder, , 1:n] bshpv <- array(0, c(k, m, n)) for (i in 1:n) { bshpv[, , i] <- bookstein.shpv(A[, , i]) } bookmean <- matrix(0, k, m) for (i in 1:n) { bookmean <- bookmean + bshpv[, , i] } bookmean <- bookmean / n bookmean[reorder, ] <- bookmean bshpv[reorder, ,] <- bshpv glim <- max(-min(bshpv), max(bshpv)) #par(pty="s") #par(mfrow=c(1,1)) #plot(bshpv[,,1],xlim=c(-glim,glim),ylim=c(-glim,glim),type="n",xlab="u",ylab="v") #for (i in 1:n) #{ #for (j in 1:k){ #text(bshpv[j,1,i],bshpv[j,2,i],as.character(j)) #} #} z$mshape <- bookmean z$bshpv <- bshpv z$k <- k z$n <- n return(z) } #================================================================================== bookstein.shpv <- function(x) { #input x: k x 2 matrix or complex k-vector #output u: k x 2 matrix of Bookstein shape variables # with baseline sent to (-0.5,0) (0.5,0) if (is.complex(x)) { x <- complextoreal(x) } nj <- dim(x)[1] j <- rep(1, times = nj) w <- (x[, 1] + (1i) * x[, 2] - (j * (x[1, 1] + (1i) * x[1, 2]))) / (x[2, 1] + (1i) * x[2, 2] - x[1, 1] - (1i) * x[1, 2]) - 0.5 w <- w[1:nj] y <- (Re(w)) z <- (Im(w)) u <- cbind(y, z) u <- matrix(u, nj, 2) u } #================================================================================== bookstein.shpv.complex <- function(z) { #input z: complex k vector #output u: k-2 complex vector of Bookstein shape variables # with baseline sent to (-0.5) (0.5) nj <- length(z) x <- matrix(cbind(Re(z), Im(z)), nj, 2) j <- rep(1, times = nj) w <- (x[, 1] + (1i) * x[, 2] - (j * (x[1, 1] + (1i) * x[1, 2]))) / (x[2, 1] + (1i) * x[2, 2] - x[1, 1] - (1i) * x[1, 2]) - 0.5 u <- w[3:nj] u } #================================================================================== cbevec <- function(z) { t1 <- reassqpr(z) # t2 <- eigen(t1,symmetric=TRUE,EISPACK=TRUE) t2 <- eigen(t1, symmetric = TRUE) reagamma <- t2$vectors[, 1] # print(t2$values/sum(t2$values)) gamma <- Vinv(reagamma) gamma } #================================================================================== cbevectors <- function(z, j) { t1 <- reassqpr(z) # t2 <- eigen(t1,symmetric=TRUE,EISPACK=TRUE) t2 <- eigen(t1, symmetric = TRUE) reagamma <- t2$vectors[, j] gamma <- Vinv(reagamma) gamma } #================================================================================== ild_centroid.size <- function(x) { #returns the centroid size of a configuration (or configurations) #input: k x m matrix/or a complex k-vector # or input a real k x m x n array to get a vector of sizes for a sample if ((is.vector(x) == FALSE) && is.complex(x)) { k <- nrow(x) n <- ncol(x) tem <- array(0, c(k, 2, n)) tem[, 1, ] <- Re(x) tem[, 2, ] <- Im(x) x <- tem } { if (length(dim(x)) == 3) { n <- dim(x)[3] sz <- rep(0, times = n) k <- dim(x)[1] h <- defh(k - 1) for (i in 1:n) { xh <- h %*% x[, , i] sz[i] <- sqrt(sum(diag(t(xh) %*% xh))) } sz } else { if (is.vector(x) && is.complex(x)) { x <- cbind(Re(x), Im(x)) } k <- nrow(x) h <- defh(k - 1) xh <- h %*% x size <- sqrt(sum(diag(t(xh) %*% xh))) size } } } #================================================================================== ild_centroid.size.complex <- function(zstar) { #returns the centroid size of a complex vector zstar h <- defh(nrow(as.matrix(zstar)) - 1) ztem <- h %*% zstar size <- sqrt(diag(Re(st(ztem) %*% ztem))) size } #================================================================================== ild_centroid.size.mD <- function(x) { #returns the centroid size of a k x m matrix if (is.complex(x)) { x <- cbind(Re(x), Im(x)) } k <- nrow(x) h <- defh(k - 1) xh <- h %*% x size <- sqrt(sum(diag(t(xh) %*% xh))) size } #================================================================================== complextoreal <- function(z) { #input complex k-vector - return k x 2 matrix nj <- length(z) x <- matrix(cbind(Re(z), Im(z)), nj, 2) x } #================================================================================== ild_defh <- function(nrow) { #Defines and returns an nrow x (nrow+1) Helmert sub-matrix k <- nrow h <- matrix(0, k, k + 1) j <- 1 while (j <= k) { jj <- 1 while (jj <= j) { h[j, jj] <- -1 / sqrt(j * (j + 1)) jj <- jj + 1 } h[j, j + 1] <- j / sqrt(j * (j + 1)) j <- j + 1 } h } #================================================================================== full.procdist <- function(x, y) { #input k x 2 matrices x, y #output full Procrustes distance rho between x,y sin(riemdist(x, y)) } #================================================================================== genpower <- function(Be, alpha) { k <- dim(Be)[1] if (alpha == 0) { gen <- diag(rep(1, times = k)) } else { l <- k - 3 # eb <- eigen(Be, symmetric = TRUE,EISPACK=TRUE) eb <- eigen(Be, symmetric = TRUE) ev <- c(eb$values[1:l] ^ (-alpha / 2), 0, 0, 0) gen <- eb$vectors %*% diag(ev) %*% t(eb$vectors) gen } } #================================================================================== isotropy.test <- function(sd, p, n) { #LR test for isotropy with Bartlett adjustment #in: sd - square roots of eigenvalues of covariance matrix # p - the number of larger eigenvalues to consider # n - sample size #out: z$bartlett - test statistic (e.g. see Mardia, Kent, Bibby, 1979, p235) # z$pval - p-value z <- list(bartlett = 0, pval = 0) tem <- sd ^ 2 bartlett <- (log(mean(tem[1:p])) - mean(log(tem[1:p]))) * p * (n - (2 * p + 11) / 6) pval <- 1 - pchisq(bartlett, ((p + 2) * (p - 1)) / 2) z$bartlett <- bartlett z$pval <- pval return(z) } #================================================================================== linegrid <- function(ref, kx, ky) { n <- ky m <- kx w <- n * m newgrid1 <- matrix(0, w, 2) v <- m * 0.5 k <- 0 for (l in 1:v) { k <- k + 1 a <- (n + m - 1) * (k - 1) + 1 b <- n * ((2 * k) - 1) d <- 2 * n * k for (j in a:b) { newgrid1[j,] <- ref[j,] } for (u in 1:n) { down <- d - u + 1 up <- b + u newgrid1[up,] <- ref[down,] } } newgrid2 <- matrix(0, w, 2) for (i in 1:v) { z <- (2 * i) - 1 for (x in 1:m) { r1 <- m * (z - 1) + x e <- n * (x - 1) + z newgrid2[r1,] <- ref[e,] } } y <- v - 1 for (p in 1:y) { f <- 2 * p for (q in 1:m) { r2 <- m * (f - 1) + q s <- n * (m - 1) + f - n * (q - 1) newgrid2[r2,] <- ref[s,] } } order <- rbind(newgrid1, newgrid2) order } #================================================================================== mahpreshapedist <- function(z, m, pcar, pcasdev) { if (is.double(z) == TRUE) z <- realtocomplex(z) if (is.double(m) == TRUE) m <- realtocomplex(m) w <- preshape(z) y <- preshape(m) zp <- project(w, y) k <- length(pcasdev) / 2 if (pcasdev[2 * k - 1] < 1e-07) pcasdev[2 * k - 1] <- 1e+22 if (pcasdev[2 * k] < 1e-07) pcasdev[2 * k] <- 1e+22 Sinv <- (pcar) %*% diag(1 / pcasdev ^ 2) %*% t(pcar) Z <- V(zp) d2 <- t(Z) %*% Sinv %*% (Z) dist <- sqrt(d2) dist } makearray <- function(x, k, m, n) { #makes a k x m x n array from a dataset read in as a table tem <- c(t(x)) tem <- array(tem, c(m, k, n)) tem <- aperm(tem, c(2, 1, 3)) tem } #================================================================================== movie <- function(mean, pc, sd, xl, xu, yl, yu, lineorder, movielength = 20) { k <- length(mean) / 2 for (i in 1:movielength) { plotPDMnoaxis(mean, pc * (-1) ^ i, sd, xl, xu, yl, yu, lineorder) } plot( mean[c(1:k)], mean[c((k + 1):(2 * k))], xlim = c(xl, xu), ylim = c(yl, yu), xlab = " ", ylab = " ", axes = FALSE ) } #================================================================================== ild_Enorm <- function(X) { #finds Euclidean/Frobenius norm of a matrix X if (is.complex(X)) { n <- sqrt(sum(diag(Re(st(X) %*% X)))) } else { n <- sqrt(sum(diag(t(X) %*% X))) } n } #================================================================================== partial.procdist <- function(x, y) { #input k x 2 matrices x, y #output partial Procrustes distance rho between x,y sqrt(2) * sqrt(1 - cos(riemdist(x, y))) } #================================================================================== partialwarpgrids <- function(TT, YY, xbegin, ybegin, xwidth, nr, nc, mag) { # #affine grid and partial warp grids for the TPS deformation of TT to YY #displayed as an nr x nc array of plots #mag = magnification effect k <- nrow(TT) YY <- TT + (YY - TT) * mag xstart <- xbegin ystart <- ybegin kx <- 22 ky <- 21 l <- kx * ky step <- xwidth / (kx - 1) r <- 0 X <- rep(0, times = 220) Y2 <- rep(0, times = 220) for (p in 1:kx) { ystart <- ybegin xstart <- xstart + step for (q in 1:ky) { ystart <- ystart + step r <- r + 1 X[r] <- xstart Y2[r] <- ystart } } refc <- matrix(c(X, Y2), kx * ky, 2) TPS <- bendingenergy(TT) gamma11 <- TPS$gamma11 gamma21 <- TPS$gamma21 gamma31 <- TPS$gamma31 W <- gamma11 %*% YY ta <- t(gamma21 %*% YY) B <- gamma31 %*% YY WtY <- t(W) %*% YY R <- matrix(0, k, 2) par(mfrow = c(nr, nc)) par(pty = "s") #AFFINEPART phi <- matrix(0, l, 2) s <- matrix(0, k, 1) for (i in 1:l) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(refc[i,] - TT[m,]) } phi[i,] <- ta + t(B) %*% refc[i,] } newpt <- matrix(0, k, 2) for (i in 1:k) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(TT[i,] - TT[m,]) } newpt[i,] <- ta + t(B) %*% TT[i,] } order <- linegrid(phi, kx, ky) plot( order[1:l, 1], order[1:l, 2], type = "l", xlim = c(xbegin - xwidth / 10, xbegin + (xwidth * 11) / 10), ylim = c(ybegin - (xwidth / 10 * ky) / kx, ybegin + ((xwidth * 11) / 10 * ky) / kx), xlab = " ", ylab = " " ) lines(order[(l + 1):(2 * l), 1], order[(l + 1):(2 * l), 2], type = "l") points(newpt, cex = 2) for (jnw in 1:(k - 3)) { nw <- k - 2 - jnw phi <- matrix(0, l, 2) s <- matrix(0, k, 1) for (i in 1:l) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(refc[i,] - TT[m,]) } phi[i,] <- refc[i,] + TPS$prinwarpeval[nw] * t(YY) %*% TPS$prinwarps[, nw] %*% t(TPS$prinwarps[, nw]) %*% s } newpt <- matrix(0, k, 2) for (i in 1:k) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(TT[i,] - TT[m,]) } newpt[i,] <- TT[i,] + TPS$prinwarpeval[nw] * t(YY) %*% TPS$prinwarps[, nw] %*% t(TPS$prinwarps[, nw]) %*% s } R <- newpt - TT + R order <- linegrid(phi, kx, ky) plot( order[1:l, 1], order[1:l, 2], type = "l", xlim = c(xbegin - xwidth / 10, xbegin + (xwidth * 11) / 10), ylim = c(ybegin - (xwidth / 10 * ky) / kx, ybegin + ((xwidth * 11) / 10 * ky) / kx), xlab = " ", ylab = " " ) lines(order[(l + 1):(2 * l), 1], order[(l + 1):(2 * l), 2], type = "l") points(newpt, cex = 2) } #percentage (need to normalize) d2 <- sin(riemdist(YY, TT)) ^ 2 d3 <- sin(riemdist(R + TT, TT)) ^ 2 percentaff <- (d2 - d3) / d2 * 100 print("percent affine") print(percentaff) } #================================================================================== partialwarps <- function(mshape, rotated) { #obtain the affine and partial warp scores for a dataset #where the reference configuration is mshape and the full procrustes #rotated figures are given in the array rotated #output: y$pwpwercent percentage of variability (squared Procrustes distance) # in the direction of each of the affine and principal warps # y$pwscores: the affine and partial warps scores # y <- list(pwpercent = 0, pwscores = 0, unpercent = 0) k <- nrow(mshape) n <- dim(rotated)[3] msh <- mshape rot <- rotated TPS <- bendingenergy(msh) FX <- rot[, 1,] FY <- rot[, 2,] U <- TPS$prinwarps[, 1:(k - 3)] partialX <- t(U) %*% FX partialY <- t(U) %*% FY Un <- TPS$Un UnXY <- t(Un) %*% rbind(FX, FY) scores <- matrix(0, 2 * (k - 3), n) for (i in 1:(k - 3)) { r <- 2 * i - 1 scores[r,] <- partialX[k - 2 - i,] scores[r + 1,] <- partialY[k - 2 - i,] } scores <- rbind(UnXY, scores) percwarp <- rep(0, times = (k - 2)) sumev <- sum(eigen(var(t(scores)))$values) for (i in 1:(k - 2)) { sum1 <- sum(eigen(var(t(scores[(2 * i - 1):(2 * i),])))$values) percwarp[i] <- sum1 / sumev } unpercent <- c(0, 0) unpercent[1] <- var(scores[1,]) / sumev unpercent[2] <- var(scores[2,]) / sumev y$unpercent <- unpercent y$pwpercent <- percwarp y$pwscores <- t(scores) return(y) } #================================================================================== plot2rwscores <- function(rwscores, rw1, rw2, ng1, ng2) { par(pch = "x") glim <- max(-min(rwscores), max(rwscores)) plot( rwscores[1:ng1, rw1], rwscores[1:ng1, rw2], xlim = c(-glim, glim), ylim = c(-glim, glim), xlab = " ", ylab = " " ) par(pch = "+") points(rwscores[(ng1 + 1):(ng1 + ng2), rw1], rwscores[(ng1 + 1):(ng1 + ng2), rw2]) } #================================================================================== plotPDM <- function(mean, pc, sd, xl, xu, yl, yu, lineorder) { for (i in c(-3, 0, 3)) { fig <- mean + i * pc * sd k <- length(mean) / 2 figx <- fig[1:k] figy <- fig[(k + 1):(2 * k)] plot( figx, figy, axes = TRUE, xlab = " ", ylab = " ", ylim = c(yl, yu), xlim = c(xl, xu) ) # par(lty = i + 1) lines(figx[lineorder], figy[lineorder]) if (i == -3) title(sub = "mean - c sd") if (i == 0) title(sub = "mean") if (i == 3) title(sub = "mean + c sd") par(lty = 1) } } #================================================================================== plotPDM2 <- function(mean, pc, sd, xl, xu, yl, yu, lineorder) { par(lty = 1) k <- length(mean) / 2 plot( mean[1:k], mean[(k + 1):(2 * k)], axes = TRUE, xlab = " ", ylab = " ", ylim = c(yl, yu), xlim = c(xl, xu) ) for (i in c(-3:3)) { fig <- mean + i * pc * sd figx <- fig[1:k] figy <- fig[(k + 1):(2 * k)] # if (i < 0) { par(lty = 1) par(pch = "*") } if (i == 0) { par(lty = 4) par(pch = 1) } if (i > 0) { par(lty = 2) par(pch = "+") } points(figx, figy) lines(figx[lineorder], figy[lineorder]) } } #================================================================================== plotPDM3 <- function(mean, pc, sd, xl, xu, yl, yu, lineorder) { par(lty = 1) k <- length(mean) / 2 figx <- matrix(0, 2 * k, 7) figy <- figx plot( mean[1:k], mean[(k + 1):(2 * k)], axes = TRUE, xlab = " ", ylab = " ", ylim = c(yl, yu), xlim = c(xl, xu) ) for (i in c(-3:3)) { fig <- mean + i * pc * sd figx[, i + 4] <- fig[1:k] figy[, i + 4] <- fig[(k + 1):(2 * k)] } for (i in 1:k) { # par(lty = 2) # lines(figx[i, 1:4], figy[i, 1:4]) par(lty = 1) lines(figx[i, 4:7], figy[i, 4:7]) } } #================================================================================== plotPDMbook <- function(mean, pc, sd, xl, xu, yl, yu, lineorder) { par(lty = 1) k <- length(mean) / 2 figx <- matrix(0, 2 * k, 7) figy <- figx plot( bookstein.shpv(cbind(mean[1:k], mean[(k + 1):(2 * k)])), axes = TRUE, xlab = " ", ylab = " ", ylim = c(yl, yu), xlim = c(xl, xu) ) for (i in c(-3:3)) { fig <- mean + i * pc * sd figx[, i + 4] <- fig[1:k] figy[, i + 4] <- fig[(k + 1):(2 * k)] u <- bookstein.shpv(cbind(figx[, i + 4], figy[, i + 4])) figx[, i + 4] <- u[, 1] figy[, i + 4] <- u[, 2] } for (i in 1:k) { # par(lty = 2) # lines(figx[i, 1:4], figy[i, 1:4]) par(lty = 1) lines(figx[i, 4:7], figy[i, 4:7]) } } #================================================================================== plotPDMnoaxis <- function(mean, pc, sd, xl, xu, yl, yu, lineorder) { for (i in c(-3:3)) { fig <- mean + i * pc * sd k <- length(mean) / 2 figx <- fig[1:k] figy <- fig[(k + 1):(2 * k)] plot( figx, figy, axes = FALSE, xlab = " ", ylab = " ", ylim = c(yl, yu), xlim = c(xl, xu) ) lines(figx[lineorder], figy[lineorder]) for (ii in 1:1000) { aa <- 1 } } } #================================================================================== pointsPDMnoaxis3 <- function(mean, pc, sd, xl, xu, yl, yu, lineorder, i) { fig <- mean + i * pc * sd k <- length(mean) / 2 figx <- fig[1:k] figy <- fig[(k + 1):(2 * k)] points(figx, figy) text(figx, figy, 1:k) lines(figx[lineorder], figy[lineorder]) } #================================================================================== plotpairscores <- function(scores, nr, nc, ng1, ng2, ch1, ch2) { #plots pairs of scores score 2 vs score 1, score 4 vs score 3 etc #in an nr x nc grid of plots par(pty = "s") par(cex = 2) par(mfrow = c(nr, nc)) k <- ncol(scores) / 2 + 2 glim <- max(-min(scores), max(scores)) for (i in 1:(k - 2)) { plot( scores[1:ng1, (2 * i - 1)], scores[1:ng1, (2 * i)], pch = ch1, xlim = c(-glim, glim), ylim = c(-glim, glim), xlab = " ", ylab = " " ) points(scores[(ng1 + 1):(ng1 + ng2), (2 * i - 1)], scores[(ng1 + 1):(ng1 + ng2), (2 * i)], pch = ch2) } } ################################# #================================================================================== plotpca <- function (proc, pcno, type, mag, xl, yl, width, joinline = c(1, 1), project = c(1, 2)) { k <- proc$k zero <- matrix(0, k - 1, k) h <- defh(k - 1) H <- cbind(h, zero) H1 <- cbind(zero, h) H <- rbind(H, H1) if (project[1] == 1) { select1 <- 1:k } if (project[1] == 2) { select1 <- (k + 1):(2 * k) } if (project[1] == 3) { select1 <- (2 * k + 1):(3 * k) } if (project[2] == 1) { select2 <- 1:k } if (project[2] == 2) { select2 <- (k + 1):(2 * k) } if (project[2] == 3) { select2 <- (2 * k + 1):(3 * k) } select <- c(select1, select2) meanxy <- c(proc$mshape[, project[1]], proc$mshape[, project[2]]) if (dim(proc$pcar)[1] == (2 * (k - 1))) { pcarot <- (t(H) %*% proc$pcar)[select, ] } if (dim(proc$pcar)[1] != (2 * (k - 1))) { pcarot <- proc$pcar[select, ] } par(pty = "s") par(lty = 1) np <- length(pcno) nr <- trunc((length(pcno) + 1) / 2) if (type == "g") { par(mfrow = c(nr, 2)) if (np == 1) { par(mfrow = c(1, 1)) } for (i in 1:np) { j <- pcno[i] fig <- meanxy + pcarot[, j] * 3 * mag * proc$pcasd[j] figx <- fig[1:k] figy <- fig[(k + 1):(2 * k)] YY <- cbind(figx, figy) tpsgrid(cbind(proc$mshape[, project[1]], proc$mshape[, project[2]]) , YY, xl, yl, width, 1, 0.1, 22) } } else { if (type == "r") { par(mfrow = c(np, 3)) for (i in 1:np) { j <- pcno[i] plotPDM(meanxy, pcarot[, j], mag * proc$pcasd[j], xl, xl + width, yl, yl + width, joinline) title(as.character( paste( "PC ", as.character(pcno[i]), ": ", as.character(round(proc$percent[i], 1)), "%" ) )) } } else { if (type == "v") { par(mfrow = c(nr, 2)) if (np == 1) { par(mfrow = c(1, 1)) } for (i in 1:np) { j <- pcno[i] plotPDM3(meanxy, pcarot[, j], mag * proc$pcasd[j], xl, xl + width, yl, yl + width, joinline) title(as.character( paste( "PC ", as.character(pcno[i]), ": ", as.character(round(proc$percent[i], 1)), "%" ) )) } } else { if (type == "b") { par(mfrow = c(nr, 2)) if (np == 1) { par(mfrow = c(1, 1)) } for (i in 1:np) { j <- pcno[i] plotPDMbook(meanxy, pcarot[, j], mag * proc$pcasd[j],-0.6, 0.6, -0.6, 0.6, joinline) title(as.character( paste( "PC ", as.character(pcno[i]), ": ", as.character(round(proc$percent[i], 1)), "%" ) )) } } else { if (type == "s") { par(mfrow = c(nr, 2)) if (np == 1) { par(mfrow = c(1, 1)) } for (i in 1:np) { j <- pcno[i] plotPDM2( meanxy, pcarot[, j], mag * proc$pcasd[j], xl, xl + width, yl, yl + width, joinline ) title(as.character( paste( "PC ", as.character(pcno[i]), ": ", as.character(round(proc$percent[i], 1)), "%" ) )) } } else { if (type == "m") { par(mfrow = c(1, 1)) for (i in 1:np) { j <- pcno[i] cat(paste("PC ", pcno[i], " \n")) movie( meanxy, pcarot[, j], mag * proc$pcasd[j], xl, xl + width, yl, yl + width, joinline, 20 ) } } } } } } } par(mfrow = c(1, 1)) } ############################################## #================================================================================== plotprinwarp <- function(TT, xbegin, ybegin, xwidth, nr, nc) { # #plots the principal warps of TT as perspective plots #the plots are displayed in an nr x nc array of plots kx <- 21 k <- nrow(TT) l <- kx ^ 2 xstart0 <- xbegin ystart0 <- ybegin xstart <- xstart0 ystart <- ystart0 step <- xwidth / kx r <- 0 X <- rep(0, times = l) Y2 <- rep(0, times = l) for (p in 1:kx) { ystart <- ystart0 xstart <- xstart + step for (q in 1:kx) { ystart <- ystart + step r <- r + 1 X[r] <- xstart Y2[r] <- ystart } } refperp <- matrix(c(X, Y2), l, 2) xstart <- xstart0 xgrid <- rep(0, times = kx) for (i in 1:kx) { xstart <- xstart + step xgrid[i] <- xstart } ystart <- ystart0 ygrid <- rep(0, times = kx) for (i in 1:kx) { ystart <- ystart + step ygrid[i] <- ystart } TPS <- bendingenergy(TT) prinwarp <- TPS$prinwarps phi <- matrix(0, l, k - 3) s <- matrix(0, k, 1) for (i in 1:l) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(refperp[i,] - TT[m,]) } phi[i,] <- diag(sqrt(TPS$prinwarpeval[1:(k - 3)])) %*% t(prinwarp[, 1:(k - 3)]) %*% s } phiTT <- matrix(0, k, k - 3) for (i in 1:k) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(TT[i,] - TT[m,]) } phiTT[i,] <- diag(sqrt(TPS$prinwarpeval[1:(k - 3)])) %*% t(prinwarp[, 1:(k - 3)]) %*% s } par(mfrow = c(nr, nc)) for (nw in 1:(k - 3)) { zgrid <- matrix(0, kx, kx) m <- 0 for (i in 1:kx) { for (j in 1:kx) { m <- m + 1 zgrid[i, j] <- phi[m, k - 2 - nw] } } zpersp <- persp(xgrid, ygrid, zgrid, axes = TRUE) # NB the following is an S-Plus function : use trans3d() in R # points(perspp(TT[, 1], TT[, 2], phiTT[, k - 2 - nw], zpersp), # cex = 2) } } #================================================================================== plotproc <- function(proc, xl, yl, width, joinline = c(1, 1)) { #provides plots of the full Procrustes rotated objects in proc #proc is an S object of the type output from the function procrustes2d #xl, yl lower xlimit and ylimit in plot #width = width (and height) of the square plotting region par(pty = "s") plot( proc$rotated[, , 1], xlim = c(xl, xl + width), ylim = c(yl, yl + width), type = "n", xlab = "", ylab = "" ) for (i in 1:proc$n) { points(proc$rotated[, , i]) lines(proc$rotated[joinline, , i]) } } #================================================================================== plotrelwarp <- function(mshape, rotsd, pcno, type, mag, xl, yl, width, joinline) { #provides PC plots: similar to plotpca but different argument #here rotsd is the rotation x s.d. , and can be from the usual # PCA or from using relative warps #pcno is a vector of the numbers (index) of PCs to be plotted #e.g. pcno<-c(1,2,4,7) will plot the four PCs no. 1,2,4,7 #type = type of display # "r" : rows along PCs evaluated at c = -3,-2,-1,0,1,2,3 sd's along PC # "v" : vectors drawn from mean to +/- 3 sd's along PC # "b" : vectors drawn as in `v' but using Bookstein shape variables # "s" : plots along c= -3, -2, -1, 0, 1, 2, 3 superimposed # "m" : movie backward and forwards from -3 to +3 sd's along PC # #mag = magnification of effect (1 = use s.d.'s from the data) #xl, yl lower xlimit and ylimit in plot #width = width (and height) of the square plotting region #joinline = vector of landmark numbers which are joined up in the plot by #straight lines: joinline = c(1,1) will give no lines # k <- nrow(mshape) pcarot <- rotsd par(pty = "s") par(lty = 1) meanxy <- c(mshape[, 1], mshape[, 2]) np <- length(pcno) if (type == "g") { par(mfrow = c(1, np)) for (i in 1:np) { j <- pcno[i] fig <- meanxy + pcarot[, j] * mag * 3 figx <- fig[1:k] figy <- fig[(k + 1):(2 * k)] YY <- cbind(figx, figy) tpsgrid(mshape, YY, xl, yl, width, 1, 0.1, 22) } } else { if (type == "r") { par(mfrow = c(np, 7)) for (i in 1:np) { j <- pcno[i] plotPDM(meanxy, pcarot[, j], mag, xl, xl + width, yl, yl + width, joinline) } } else { if (type == "v") { par(mfrow = c(1, np)) for (i in 1:np) { j <- pcno[i] plotPDM3(meanxy, pcarot[, j], mag, xl, xl + width, yl, yl + width, joinline) } } else { if (type == "b") { par(mfrow = c(1, np)) for (i in 1:np) { j <- pcno[i] plotPDMbook(meanxy, pcarot[, j], mag, xl, xl + width, yl, yl + width, joinline) } } else { if (type == "s") { par(mfrow = c(1, np)) for (i in 1:np) { j <- pcno[i] plotPDM2(meanxy, pcarot[, j], mag, xl, xl + width, yl, yl + width, joinline) } } else { if (type == "m") { par(mfrow = c(1, 1)) for (i in 1:np) { j <- pcno[i] movie(meanxy, pcarot[, j], mag, xl, xl + width, yl, yl + width, joinline, 20) } } } } } } } par(mfrow = c(1, 1)) } #================================================================================== ild_preshape <- function(x) { #input k x m matrix / complex k-vector #output k-1 x m matrix / k-1 x 1 complex matrix if (is.complex(x)) { k <- nrow(as.matrix(x)) h <- defh(k - 1) zstar <- x ztem <- h %*% zstar size <- sqrt(diag(Re(st(ztem) %*% ztem))) if (is.vector(zstar)) z <- ztem / size if (is.matrix(zstar)) z <- ztem %*% diag(1 / size) } else { if (length(dim(x)) == 3) { k <- dim(x)[1] h <- defh(k - 1) n <- dim(x)[3] m <- dim(x)[2] z <- array(0, c(k - 1, m, n)) for (i in 1:n) { z[, , i] <- h %*% x[, , i] size <- centroid.size(x[, , i]) z[, , i] <- z[, , i] / size } } else { k <- nrow(as.matrix(x)) h <- defh(k - 1) ztem <- h %*% x size <- centroid.size(x) z <- ztem / size } } z } #================================================================================== ild_preshape.mD <- function(x) { #input k x m matrix #output k-1 x 1 matrix h <- defh(nrow(x) - 1) ztem <- h %*% x size <- centroid.size.mD(x) z <- ztem / size z } #================================================================================== ild_preshape.mat <- function(zstar) { h <- defh(nrow(as.matrix(zstar)) - 1) ztem <- h %*% zstar size <- sqrt(diag(Re(st(ztem) %*% ztem))) if (is.vector(zstar)) z <- ztem / size if (is.matrix(zstar)) z <- ztem %*% diag(1 / size) z } #================================================================================== ild_preshapetoicon <- function(z) { #convert a preshape (real or complex) to an icon in configuration space h <- defh(nrow(z)) t(h) %*% z } # # # #prcomp1<-function(x, retx = TRUE) #{ # s <- svd(scale(x, scale = FALSE), nu = 0) # remove column means # rank <- sum(s$d > 0) # if(rank < ncol(x)) # s$v <- s$v[, 1:rank] # s$d <- s$d/sqrt(max(1, nrow(x) - 1)) # if(retx) # list(sdev = s$d, rotation = s$v, x = x %*% s$v) # else list(sdev = s$d, rotation = s$v) #} #================================================================================== prinwscoregrids <- function(TT, TPS, score, xbegin, ybegin, xwidth, nr, nc) { #grids displaying the effect of each principal warp at `score' #along each warp. Grids displayed in an nr x nc array par(pty = "s") par(mfrow = c(nr, nc)) k <- nrow(TT) xstart <- xbegin ystart <- ybegin kx <- 22 ky <- 21 l <- kx * ky step <- xwidth / (kx - 1) r <- 0 X <- rep(0, times = 220) Y2 <- rep(0, times = 220) for (p in 1:kx) { ystart <- ybegin xstart <- xstart + step for (q in 1:ky) { ystart <- ystart + step r <- r + 1 X[r] <- xstart Y2[r] <- ystart } } refc <- matrix(c(X, Y2), kx * ky, 2) # TPS <- bendingenergy(TT) for (jnw in 1:(k - 3)) { nw <- k - 2 - jnw phi <- matrix(0, l, 2) s <- matrix(0, k, 1) for (i in 1:l) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(refc[i,] - TT[m,]) } phi[i,] <- refc[i,] + sqrt(TPS$prinwarpeval[nw]) * score * t(TPS$prinwarps[, nw]) %*% s } newpt <- matrix(0, k, 2) for (i in 1:k) { s <- matrix(0, k, 1) for (m in 1:k) { s[m,] <- sigmacov(TT[i,] - TT[m,]) } newpt[i,] <- TT[i,] + sqrt(TPS$prinwarpeval[nw]) * score * t(TPS$prinwarps[, nw]) %*% s } order <- linegrid(phi, kx, ky) plot( order[1:l, 1], order[1:l, 2], type = "l", xlim = c(xbegin - xwidth / 10, xbegin + (xwidth * 11) / 10), ylim = c(ybegin - (xwidth / 10 * ky) / kx, ybegin + ((xwidth * 11) / 10 * ky) / kx), xlab = " ", ylab = " " ) lines(order[(l + 1):(2 * l), 1], order[(l + 1):(2 * l), 2], type = "l") points(newpt, cex = 2) } } #================================================================================== procdistreflect <- function(x, y) { #input k x m matrices x, y #output reflection shape distance (rho*) between them #if x, y are not too far apart then (rho*)=rho (Riemannian dist) if (sum((x - y) ^ 2) == 0) { riem <- 0 } if (sum((x - y) ^ 2) != 0) { m <- ncol(x) z <- preshape(x) w <- preshape(y) Q <- t(z) %*% w %*% t(w) %*% z ev <- sqrt(eigen(Q, symmetric = TRUE)$values) # riem <- acos(sum(ev)) riem <- acos(min(sum(ev), 1)) } riem } #================================================================================== procrustes2d <- function(x, l1 = 1, l2 = 2, approxtangent = FALSE, expomap = FALSE) { #input k x 2 x n real array, or k x n complex matrix #mean shape will have landmarks l1, l2 horizontal (l1 left, l2 right) # #output: # z$k : no of landmarks # z$m : no of dimensions (=2 here) # z$n : sample size # z$tan : the real 2k-2 x n matrix of partial Procrustes tangent coordinates # with pole given by the preshape of the full Procrustes mean # z$rotated : the k x m x n array of real full Procrustes rotated data # z$pcar : the columns are eigenvectors (PCs) of the sample covariance Sv of z$tan # z$pcasd : the square roots of eigenvalues of Sv (s.d.'s of PCs) # z$percent : the % of variability explained by the PCs # z$scores : PC scores normalised to have unit variance # z$rawscores : PC scores (unnormalised) # z$size : the centroid sizes of the configurations # z$rho : Kendall's Procrustean (Riemannian) distance rho to the mean shape # z$rmsrho : r.m.s. of rho # z$rmsd1 : r.m.s. of full Procrustes distances to the mean shape d1 # z <- list( k = 0, m = 0, n = 0, rotated = 0, tan = 0, pcar = 0, scores = 0, rawscores = 0, pcasd = 0, percent = 0, size = 0, rho = 0, rmsrho = 0, rmsd1 = 0, mshape = 0 ) if (is.complex(x) == FALSE) { x <- x[, 1,] + (1i) * x[, 2,] } # cat("Procrustes 2D eigenanalysis \n") k <- nrow(x) n <- ncol(x) h <- defh(k - 1) zp <- preshape(x) gamma <- cbevec(zp) cbmean <- t(h) %*% gamma theta <- Arg(cbmean[l2] - cbmean[l1]) cbmeanrot <- exp((-0 - 1i) * theta) * cbmean gamma <- h %*% cbmeanrot tan <- project(zp, gamma) icon <- array(0, c(k, 2, n)) tanapprox <- matrix(0, 2 * k, n) size <- rep(0, times = n) rho <- rep(0, times = n) mu <- complextoreal(cbmeanrot) sum <- 0 for (i in 1:n) { tem <- tanfigurefull(tan[, i], gamma) icon[, 1, i] <- Re(tem) icon[, 2, i] <- Im(tem) sum <- sum + icon[, , i] size[i] <- centroid.size(x[, i]) rho[i] <- riemdist(x[, i], c(cbmeanrot)) } xbar <- sum / n rv <- Vmat(tan) if (approxtangent == TRUE) { for (i in 1:n) { tanapprox[, i] <- as.vector(icon[, , i]) - as.vector(xbar) } tanapprox <- tanapprox / centroid.size(xbar) pca <- prcomp1(t(tanapprox)) z$tan <- tanapprox } if (expomap == TRUE) { temp <- rv for (i in 1:(n)) { temp[, i] <- rv[, i] / Enorm(rv[, i]) * rho[i] } rv <- temp } if (approxtangent == FALSE) { pca <- prcomp1(t(rv)) z$tan <- rv } z$pcar <- pca$rotation z$pcasd <- pca$sdev z$percent <- z$pcasd ^ 2 / sum(z$pcasd ^ 2) * 100 z$rotated <- icon npc <- 0 for (i in 1:length(pca$sdev)) { if (pca$sdev[i] > 1e-07) { npc <- npc + 1 } } z$scores <- pca$x z$rawscores <- pca$x for (i in 1:npc) { z$scores[, i] <- pca$x[, i] / pca$sdev[i] } z$rho <- rho z$size <- size z$mshape <- mu z$k <- k z$m <- 2 z$n <- n z$rmsrho <- sqrt(mean(rho ^ 2)) z$rmsd1 <- sqrt(mean(sin(rho) ^ 2)) return(z) } #================================================================================== testmeanshapes.old <- function(A, B, Hotelling = TRUE, tol1 = 1e05, tol2 = 1e05) { if (is.complex(A)) { tem <- array(0, c(nrow(A), 2, ncol(A))) tem[, 1,] <- Re(A) tem[, 2,] <- Im(A) A <- tem } if (is.complex(B)) { tem <- array(0, c(nrow(B), 2, ncol(B))) tem[, 1,] <- Re(B) tem[, 2,] <- Im(B) B <- tem } m <- dim(A)[2] if (Hotelling == TRUE) { if (m == 2) { test <- Hotelling2D(A, B) } if (m > 2) { test <- Hotellingtest(A, B, tol1 = tol1, tol2 = tol2) } cat( "Hotelling's T^2 test: ", c("Test statistic = ", round(test$F, 2)), c("\n p-value = ", round(test$pval, 4)), c("Degrees of freedom = ", test$df1, test$df2), "\n" ) } if (Hotelling == FALSE) { if (m == 2) { test <- Goodall2D(A, B) } if (m > 2) { test <- Goodalltest(A, B, tol1 = tol1, tol2 = tol2) } cat( "Goodall's F test: ", c("Test statistic = ", round(test$F, 2)), c("\n p-value = ", round(test$pval, 4)), c("Degrees of freedom = ", test$df1, test$df2), "\n" ) } test } #================================================================================== procGPA <- function(x, scale = TRUE, reflect = FALSE, eigen2d = FALSE, tol1 = 1e-05, tol2 = tol1, tangentcoords = "residual", proc.output = FALSE, distances = TRUE, pcaoutput = TRUE, alpha = 0, affine = FALSE) { # # n <- dim(x)[length(dim(x))] # if ((n > 100) & (distances == TRUE)) { # print("To speed up use option distances=FALSE") # } # if ((n > 100) & (pcaoutput == TRUE)) { # print("To speed up use option pcaoutput=FALSE") # } if (scale == TRUE) { if (tangentcoords == "residual") { tangentresiduals <- TRUE expomap <- FALSE } if (tangentcoords == "partial") { tangentresiduals <- FALSE expomap <- FALSE } if (tangentcoords == "expomap") { tangentresiduals <- FALSE expomap <- TRUE } } if (scale == FALSE) { #all three options are equivalent if (tangentcoords == "residual") { tangentresiduals <- TRUE expomap <- FALSE } if (tangentcoords == "partial") { tangentresiduals <- TRUE expomap <- FALSE } if (tangentcoords == "expomap") { tangentresiduals <- TRUE expomap <- FALSE } } approxtangent <- tangentresiduals if (is.complex(x)) { tem <- array(0, c(nrow(x), 2, ncol(x))) tem[, 1,] <- Re(x) tem[, 2,] <- Im(x) x <- tem } m <- dim(x)[2] n <- dim(x)[3] if (reflect == FALSE) { if ((m == 2) && (scale == TRUE)) { if (eigen2d == TRUE) { out <- procrustes2d(x, approxtangent = approxtangent, expomap = expomap) } else { out <- procrustesGPA( x, tol1, tol2, approxtangent = approxtangent, proc.output = proc.output, distances = distances, pcaoutput = pcaoutput, reflect = reflect, expomap = expomap ) } } if ((m > 2) && (scale == TRUE)) { out <- procrustesGPA( x, tol1, tol2, approxtangent = approxtangent, proc.output = proc.output , distances = distances, pcaoutput = pcaoutput, reflect = reflect, expomap = expomap ) } if (scale == FALSE) { out <- procrustesGPA.rot( x, tol1, tol2, approxtangent = approxtangent, proc.output = proc.output, distances = distances, pcaoutput = pcaoutput, reflect = reflect, expomap = expomap ) } } if (reflect == TRUE) { if (scale == TRUE) { out <- procrustesGPA( x, tol1, tol2, approxtangent = approxtangent, proc.output = proc.output, distances = distances, pcaoutput = pcaoutput, reflect = reflect, expomap = expomap ) } if (scale == FALSE) { out <- procrustesGPA.rot( x, tol1, tol2, approxtangent = approxtangent, proc.output = proc.output, distances = distances, pcaoutput = pcaoutput, reflect = reflect, expomap = expomap ) } } out$stdscores <- out$scores out$scores <- out$rawscores if (approxtangent == FALSE) { out$mshape <- out$mshape / centroid.size(out$mshape) for (i in 1:n) { out$rotated[, , i] <- out$rotated[, , i] / centroid.size(out$rotated[, , i]) } } rw <- out rw <- shaperw(out, alpha = alpha , affine = affine) rw$GSS <- sum((n - 1) * rw$pcasd ** 2) rw } #================================================================================== procrustesGPA <- function (x, tol1 = 1e-05, tol2 = 1e-05, distances = TRUE, pcaoutput = TRUE, approxtangent = TRUE, proc.output = FALSE, reflect = FALSE, expomap = FALSE) { z <- list( k = 0, m = 0, n = 0, rotated = 0, tan = 0, pcar = 0, scores = 0, rawscores = 0, pcasd = 0, percent = 0, size = 0, rho = 0, rmsrho = 0, rmsd1 = 0, mshape = 0 ) if (is.complex(x)) { tem <- array(0, c(nrow(x), 2, ncol(x))) tem[, 1,] <- Re(x) tem[, 2,] <- Im(x) x <- tem } k <- dim(x)[1] m <- dim(x)[2] n <- dim(x)[3] x <- cnt3(x) zgpa <- fgpa(x, tol1, tol2, proc.output = proc.output, reflect = reflect) if (distances == TRUE) { if (proc.output) { cat("Shape distances and sizes calculation ...\n") } size <- rep(0, times = n) rho <- rep(0, times = n) size <- apply(x, 3, centroid.size) rho <- apply(x, 3, y <- function(x) { riemdist(x, zgpa$mshape) }) } tanpartial <- matrix(0, k * m - m , n) ident <- diag(rep(1, times = (m * k - m))) gamma <- as.vector(preshape(zgpa$mshape)) for (i in 1:n) { tanpartial[, i] <- (ident - gamma %*% t(gamma)) %*% as.vector(preshape(zgpa$r.s.r[, , i])) } if (expomap == TRUE) { temp <- tanpartial for (i in 1:(n)) { temp[, i] <- tanpartial[, i] / Enorm(tanpartial[, i]) * rho[i] } tanpartial <- temp } tan <- zgpa$r.s.r[, 1,] - zgpa$mshape[, 1] for (i in 2:m) { tan <- rbind(tan, zgpa$r.s.r[, i,] - zgpa$mshape[, i]) } if (pcaoutput == TRUE) { if (proc.output) { cat("PCA calculation ...\n") } if (approxtangent == FALSE) { pca <- prcomp1(t(tanpartial)) } if (approxtangent == TRUE) { pca <- prcomp1(t(tan)) } npc <- 0 for (i in 1:length(pca$sdev)) { if (pca$sdev[i] > 1e-07) { npc <- npc + 1 } } z$scores <- pca$x z$rawscores <- pca$x for (i in 1:npc) { z$scores[, i] <- pca$x[, i] / pca$sdev[i] } z$pcar <- pca$rotation z$pcasd <- pca$sdev z$percent <- z$pcasd ^ 2 / sum(z$pcasd ^ 2) * 100 } if (approxtangent == FALSE) { z$tan <- tanpartial } if (approxtangent == TRUE) { z$tan <- tan } if (distances == TRUE) { z$rho <- rho z$size <- size z$rmsrho <- sqrt(mean(rho ^ 2)) z$rmsd1 <- sqrt(mean(sin(rho) ^ 2)) } z$rotated <- zgpa$r.s.r z$mshape <- zgpa$mshape z$k <- k z$m <- m z$n <- n if (proc.output) { cat("Finished.\n") } return(z) } #================================================================================== procrustesGPA.rot <- function (x, tol1 = 1e-05, tol2 = 1e-05, distances = TRUE, pcaoutput = TRUE, approxtangent = TRUE, proc.output = FALSE, reflect = FALSE, expomap = FALSE) { z <- list( k = 0, m = 0, n = 0, rotated = 0, tan = 0, pcar = 0, scores = 0, rawscores = 0, pcasd = 0, percent = 0, size = 0, rho = 0, rmsrho = 0, rmsd1 = 0, mshape = 0 ) if (is.complex(x)) { tem <- array(0, c(nrow(x), 2, ncol(x))) tem[, 1,] <- Re(x) tem[, 2,] <- Im(x) x <- tem } k <- dim(x)[1] m <- dim(x)[2] n <- dim(x)[3] # print("GPA (rotation only)") x <- cnt3(x) zgpa <- fgpa.rot(x, tol1, tol2, proc.output = proc.output, reflect = reflect) if (distances == TRUE) { if (proc.output) { cat("Shape distances and sizes calculation ...\n") } size <- rep(0, times = n) rho <- rep(0, times = n) size <- apply(x, 3, centroid.size) rho <- apply(x, 3, y <- function(x) { riemdist(x, zgpa$mshape) }) } tanpartial <- matrix(0, k * m - m, n) ident <- diag(rep(1, times = (m * k - m))) gamma <- as.vector(preshape(zgpa$mshape)) for (i in 1:n) { tanpartial[, i] <- (ident - gamma %*% t(gamma)) %*% as.vector(preshape(zgpa$r.s.r[, , i])) } if (expomap == TRUE) { temp <- tanpartial for (i in 1:(n)) { temp[, i] <- tanpartial[, i] / Enorm(tanpartial[, i]) * rho[i] } tanpartial <- temp } tan <- zgpa$r.s.r[, 1,] - zgpa$mshape[, 1] for (i in 2:m) { tan <- rbind(tan, zgpa$r.s.r[, i,] - zgpa$mshape[, i]) } if (approxtangent == FALSE) { z$tan <- tanpartial } if (approxtangent == TRUE) { z$tan <- tan } if (pcaoutput == TRUE) { if (proc.output) { cat("PCA calculation ...\n") } if (approxtangent == FALSE) { pca <- prcomp1(t(tanpartial)) } if (approxtangent == TRUE) { pca <- prcomp1(t(tan)) } npc <- 0 for (i in 1:length(pca$sdev)) { if (pca$sdev[i] > 1e-07) { npc <- npc + 1 } } z$scores <- pca$x z$rawscores <- pca$x for (i in 1:npc) { z$scores[, i] <- pca$x[, i] / pca$sdev[i] } z$pcar <- pca$rotation z$pcasd <- pca$sdev z$percent <- z$pcasd ^ 2 / sum(z$pcasd ^ 2) * 100 } if (distances == TRUE) { z$rho <- rho z$size <- size z$rmsrho <- sqrt(mean(rho ^ 2)) z$rmsd1 <- sqrt(mean(sin(rho) ^ 2)) } z$rotated <- zgpa$r.s.r z$mshape <- zgpa$mshape z$k <- k z$m <- m z$n <- n if (proc.output) { cat("Finished.\n") } return(z) } #================================================================================== project <- function(z, gamma) { #input z: preshape, gamma: preshape (k-1 x 1 matrices) #output Kent's tangent plane coordinates #of z at the pole gamma (k-1 complex vector) nr <- nrow(z) nc <- ncol(z) g <- matrix(gamma, nr, 1) ident <- diag(nr) theta <- diag(c(exp((-0 - 1i) * Arg(st( g ) %*% z))), nc, nc) v <- (ident - g %*% st(g)) %*% z %*% theta v } #================================================================================== read.array <- function(name, k, m, n) { #input name : filename, k: no of points, m: no of dimensions, n: sample size #output x: k x m x n array of data #e.g. for 2D data assume file format x1 y1 x2 y2 .. xn yn for each object tem <- scan(name) tem <- array(tem, c(m, k, n)) tem <- aperm(tem, c(2, 1, 3)) x <- tem x } #================================================================================== read.in <- function(name, k, m) { #input name : filename, k: no of points, m: no of dimensions #output x: k x m x n array of data ( n: sample size) #e.g. for m=2-D data assume file format x1 y1 x2 y2 ... xk yk for each object #for m=3-D data: x1 y1 z1 x2 y2 z2 ... xk yk zk tem <- scan(name) n <- length(tem) / (k * m) tem <- array(tem, c(m, k, n)) tem <- aperm(tem, c(2, 1, 3)) x <- tem x } #================================================================================== realtocomplex <- function(x) { #input k x 2 matrix - return complex k-vector k <- nrow(x) zstar <- x[, 1] + (1i) * x[, 2] zstar } #================================================================================== reassqpr <- function(z) { j <- 1 nc <- ncol(z) nr <- nrow(z) stemp <- matrix(0, 2 * nr, 2 * nr) repeat { t1 <- matrix(z[, j], nr, 1) vz <- rbind(Re(t1), Im(t1)) viz <- rbind(Re((1i) * t1), Im((1i) * t1)) stemp <- stemp + vz %*% t(vz) + viz %*% t(viz) if (j == nc) break j <- j + 1 } stemp } #================================================================================== relwarps <- function(mshape, rotated, alpha) { #find the relative warps for a dataset with mshape as the reference #and `rotated' as the array of Procrustes rotated figures #alpha is the power of the bending energy # alpha=+1 : emphasizes large scale # alpha=-1 : emphasizes small scale #output: # z$rwarps : the relative warps # z$rwscores : the relative warp scores # z$rwpercent : the percentage of total variability explained by each #relative warp z <- list( rwarps = 0, rwscores = 0, rwpercent = 0, ev = 0, unif = 0, unscores = 0, lengths = 0 ) k <- nrow(mshape) TPS <- bendingenergy(mshape) Be <- TPS$gamma11 stackxy <- rbind(rotated[, 1,], rotated[, 2,]) n <- dim(rotated)[3] msum <- rep(0, times = 2 * k) for (i in 1:n) { msum <- msum + stackxy[, i] } msum <- msum / n meanxy <- msum cstackxy <- matrix(0, 2 * k, n) for (i in 1:n) { cstackxy[, i] <- stackxy[, i] - meanxy } Bpow <- genpower(Be, alpha) Bpowinv <- genpower(Be,-alpha) IBpow <- I2mat(Bpow) IBpowinv <- I2mat(Bpowinv) if (alpha == 0) { IBpow <- diag(rep(1, times = (2 * k))) IBpowinv <- diag(rep(1, times = (2 * k))) } stacknew <- IBpow %*% cstackxy gamma <- matrix(0, 2 * k, 2 * k) pcarotation <- eigen(stacknew %*% t(stacknew) / n, symmetric = TRUE)$vectors pcaev <- eigen(stacknew %*% t(stacknew) / n, symmetric = TRUE)$values pcasdev <- rep(0, times = 2 * k) for (i in 1:(2 * k)) { pcasdev[i] <- sqrt(abs(pcaev[i])) } scores <- t(IBpow %*% pcarotation) %*% cstackxy percent <- rep(0, times = 2 * k) for (i in 1:(2 * k)) { percent[i] <- pcasdev[i] ^ 2 } Un <- TPS$Un UnXY <- t(Un) %*% cstackxy z$unif <- Un %*% t(matrix(c(sqrt(var( UnXY[1,] )), 0, 0, sqrt(var( UnXY[2,] ))), 2, 2)) z$unscores <- t(UnXY) z$lengths <- sqrt(abs(percent)) z$rwarps <- IBpowinv %*% pcarotation %*% diag(pcasdev) z$rwscores <- t(scores) z$ev <- pcaev percentrw <- percent / sum(percent) * 100 z$rwpercent <- percentrw return(z) } #================================================================================== ssriemdist <- function(x, y, reflect = FALSE) { sx <- centroid.size(x) sy <- centroid.size(y) sd <- sx ** 2 + sy ** 2 - 2 * sx * sy * cos(riemdist(x, y, reflect = reflect)) sqrt(abs(sd)) } #================================================================================== riemdist <- function(x, y, reflect = FALSE) { #input two k x m matrices x, y or complex k-vectors #output Riemannian distance rho between them if (sum((x - y) ** 2) == 0) { riem <- 0 } if (sum((x - y) ** 2) != 0) { if (reflect == FALSE) { if (ncol(as.matrix(x)) < 3) { if (is.complex(x) == FALSE) { x <- realtocomplex(x) } if (is.complex(y) == FALSE) { y <- realtocomplex(y) } #riem <- c(acos(Mod(st(preshape(x)) %*% preshape(y)))) riem <- c(acos(min(1, ( Mod(st(preshape(x)) %*% preshape(y)) )))) } else { m <- ncol(x) z <- preshape(x) w <- preshape(y) Q <- t(z) %*% w %*% t(w) %*% z ev <- eigen(t(z) %*% w)$values check <- 1 for (i in 1:m) { check <- check * ev[i] } ev <- sqrt(abs(eigen(Q, symmetric = TRUE)$values)) if (Re(check) < 0) ev[m] <- -ev[m] riem <- acos(min(sum(ev), 1)) } } if (reflect == TRUE) { m <- ncol(x) z <- preshape(x) w <- preshape(y) Q <- t(z) %*% w %*% t(w) %*% z ev <- sqrt(abs(eigen(Q, symmetric = TRUE)$values)) riem <- acos(min(sum(ev), 1)) } } riem } #================================================================================== riemdist.complex <- function(z, w) { #input complex k-vectors z, w #output Riemannian distance rho between them c(acos(min(Mod( st(preshape(z)) %*% preshape(w) ), 1))) } #================================================================================== riemdist.mD <- function(x, y) { #input k x m matrices x, y #output Riemannian distance rho between them m <- ncol(x) z <- preshape.mD(x) w <- preshape.mD(y) Q <- t(z) %*% w %*% t(w) %*% z ev <- eigen(t(z) %*% w)$values check <- 1 for (i in 1:m) { check <- check * ev[i] } ev <- sqrt(eigen(Q, symmetric = TRUE)$values) if (check < 0) ev[m] <- -ev[m] riem <- acos(min(sum(ev), 1)) riem } #================================================================================== rotateaxes <- function(mshapein, rotatedin) { #Rotates a mean shape and the Procrustes rotated data to have #horizontal and vertical principal axes #output: z$mshape rotated mean shape # z$rotated rotated procrustes registered data # z$R the rotation matrix # z <- list(mshape = 0, rotated = 0, R = 0) n <- dim(rotatedin)[3] S <- var(mshapein) R <- eigen(S)$vectors msh <- mshapein %*% R ico <- rotatedin for (i in 1:n) { ico[, , i] <- rotatedin[, , i] %*% R } z$mshape <- msh z$rotated <- ico z$R <- R return(z) } #sigma<-function(x) #{ # length <- sqrt(x[1]^2 + x[2]^2) # if(length == 0) # sig <- 0 # else sig <- length^2 * log(length^2) # sig #} #================================================================================== sigmacov <- function(x) { # other radial basis functions/covariance functions are possible of course hh <- Enorm(x) if (hh == 0) sig <- 0 else { if (length(x) == 2) { sig <- hh ^ 2 * log(hh ^ 2) # null space includes affine terms (2D data) } if (length(x) == 3) { sig <- -hh # null space includes affine terms (3D data) } } sig } #================================================================================== st <- function(zstar) { #input complex matrix #output transpose of the complex conjugate st <- t(Conj(zstar)) st } #================================================================================== ild_tanfigure <- function(vv, gamma) { #inverse projection from complex tangent plane coordinates vv, using pole gamma #output centred icon k <- nrow(gamma) + 1 h <- defh(k - 1) zvv <- tanpreshape(vv, gamma) zstvv <- t(h) %*% zvv zstvv } #================================================================================== ild_tanfigurefull <- function(vv, gamma) { #inverse projection from complex tangent plane coordinates vv, using pole gamma #using Procrustes to with scaling to the pole gamma #output centred icon k <- nrow(gamma) + 1 f1 <- tanfigure(vv, gamma) h <- defh(k - 1) f2 <- t(h) %*% gamma beta <- Mod(st(f1) %*% f2) f1 <- f1 * c(beta) f1 } #================================================================================== tanpreshape <- function(vv, gamma) { #inverse projection from tangent plane coordinates vv, using pole gamma #output preshape z <- c((1 - st(vv) %*% vv) ^ 0.5) * gamma + vv z } #================================================================================== plot3Ddata <- function(dna.data, land = 1:k, objects = 1:n, joinline = c(1, 1)) { dna <- procGPA(dna.data[, , 1:2]) w1 <- defplotsize2(dna.data[, 1:2, ]) w2 <- defplotsize2(dna.data[, c(1, 3), ]) w3 <- defplotsize2(dna.data[, c(2, 3), ]) width <- max(c(w1$width, w2$width, w3$width)) xl <- min(c(w1$xl, w2$xl, w3$xl)) xu <- xl + width yl <- min(c(w1$yl, w2$yl, w3$yl)) yu <- yl + width n <- dim(dna.data)[3] k <- dim(dna.data)[1] m <- dim(dna.data)[2] par(mfrow = c(1, 1)) par(pty = "s") view1 <- 1 view2 <- 2 view3 <- 3 lineorder <- joinline for (j in 1:1) { for (ii in objects) { par(mfrow = c(2, 2)) mag <- 0 pcno <- 1 plotPDMnoaxis3( c(dna.data[land, view2, ii], dna.data[land, view3, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) mag <- 0 pcno <- 1 plotPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view3, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) mag <- 0 pcno <- 1 plotPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view2, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) plot( c(0, 0), c(50, 50), xlim = c(0, 0), ylim = c(0, 0), type = "n", xlab = " ", ylab = " ", axes = FALSE ) title(as.character(ii)) } } } #================================================================================== plot3Ddata.static <- function(dna.data, land = 1:k, objects = 1:n, joinline = c(1, 1)) { dna <- procGPA(dna.data[, , 1:2]) w1 <- defplotsize2(dna.data[, 1:2, ]) w2 <- defplotsize2(dna.data[, c(1, 3), ]) w3 <- defplotsize2(dna.data[, c(2, 3), ]) width <- max(c(w1$width, w2$width, w3$width)) xl <- min(c(w1$xl, w2$xl, w3$xl)) xu <- xl + width yl <- min(c(w1$yl, w2$yl, w3$yl)) yu <- yl + width n <- dim(dna.data)[3] k <- dim(dna.data)[1] m <- dim(dna.data)[2] par(mfrow = c(1, 1)) par(pty = "s") lineorder <- joinline par(mfrow = c(2, 2)) mag <- 0 pcno <- 1 ii <- 1 view1 <- 1 view2 <- 2 view3 <- 3 plotPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view2, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) for (ii in objects) { pointsPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view2, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } view1 <- 1 view2 <- 3 view3 <- 2 plotPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view2, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) for (ii in objects) { pointsPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view2, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } view1 <- 2 view2 <- 3 view3 <- 1 plotPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view2, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) for (ii in objects) { pointsPDMnoaxis3( c(dna.data[land, view1, ii], dna.data[land, view2, ii]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } } #================================================================================== plot3Dmean <- function(dna) { land <- 1:dim(dna$mshape)[1] w1 <- defplotsize2(dna$rotated[, 1:2, ]) w2 <- defplotsize2(dna$rotated[, c(1, 3), ]) w3 <- defplotsize2(dna$rotated[, c(2, 3), ]) width <- max(c(w1$width, w2$width, w3$width)) xl <- min(c(w1$xl, w2$xl, w3$xl)) xu <- xl + width yl <- min(c(w1$yl, w2$yl, w3$yl)) yu <- yl + width par(mfrow = c(2, 2)) par(pty = "s") plot( dna$mshape[land, 1], dna$mshape[land, 2], xlim = c(xl, xu), ylim = c(yl, yu), xlab = " ", ylab = " " ) text(dna$mshape[land, 1], dna$mshape[land, 2], land) lines(dna$mshape[land, 1], dna$mshape[land, 2]) plot( dna$mshape[land, 1], dna$mshape[land, 3], xlim = c(xl, xu), ylim = c(yl, yu), xlab = " ", ylab = " " ) text(dna$mshape[land, 1], dna$mshape[land, 3], land) lines(dna$mshape[land, 1], dna$mshape[land, 3]) plot( dna$mshape[land, 2], dna$mshape[land, 3], xlim = c(xl, xu), ylim = c(yl, yu), xlab = " ", ylab = " " ) text(dna$mshape[land, 2], dna$mshape[land, 3], land) lines(dna$mshape[land, 2], dna$mshape[land, 3]) title("Procrustes mean shape estimate") } #================================================================================== plot3Dpca <- function(dna, pcno, joinline = c(1, 1)) { #choose subset w1 <- defplotsize2(dna$rotated[, 1:2, ]) w2 <- defplotsize2(dna$rotated[, c(1, 3), ]) w3 <- defplotsize2(dna$rotated[, c(2, 3), ]) width <- max(c(w1$width, w2$width, w3$width)) xl <- min(c(w1$xl, w2$xl, w3$xl)) - width / 4 xu <- xl + width * 1.5 yl <- min(c(w1$yl, w2$yl, w3$yl)) - width / 4 yu <- yl + width * 1.5 k <- dim(dna$mshape)[1] lineorder <- joinline par(mfrow = c(1, 1)) cat("X-Y view \n") view1 <- 1 view2 <- 2 view3 <- 3 land <- c(1:k) for (j in 1:10) { for (ii in-12:12) { mag <- ii / 4 plotPDMnoaxis3( c(dna$mshape[land, view1], dna$mshape[land, view2]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } for (ii in-11:11) { mag <- -ii / 4 plotPDMnoaxis3( c(dna$mshape[land, view1], dna$mshape[land, view2]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } } #choose subset par(mfrow = c(1, 1)) cat("X-Z view \n") view1 <- 1 view2 <- 3 view3 <- 2 land <- c(1:k) for (j in 1:10) { for (ii in-12:12) { mag <- ii / 4 plotPDMnoaxis3( c(dna$mshape[land, view1], dna$mshape[land, view2]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } for (ii in-11:11) { mag <- -ii / 4 plotPDMnoaxis3( c(dna$mshape[land, view1], dna$mshape[land, view2]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } } #choose subset par(mfrow = c(1, 1)) cat("Y-Z view \n") view1 <- 2 view2 <- 3 view3 <- 1 land <- c(1:k) for (j in 1:10) { for (ii in-12:12) { mag <- ii / 4 plotPDMnoaxis3( c(dna$mshape[land, view1], dna$mshape[land, view2]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } for (ii in-11:11) { mag <- -ii / 4 plotPDMnoaxis3( c(dna$mshape[land, view1], dna$mshape[land, view2]), c(dna$pcar[((view1 - 1) * k + (land)), pcno], dna$pcar[((view2 - 1) * k + (land)), pcno]), mag * dna$pcasd[pcno], xl, xu, yl, yu, lineorder, 1 ) } } } #================================================================================== banner1 <- function(char) { par(mfrow = c(1, 1)) plot( c(0, 0), c(1, 1), axes = FALSE, type = "n", xlab = " ", ylab = " " ) a1 <- char if (length(a1) == 2) a1 <- paste(a1[1], a1[2]) if (length(a1) == 3) a1 <- paste(a1[1], a1[2], a1[3]) if (is.character(a1) == FALSE) char <- as.character(a1) title(a1) } #================================================================================== banner4 <- function(a1, a2, a3, a4) { par(mfrow = c(2, 2)) plot( c(0, 0), c(1, 1), axes = FALSE, type = "n", xlab = " ", ylab = " " ) if (length(a1) == 2) a1 <- paste(a1[1], a1[2]) if (length(a1) == 3) a1 <- paste(a1[1], a1[2], a1[3]) if (is.character(a1) == FALSE) a1 <- as.character(a1) title(a1) plot( c(0, 0), c(1, 1), axes = FALSE, type = "n", xlab = " ", ylab = " " ) if (length(a2) == 2) a2 <- paste(a2[1], a2[2]) if (length(a2) == 3) a2 <- paste(a2[1], a2[2], a2[3]) if (is.character(a2) == FALSE) a2 <- as.character(a2) title(a2) plot( c(0, 0), c(1, 1), axes = FALSE, type = "n", xlab = " ", ylab = " " ) if (length(a3) == 2) a3 <- paste(a3[1], a3[2]) if (length(a3) == 3) a3 <- paste(a3[1], a3[2], a3[3]) if (is.character(a3) == FALSE) a3 <- as.character(a3) title(a3) plot( c(0, 0), c(1, 1), axes = FALSE, type = "n", xlab = " ", ylab = " " ) if (length(a4) == 2) a4 <- paste(a4[1], a4[2]) if (length(a4) == 3) a4 <- paste(a4[1], a4[2], a4[3]) if (is.character(a4) == FALSE) a4 <- as.character(a4) title(a4) } ####### #exact Gaussian MLE - isotropic distribution #######not fully tested yet #================================================================================== isomle <- function(x) { if (is.complex(x)) { tem <- array(0, c(nrow(x), 2, ncol(x))) tem[, 1,] <- Re(x) tem[, 2,] <- Im(x) x <- tem } k <- dim(x)[1] m <- dim(x)[2] n <- dim(x)[3] if (m > 2) { print("Only valid for 2D data") } if (m == 2) { pm <- rep(0, times = 2 * k - 3) tem <- procrustes2d(x) tem1 <- bookstein.shpv(tem$mshape) sigm <- sum(diag(var(tem$tan))) / (n - 1) / 2 #cat("Isotropic shape MLE \n") pm[1:(k - 2)] <- tem1[3:k, 1] pm[(k - 1):(2 * k - 4)] <- tem1[3:k, 2] pm[2 * k - 3] <- 10 ans <- nlm(objfuniso, hessian = TRUE, pm, uu = x) #while (ans$code!=1){ #print("code not equal 1") #print(pm) #pm<-pm+rnorm(2*k-3,0,0.1) #pm[2*k-3]<-abs(pm[2*k-3]) #ans<-nlm(objfuniso,hessian=TRUE,pm,uu=x) #print(ans) #} out <- list( code = 0, mshape = 0, tau = 0, kappa = 0, varcov = 0, gradient = 0 ) mn <- matrix(0, k, 2) mn[1, 1] <- -0.5 mn[2, 1] <- 0.5 mn[3:k, 1] <- ans$estimate[1:(k - 2)] mn[3:k, 2] <- ans$estimate[(k - 1):(2 * k - 4)] out$mshape <- mn out$code <- ans$code out$loglike <- -ans$minimum out$gradient <- ans$gradient out$tau <- sqrt(1 / ans$estimate[2 * k - 3] ** 2) out$kappa <- centroid.size(mn) ** 2 / (4 * out$tau ** 2) out$varcov <- solve(ans$hessian) out$se <- c(sqrt(diag(out$varcov))) out$se[2 * k - 3] <- out$se[2 * k - 3] * out$tau ** 2 out } } #================================================================================== objfuniso <- function(pm, uu) { k <- dim(uu)[1] h <- defh(k - 1) zero <- matrix(0, k - 1, k) L1 <- cbind(h, zero) L2 <- cbind(zero, h) L <- rbind(L1, L2) mustar <- c(-1 / 2, 1 / 2, pm[1:(k - 2)], 0, 0, pm[(k - 1):(2 * k - 4)]) mu <- L %*% mustar obj <- -loglikeiso2(uu, mu, 1 / pm[2 * k - 3]) obj } #================================================================================== loglikeiso <- function(uu, mu, s) { nsam <- dim(uu)[3] sum <- 0 for (i in 1:nsam) { sum <- sum + log(isodens(uu[, , i], mu, s)) } sum } #================================================================================== loglikeiso2 <- function(uu, mu, s) { nsam <- dim(uu)[3] sum <- 0 for (i in 1:nsam) { sum <- sum + isologdens(uu[, , i], mu, s) } sum } #================================================================================== isodens <- function(usam, mu, s) { k <- dim(usam)[1] u <- kendall.shpv(usam) uuu <- u[, 1] vvv <- u[, 2] up <- c(1, uuu, 0, vvv) vp <- c(0, -vvv, 1, uuu) usu <- t(up) %*% up beta <- c(t(mu) %*% up, t(mu) %*% vp) sin2rho <- 1 - t(beta) %*% beta / (usu * c(t(mu) %*% mu)) kappa <- c(t(mu) %*% mu) / (4 * s ** 2) #finf<-gamma(k-1)*pi/(pi*usu)**(k-1) dens <- oneFone(k - 2, 2 * kappa * (1 - sin2rho)) %*% exp(-2 * kappa * sin2rho) dens } #================================================================================== isologdens <- function(usam, mu, s) { k <- dim(usam)[1] u <- kendall.shpv(usam) uuu <- u[, 1] vvv <- u[, 2] up <- c(1, uuu, 0, vvv) vp <- c(0, -vvv, 1, uuu) usu <- t(up) %*% up beta <- c(t(mu) %*% up, t(mu) %*% vp) sin2rho <- 1 - t(beta) %*% beta / (usu * c(t(mu) %*% mu)) kappa <- c(t(mu) %*% mu) / (4 * s ** 2) #finf<-lgamma(k-1)+log(pi)-(k-1)*log(pi*usu) dens <- loneFone(k - 2, 2 * kappa * (1 - sin2rho)) - 2 * kappa * sin2rho c(dens) } #================================================================================== loneFone <- function(r, x) { #note this is log 1F1(-r,1,-x) if (x > 1) { sum1 <- r * log(x) sum <- 0 for (j in 0:r) { sum <- sum + choose(r, j) * x ** (j - r) / gamma(j + 1) } out <- sum1 + log(sum) } if (x <= 1) { sum <- 0 for (j in 0:r) { sum <- sum + choose(r, j) * x ** (j) / gamma(j + 1) } out <- log(sum) } out } #================================================================================== ild_kendall.shpv <- function(x) { k <- dim(x)[1] h <- defh(k - 1) zz <- h %*% x kendall <- (zz[2:(k - 1), 1] + 1i * zz[2:(k - 1), 2]) / (zz[1, 1] + 1i * zz[1, 2]) kendall <- cbind(Re(kendall), Im(kendall)) kendall } #================================================================================== oneFone <- function(r, x) { #note this is 1F1(-r,1,-x) sum <- 0 for (j in 0:r) { sum <- sum + choose(r, j) * x ** j / gamma(j + 1) } sum } #================================================================================== permutationtest <- function(A, B, nperms = 200) { A1 <- A A2 <- B B <- nperms nsam1 <- dim(A1)[3] nsam2 <- dim(A2)[3] Gtem <- Goodalltest(A1, A2) Htem <- Hotellingtest(A1, A2) Gumc <- Gtem$F Humc <- Htem$F Gtabpval <- Gtem$pval Htabpval <- Htem$pval if (B > 0) { Apool <- array(0, c(dim(A1)[1], dim(A1)[2], dim(A1)[3] + dim(A2)[3])) Apool[, , 1:nsam1] <- A1 Apool[, , (nsam1 + 1):(nsam1 + nsam2)] <- A2 out <- list( H = 0, H.pvalue = 0, H.table.pvalue = 0, G = 0, G.pvalue = 0, G.table.pvalue = 0 ) Gu <- rep(0, times = B) Hu <- rep(0, times = B) cat("Permutations - sampling without replacement: ") cat(c("No of permutations = ", B, "\n")) for (i in 1:B) { cat(c(i, " ")) select <- sample(1:(nsam1 + nsam2)) Gu[i] <- Goodalltest(Apool[, , select[1:nsam1]] , Apool[, , select[(nsam1 + 1):(nsam2 + nsam1)]])$F Hu[i] <- Hotellingtest(Apool[, , select[1:nsam1]], Apool[, , select[(nsam1 + 1):(nsam1 + nsam2)]])$F } Gu <- sort(Gu) numbig <- length(Gu[Gumc < Gu]) pvalG <- (1 + numbig) / (B + 1) Hu <- sort(Hu) numbig <- length(Hu[Humc < Hu]) pvalH <- (1 + numbig) / (B + 1) cat(" \n") out$H <- Humc out$H.pvalue <- pvalH out$H.table.pvalue <- Htabpval out$G <- Gumc out$G.pvalue <- pvalG out$G.table.pvalue <- Gtabpval } if (B == 0) { out <- list( H = 0, H.table.pvalue = 0, G = 0, G.table.pvalue = 0 ) out$H <- Humc out$H.table.pvalue <- Htabpval out$G <- Gumc out$G.table.pvalue <- Gtabpval } out } #================================================================================== permutationtest <- permutationtest2 #================================================================================== frechet <- function(x, mean = "intrinsic") { if (mean == "intrinsic") { option <- 1 } if (mean == "partial.procrustes") { option <- 2 } if (mean == "full.procrustes") { option <- 3 } if (mean == "mle") { option <- 4 } if (is.double(mean)) { if (mean > 0) { option <- -mean } } n <- dim(x)[3] for (i in 1:n) { x[, , i] <- x[, , i] / centroid.size(x[, , i]) } if (option < 4) { pm <- procGPA(x, scale = FALSE, tol1 = 10 ^ (-8))$mshape m <- dim(x)[2] k <- dim(x)[1] ans <- list( mshape = 0, var = 0, code = 0, gradient = 0 ) out <- nlm( objfun, hessian = TRUE, c(pm), uu = x, option = option, iterlim = 1000 ) B <- matrix(out$estimate, k, m) ans$mshape <- procOPA(pm, B)$Bhat ans$var <- out$minimum ans$code <- out$code ans$gradient <- out$gradient } if (option == 4) { pm <- procGPA(x, scale = FALSE, tol1 = 10 ^ (-8))$mshape m <- dim(x)[2] k <- dim(x)[1] if (m == 2) { theta <- c(log(centroid.size(pm) ** 2 / (4 * 0.1 ** 2)), pm) ans <- list( mshape = 0, kappa = 0, code = 0, gradient = 0 ) out <- nlm( objfun4, hessian = TRUE, theta, uu = x, iterlim = 1000 ) B <- matrix(out$estimate[-1], k, m) ans$mshape <- procOPA(pm, B)$Bhat ans$kappa <- exp(out$estimate[1]) ans$loglike <- -out$minimum ans$code <- out$code ans$gradient <- out$gradient } if (m != 2) { print("MLE is only appropriate for planar shapes") } } ans } #================================================================================== objfun <- function(pm, uu, option) { m <- dim(uu)[2] k <- dim(uu)[1] pm <- matrix(pm, k, m) sum <- 0 for (i in 1:dim(uu)[3]) { if (option == 1) { sum <- sum + (riemdist(pm, uu[, , i])) ** 2 } if (option == 2) { sum <- sum + 4 * sin(riemdist(pm, uu[, , i]) / 2) ** 2 } if (option == 3) { sum <- sum + sin(riemdist(pm, uu[, , i])) ** 2 } if (option < 0) { h <- -option sum <- sum + ((1 - cos(riemdist(pm, uu[, , i])) ** (2 * h)) / h) } } sum } #================================================================================== objfun4 <- function(pm, uu) { m <- dim(uu)[2] k <- dim(uu)[1] n <- dim(uu)[3] kappa <- exp(pm[1]) pm <- matrix(pm[-1], k, m) sum <- 0 for (i in 1:n) { sin2rho <- sin(riemdist(pm, uu[, , i])) ** 2 sum <- sum + loneFone(k - 2, 2 * kappa * (1 - sin2rho)) - 2 * kappa * sin2rho } - sum } #================================================================================== MDSshape <- function(x, alpha = 1, projalpha = 1 / 2) { mu <- procGPA(x)$mshape k <- dim(x)[1] n <- dim(x)[3] m <- dim(x)[2] H <- defh(k - 1) sum <- matrix(0, k - 1, k - 1) for (i in 1:n) { Z <- preshape(x[, , i]) if (alpha == 1) { sum <- sum + (Z) %*% t((Z)) } if (alpha == 1 / 2) { ee <- eigen((Z) %*% t((Z)), symmetric = TRUE) sum <- sum + ee$vectors %*% diag(sqrt(abs(ee$values))) %*% t(ee$vectors) } } eig <- eigen(sum / n, symmetric = TRUE) lam <- eig$values if (m == 2) { if (projalpha == 1 / 2) { meanshape <- cbind( t(H) %*% (sqrt(lam[1]) * eig$vectors[, 1]) / sqrt(lam[1] + lam[2]) , -t(H) %*% (sqrt(lam[2]) * eig$vectors[, 2]) / sqrt(lam[1] + lam[2]) ) } if (projalpha == 1) { lambar <- (lam[1] + lam[2]) / 2 meanshape <- cbind(t(H) %*% (sqrt(lam[1] - lambar + 1 / m) * eig$vectors[, 1]) , -t(H) %*% (sqrt(lam[2] - lambar + 1 / m) * eig$vectors[, 2])) } } if (m == 3) { if (projalpha == 1 / 2) { meanshape <- cbind( t(H) %*% (sqrt(lam[1]) * eig$vectors[, 1]) / sqrt(lam[1] + lam[2] + lam[3]) , t(H) %*% (sqrt(lam[2]) * eig$vectors[, 2]) / sqrt(lam[1] + lam[2] + lam[3]), t(H) %*% (sqrt(lam[3]) * eig$vectors[, 3]) / sqrt(lam[1] + lam[2] + lam[3]) ) } if (projalpha == 1) { lambar <- (lam[1] + lam[2] + lam[3]) / 3 meanshape <- cbind( t(H) %*% (sqrt(abs( lam[1] - lambar + 1 / m )) * eig$vectors[, 1]) , t(H) %*% (sqrt(abs( lam[2] - lambar + 1 / m )) * eig$vectors[, 2]) , t(H) %*% (sqrt(abs( lam[3] - lambar + 1 / m )) * eig$vectors[, 3]) ) } } if (riemdist(meanshape, mu) > riemdist(meanshape, mu, reflect = TRUE)) { meanshape[, m] <- -meanshape[, m] } meanshape } ################################################################################################ #The Procrustes routines in the next part were initially # written by Mohammad Faghihi (University of Leeds) 1993, although many improvements, corrections, # and speed-ups have been done since then. # add(a3) compute the summation of a3[,,i]'s # bgpa(a3) compute the scaling coefficients (bi's) # close1(a) adds one additional row to matrix a that is the same as the first row # cnt3(a3) replace each a3[ , , i] by fcnt(a3[ , , i]) # del(po, w1) plots point of po and joins them by contiguity matrix w1. # dif(a3) compute sum( tr (xi-xj)'(xi-xj) )/n^2 for i kk) { # qq<-diag(cov(vec1(zd))) qq <- rep(0, times = nn) for (i in 1:n) { qq[i] <- var(omat[i, ]) * (n - 1) / n omat[i, ] <- omat[i, ] - mean(omat[i, ]) } omat <- diag(sqrt(1 / qq)) %*% omat n <- kk Lmat <- t(omat) %*% omat / n eig <- eigen(Lmat, symmetric = TRUE) U <- eig$vectors lambda <- eig$values V <- omat %*% U vv <- rep(0, times = n) for (i in 1:n) { vv[i] <- sqrt(t(V[, i]) %*% V[, i]) V[, i] <- V[, i] / vv[i] } delta <- sqrt(abs(lambda / n)) * vv od <- order(delta, decreasing = TRUE) delta <- delta[od] V <- V[, od] h <- sqrt(s / aa) * V[, 1] } if (kk >= nn) { zz <- cor(vec1(zd)) h <- sqrt(s / aa) * eigen(zz)$vectors[, 1] } h <- abs(h) return(h) } #================================================================================== close1 <- function(a) { a1 <- matrix(0:0, nrow = dim(a)[1] + 1, ncol = dim(a)[2]) for (i in 1:dim(a)[1]) { a1[i,] <- a[i,] } a1[dim(a)[1] + 1,] <- a[1,] a1 } #================================================================================== cnt3 <- function(a3) { #zz <- array(c(0:0), dim = c(dim(a3)[1], dim(a3)[2], dim(a3)[3])) #for(i in 1:dim(a3)[3]) { #zz[, , i] <- fcnt(a3[, , i]) #} zz <- apply(a3, 3, fcnt) zz <- array(zz, dim(a3)) return(zz) } #================================================================================== del <- function(po, w1) { plot(po, type = "n", xlab = "x", ylab = "y") text(po) n <- dim(po)[1] for (i in 1:n) { for (j in i:n) { if (w1[i, j] > 0) { a1 <- c(po[i, 1], po[j, 1]) b1 <- c(po[i, 2], po[j, 2]) lines(a1, b1) } } } } #================================================================================== dis <- function(a, b, c) { d <- 0 d[1] <- sqrt((a[1] - b[1]) ^ 2 + (a[2] - b[2]) ^ 2) d[2] <- sqrt((a[1] - c[1]) ^ 2 + (a[2] - c[2]) ^ 2) d[3] <- sqrt((c[1] - b[1]) ^ 2 + (c[2] - b[2]) ^ 2) d } #================================================================================== dif.old <- function(a3) { s <- 0 for (i in 1:(dim(a3)[3] - 1)) { for (j in (i + 1):dim(a3)[3]) { s <- s + ((Enorm(a3[, , i] - a3[, , j])) ^ 2) } } return(s) } #dif<-function(a3) #original (slow) version #{ # s <- 0 #n<-dim(a3)[3] #mshape<-add(a3)/n #psum<-0 #for (i in 1:n){ #x<-a3[,,i]-mshape #psum<-psum+sum(diag(t(x)%*%x)) #} #psum*n #} #dif<-function(a3) ##faster version #{ #x<-sweep(a3,c(1,2),apply(a3,c(1,2),mean)) #z<-Enorm(as.vector(x))^2/dim(a3)[3] #z #} #================================================================================== dif <- function (a3) { #version that does not depend on scale of original measurements # assumes already centred cc <- centroid.size(add(a3) / dim(a3)[3]) x <- sweep(a3, c(1, 2), apply(a3, c(1, 2), mean)) z <- Enorm(as.vector(x) / cc) ^ 2 / dim(a3)[3] z } #================================================================================== fJ <- function(n) { zz <- matrix(1:1, n, n) H <- diag(n) - (1 / n) * zz H } #================================================================================== fcel <- function(n, d) { v <- ceiling(sqrt(n)) p <- matrix(c(0:0), n, 2) for (i in 1:v) { for (j in 1:v) { if ((v * (i - 1) + j) < (n + 1)) { p[(v * (i - 1) + j), 1] <- (d / 4) * (-1) ^ i + (d * j) p[(v * (i - 1) + j), 2] <- i * ((d * sqrt(3)) / 2) } } } p } #================================================================================== fcnt <- function(a) { aa <- fJ(dim(a)[1]) %*% a aa } #================================================================================== fgpa.singleiteration <- function(a3, p) { # Note this is an approximation to GPA - # It carries out an initial match by optimally rotating all the data, # the rescaling the observations, then rotating the observations # NB it does not repeat this until convergence, but in practice # for many real datasets this gives an excellent registration # zd <- list( rot. = 0, r.s.r. = 0, Gpa = 0, I.no. = 0, mshape = 0 ) zd$rot. <- rgpa(a3, p) zz <- rgpa(sgpa(zd$rot.$rotated), p) zd$r.s.r. <- zz$rotated zd$Gpa <- zz$dif zd$I.no. <- zz$r.no. zd$mshape <- msh(zd$r.s.r.) return(zd) } #================================================================================== fgpa <- function(a3, tol1, tol2, proc.output = FALSE, reflect = FALSE) { # # Fully iterative fgpa (now assumes a3 is already centred) # # zd <- list( rot. = 0, r.s.r. = 0, Gpa = 0, I.no. = 0, mshape = 0 ) p <- tol1 if (proc.output) { cat(" Step | Objective function | change \n") } if (proc.output) { cat("---------------------------------------------------\n") } x1 <- dif(a3) if (proc.output) { cat("Initial objective fn", x1, " - \n") } if (proc.output) { cat("-----------------------------------------\n") } zz <- rgpa(a3, p, proc.output = proc.output, reflect = reflect) x2 <- dif(zz$rotated) if (proc.output) { cat("Rotation step 0", x2, x1 - x2, " \n") } if (proc.output) { cat("-----------------------------------------\n") } ii <- 1 zz <- rgpa( sgpa(zz$rotated, proc.output = proc.output), p, proc.output = proc.output, reflect = reflect ) x1 <- x2 x2 <- dif(zz$rotated) rho <- x1 - x2 if (proc.output) { cat("Scale/rotate step ", ii, x2, rho, " \n") } if (proc.output) { cat("-----------------------------------------\n") } if (rho > tol2) { while (rho > tol2) { x1 <- x2 ii <- ii + 1 zz <- rgpa( sgpa(zz$rotated, proc.output = proc.output), p, proc.output = proc.output, reflect = reflect ) x2 <- dif(zz$rotated) rho <- x1 - x2 if (proc.output) { cat("Scale/rotate step ", ii, x2, rho, " \n") } if (proc.output) { cat("-----------------------------------------\n") } } } zd$r.s.r. <- zz$rotated zd$Gpa <- zz$dif zd$I.no. <- ii zd$mshape <- msh(zd$r.s.r.) return(zd) } #================================================================================== fgpa.rot <- function(a3, tol1, tol2, proc.output = FALSE, reflect = FALSE) { # Assumes that a3 has been centred already zd <- list( rot. = 0, r.s.r. = 0, Gpa = 0, I.no. = 0, mshape = 0 ) p <- tol1 zz <- rgpa(a3, p, proc.output = proc.output, reflect = reflect) x1 <- msh(zz$rotated) ii <- zz$r.no. # zz <- rgpa(zz$rotated, p,proc.output=proc.output,reflect=reflect) #x2<-msh(zz$rotated) #rho<-riemdist(x1,x2) # while (rho > tol2){ #print(rho) #x1<-x2 #ii<-ii+1 # zz <- rgpa(zz$rotated, p,proc.output=proc.output) # x2<-msh(zz$rotated) #rho<-riemdist(x1,x2) # } zd$r.s.r. <- zz$rotated zd$Gpa <- zz$dif zd$I.no. <- ii zd$mshape <- msh(zd$r.s.r.) return(zd) } #================================================================================== fopa <- function(a, b) { abar <- fcnt(a) bbar <- fcnt(b) q1 <- sum(diag(abar %*% t(abar))) q2 <- fos(a, b) ^ 2 * sum(diag(bbar %*% t(bbar))) q3 <- 2 * fos(a, b) * sum(diag(fort(a, b) %*% t(abar) %*% bbar)) gs <- q1 + q2 - q3 gs } #================================================================================== fort.ROTATEANDREFLECT <- function(a, b) { x <- t(fcnt(a)) %*% fcnt(b) xsvd <- svd(x) t <- xsvd$v %*% t(xsvd$u) return(t) } #================================================================================== fos.REFLECT <- function(a, b) { abar <- fcnt(a) bbar <- fcnt(b) z <- ftrsq(abar, bbar) / sum(diag(t(bbar) %*% bbar)) z } #================================================================================== fos <- function (a, b) { z <- cos(riemdist(a, b)) * centroid.size(a) / centroid.size(b) z } #================================================================================== ftrsq <- function(a, b) { z <- sum(sqrt(abs(eigen( t(b) %*% a %*% t(a) %*% b )$values))) z } #================================================================================== graf <- function(a3) { l <- 0 xmin <- 0 xmax <- 0 ymin <- 0 ymax <- 0 for (i in 1:dim(a3)[3]) { xmin[i] <- min(a3[, 1, i]) xmax[i] <- max(a3[, 1, i]) ymin[i] <- min(a3[, 2, i]) ymax[i] <- max(a3[, 2, i]) } l <- c(min(xmin), min(ymin), max(xmax), max(ymax)) plot((min(l) - 1):(max(l) + 1), (min(l) - 1):(max(l) + 1), type = "n") for (i in 1:dim(a3)[3]) { lines(close1(a3[, , i])) } } #================================================================================== msh <- function(a3) { s <- 0 # print("finding mean shape") m <- apply(a3, c(1, 2), mean) # print("found mean shape") # for(i in 1:dim(a3)[3]) { # s <- s + a3[, , i] # } # m <- (1/dim(a3)[3]) * s return(m) } #Enorm<-function(a) #{ # return(sqrt(sum(diag(t(a) %*% a)))) #} #================================================================================== rgpa <- function(a3, p, reflect = FALSE, proc.output = FALSE) { # assumes a3 already centred now if (reflect == TRUE) { fort <- fort.ROTATEANDREFLECT } zd <- list( rotated = 0, dif = 0, r.no. = 0, inc = 0 ) l <- dim(a3)[3] a <- 0 d <- 0 n <- 0 # zz <- cnt3(a3) zz <- a3 # print("Rotations ...") # print("Iteration,meanSS before,meanSS after,difference,tolerance") d[1] <- 10 ^ 12 d[2] <- dif(zz) a[1] <- d[2] s <- add(zz) # print(c(d[1],d[2])) if (dif(zz) > p) { while (d[1] - d[2] > p) { n <- n + 1 d[1] <- d[2] for (i in 1:l) { old <- zz[, , i] zz[, , i] <- old %*% fort(((1 / (l - 1)) * (s - old)), old) s <- s - old + zz[, , i] } d[2] <- dif(zz) a[n + 1] <- d[2] # print(c(n,d[1],d[2],d[1]-d[2],p)) if (proc.output) { cat(" Rotation iteration ", n, d[2], d[1] - d[2], " \n") } } } zd$rotated <- zz zd$dif <- a zd$r.no. <- n zd$inc <- d[1] - d[2] if (proc.output) { cat("-----------------------------------------\n") } fort <- fort.ROTATION return(zd) } # sgpa<-function(a3) #{ # zz <- a3 # a <- bgpa(zz) # for(i in 1:dim(a3)[3]) { # zz[, , i] <- a[i] * a3[, , i] # } # return(zz) #} #================================================================================== sgpa <- function(a3, proc.output = FALSE) { #assumes a3 is centred zz <- a3 di <- dim(a3) a <- bgpa(zz, proc.output = proc.output) i <- rep(dim(a3)[1] * dim(a3)[2], dim(a3)[3]) sequen <- rep(a, i) zz <- array(as.vector(a3) * sequen, di) if (proc.output) { cat(" Scaling updated \n") } return(zz) } #================================================================================== sh <- function(a) { u1 <- (a[2, 1] - a[1, 1]) / sqrt(2) u2 <- (a[2, 2] - a[1, 2]) / sqrt(2) v1 <- (2 * a[3, 1] - a[2, 1] - a[1, 1]) / sqrt(6) v2 <- (2 * a[3, 2] - a[2, 2] - a[1, 2]) / sqrt(6) d <- c(0, 0) d[1] <- (u1 * v1 + u2 * v2) / (u1 ^ 2 + u2 ^ 2) d[2] <- (u1 * v2 - u2 * v1) / (u1 ^ 2 + u2 ^ 2) d } #================================================================================== sim1 <- function(n, d, s) { a <- fcel(n, d) sig <- matrix(c(1:1), n, 1)[, 1] sig <- sig * s b <- a b[, 1] <- rnorm(n, mean = a[, 1], sd = sig) b[, 2] <- rnorm(n, mean = a[, 2], sd = sig) b } #================================================================================== vec1 <- function(a3) { #zz <- array(c(0:0), dim = c((dim(a3)[1] * dim(a3)[2]), dim(a3)[3])) #for(i in 1:dim(a3)[3]) { #for(j in 1:dim(a3)[2]) { #for(k in 1:dim(a3)[1]) { #zz[((j - 1) * dim(a3)[1] + k), i] <- a3[k, j, i #] #} #} #} zz <- matrix(a3, dim(a3)[1] * dim(a3)[2], dim(a3)[3]) return(zz) } #================================================================================== fort.ROTATION <- function(a, b) { x <- t(fcnt(a)) %*% fcnt(b) xsvd <- svd(x) v <- xsvd$v u <- xsvd$u tt <- v %*% t(u) chk1 <- Re(prod(eigen(v)$values)) chk2 <- Re(prod(eigen(u)$values)) if ((chk1 < 0) && (chk2 > 0)) { v[, dim(v)[2]] <- v[, dim(v)[2]] * (-1) tt <- v %*% t(u) } if ((chk2 < 0) && (chk1 > 0)) { u[, dim(u)[2]] <- u[, dim(u)[2]] * (-1) tt <- v %*% t(u) } return(tt) } ############end of Mohammad Faghihi's (adapted) routines #alias functions (all lower-case) hotelling2d <- Hotelling2D hotellingtest <- Hotellingtest procrustesgpa <- procrustesGPA goodall2d <- Goodall2D goodalltest <- Goodalltest # alias TPSgrid <- tpsgrid #if you wish the default to *not* include reflection #invariance (as is normal in shape analysis) then you need the line below. fort <- fort.ROTATION ################################################################################ # # Datasets # ################################################################################ #================================================================================== # Gorillas #================================================================================== gorf.dat<-array(c(5,193,53,-27,0,0,0,33,-2,105,18,176,72,114,92,38 ,51,191,55,-31,0,0,0,33,25,106,56,171,98,105,99,15 ,36,187,59,-31,0,0,0,36,12,102,38,171,91,103,100,19 ,23,202,48,-30,0,0,0,39,3,103,33,180,84,112,94,28 ,30,185,62,-25,0,0,0,32,11,101,37,168,85,106,96,21 ,4,195,65,-21,0,0,0,34,-4,100,15,180,69,120,102,34 ,37,195,62,-32,0,0,0,35,20,101,50,173,102,105,105,22 ,41,191,58,-34,0,0,0,34,15,100,47,175,93,105,99,18 ,40,190,52,-33,0,0,0,38,13,107,44,176,88,113,102,31 ,-4,179,62,-21,0,0,0,29,1,89,9,164,70,111,100,36 ,41,206,53,-25,0,0,0,39,11,104,47,177,95,111,95,26 ,33,197,55,-30,0,0,0,35,7,106,39,175,89,111,95,24 ,-12,205,52,-15,0,0,0,38,-10,111,4,187,66,129,80,44 ,13,186,56,-32,0,0,0,34,8,101,25,166,80,105,97,26 ,20,186,45,-31,0,0,0,34,10,96,31,165,84,104,90,19 ,29,183,55,-31,0,0,0,32,10,98,39,163,82,106,95,17 ,11,203,57,-28,0,0,0,39,-2,106,23,182,77,122,100,36 ,37,187,54,-27,0,0,0,34,11,100,43,171,84,106,93,28 ,49,191,53,-31,0,0,0,35,21,102,54,172,94,98,99,18 ,-8,191,57,-34,0,0,0,32,-7,93,6,173,71,119,101,30 ,43,184,49,-32,0,0,0,33,14,100,49,165,91,99,98,20 ,57,185,62,-37,0,0,0,35,22,103,61,169,96,100,104,24 ,-10,196,55,-20,0,0,0,38,-10,107,5,181,73,123,88,46 ,20,195,60,-28,0,0,0,32,6,101,33,173,84,114,100,30 ,35,202,59,-27,0,0,0,34,6,108,41,182,83,117,99,31 ,1,188,60,-19,0,0,0,35,-2,99,12,170,70,119,93,45 ,24,194,52,-24,0,0,0,39,8,105,34,174,80,115,95,32 ,25,204,55,-27,0,0,0,34,7,108,35,185,83,118,92,32 ,36,198,47,-30,0,0,0,39,14,110,43,177,92,105,98,25 ,8,198,53,-35,0,0,0,34,4,101,22,175,82,111,100,24),c(2,8,30)) gorf.dat<-aperm(gorf.dat,c(2,1,3)) gorm.dat<-array(c(53,220,46,-35,0,0,0,37,12,122,58,204,93,117,103,28 ,57,219,50,-43,0,0,0,37,13,119,61,198,102,110,104,20 ,89,227,52,-47,0,0,0,32,35,120,93,201,131,92,104,4 ,46,222,51,-45,0,0,0,30,11,113,54,196,101,117,101,16 ,85,220,48,-38,0,0,0,39,28,125,87,203,121,106,103,7 ,64,208,43,-39,0,0,0,36,22,111,67,191,104,102,101,18 ,67,216,51,-37,0,0,0,35,17,119,68,191,108,109,94,15 ,35,236,61,-42,0,0,0,33,2,119,43,211,90,126,104,30 ,116,218,40,-38,0,0,0,41,41,124,116,201,133,94,103,12 ,56,234,60,-34,0,0,0,34,12,121,58,215,109,119,112,28 ,40,223,58,-36,0,0,0,34,9,113,46,202,97,120,112,24 ,94,223,49,-57,0,0,0,33,31,122,94,206,136,99,113,-1 ,68,222,59,-41,0,0,0,30,18,119,68,204,104,114,98,11 ,65,224,56,-33,0,0,0,35,15,130,67,205,108,115,95,20 ,67,214,52,-47,0,0,0,36,26,115,74,192,114,105,104,11 ,110,213,52,-46,0,0,0,37,42,121,109,190,133,97,108,-8 ,46,219,50,-42,0,0,0,36,11,121,56,199,104,108,102,21 ,79,209,66,-43,0,0,0,35,24,114,84,193,108,115,109,14 ,58,244,74,-22,0,0,0,37,7,131,64,219,98,128,100,29 ,43,236,64,-43,0,0,0,33,12,124,52,215,110,121,105,7 ,70,226,54,-37,0,0,0,39,28,121,74,204,122,105,107,7 ,68,224,55,-37,0,0,0,35,18,121,71,207,109,108,98,13 ,34,247,63,-35,0,0,0,35,4,124,45,225,104,135,110,29 ,49,236,59,-40,0,0,0,38,19,127,59,219,105,121,109,25 ,98,195,44,-44,0,0,0,36,30,116,98,177,121,89,105,10 ,109,208,49,-40,0,0,0,36,29,125,105,189,120,102,102,12 ,61,224,51,-35,0,0,0,41,15,122,67,206,107,121,103,25 ,43,213,49,-57,0,0,0,28,20,111,58,194,112,106,108,6 ,26,249,67,-14,0,0,0,38,-11,130,33,225,87,148,97,53),c(2,8,29)) gorm.dat<-aperm(gorm.dat,c(2,1,3)) #================================================================================== # mice #================================================================================== qset2.dat<-array(c(117.98,219.62,114.52,41.93,166.15,113.59,206.54,121.79,165.11,142.92,62.07,136.58 ,105.52,235.08,109.96,57.31,165.44,126.42,223.05,140.88,169.58,156.83,59.5,138.02 ,142.83,222,132.08,40.2,188.8,115.39,236.9,125.08,193.18,142.22,83.37,141.47 ,126.35,204.27,113.2,36.04,171.77,102.43,228.93,111.75,173.55,131.8,66.26,126.65 ,99.11,231.52,119.58,44.52,169.28,129.51,219.93,141.98,167.65,154.41,56.83,141.64 ,134.14,228.48,129.09,56.98,175.85,125.39,217.57,138.01,179.29,152.67,73.84,153.08 ,119.8,219.48,122.36,48.52,171.44,115.58,216.57,131.13,170.86,148.36,65.8,138.8 ,105.62,222.74,96.27,51.3,152.13,119.07,205.02,131.95,157.36,141.61,52.35,142.73 ,122.15,202.41,128.75,32.09,176.88,102.84,220.81,119.41,177.78,131.04,76.65,120.61 ,127.78,223.48,117.65,53.94,183.45,123.87,236.96,133.84,184.24,149.04,77.96,149.95 ,123.4,200.6,116.57,28.43,172.67,97.33,221.34,106.24,175.29,122.05,64.69,115.53 ,132.4,227.96,127.46,50.4,171.57,118.67,203.72,131.91,175.25,152.38,71.98,138.5 ,123.39,216.23,113.96,29.9,167.68,105.58,202.15,114.18,172.01,133.8,65.78,125.86 ,136.83,207.84,117.37,33.67,178.1,100.65,233.17,111.44,184.05,124.85,69.8,129.69 ,143.31,219.71,122.1,48.08,177.23,113.52,221.38,122.32,180.86,140.87,80.11,151.72 ,105.96,218.06,100.46,48.73,155.23,119.51,217.76,130.01,159.11,145.49,51.29,139.66 ,115.73,234.14,115.74,56.11,168.42,128.73,220.32,135.6,169.4,154.65,66.02,152.32 ,101.73,215.74,102.67,35.73,151.69,110.19,199.12,120.24,151.6,136.36,48.82,132.42 ,124.93,222.42,130.09,46.89,163.86,118.81,197.76,137.59,165.11,148.92,67.45,139.67 ,104.68,231.95,88.17,53.4,150.87,128.76,203.38,143.96,151.59,152.11,41.85,151.15 ,123.93,242.1,121.99,64.08,175.47,143.77,211.56,155.4,173.07,164.91,68.98,158.26 ,137.21,207.27,130.76,34.56,188.92,105.07,242.85,109.74,187.67,127.43,80.29,127.14 ,107.35,212.21,89.5,38.88,151.63,105.73,196.56,113.82,152.69,133.73,46.53,135.99),c(2,6,23)) qset2.dat<-aperm(qset2.dat,c(2,1,3)) qcet2.dat<-array(c(168.59,35.66,159.99,215.17,104.93,141.07,49.01,115.13,101.69,110.87,227.11,120.51 ,165,38.35,163.89,214.32,108.26,144.79,50.17,124.02,103.5,113.13,220.43,122.65 ,166.97,39.44,163.63,221.62,108.18,147.07,54.11,137.43,109.15,118.11,227.89,128.32 ,164.02,44.22,171.76,237.29,95.93,161.44,32,131.85,95.91,126.54,222.54,133.51 ,153.46,40.67,156.62,225.12,103.81,152.44,43.65,139.01,99.95,120.7,216.62,132.9 ,148.3,52.66,147.61,239.16,90.37,164.39,32.39,145.13,88.1,130.85,209.22,145.88 ,141.33,32.7,128.49,215.09,71.39,135.31,18.32,115.62,77.48,102.92,186.28,125.49 ,130.21,18.71,136.38,201.17,68.85,125.19,11.43,94.64,64.22,90.83,184.64,107 ,130,26.8,134.24,217.41,77.07,141.93,14.66,122.68,74.56,105.14,189.9,109.31 ,134.99,22.44,116.08,205.87,74.69,130.05,22.18,96.09,68.08,95.91,185.97,115.99 ,146.87,22.6,111.5,201.74,77.67,124.1,23.04,97.03,80.91,85.93,192.2,118.4 ,146.26,23.38,119.94,209.46,75.94,125.31,19.72,100.92,82.97,87.47,192.22,109.63 ,138.32,25.44,119.25,208.88,71.18,133.17,16.68,103.45,69.21,98.08,178.43,123.71 ,142.57,19.25,99.1,197.59,62.7,111.06,3.94,86.78,69.17,79.06,180.48,117.38 ,144.57,21.44,129,204.76,80.93,121.11,18.96,103.58,82.35,90.59,191.23,111.98 ,137.6,19.71,120.16,214.71,77.7,128.06,16.08,102.22,73.54,90.19,193.21,118.14 ,123.81,22.67,118.93,207.44,73.63,129.11,4.94,104.21,71.72,100.35,191.62,119.61 ,131.1,28.64,94.82,211.86,59.44,129.47,3.89,102.71,70.28,95.52,178.71,131.69 ,155.84,22.41,112.53,207.45,68.64,118.65,8.37,97.65,78.78,85.28,184.6,114.92 ,174.04,27.44,108.13,202.49,80.74,111.51,20.1,79.49,96.21,80.84,205.25,127.23 ,127.85,20.44,119.59,208.01,61.98,125.83,4.2,112.66,80.06,90.68,182.45,108.83 ,146.48,28.36,113.82,214.92,75.14,127.12,14.06,98.64,81.57,96.68,198.33,125.63 ,139.46,33.99,99.48,220.24,73.24,135.58,8.99,105,75.01,103.38,191.51,135.63 ,152.27,30.86,138.67,226.92,91.78,137.46,24.93,121.51,92.28,107.03,216.37,131.07 ,139.15,28.78,133.63,210.56,88.84,131.16,26.42,112.92,87.97,99.71,201.01,119.24 ,153.32,20.49,109.35,201.5,76.58,109.87,10.91,91.13,74.45,85.03,183.14,119.64 ,166.02,23.04,140.31,215.68,91.82,128.43,26.01,109.78,94.61,99.14,212.09,119.48 ,127.79,22.26,136.79,202.76,89.87,131.73,26.63,113.72,88.85,90.81,198.88,105.03 ,169.22,26.47,158.71,210.32,102.37,134.39,30.64,108.87,100.56,97.55,220.44,125.16 ,146.88,23.83,116.78,218.55,84.03,132.22,25.08,111.84,89.31,94.31,194.7,129.03), c(2,6,30)) qcet2.dat<-aperm(qcet2.dat,c(2,1,3)) qlet2.dat<-array(c(134.26,224.28,122.34,36.86,174.35,111.24,235.79,127.9,174.49,142.43,51.5,141.89 ,139.29,231.38,80.82,47.82,159.37,105.97,236.93,120.91,162.59,139.69,39.92,163.16 ,151.57,219.95,104.42,49.26,162.95,105.68,241.12,123.23,181.45,133.49,60.47,151.83 ,146.16,231.16,95.78,46.87,170.85,111.77,234.72,109.48,178.8,140.05,56.79,157.8 ,150.16,222.81,81.59,53.08,161.66,102.76,238.7,94,173.74,131.99,42.42,166.01 ,134.04,218.32,84.43,40.37,155.91,104.39,227.07,112.75,163.69,135.45,45.04,154 ,141,221.6,98.86,46.69,160.43,112.77,218.15,114.61,162.83,136.17,37.06,153.86 ,123.63,231.23,66.42,46.17,140.02,108.31,217.82,118,147.98,137.78,25.35,159.24 ,137.62,226.64,96.5,39.64,164.59,105.39,235.04,102.87,169.37,134.5,46.83,150.8 ,173.79,206.17,90.39,27.9,161.84,84.83,234.85,91.6,180.59,110.28,55.57,160.27 ,117.39,233.75,114.47,42.63,167.1,124.53,229.45,135.47,167.66,150.42,40.92,142.56 ,131.55,225.48,102.05,26.81,161.73,103.06,244.48,115.44,170.49,133.86,38.65,144.13 ,134.78,226.28,110.56,41.28,170.17,112.5,231.45,114.1,176.5,139.26,51.28,145.88 ,115.95,227.77,85.99,46.33,156.48,111.17,220.59,117.43,161.6,140.85,43.06,154.56 ,133.09,226.95,99.38,40.42,160.22,111.1,236.36,117.74,168.23,138.63,44.79,149.37 ,125.36,216.11,93.92,36.95,161.42,103.33,220.04,104.98,165.19,129.44,43.48,133.74 ,123.1,202.86,99.27,42.82,157.22,98.93,206.46,111.18,162.05,129.3,64.39,123.39 ,121.37,217.11,108.09,34.09,155.47,105.03,214.66,121.61,160.24,135.04,48.64,133.8 ,120.54,232.1,85.37,53.23,157.81,109.98,213.66,117.86,169.01,146.01,38.88,151.63 ,126.42,222.64,82.96,46.57,157.34,100.52,218.67,101.9,165.27,131.51,42.51,147.56 ,126.91,220.11,105.38,35.76,158.15,109.6,207.12,117.23,160.11,138.72,40.17,142.75 ,117.87,227.17,113.96,49.9,163.19,119.44,228.16,124.54,163.3,152.93,42.17,141.99 ,125.23,224.48,93.4,39.47,166.22,109.39,234.83,108.47,165.65,139.89,42.06,144.54), c(2,6,23)) qlet2.dat<-aperm(qlet2.dat,c(2,1,3)) #================================================================================== digit3.dat<-c(9,27,12,31,17,36,26,39,34,37,36,33,38,27,35,19,30,15,21,14,21,8,16,6,8,5 ,17,40,21,38,26,36,27,32,25,28,22,27,19,29,24,25,26,20,28,16,26,13,18,14,15,17 ,19,38,24,38,29,33,30,29,27,24,21,25,17,26,27,24,30,22,31,19,31,16,27,15,24,15 ,9,40,15,43,24,41,29,36,24,30,20,26,12,22,20,22,24,20,21,16,18,14,13,12,9,10 ,14,41,21,42,29,42,35,37,32,33,26,30,16,26,25,26,29,24,33,20,30,16,23,11,16,12 ,24,39,28,40,35,38,38,35,34,30,29,27,22,24,27,24,29,22,31,19,28,15,20,11,13,12 ,9,39,15,39,21,40,25,36,23,31,21,27,19,25,21,25,23,24,25,22,22,19,15,17,8,17 ,8,38,14,41,25,43,29,38,25,33,18,29,8,28,12,27,16,25,18,23,13,21,7,21,1,22 ,4,34,12,39,22,42,31,36,27,30,23,28,11,25,20,25,22,24,22,22,19,19,13,18,8,18 ,21,36,25,37,31,36,33,32,32,28,29,25,27,22,29,21,31,20,31,18,28,16,24,16,20,16 ,14,40,20,39,25,37,27,31,26,28,20,29,16,31,21,28,25,23,28,16,25,13,17,15,13,18 ,12,40,20,42,30,42,36,33,31,24,23,22,16,23,25,22,31,18,33,13,31,9,24,8,17,8 ,9,35,17,36,26,34,30,31,26,27,20,25,13,27,19,25,23,21,26,15,22,12,12,12,7,13 ,17,38,24,39,30,37,34,34,31,28,22,25,16,28,21,26,27,24,30,20,26,15,18,14,10,17 ,21,35,27,36,36,35,39,28,38,22,34,18,28,19,31,18,33,17,31,15,26,15,20,17,14,20 ,16,40,20,43,25,39,27,31,24,24,19,21,17,23,19,22,21,21,23,21,22,18,19,16,15,16 ,15,41,21,45,34,44,40,39,36,35,26,30,16,29,24,25,28,20,31,16,28,14,21,14,12,12 ,11,42,22,42,32,39,35,34,32,29,25,26,20,27,25,26,31,23,35,19,31,14,21,12,16,15 ,5,44,15,43,24,41,29,36,22,28,13,28,5,29,14,28,24,26,29,22,26,19,17,17,10,20 ,14,37,19,39,25,38,28,32,25,26,20,22,14,23,17,23,21,20,23,17,21,15,16,15,11,15 ,16,35,22,38,30,36,32,29,29,23,23,20,17,20,20,19,24,17,26,14,21,11,16,12,12,15 ,14,38,17,40,25,42,28,38,27,32,24,28,20,25,23,25,26,24,28,21,24,18,18,17,10,18 ,7,40,13,43,22,45,31,42,27,38,21,34,13,32,18,31,24,30,27,27,23,23,15,22,6,22 ,14,35,21,36,26,34,31,30,28,26,25,22,21,18,21,17,22,16,23,15,20,12,13,10,5,10 ,10,46,17,47,27,43,29,36,26,30,22,29,16,28,20,27,21,25,23,21,21,19,15,20,9,20 ,18,39,24,42,33,41,38,35,37,30,32,28,28,27,33,22,37,18,41,15,37,13,29,11,21,12 ,18,38,22,42,30,42,34,36,33,32,29,30,22,28,25,26,28,24,28,20,27,19,22,18,18,18 ,9,41,17,43,30,40,34,31,30,23,23,19,11,19,15,17,18,13,21,10,17,8,12,7,5,7 ,8,36,12,42,20,43,25,38,24,35,23,33,21,32,20,31,20,30,20,27,16,25,9,24,2,25 ,19,41,24,45,33,45,38,38,36,31,28,27,21,23,24,22,26,20,28,17,26,14,20,13,14,11) digit3.dat<-array(digit3.dat,c(2,13,30)) digit3.dat<-aperm(digit3.dat,c(2,1,3)) digit3.dat[,2,]<- -digit3.dat[,2,] #================================================================================== dna.dat<-array(c(23.825,12.021,13.002,25.742,18.923,13.225,22.784,25.153,15.445,17.418 ,28.811,17.309,12.468,29.084,21.876,8.439,26.152,26.442,5.606,21.087 ,29.894,6.200,14.944,33.112,8.585,12.034,38.280,14.445,8.903,39.890 ,20.638,10.881,42.477,21.716,27.837,44.502,24.662,23.765,40.767,25.795 ,17.985,37.076,24.130,12.686,33.111,20.240,10.380,28.222,14.758,7.779 ,24.003,9.126,10.368,21.474,7.514,14.143,16.620,5.636,20.061,13.796 ,9.181,24.591,9.975,15.219,27.372,7.792 ,24.426,12.320,12.815,25.129,18.383,14.600,22.555,25.151,16.215,17.277 ,28.975,17.620,12.170,28.852,22.133,7.779,25.623,26.239,5.167,20.176 ,30.154,6.302,14.201,32.961,8.863,11.842,38.282,15.019,9.028,40.102 ,21.051,10.202,42.586,22.535,27.544,45.013,24.570,23.693,40.375,25.299 ,18.777,35.736,23.716,12.495,33.049,19.815,9.500,29.441,13.961,7.614 ,25.021,9.187,10.748,21.303,7.266,14.440,16.882,5.328,20.518,13.417 ,9.450,24.724,9.887,16.128,27.037,7.757 ,24.824,12.355,12.721,25.459,18.787,14.482,22.545,24.678,16.606,17.068 ,28.216,18.062,11.696,28.643,22.449,7.256,25.495,26.539,4.443,20.008 ,29.999,5.302,14.541,33.584,8.475,12.111,38.538,14.696,9.392,40.333 ,21.118,10.517,42.136,23.203,27.877,44.420,25.594,23.483,39.833,25.459 ,18.596,35.894,23.239,12.499,33.283,19.753,10.123,28.758,14.685,7.357 ,24.571,9.730,10.141,20.369,7.686,14.172,15.883,5.535,20.148,13.033 ,9.722,25.009,10.287,16.126,27.525,8.623 ,24.562,12.271,12.907,25.641,18.820,14.322,22.811,24.763,17.048,17.248 ,28.619,18.489,11.519,27.989,22.598,8.070,25.157,27.032,3.894,19.924 ,29.213,5.220,15.143,33.490,8.348,12.542,38.506,14.119,9.535,40.897 ,20.276,10.987,42.136,23.192,28.071,44.539,25.274,23.775,39.509,25.630 ,18.350,35.879,23.652,12.505,32.860,19.781,9.775,28.642,14.454,6.712 ,24.583,9.440,9.756,20.462,7.865,14.225,16.493,5.837,20.340,13.680 ,9.425,25.287,10.594,15.637,27.792,8.320 ,24.498,12.655,13.535,26.012,19.043,14.582,22.839,24.695,17.030,17.673 ,28.305,18.898,12.275,28.466,22.641,7.960,25.669,26.958,4.000,20.256 ,29.476,5.319,15.623,33.821,8.755,12.476,38.043,14.771,9.263,39.758 ,20.522,10.340,41.694,22.720,27.780,45.260,25.492,23.558,40.577,25.904 ,18.294,35.791,23.664,13.116,32.898,19.581,9.743,29.357,14.351,7.149 ,25.092,10.135,9.427,20.128,7.067,13.562,15.964,5.322,20.148,13.918 ,9.684,24.717,10.987,15.626,27.045,8.706 ,24.253,12.608,13.053,25.931,19.065,13.470,23.190,24.682,16.697,17.355 ,28.266,18.178,11.941,28.445,21.624,8.302,26.165,26.289,4.645,20.902 ,29.472,5.834,15.445,33.346,9.014,13.039,38.182,14.821,8.706,39.192 ,20.416,10.356,42.138,21.676,27.355,45.520,25.249,22.900,41.575,26.118 ,18.221,36.773,23.771,12.865,32.905,19.117,9.404,29.920,14.366,7.244 ,25.218,9.684,9.810,21.100,7.052,13.603,16.361,5.871,20.211,14.759 ,9.332,24.692,10.714,14.984,27.381,8.114 ,23.794,12.783,13.221,26.116,19.069,14.260,22.944,24.986,16.310,17.113 ,28.409,17.881,11.562,28.432,21.504,7.479,25.690,25.928,4.418,20.599 ,30.049,5.580,15.584,34.067,9.173,12.544,38.631,15.060,9.018,38.984 ,20.102,10.329,42.574,22.345,27.701,44.920,25.689,22.778,41.294,26.502 ,17.802,36.716,23.573,12.346,33.446,19.038,9.376,29.982,14.359,7.379 ,25.213,9.768,10.069,20.982,7.294,13.751,16.439,5.559,20.199,13.972 ,9.213,24.830,10.359,15.581,27.031,7.719 ,23.617,12.350,13.813,25.639,19.130,14.870,22.756,25.155,16.183,16.854 ,28.676,17.591,11.233,28.507,21.359,7.934,26.050,26.376,5.116,20.641 ,29.944,5.718,15.029,32.991,8.692,12.395,37.840,14.732,8.728,39.201 ,19.511,9.906,43.019,22.376,27.740,44.419,25.920,23.168,41.030,26.208 ,18.416,36.239,23.729,12.432,33.529,19.435,9.740,29.434,14.798,7.666 ,24.759,9.937,10.295,20.754,7.938,13.711,15.998,5.671,20.047,14.131 ,9.114,24.716,10.494,14.954,26.951,7.747 ,24.012,12.503,13.953,25.912,19.342,14.449,23.029,25.100,16.549,17.484 ,28.586,18.903,11.667,28.481,21.397,7.785,26.260,26.607,4.911,20.648 ,29.762,5.753,15.350,33.300,8.908,12.434,37.994,14.578,8.736,39.552 ,19.979,10.470,43.119,22.662,27.821,43.727,25.443,22.420,41.221,26.247 ,17.848,36.494,24.167,12.379,32.929,19.582,9.488,29.216,14.702,7.711 ,24.595,9.384,9.829,20.604,7.131,13.683,16.123,5.060,20.085,13.915 ,8.908,25.200,11.222,14.847,27.059,8.911 ,23.851,12.509,13.804,25.990,19.002,14.469,22.931,24.771,16.634,17.508 ,28.373,18.286,11.915,28.212,21.270,7.770,25.930,26.098,5.343,20.386 ,29.828,5.846,15.077,33.966,9.031,12.428,38.933,15.099,8.924,39.810 ,20.518,10.602,43.163,21.689,28.245,42.375,25.115,22.774,40.248,25.516 ,17.567,36.126,23.642,11.533,33.571,19.658,9.291,29.426,14.590,7.776 ,24.159,9.043,9.992,20.933,7.292,14.245,16.582,5.694,20.509,13.985 ,8.699,25.401,10.715,15.055,27.404,8.281 ,23.695,12.829,13.504,25.764,19.437,13.969,22.597,25.450,15.948,17.092 ,28.423,18.022,11.790,28.676,21.803,7.059,25.934,26.430,5.091,20.793 ,30.234,5.589,15.473,34.066,8.997,11.769,38.160,14.696,8.522,40.353 ,19.819,10.878,44.196,22.554,28.318,43.074,25.597,23.197,40.337,25.806 ,17.780,36.375,23.787,11.741,33.154,19.557,8.962,29.841,14.286,7.574 ,25.083,9.196,9.944,20.748,7.313,14.236,16.045,5.646,20.541,13.471 ,9.889,25.682,11.896,15.361,27.634,8.380 ,24.570,13.140,12.786,26.102,19.946,13.576,22.686,25.498,15.318,17.702 ,28.165,18.723,12.523,28.503,22.326,7.233,26.220,26.025,4.907,21.266 ,30.023,5.678,15.793,33.796,9.233,12.043,37.348,14.858,8.771,40.203 ,19.898,10.903,44.171,21.444,28.378,42.556,25.142,23.227,39.449,25.636 ,17.412,36.446,23.332,11.752,33.264,18.848,9.020,29.643,13.468,7.620 ,24.944,9.220,9.848,21.160,7.691,13.422,15.760,6.713,19.640,13.470 ,9.683,25.976,12.855,14.939,27.417,8.986 ,24.627,13.046,12.380,25.895,19.776,12.833,23.067,25.155,15.595,18.103 ,27.715,18.877,13.546,27.639,23.414,7.305,26.190,26.006,4.724,20.975 ,29.586,5.140,15.664,33.846,9.195,11.925,37.119,15.034,8.789,39.473 ,20.075,10.553,43.273,21.398,28.628,42.349,25.145,23.406,40.183,25.822 ,18.112,36.110,23.461,12.655,32.655,18.873,9.201,29.785,13.440,7.458 ,25.414,8.322,9.906,21.597,7.603,13.366,16.335,6.232,19.783,14.282 ,9.705,25.919,12.853,14.983,27.636,9.035 ,24.787,13.151,13.411,26.120,19.950,13.492,22.909,25.361,15.449,17.724 ,28.036,18.727,13.426,27.879,23.848,7.001,25.988,26.517,5.155,20.872 ,30.584,5.420,15.382,34.616,9.694,11.348,37.645,15.821,8.699,39.613 ,20.186,10.669,43.251,21.809,28.473,42.674,25.263,23.078,39.879,25.499 ,17.890,35.848,23.637,12.841,32.064,18.802,8.835,28.782,13.400,7.644 ,24.509,8.059,10.687,21.628,7.038,13.879,16.268,6.444,19.486,12.936 ,9.772,25.582,11.871,15.490,27.474,8.755 ,24.879,12.862,13.363,25.855,19.829,14.067,22.454,25.488,15.988,16.932 ,28.288,18.371,13.232,28.098,23.747,7.640,26.351,27.493,5.631,20.657 ,30.620,5.432,14.891,34.055,10.077,11.331,37.364,15.912,8.673,39.810 ,20.365,10.935,43.227,22.006,28.874,42.468,25.377,23.089,40.458,25.434 ,18.097,36.265,23.154,12.725,32.439,18.303,8.809,29.316,12.224,7.154 ,25.247,8.256,10.648,21.434,6.867,13.846,16.261,6.495,19.229,12.785 ,9.444,25.660,11.445,16.015,27.106,9.083 ,24.569,13.132,13.356,26.118,20.059,13.598,22.943,25.493,16.332,17.156 ,28.220,18.641,12.640,27.993,23.201,6.940,26.026,26.789,5.822,20.299 ,30.624,5.577,14.426,34.013,9.260,11.671,38.441,15.405,9.037,40.045 ,20.732,11.190,43.389,22.255,28.629,41.898,25.166,23.030,39.331,25.211 ,17.886,34.989,22.927,11.813,32.321,18.034,7.986,30.112,12.507,7.039 ,25.429,7.760,10.850,22.086,6.699,14.098,16.608,6.578,19.622,12.735 ,9.516,25.603,10.904,15.494,27.452,8.388 ,24.374,13.368,13.547,25.968,20.247,13.246,23.008,25.503,15.953,17.295 ,28.819,18.144,12.941,28.253,23.238,7.486,25.753,26.647,5.568,20.694 ,30.577,5.546,14.753,34.301,9.336,11.829,38.770,14.971,8.889,41.320 ,20.733,10.856,43.703,22.427,28.706,42.112,25.228,23.369,39.109,25.342 ,17.710,35.477,23.173,11.708,32.903,18.173,7.920,30.467,12.415,7.036 ,25.282,8.608,10.579,22.073,6.742,14.416,16.828,6.456,19.579,12.318 ,9.521,25.792,11.092,15.795,27.217,8.544 ,24.523,13.575,13.730,26.283,20.256,14.113,22.742,25.391,16.837,16.910 ,28.361,18.931,12.169,28.452,22.750,7.157,25.331,26.758,5.413,20.606 ,30.489,5.381,15.019,34.458,9.238,12.654,38.882,15.055,9.116,40.835 ,20.612,11.073,44.104,22.835,28.368,41.865,25.681,23.191,38.900,25.820 ,17.319,35.189,23.205,11.268,33.056,18.536,8.055,29.949,12.768,7.279 ,25.385,7.923,10.343,21.699,7.260,13.681,16.484,6.793,20.112,13.511 ,9.567,26.174,11.279,15.334,27.686,8.372 ,24.006,13.405,12.592,26.309,20.061,13.619,23.040,25.554,16.139,17.822 ,28.432,19.405,12.417,28.345,23.022,7.234,25.262,26.351,5.410,20.248 ,30.270,5.563,14.632,34.272,9.276,12.834,39.126,14.824,9.049,40.659 ,19.558,11.043,44.656,22.847,28.845,41.482,25.470,23.095,38.692,25.220 ,16.932,36.035,22.990,11.096,33.874,18.029,7.900,30.415,12.609,6.544 ,25.900,8.550,9.951,21.714,7.448,13.457,16.513,6.870,19.847,13.544 ,8.872,25.764,11.318,14.641,27.537,7.839 ,23.936,13.085,12.376,25.865,19.427,13.664,23.213,25.058,16.283,18.112 ,28.607,19.261,12.743,28.401,22.584,7.267,25.067,26.234,6.259,20.058 ,30.295,5.223,14.693,34.091,8.846,12.606,38.941,14.581,8.891,40.367 ,19.148,10.977,44.551,22.080,28.672,41.808,25.625,23.181,39.061,25.517 ,17.658,35.650,23.555,11.141,33.784,18.422,7.879,30.872,13.176,6.986 ,25.093,9.595,10.402,21.787,7.283,14.052,17.155,6.272,19.831,13.550 ,8.912,25.658,10.834,15.066,27.919,8.719 ,24.228,13.221,11.812,25.933,19.620,13.289,23.382,25.319,15.563,18.068 ,28.246,18.967,13.613,28.286,22.944,8.360,25.533,27.070,6.114,20.845 ,30.299,5.328,14.990,34.186,8.986,11.480,38.107,14.578,9.012,40.742 ,18.999,11.541,45.355,21.695,28.682,41.301,25.220,23.429,38.858,25.281 ,17.872,35.522,23.677,11.484,33.448,19.107,8.155,29.984,12.684,7.155 ,25.575,10.248,10.120,21.324,7.475,14.113,16.755,5.670,20.340,13.921 ,9.459,25.472,10.983,15.771,28.089,9.318 ,24.316,12.458,11.843,25.508,18.965,13.747,23.278,24.916,16.394,17.774 ,28.402,19.187,12.378,28.542,22.605,7.252,25.365,26.306,6.069,20.368 ,29.967,5.496,14.233,33.573,8.681,11.885,38.394,14.356,9.525,41.153 ,19.296,11.200,44.990,21.956,28.698,41.790,25.477,23.507,38.898,25.134 ,17.916,35.541,23.580,11.891,33.423,18.965,7.818,30.491,13.199,7.030 ,25.775,9.665,9.849,21.557,7.725,13.950,16.492,6.011,20.248,14.478 ,9.515,25.732,11.493,16.071,28.073,8.995 ,24.069,12.514,11.576,26.193,19.281,13.560,23.049,25.025,15.906,17.225 ,28.166,19.122,12.145,27.688,22.386,7.635,25.248,26.821,5.438,20.677 ,30.447,5.051,15.003,34.500,9.197,12.486,38.468,14.699,9.325,40.616 ,19.694,10.810,44.394,21.784,28.486,41.204,25.422,23.303,39.170,25.769 ,17.606,36.130,23.125,11.743,33.599,18.675,8.250,30.057,12.399,6.446 ,25.964,9.671,9.713,21.051,8.200,13.572,16.156,6.096,20.125,14.059 ,9.421,25.580,11.507,15.633,28.168,9.245 ,24.382,13.415,12.005,26.227,19.807,13.778,23.018,25.170,16.477,17.422 ,28.183,18.648,12.599,27.936,22.634,7.930,25.547,26.937,5.015,20.995 ,30.642,5.322,15.062,34.391,9.387,12.104,38.000,14.870,9.037,40.766 ,20.116,11.114,44.270,22.390,28.993,40.814,25.331,22.929,39.238,25.429 ,17.057,36.390,22.793,10.993,34.070,18.588,7.965,30.069,11.850,6.919 ,26.147,9.683,9.913,20.736,7.799,13.653,15.823,5.725,20.032,14.331 ,9.347,25.125,11.310,15.548,27.697,8.797 ,25.071,13.359,12.219,25.922,20.228,13.700,22.969,25.646,16.479,17.218 ,28.753,18.370,12.285,28.254,22.454,8.012,26.006,26.558,5.684,20.677 ,30.618,5.143,14.471,34.316,8.841,12.183,39.055,14.522,8.799,41.346 ,19.438,10.811,44.824,22.870,28.797,40.740,25.663,23.231,38.089,25.721 ,17.236,35.440,22.782,11.278,33.869,18.262,8.303,30.135,11.771,6.803 ,25.902,9.355,9.961,21.065,8.367,13.499,15.573,5.697,19.805,14.183 ,8.787,25.293,11.196,14.928,27.345,8.810 ,24.555,13.167,12.945,26.062,19.730,14.230,23.077,25.395,16.617,17.485 ,28.522,18.766,12.427,28.226,22.678,7.346,25.153,26.424,5.141,20.778 ,31.057,5.181,14.573,34.397,9.210,12.140,38.451,14.821,8.758,40.470 ,20.120,10.521,44.182,22.452,28.993,40.984,25.474,23.382,38.705,25.796 ,17.536,35.590,23.012,12.041,32.760,18.130,9.197,29.415,11.158,6.757 ,26.335,9.712,9.912,20.939,7.884,13.871,15.872,5.667,20.538,14.465 ,9.330,25.550,11.486,15.120,27.100,8.018 ,25.137,12.870,12.482,26.450,19.304,14.192,22.839,25.036,16.498,17.098 ,27.988,18.477,12.516,27.594,23.342,6.652,25.339,26.480,5.038,20.611 ,30.998,5.596,14.238,33.760,9.367,12.383,38.383,14.898,8.935,40.587 ,20.080,11.064,43.809,22.269,28.515,41.425,25.532,22.994,39.101,25.689 ,17.577,35.290,23.238,12.103,32.263,18.131,8.696,29.280,11.572,6.737 ,25.943,9.747,10.059,20.420,7.506,14.235,15.951,5.520,20.764,14.883 ,9.477,25.594,12.102,14.816,27.279,8.341 ,24.811,13.177,12.248,26.359,19.647,13.791,22.819,25.076,15.935,17.259 ,28.137,18.816,12.031,27.817,22.524,7.139,25.285,26.476,5.233,20.844 ,30.918,5.023,14.625,34.304,8.951,12.113,38.641,14.903,9.183,40.263 ,19.489,10.837,44.214,22.943,28.849,41.934,25.785,23.491,38.818,25.458 ,17.501,35.809,23.084,12.499,32.507,18.711,8.415,29.596,11.995,6.648 ,25.674,9.782,9.834,20.682,7.330,14.037,16.282,5.679,20.535,14.148 ,9.529,25.973,12.347,14.857,27.412,8.891 ,25.461,13.475,12.459,26.240,19.803,14.240,22.439,25.184,16.246,17.018 ,28.482,18.729,12.138,27.810,22.628,6.935,25.500,26.392,5.181,21.303 ,30.774,5.269,15.405,34.596,9.057,12.253,38.675,14.733,9.098,40.950 ,18.928,10.930,44.884,22.702,28.490,41.516,25.756,22.649,39.048,26.150 ,16.724,36.124,23.328,11.649,32.925,18.644,8.006,30.218,12.586,6.889 ,25.838,9.876,10.168,20.938,7.544,13.875,16.115,5.352,20.441,14.098 ,9.147,25.602,11.691,14.869,27.495,8.845 ,24.646,13.201,12.498,26.020,19.910,14.081,22.700,25.203,16.348,16.921 ,28.147,18.532,12.219,27.992,22.139,7.297,25.197,26.330,5.477,21.167 ,31.099,5.289,15.822,35.342,8.801,12.200,39.234,14.381,9.267,41.504 ,19.133,11.253,44.763,22.661,28.604,41.983,25.373,23.002,39.097,25.724 ,16.979,36.597,23.274,11.205,33.696,18.583,7.895,30.512,12.581,6.908 ,26.393,10.461,9.886,20.595,7.139,14.317,16.469,5.308,21.069,14.978 ,8.870,25.450,10.652,14.988,27.488,7.901) ,c(3,22,30)) dna.dat<-aperm(dna.dat,c(2,1,3)) # # # #================================================================================== macf.dat<-c(54.33203,24.10905,69.5 ,141.80250,21.59643,69.5 ,132.23880,62.78124,69.5 ,88.22106,52.28123,69.5 ,147.10890,26.61518,90.0 ,107.42800,27.77578,101.0 ,99.74427,46.85715,97.0 ,58.35540,29.57223,67.0 ,134.87930,26.38988,67.0 ,120.57150,66.43083,67.0 ,79.14922,52.19386,67.0 ,138.17850,37.67144,86.0 ,101.76780,34.47324,97.5 ,90.83484,54.19082,92.0 ,50.04349,15.22191,71.5 ,139.76850,21.33820,71.5 ,124.26710,63.79000,71.5 ,80.94720,51.47673,71.5 ,147.78980,32.26446,94.0 ,102.32870,25.23133,105.5 ,90.64163,47.04449,98.5 ,41.93115,24.83244,70.5 ,138.72930,22.35828,70.5 ,122.68840,65.04043,70.5 ,74.09913,53.69709,70.5 ,142.63240,35.36625,92.0 ,97.04822,33.37946,111.5 ,89.51760,56.40900,96.5 ,48.44877,35.75250,68.0 ,134.68970,33.55962,68.0 ,120.88830,73.77755,68.0 ,77.94841,65.53058,68.0 ,135.42950,42.75692,91.0 ,101.92880,40.64505,99.5 ,87.04530,59.04715,92.5 ,44.05272,36.38397,70.0 ,133.47320,45.07240,70.0 ,114.88450,83.74655,70.0 ,70.13158,71.71946,70.0 ,139.94810,54.24338,87.0 ,97.87708,47.19924,105.5 ,80.04594,65.13947,96.5 ,53.94042,32.50219,69.0 ,136.19530,33.46588,69.0 ,120.75410,74.12678,69.0 ,78.24210,60.88469,69.0 ,142.38210,44.35960,89.5 ,100.75480,38.09180,101.0 ,87.92361,55.80280,94.5 ,45.11740,11.62884,68.5 ,132.08950,17.75877,68.5 ,112.66980,57.22899,68.5 ,71.76939,47.64127,68.5 ,136.93780,26.69818,88.5 ,96.43125,21.78416,101.0 ,84.39475,41.89694,95.0 ,42.09966,16.11359,69.0 ,131.92440,19.70687,69.0 ,121.73400,57.71608,69.0 ,72.94730,49.99466,69.0 ,136.93340,26.92302,89.0 ,96.84825,26.58288,103.0 ,84.30907,48.96717,94.5) macf.dat<-array(macf.dat,c(3,7,9)) macf.dat<-aperm(macf.dat,c(2,1,3)) macm.dat<-c(34.82811,16.50834,77.5 ,138.91980,15.13858,77.5 ,125.15760,58.60464,77.5 ,72.28854,49.79207,77.5 ,146.19080,22.68885,100.0 ,99.30268,24.86908,117.0 ,91.79910,46.49960,107.0 ,40.40179,3.73932,73.0 ,132.23560,7.56574,73.0 ,114.63210,53.28955,73.0 ,70.66502,33.57051,73.0 ,139.58480,21.61227,90.5 ,97.93692,8.49867,108.5 ,79.90506,28.91153,100.5 ,40.54510,9.51130,75.0 ,136.61260,15.82863,75.0 ,106.90960,63.82611,75.0 ,76.19816,46.63517,75.0 ,145.02210,30.40421,94.5 ,101.72660,19.45746,113.5 ,86.97967,43.98130,105.5 ,21.11454,16.57673,75.0 ,131.52700,23.12809,75.0 ,109.44810,63.03707,75.0 ,61.73774,53.69610,75.0 ,135.91480,34.78890,101.5 ,90.65395,25.30813,117.5 ,75.66082,49.38123,105.5 ,30.79976,19.21503,73.5 ,134.92160,32.11148,73.5 ,115.81510,69.88405,73.5 ,67.15240,57.06633,73.5 ,139.56950,44.82271,97.5 ,95.38217,25.95223,112.0 ,78.97741,47.89584,107.0 ,18.88770,10.47136,74.5 ,130.35790,12.40497,74.5 ,114.85390,57.63774,74.5 ,63.47649,48.13175,74.5 ,138.25830,25.62929,97.5 ,89.01810,18.95535,117.0 ,75.67622,43.31009,104.5 ,40.28789,14.90687,69.0 ,134.29020,14.66977,69.0 ,125.54870,56.83236,69.0 ,75.68020,53.65364,69.0 ,142.36350,24.22211,92.5 ,99.44497,25.41932,106.0 ,87.63929,45.45810,99.5 ,25.38359,10.64805,72.5 ,130.99770,9.63434,72.5 ,118.65580,54.78021,72.5 ,68.79280,48.67834,72.5 ,139.77820,20.83856,97.0 ,91.36346,16.29169,111.5 ,75.55544,44.28398,101.0 ,27.93545,5.21197,71 ,130.98990,4.76235,71 ,103.16230,51.99304,71 ,70.59641,43.71388,71 ,136.03820,13.90246,92 ,91.75840,14.31955,109 ,79.95213,35.70748,95) macm.dat<-array(macm.dat,c(3,7,9)) macm.dat<-aperm(macm.dat,c(2,1,3)) #================================================================================== sooty.dat<- c(-1426,-310.4167 ,-1424,-160.4167 ,-1117,320.5833 ,-755,854.5833 ,1238,1363.5833 ,2330,471.5833 ,1435,-748.4167 ,771,-557.4167 ,433,-395.4167 ,-176,-299.4167 ,-376,-290.4167 ,-933,-248.4167 ,-1000.20254,-1601.5969 ,-1076.57007,-1266.4282 ,-1124.65334,-635.6890 ,-1193.94980,147.7853 ,-61.16474,1895.7533 ,1484.57069,2113.5422 ,1649.32657,746.7048 ,1212.33458,388.9087 ,730.79486,166.1701 ,156.62415,-383.9590 ,-88.03479,-533.8656 ,-689.07556,-1037.3256) sooty.dat<-array(sooty.dat,c(2,12,2)) sooty.dat<-aperm(sooty.dat,c(2,1,3)) #================================================================================== panf.dat<-array(c(47,-23,0,0,0,32,12,87,21,156,31,133,66,92,83,20, 63,-22,0,0,0,29,6,89,14,157,23,136,62,101,95,24, 56,-11,0,0,0,31,2,89,4,159,17,141,54,107,86,34, 51,-27,0,0,0,29,12,89,30,156,39,135,71,94,86,18, 51,-19,0,0,0,35,8,97,23,169,36,143,67,101,85,25, 54,-23,0,0,0,34,14,84,36,155,44,133,76,87,89,19, 53,-21,0,0,0,30,5,90,24,162,31,139,63,99,86,21, 56,-23,0,0,0,33,16,92,30,156,40,131,75,95,95,15, 55,-20,0,0,0,33,12,89,13,157,31,136,63,97,91,22, 35,-23,0,0,0,26,9,81,11,153,26,131,64,92,84,18, 48,-25,0,0,0,30,23,89,44,160,49,139,81,95,95,18, 35,-34,0,0,0,30,10,84,23,153,36,128,68,95,94,13, 46,-23,0,0,0,28,4,92,14,163,27,137,60,101,86,27, 42,-23,0,0,0,30,19,88,33,163,45,130,77,95,93,20, 50,-19,0,0,0,32,7,90,14,157,25,139,68,101,87,23, 54,-19,0,0,0,29,6,92,9,163,20,140,64,104,92,26, 46,-31,0,0,0,25,3,89,2,167,24,136,63,95,85,19, 47,-19,0,0,0,29,7,84,6,148,22,126,58,89,80,24, 46,-27,0,0,0,31,12,86,23,156,35,130,72,93,89,18, 49,-23,0,0,0,29,14,88,25,159,36,133,76,90,90,16, 50,-23,0,0,0,32,9,92,14,167,31,141,71,97,87,28, 40,-23,0,0,0,30,13,92,30,167,40,140,74,99,91,21, 32,-25,0,0,0,36,7,96,12,170,22,147,61,108,81,35, 41,-30,0,0,0,29,18,87,31,160,43,135,74,87,89,10, 46,-25,0,0,0,29,15,88,23,163,37,134,70,91,85,22, 43,-22,0,0,0,33,-1,96,10,178,24,153,66,105,87,32),c(2,8,26)) panf.dat<-aperm(panf.dat,c(2,1,3)) select<-c(5,1,2,3,4,6,7,8) panf.dat<-panf.dat[select,,] panm.dat<-array(c(43,-21,0,0,0,34,14,101,25,179,40,150,75,104,90,31, 48,-23,0,0,0,31,5,92,11,166,24,144,63,99,82,24, 43,-23,0,0,0,29,13,92,21,161,33,138,68,100,84,21, 45,-32,0,0,0,30,8,100,14,163,28,143,74,102,97,21, 40,-27,0,0,0,29,7,93,12,166,23,147,69,102,90,25, 49,-19,0,0,0,33,3,94,11,165,23,144,64,108,89,30, 55,-17,0,0,0,31,6,97,17,168,29,144,69,101,85,23, 49,-27,0,0,0,26,11,92,16,178,30,152,78,100,89,23, 48,-23,0,0,0,29,10,96,32,166,42,139,69,96,87,21, 49,-19,0,0,0,29,3,100,14,172,25,152,63,109,87,32, 49,-26,0,0,0,34,8,91,22,168,34,140,74,93,93,17, 52,-26,0,0,0,32,7,92,10,172,28,143,66,100,93,23, 36,-26,0,0,0,28,11,92,25,165,34,140,71,98,90,18, 46,-26,0,0,0,33,12,94,20,174,35,145,71,106,93,24, 47,-22,0,0,0,31,10,88,29,156,34,138,68,93,91,20, 47,-25,0,0,0,30,0,97,2,172,19,147,62,102,82,26, 53,-19,0,0,0,29,6,80,2,142,13,123,54,100,91,31, 49,-24,0,0,0,29,5,90,14,168,31,144,77,96,89,22, 52,-25,0,0,0,30,6,93,15,167,25,147,74,99,92,24, 42,-27,0,0,0,32,11,87,26,159,37,137,76,95,87,21, 37,-25,0,0,0,29,-2,87,-2,175,16,152,63,107,91,33, 41,-27,0,0,0,25,6,87,13,167,29,141,70,99,89,28, 46,-24,0,0,0,35,12,98,15,175,31,152,76,106,92,27, 45,-22,0,0,0,29,8,90,12,176,24,151,70,104,88,24, 46,-27,0,0,0,29,2,88,6,166,23,138,67,100,86,24, 43,-20,0,0,0,33,7,94,17,165,30,143,70,93,81,24, 44,-20,0,0,0,29,1,87,0,154,19,133,64,98,80,16, 52,-28,0,0,0,28,2,84,18,155,25,135,63,97,93,21),c(2,8,28)) panm.dat<-aperm(panm.dat,c(2,1,3)) select<-c(5,1,2,3,4,6,7,8) panm.dat<-panm.dat[select,,] pongof.dat<-array(c(43,-31,0,0,0,29,13,90,45,150,48,126,74,80,91,19, 49,-31,0,0,0,33,28,93,70,152,72,130,86,78,85,-5, 51,-36,0,0,0,32,34,100,74,152,74,131,87,73,92,-2, 48,-26,0,0,0,32,10,89,35,154,40,136,65,88,86,14, 56,-29,0,0,0,24,11,87,44,155,48,133,72,82,91,12, 49,-30,0,0,0,29,25,96,72,159,69,137,85,78,93,9, 51,-28,0,0,0,26,11,94,50,162,49,132,75,87,89,13, 57,-24,0,0,0,35,10,98,55,164,53,138,77,88,93,21, 37,-29,0,0,0,38,30,93,63,161,68,129,86,68,87,6, 53,-30,0,0,0,29,5,88,39,147,38,131,64,84,90,14, 58,-24,0,0,0,30,0,88,14,151,24,133,59,91,88,21, 54,-26,0,0,0,36,11,106,41,173,48,146,78,94,99,24, 59,-25,0,0,0,29,4,102,28,177,34,156,63,100,90,25, 32,-36,0,0,0,25,26,90,71,144,69,124,82,72,91,3, 52,-30,0,0,0,35,21,99,55,164,59,143,79,90,95,22, 51,-27,0,0,0,35,11,92,37,152,42,132,69,88,95,26, 47,-24,0,0,0,35,7,98,36,163,38,138,66,89,87,21, 60,-23,0,0,0,23,-2,82,28,158,32,135,56,90,89,25, 46,-31,0,0,0,25,4,87,34,145,37,120,66,80,89,20, 46,-28,0,0,0,36,29,94,73,148,71,123,82,74,92,11, 32,-37,0,0,0,36,32,88,81,140,81,117,91,63,90,-5, 43,-27,0,0,0,25,2,90,32,159,37,131,62,91,87,22, 38,-27,0,0,0,30,4,93,30,160,36,136,60,92,86,27, 38,-27,0,0,0,34,14,92,53,155,48,129,71,82,84,24),c(2,8,24)) pongof.dat<-aperm(pongof.dat,c(2,1,3)) select<-c(5,1,2,3,4,6,7,8) pongof.dat<-pongof.dat[select,,] pongom.dat<-array(c(49,-45,0,0,0,26,25,106,68,190,68,151,84,80,100,14, 64,-28,0,0,0,31,10,106,46,185,53,156,77,95,99,14, 55,-31,0,0,0,33,23,113,72,186,72,160,92,95,102,21, 64,-25,0,0,0,36,5,109,35,188,42,165,69,102,101,33, 46,-39,0,0,0,31,36,106,97,155,89,133,95,74,92,1, 53,-28,0,0,0,33,17,111,54,185,59,159,87,88,98,16, 47,-36,0,0,0,36,35,114,72,183,74,150,94,81,105,15, 44,-35,0,0,0,37,15,110,69,183,74,153,84,89,94,11, 55,-43,0,0,0,26,24,105,71,172,75,146,91,81,104,1, 49,-33,0,0,0,35,11,113,58,188,56,159,79,92,93,24, 45,-32,0,0,0,29,20,107,67,184,67,155,85,82,93,11, 48,-34,0,0,0,32,33,116,89,192,91,160,100,81,99,5, 41,-51,0,0,0,29,50,100,127,139,115,119,105,53,96,-19, 60,-45,0,0,0,32,36,102,108,163,97,129,98,75,98,-6, 65,-35,0,0,0,30,24,112,65,188,72,158,88,87,103,18, 54,-28,0,0,0,33,7,114,33,206,42,172,74,98,94,28, 41,-39,0,0,0,34,24,115,79,188,79,154,93,79,99,2, 42,-40,0,0,0,39,41,114,112,187,102,147,112,70,97,-14, 65,-27,0,0,0,30,17,109,62,187,66,151,83,82,96,18, 54,-36,0,0,0,30,29,122,65,204,70,176,93,87,96,9, 55,-37,0,0,0,32,25,116,75,190,71,155,88,84,98,8, 50,-35,0,0,0,26,8,101,39,172,49,148,75,87,98,18, 78,-31,0,0,0,28,15,119,56,204,60,179,91,94,103,8, 42,-32,0,0,0,34,37,117,102,181,99,148,102,83,97,5, 52,-39,0,0,0,38,15,111,58,201,63,158,89,91,95,-8, 47,-37,0,0,0,23,37,98,85,160,83,136,89,75,94,-5, 49,-37,0,0,0,34,37,115,105,179,98,151,96,80,97,5, 48,-32,0,0,0,36,10,113,53,189,57,166,79,100,99,21, 41,-24,0,0,0,39,4,128,42,209,47,178,73,102,93,21, 50,-32,0,0,0,39,27,121,73,198,75,166,95,89,101,15),c(2,8,30)) pongom.dat<-aperm(pongom.dat,c(2,1,3)) select<-c(5,1,2,3,4,6,7,8) pongom.dat<-pongom.dat[select,,] #================================================================================== schizophrenia.dat<-c( 0.345632 , -0.0360314 , -0.356301 , 0.0234333 , 0.0119311 , 0.17692 , 0.37789 , 0.480402 , 0.719631 , -0.41189 , 0.397921 , -0.140558 , 0.351751 , -0.385748 , 0.333756 , -0.655051 , 0.032181 , -0.275235 , 0.112563 , -0.506533 , -0.233126 , -0.28334 , -0.667337 , 0.0522613 , 0.188945 , -0.142714 , 0.237198 , 0.048306 , -0.340236 , 0.0997385 , -0.0161814 , 0.201017 , 0.301584 , 0.516546 , 0.510795 , -0.323537 , 0.269407 , -0.0562209 , 0.239301 , -0.253218 , 0.229339 , -0.48236 , 0.0201328 , -0.122625 , 0.048306 , -0.341874 , -0.200997 , -0.122698 , -0.62316 , 0.120534 , 0.124688 , -0.0262477 , 0.341616 , 0.048306 , -0.408509 , 0.119819 , -0.00814926 , 0.277322 , 0.39797 , 0.62498 , 0.591116 , -0.299441 , 0.35776 , -0.0361405 , 0.27143 , -0.249202 , 0.273516 , -0.530553 , 0.032181 , -0.110577 , 0.0724024 , -0.34589 , -0.188949 , -0.138762 , -0.707498 , 0.140615 , 0.124688 , -0.0262477 , 0.329567 , -0.10832 , -0.359859 , 0.0341931 , -0.056342 , 0.152824 , 0.377668 , 0.474464 , 0.673363 , -0.462009 , 0.373825 , -0.228912 , 0.323639 , -0.450005 , 0.34179 , -0.735372 , 0.0924219 , -0.295315 , 0.100555 , -0.540522 , -0.181195 , -0.260518 , -0.651361 , 0.0963372 , 0.174798 , -0.178741 , 0.193021 , 0.0683864 , -0.539516 , 0.210918 , -0.16074 , 0.333555 , 0.293246 , 0.639288 , 0.520753 , -0.301366 , 0.245311 , -0.0281084 , 0.142916 , -0.28133 , 0.128938 , -0.510473 , -0.152558 , -0.118609 , -0.0761516 , -0.379879 , -0.414127 , -0.127988 , -0.848201 , 0.246974 , -0.00592517 , -0.00203414 , 0.337599 , -0.076192 , -0.356431 , 0.146356 , 0.068156 , 0.201017 , 0.520571 , 0.464342 , 0.601074 , -0.518234 , 0.321616 , -0.208831 , 0.251349 , -0.409844 , 0.197211 , -0.695211 , -0.00797966 , -0.251139 , -0.00787855 , -0.500361 , -0.26726 , -0.201009 , -0.719602 , 0.25526 , 0.110557 , -0.140611 , 0.223261 , 0.228767 , -0.431293 , 0.230133 , -0.0439952 , 0.389752 , 0.23941 , 0.819652 , 0.641234 , -0.088515 , 0.377841 , 0.140566 , 0.339703 , -0.10864 , 0.393998 , -0.345813 , 0.0201328 , -0.0583678 , 0.172844 , -0.283494 , -0.268058 , -0.0890055 , -0.777652 , 0.251188 , 0.154806 , 0.12832 , 0.243341 , -0.052358 , -0.451374 , 0.145795 , -0.0480112 , 0.297382 , 0.408185 , 0.574616 , 0.56291 , -0.538339 , 0.31561 , -0.190749 , 0.251349 , -0.437957 , 0.169098 , -0.715291 , 0.00005 , -0.194914 , 0.000153631 , -0.492329 , -0.278085 , -0.117118 , -0.797732 , 0.255204 , 0.122674 , -0.0905492 , 0.287518 , 0.0600918 , -0.503583 , 0.121699 , -0.0861578 , 0.307424 , 0.355977 , 0.614776 , 0.603071 , -0.277295 , 0.303562 , -0.0100258 , 0.259382 , -0.293379 , 0.241387 , -0.538584 , -0.0521564 , -0.114593 , 0.0443303 , -0.343735 , -0.274068 , -0.0930217 , -0.805764 , 0.138738 , 0.12669 , 0.00182023 , 0.319646 , 0.20467 , -0.431294 , 0.153827 , -0.0660775 , 0.391762 , 0.29172 , 0.793493 , 0.771746 , -0.00420256 , 0.407979 , 0.166681 , 0.387896 , -0.12872 , 0.393998 , -0.394006 , 0.0864079 , -0.0382915 , 0.168828 , -0.279477 , -0.225876 , -0.109086 , -0.779633 , 0.126677 , 0.190947 , 0.126318 , 0.303582 , 0.208686 , -0.395149 , 0.302422 , -0.00985258 , 0.387746 , 0.388105 , 0.72522 , 0.611103 , -0.289343 , 0.327658 , 0.0743116 , 0.283478 , -0.229121 , 0.201226 , -0.494408 , 0.00608663 , -0.0141951 , 0.0362983 , -0.279477 , -0.24194 , -0.00466831 , -0.699312 , 0.339529 , 0.12669 , 0.0901736 , 0.287518 , -0.0362937 , -0.428786 , 0.133507 , -0.0801519 , 0.233129 , 0.374063 , 0.614792 , 0.671344 , -0.478098 , 0.383883 , -0.134524 , 0.315606 , -0.417876 , 0.265483 , -0.675131 , 0.0342193 , -0.19491 , 0.0443223 , -0.466226 , -0.266036 , -0.201455 , -0.735453 , 0.202987 , 0.176577 , -0.0906634 , 0.251373 , 0.212702 , -0.42477 , 0.149571 , -0.124329 , 0.345579 , 0.145148 , 0.767403 , 0.671344 , -0.00821852 , 0.424044 , 0.138569 , 0.407976 , -0.116671 , 0.44219 , -0.377942 , 0.122573 , -0.0583636 , 0.202939 , -0.283647 , -0.14957 , -0.0970378 , -0.755533 , 0.114633 , 0.180593 , 0.0940755 , 0.29555 , -0.0362937 , -0.348465 , 0.000976592 , -0.0480233 , 0.148792 , 0.273662 , 0.458166 , 0.65528 , -0.341552 , 0.371835 , -0.106411 , 0.327655 , -0.377715 , 0.333757 , -0.65505 , 0.0984763 , -0.247119 , 0.118601 , -0.500514 , -0.181699 , -0.253664 , -0.675212 , 0.0182479 , 0.192642 , -0.122792 , 0.309487 , 0.265173 , -0.3438 , 0.289185 , 0.0199632 , 0.482141 , 0.355444 , 0.735605 , 0.613122 , -0.156788 , 0.357761 , 0.128518 , 0.315607 , -0.132736 , 0.305644 , -0.36991 , 0.0121007 , 0.0380178 , 0.100555 , -0.223253 , -0.182924 , 0.0134128 , -0.623245 , 0.301185 , 0.162814 , 0.142714 , 0.193021 , 0.305334 , -0.472766 , 0.163996 , -0.172808 , 0.38174 , 0.0847168 , 0.829799 , 0.538908 , 0.114214 , 0.249327 , 0.273096 , 0.199141 , 0.0319229 , 0.273516 , -0.165091 , -0.0360921 , 0.0340017 , 0.0563381 , -0.141071 , -0.257222 , -0.0263121 , -0.791835 , 0.0884059 , -0.00382644 , 0.178572 , 0.39784 , -0.011935 , -0.440185 , 0.132558 , -0.00814926 , 0.309451 , 0.470037 , 0.542738 , 0.580994 , -0.385704 , 0.389889 , -0.212847 , 0.283478 , -0.401812 , 0.237372 , -0.675131 , 0.0201328 , -0.267203 , 0.0644106 , -0.508393 , -0.23742 , -0.196261 , -0.711598 , 0.184719 , 0.0944764 , -0.130548 , 0.269326 , 0.0844506 , -0.327735 , 0.048221 , -0.0242135 , 0.253226 , 0.257186 , 0.643139 , 0.601074 , -0.1849 , 0.325632 , 0.0160683 , 0.307574 , -0.217073 , 0.301629 , -0.442199 , 0.0803737 , -0.126641 , 0.112603 , -0.351767 , -0.153083 , -0.13602 , -0.635293 , 0.0280923 , 0.158733 , -0.00605034 , 0.217118 , 0.212965 , -0.416089 , 0.192799 , -0.104535 , 0.353627 , 0.229073 , 0.727476 , 0.601074 , -0.1849 , 0.293503 , 0.112454 , 0.267414 , -0.112655 , 0.285565 , -0.402039 , 0.0281649 , -0.0101749 , 0.0844909 , -0.259397 , -0.221356 , -0.0275863 , -0.743727 , 0.188735 , 0.0944764 , 0.118448 , 0.293423 , -0.076192 , -0.327736 , 0.0442049 , -0.0121653 , 0.160856 , 0.357587 , 0.394143 , 0.572961 , -0.457993 , 0.281455 , -0.228912 , 0.263398 , -0.470085 , 0.189179 , -0.679147 , 0.00005 , -0.259171 , 0.02425 , -0.524458 , -0.193244 , -0.208309 , -0.583084 , 0.0883332 , 0.142669 , -0.178741 , 0.289407 , 0.0201935 , -0.351832 , 0.164687 , 0.00389893 , 0.265274 , 0.40578 , 0.510609 , 0.49264 , -0.433896 , 0.3176 , -0.120478 , 0.235285 , -0.329523 , 0.201227 , -0.554649 , 0.00406852 , -0.17885 , 0.0081857 , -0.403976 , -0.245452 , -0.107908 , -0.647341 , 0.228896 , 0.0583318 , -0.0622752 , 0.301455 , 0.0603542 , -0.391993 , 0.224928 , -0.0121653 , 0.341579 , 0.441925 , 0.594946 , 0.45248 , -0.389719 , 0.29752 , -0.0963815 , 0.17906 , -0.30141 , 0.140986 , -0.570714 , -0.02806 , -0.106561 , -0.0560713 , -0.391927 , -0.245452 , -0.0556988 , -0.683486 , 0.293153 , 0.0583318 , -0.00605033 , 0.237198 , -0.0922563 , -0.396005 , 0.00807245 , -0.116583 , 0.11668 , 0.29333 , 0.402175 , 0.47256 , -0.502169 , 0.22523 , -0.22088 , 0.17906 , -0.433941 , 0.157051 , -0.634971 , -0.0320761 , -0.271219 , -0.0400071 , -0.500361 , -0.257501 , -0.260518 , -0.69955 , 0.0521888 , 0.0382515 , -0.158661 , 0.321535 , -0.0641438 , -0.379941 , 0.108474 , -0.0201975 , 0.192985 , 0.445941 , 0.450368 , 0.49264 , -0.506185 , 0.325632 , -0.184735 , 0.203157 , -0.365667 , 0.124922 , -0.675131 , -0.0119958 , -0.206962 , -0.0279589 , -0.476265 , -0.285613 , -0.192245 , -0.651357 , 0.176687 , 0.0944764 , -0.126532 , 0.317519 , -0.0761919 , -0.219297 , -0.0300639 , 0.072172 , 0.140776 , 0.40578 , 0.430287 , 0.580994 , -0.457993 , 0.345712 , -0.216863 , 0.287494 , -0.417876 , 0.2695 , -0.663083 , 0.096438 , -0.259171 , 0.0764588 , -0.496345 , -0.165131 , -0.24847 , -0.518831 , -0.00808046 , 0.162749 , -0.178741 , 0.363819 , -0.132663 , -0.295482 , 0.140679 , 0.178874 , 0.174894 , 0.568759 , 0.29153 , 0.593042 , -0.550362 , 0.345712 , -0.297185 , 0.267414 , -0.50623 , 0.136969 , -0.74742 , -0.0039636 , -0.275235 , 0.0724427 , -0.520442 , -0.239946 , -0.153262 , -0.524623 , 0.229146 , 0.194967 , -0.196981 , 0.255389 , 0.160493 , -0.435309 , 0.214068 , -0.124316 , 0.357623 , 0.267522 , 0.65901 , 0.597058 , -0.136708 , 0.305552 , 0.0763094 , 0.255365 , -0.140768 , 0.257451 , -0.402038 , 0.032181 , -0.0382875 , 0.084491 , -0.279478 , -0.243962 , -0.0167163 , -0.761587 , 0.231107 , 0.0945651 , 0.0881595 , 0.279486 , 0.00788297 , -0.330892 , 0.141779 , 0.0222759 , 0.267264 , 0.386119 , 0.484248 , 0.574959 , -0.365648 , 0.33569 , -0.102395 , 0.263398 , -0.345587 , 0.233355 , -0.566697 , -0.0180098 , -0.178854 , 0.0965392 , -0.387911 , -0.233908 , -0.12515 , -0.627023 , 0.206999 , 0.0681437 , -0.0866473) schizo.dat<-schizophrenia.dat schizophrenia.dat<-array(schizophrenia.dat,c(2,13,28)) schizophrenia.dat<-aperm(schizophrenia.dat,c(2,1,3)) schizo.dat<-array(schizo.dat,c(2,13,28)) schizo.dat<-aperm(schizo.dat,c(2,1,3)) braincon.dat<-schizo.dat[,,1:14] brainscz.dat<-schizo.dat[,,15:28] ###################### Additional functions by other authors ################## # # ============================================================================= # Authors # ============================================================================= # Gregorio Quintana-Orti # Depto. de Ingenieria y Ciencia de Computadores, # Universitat Jaume I, # 12.071 Castellon, Spain # Amelia Simo # Depto. de Matematicas, # Universitat Jaume I, # 12.071 Castellon, Spain # # ============================================================================= # Copyright # ============================================================================= # Copyright (C) 2018, # Universitat Jaume I. # # ============================================================================= # Disclaimer # ============================================================================= # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # # This module contains several modifications of some functions provided by # the noteworthy "shapes" package by Ian L. Dryden. These new implementations # have been accelerated to be much faster for medium and large datasets # than the original codes. All the other functions in the library that employ # the accelerated ones will also take advantage of this performance # improvement. # # The new code includes the original code in commented lines with four "#" # chars as a reference. # # ============================================================================= # ============================================================================= uji_preshape = function( x ) { # # It computes the preshape in a faster way on medium and large datasets # on real (non-complex) data. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # if ( is.complex( x ) ) { # # Complex case. # k <- nrow( as.matrix( x ) ) h <- uji_defh( k - 1 ) zstar <- x ztem <- h %*% zstar size <- sqrt( diag( Re( st( ztem ) %*% ztem ) ) ) if ( is.vector( zstar ) ) z <- ztem / size if ( is.matrix(zstar ) ) z <- ztem %*% diag( 1.0 / size ) } else { # # Real case. # if (length(dim(x)) == 3) { # # Argument X is a 3D array. # k <- dim( x )[ 1 ] #### h <- uji_defh( k - 1 ) n <- dim( x )[ 3 ] m <- dim( x )[ 2 ] z <- array( 0, c( k - 1, m, n ) ) for ( i in 1 : n ) { #### z[, , i] <- h %*% x[, , i] # Accelerated code. z[ , , i ] <- multiply_by_helmert( x[ , , i ] ) size <- uji_centroid.size( x[ , , i ] ) z[ , , i ] <- z[ , , i ] / size } } else { # # Argument X is not a 3D array. # k <- nrow( as.matrix( x ) ) #### h <- defh(k - 1) #### ztem <- h %*% x # Accelerated code. ztem <- multiply_by_helmert( x ) size <- uji_centroid.size( x ) z <- ztem / size } } return( z ) } # ============================================================================= uji_centroid.size = function( x ) { # # It returns the centroid size of a configuration (or configurations). # Input: # k x m matrix, or # a complex k-vector, or # a real k x m x n array to get a vector of sizes for a sample # # It computes the centroid size in a faster way on medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # if ((is.vector(x) == FALSE) && is.complex(x)) { k <- nrow(x) n <- ncol(x) tem <- array(0, c(k, 2, n)) tem[, 1, ] <- Re(x) tem[, 2, ] <- Im(x) x <- tem } { if (length( dim( x ) ) == 3 ) { # # Argument x is a 3D array. # n <- dim( x )[ 3 ] sz <- rep( 0, times = n ) k <- dim( x )[ 1 ] #### h <- defh( k - 1 ) for ( i in 1 : n ) { #### xh <- h %*% x[, , i] #### sz[ i ] <- sqrt( sum( diag( t( xh ) %*% xh ) ) ) # Accelerated code. xh <- multiply_by_helmert( x[ , , i ] ) sz[ i ] <- uji_Enorm( xh ) } sz } else { if ( is.vector( x ) && is.complex( x ) ) { x <- cbind( Re( x ), Im( x ) ) } k <- nrow( x ) #### h <- defh(k - 1) #### xh <- h %*% x #### size <- sqrt( sum( diag( t( xh ) %*% xh ) ) ) #cat( "pepe\n" ) # Accelerated code. xh <- multiply_by_helmert( x ) size <- uji_Enorm( xh ) size } } } # ============================================================================= uji_defh = function( nrow ) { # # It generates a Helmert matrix in a faster way on medium and large datasets. # The use of this function should be avoided when the Helmert matrix is # just built to multiply another matrix or vector. # In this case, the "multiply_by_helmert_implicitly" and # "multiply_by_transpose_of_helmert_implicitly" should be employed since # this approach is much faster. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # k <- nrow h <- matrix( 0, k, k + 1 ) if( nrow > 0 ) { for( j in seq( 1, k ) ) { val = -1 / sqrt( j * ( j + 1 ) ) h[ j, seq( 1, j ) ] = val h[ j, j+1 ] = - j * val } } h } # ============================================================================= uji_Enorm = function( X ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # if( is.complex( X ) ) { #### n <- sqrt( sum( diag( Re( st(X) %*% X ) ) ) ) n <- sqrt( sum( Re( X )^2 + Im( X )^2 ) ) } else { #### n <- sqrt(sum(diag(t(X) %*% X))) n <- sqrt( sum( X^2 ) ) } return( n ) } # ============================================================================= uji_distProcrustesFull = function( P1, P2 ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### H <- defh( dim( P1 )[ 1 ] ) #### Q1 <- t( H ) %*% rootmat( P1 ) #### Q2 <- t( H ) %*% rootmat( P2 ) # Accelerated code. Q1 <- multiply_by_transpose_of_helmert( rootmat( P1 ) ) Q2 <- multiply_by_transpose_of_helmert( rootmat( P2 ) ) ans <- riemdist( Q1, Q2, reflect = TRUE ) ans } # ============================================================================= uji_distProcrustesSizeShape = function( P1, P2 ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### H <- defh( dim( P1 )[ 1 ] ) #### Q1 <- t( H ) %*% rootmat( P1 ) #### Q2 <- t( H ) %*% rootmat( P2 ) # Accelerated code. Q1 <- multiply_by_transpose_of_helmert( rootmat( P1 ) ) Q2 <- multiply_by_transpose_of_helmert( rootmat( P2 ) ) ans <- sqrt(centroid.size(Q1)^2 + centroid.size(Q2)^2 - 2 * centroid.size(Q1) * centroid.size(Q2) * cos(riemdist(Q1, Q2, reflect = TRUE))) ans } # ============================================================================= uji_distCholesky = function( P1, P2 ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### H <- defh( dim( P1 )[ 1 ] ) #### Q1 <- t( H ) %*% t( chol( P1 ) ) #### Q2 <- t( H ) %*% t( chol( P2 ) ) # Accelerated code. Q1 <- multiply_by_transpose_of_helmert( t( chol( P1 ) ) ) Q2 <- multiply_by_transpose_of_helmert( t( chol( P2 ) ) ) ans <- Enorm( Q1 - Q2 ) ans } # ============================================================================= uji_estSS = function( S, weights = 1 ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # M <- dim( S )[ 3 ] k <- dim( S )[ 1 ] #### H <- defh( k ) if ( length( weights ) == 1 ) { weights <- rep( 1, times = M ) } Q <- array( 0, c( k+1, k, M ) ) for ( j in 1 : M ){ #### Q[,,j]<-t(H)%*%(rootmat(S[,,j])) # Accelerated code. Q[ , , j ] <- multiply_by_transpose_of_helmert( rootmat( S[ , , j ] ) ) } ans <- procWGPA( Q, fixcovmatrix = diag( k + 1 ), scale = FALSE, reflect = TRUE, sampleweights = weights ) #### H%*%ans$mshape%*%t(H%*%ans$mshape) # Accelerated code. auxMat = multiply_by_helmert( ans$mshape ) return( auxMat %*% t( auxMat ) ) } # ============================================================================= uji_estShape = function( S, weights = 1 ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # M <- dim( S )[ 3 ] k <- dim( S )[ 1 ] H <- defh( k ) if ( length( weights ) == 1 ) { weights <- rep( 1, times = M ) } Q <- array( 0, c( k+1, k, M ) ) for ( j in 1 : M ) { #### Q[,,j]<-t(H)%*%(rootmat(S[,,j])) # Accelerated code. Q[ , , j ] <- multiply_by_transpose_of_helmert( rootmat( S[ , , j ] ) ) } ans <- procWGPA( Q, fixcovmatrix = diag( k + 1 ), scale = TRUE, reflect = TRUE, sampleweights = weights) #### H%*%ans$mshape%*%t(H%*%ans$mshape) # Accelerated code. auxMat = multiply_by_helmert( ans$mshape ) return( auxMat %*% t( auxMat ) ) } # ============================================================================= uji_centroid.size.complex = function( zstar ) { # # It returns the centroid size of a complex vector zstar. # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### h <- defh( nrow( as.matrix( zstar ) ) - 1 ) #### ztem <- h %*% zstar # Accelerated code. ztem <- multiply_by_helmert( zstar ) size <- sqrt( diag( Re( st( ztem ) %*% ztem ) ) ) size } # ============================================================================= uji_centroid.size.mD = function( x ) { # # It returns the centroid size of a k x m matrix. # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # if( is.complex( x ) ) { x <- cbind( Re( x ), Im( x ) ) } #### k <- nrow( x ) #### h <- defh( k - 1 ) #### xh <- h %*% x #### size <- sqrt( sum( diag( t( xh ) %*% xh ) ) ) # Accelerated code. xh <- multiply_by_helmert( x ) size <- uji_Enorm( xh ) return( size ) } # ============================================================================= uji_preshape.mD = function( x ) { # # Input: k x m matrix # Output: k-1 x 1 matrix # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### h <- defh( nrow( x ) - 1 ) #### ztem <- h %*% x #### size <- centroid.size.mD( x ) # Accelerated code. ztem <- multiply_by_helmert( x ) size <- uji_centroid.size.mD( x ) z <- ztem / size return( z ) } # ============================================================================= uji_preshape.mat = function( zstar ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### h <- defh( nrow( as.matrix( zstar ) ) - 1 ) #### ztem <- h %*% zstar # Accelerated code. ztem <- multiply_by_helmert( zstar ) size <- sqrt( diag( Re( st( ztem ) %*% ztem ) ) ) if( is.vector( zstar ) ) z <- ztem / size if( is.matrix( zstar ) ) z <- ztem %*% diag( 1.0 / size ) return( z ) } # ============================================================================= uji_tanfigure = function( vv, gamma ) { # # Inverse projection from complex tangent plane coordinates vv, using pole # gamma. # Output: centred icon # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # zvv <- tanpreshape(vv, gamma) #### k <- nrow( gamma ) + 1 #### h <- defh( k - 1 ) #### zstvv <- t( h ) %*% zvv # Accelerated code. zstvv <- multiply_by_transpose_of_helmert( zvv ) return( zstvv ) } # ============================================================================= uji_tanfigurefull = function( vv, gamma ) { # # Inverse projection from complex tangent plane coordinates vv, using pole # gamma # Using Procrustes to with scaling to the pole gamma. # Output: centred icon # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # f1 <- uji_tanfigure( vv, gamma ) #### k <- nrow( gamma ) + 1 #### h <- defh( k - 1 ) #### f2 <- t(h) %*% gamma # Accelerated code. f2 <- multiply_by_transpose_of_helmert( gamma ) beta <- Mod( st( f1 ) %*% f2 ) f1 <- f1 * c( beta ) f1 } # ============================================================================= uji_kendall.shpv = function( x ) { # # Accelerated version of the original function for medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # k <- dim( x )[ 1 ] #### h <- defh( k - 1 ) #### zz <- h %*% x # Accelerated code. zz <- multiply_by_helmert( x ) kendall <- ( zz[2:(k-1),1] + 1i*zz[2:(k-1),2] ) / ( zz[1,1] + 1i*zz[1,2] ) kendall <- cbind( Re( kendall ), Im( kendall ) ) kendall } # ============================================================================= multiply_by_helmert = function( x ) { # # This code multiplies the "x" argument by the transpose of the Helmert matrix # of the corresponding size. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # # # threshold chosen as 30 # if( nrow( x ) < 30 ) { xh = multiply_by_helmert_explicitly( x ) } else { xh = multiply_by_helmert_implicitly( x ) } xh } # ============================================================================= multiply_by_helmert_explicitly = function( x ) { # # This code multiplies the "x" argument by the transpose of the Helmert matrix # of the corresponding size by explicitly building the matrix. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # k <- nrow( x ) h <- defh( k - 1 ) xh <- h %*% x xh } # ============================================================================= multiply_by_helmert_implicitly = function( x ) { # # This code multiplies the "x" argument by the Helmert matrix of the # corresponding size without explicitly building the matrix in order to # increase performances. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # m = dim( x )[ 1 ] - 1 n = dim( x )[ 2 ] result <- matrix( 0, m, n ) vsum <- rep( 0, n ) if( m > 0 ) { for( i in seq( 1, m ) ) { val = -1 / sqrt( i * ( i + 1 ) ) hi = val hip1 = - i * val vsum = vsum + x[ i, ] result[ i, ] = vsum * hi + x[ i + 1, ] * hip1 } } return( result ) } # ============================================================================= multiply_by_transpose_of_helmert = function( x ) { # # This code multiplies the "x" argument by the transpose of the Helmert matrix # of the corresponding size. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # k = nrow( x ) if( k < 30 ) { result = multiply_by_transpose_of_helmert_explicitly( x ) } else { result = multiply_by_transpose_of_helmert_implicitly( x ) } return( result ) } # ============================================================================== multiply_by_transpose_of_helmert_explicitly = function( x ) { # # This code multiplies the "x" argument by the transpose of the Helmert matrix # of the corresponding size by explicitly building the matrix. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### m = dim( x )[ 1 ] m = nrow( x ) h = defh( m ) result = t( h ) %*% x return( result ) } # ============================================================================= multiply_by_transpose_of_helmert_implicitly = function( x ) { # # This code multiplies the "x" argument by the transpose of the Helmert matrix # of the corresponding size without explicitly building the matrix in order to # increase performances. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # #### m = dim( x )[ 1 ] + 1 #### n = dim( x )[ 2 ] m = nrow( x ) + 1 n = ncol( x ) result <- matrix( 0, m, n ) rowAccum <- rep( 0, n ) if( m > 0 ) { for( i in seq( m, 1, by = -1 ) ) { val = - 1 / sqrt( ( i - 1 ) * i ) hi = val hip1 = - ( i - 1 ) * val if( i == 1 ) { result[ i, ] = rowAccum } else { result[ i, ] = hip1 * x[ i - 1, ] + rowAccum rowAccum = rowAccum + hi * x[ i - 1, ] } } } return( result ) } # ============================================================================= # ============================================================================= uji2_centroid.size = function( x ) { # # It returns the centroid size of a configuration (or configurations). # Input: # k x m matrix, or # a complex k-vector, or # a real k x m x n array to get a vector of sizes for a sample # # It computes the centroid size in a faster way on medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # if ((is.vector(x) == FALSE) && is.complex(x)) { k <- nrow(x) n <- ncol(x) tem <- array(0, c(k, 2, n)) tem[, 1, ] <- Re(x) tem[, 2, ] <- Im(x) x <- tem } { if (length( dim( x ) ) == 3 ) { # # Argument x is a 3D array. # n <- dim( x )[ 3 ] k <- dim( x )[ 1 ] sz <- rep( 0, times = n ) for ( i in 1 : n ) { xh <- multiply_by_helmert( x[ , , i ] ) sz[ i ] <- Enorm( xh ) } sz } else { if ( is.vector( x ) && is.complex( x ) ) { x <- cbind( Re( x ), Im( x ) ) } #### k <- nrow( x ) #### h <- defh(k - 1) #### xh <- h %*% x #### size <- sqrt( sum( diag( t( xh ) %*% xh ) ) ) # Accelerated code. xh <- multiply_by_helmert( x ) size <- Enorm( xh ) size } } } uji3_centroid.size = function( x ) { # # It returns the centroid size of a configuration (or configurations). # Input: # k x m matrix, or # a complex k-vector, or # a real k x m x n array to get a vector of sizes for a sample # # It computes the centroid size in a faster way on medium and large datasets. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # if ((is.vector(x) == FALSE) && is.complex(x)) { k <- nrow(x) n <- ncol(x) tem <- array(0, c(k, 2, n)) tem[, 1, ] <- Re(x) tem[, 2, ] <- Im(x) x <- tem } { if (length( dim( x ) ) == 3 ) { # # Argument x is a 3D array. # n <- dim( x )[ 3 ] k <- dim( x )[ 1 ] z <- multiply_by_helmert_implicitly_3d( x ) sz <- rep( 0, times = n ) for ( i in 1 : n ) { sz[ i ] <- Enorm( z[ , , i ] ) } sz } else { if ( is.vector( x ) && is.complex( x ) ) { x <- cbind( Re( x ), Im( x ) ) } #### k <- nrow( x ) #### h <- defh(k - 1) #### xh <- h %*% x #### size <- sqrt( sum( diag( t( xh ) %*% xh ) ) ) # Accelerated code. xh <- multiply_by_helmert( x ) size <- Enorm( xh ) size } } } # ============================================================================= multiply_by_helmert_implicitly_3d = function( x ) { # # This code multiplies the "x" argument by the Helmert matrix of the # corresponding size without explicitly building the matrix in order to # increase performances. # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # # Initialize result and vsum. k <- dim( x )[ 1 ] - 1 m <- dim( x )[ 2 ] n <- dim( x )[ 3 ] result <- array( 0, c( k, m, n ) ) vsum <- matrix( 0, m, n ) if( m > 0 ) { for( i in seq( 1, k ) ) { val = -1 / sqrt( i * ( i + 1 ) ) hi = val hip1 = - i * val vsum = vsum + x[ i, , ] result[ i, , ] = vsum * hi + x[ i + 1, , ] * hip1 } } return( result ) } # =========================== # Replace original functions # =========================== # ============================================================================= defh = function( nrow ) { # # Written by G. Quintana-Orti and Amelia Simo, University Jaume I, Spain. # This code is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY EXPRESSED OR IMPLIED. # if ( nrow < 100 ) { return( ild_defh( nrow ) ) } else { return( uji_defh( nrow ) ) } } centroid.size <- function(x){ if (is.vector(x)==FALSE){ k<-dim(x)[1] m<-dim(x)[2] if ( ( m == 2 ) | ( m == 3 ) ) { # Matrices with 2D or 3D landmarks. if ( k < 40 ) { return( ild_centroid.size(x) ) } else { return( uji3_centroid.size(x) ) } } else { # Often square or nearly-square matrices where m is larger if ( k < 85 ) { return( ild_centroid.size(x) ) } else { return( uji2_centroid.size(x) ) } } } else{ return(ild_centroid.size(x)) } } Enorm<-uji_Enorm preshapetoicon<-ild_preshapetoicon preshape<-ild_preshape distProcrustesFull <- uji_distProcrustesFull distProcrustesSizeShape <- uji_distProcrustesSizeShape distCholesky <- uji_distCholesky estSS <- ild_estSS estShape <- ild_estShape centroid.size.complex <- uji_centroid.size.complex centroid.size.mD <- uji_centroid.size.mD preshape.mD <- uji_preshape.mD preshape.mat <- uji_preshape.mat tanfigure <- uji_tanfigure tanfigurefull <- uji_tanfigurefull kendall.shpv <- uji_kendall.shpv ########################################################################## shapes/NEWS.md0000644000176200001440000000473214362534645012655 0ustar liggesusers# shapes 1.2.7 ## Features * New backfit function for backfitting from PNSS or PCA scores * Added tangentcoords option to shapes.cva and output all the CV scores (rather than just 3) * Improved the 3d sphere plot for pns() * speed up pnss3d when n < km-m(m-1)/2-m ## Fixes * changed rgl.open to open3d and rgl.bg to bg3d # shapes 1.2.6 ## Features Added in pnss3d and plot3darcs for displaying the PNSS modes of variation # shapes 1.2.5 ## Features Faster versions of some functions kindly supplied by Gregorio Quintana-Orti and Amelia Simo, University Jaume I, Spain. ## Fixes Corrected bug in estcov for method="Power" when exit occurred in some zero eigenvalue cases, by including abs(eigenvalue) # shapes 1.2.4 Added Principal Nested Spheres (pns) Added Principal Nested Shape Spaces using PCA (pns4pc) Updated some references in help files # shapes 1.2.3 Minor adjustment to Penalized Euclidean Distance regression function, including a different name ped() # shapes 1.2.2 Added in a function to carry out Penalized Euclidean Distance regression, which is a sparse regression method (Vasiliu et al., 2017, arxiv). Renamed the function sigma() to sigmacov() prevent a warning that the same function name is used in the `stats' package. # shapes 1.2.1 corrected a bug in the calculation of principal warp eigenvectors in the function shaperw, which in turn is used by procGPA (thanks to Paolo Piras) # shapes 1.2.0 corrected an error in apes$x[,,60] data, which should have been the same as panf.dat[,,1] (thanks to Katie Severn) # shapes 1.1-13 Corrected a bug in shaperw for the m=3 case (transposes needed) (thanks to Valerio Varano and Paulo Piras) internal expression of bendingenergy (benergy in TPSgrid) has correct constant now. (thanks to Valerio Varano) # shapes 1.1-12 procdist - function added to compute different types of Procrustes shape distances # shapes 1.1-11 MDSshape - function added to compute MDS mean shape Several new datasets added # shapes 1.1-10 procGPA fixed recently introduced error in reading in complex matrices procGPA( , scale=FALSE,pcaoutput=FALSE) was still calculating PCA, so this has now been fixed. The internal function prcomp1 now uses eigen() rather than svd(), due to some convergence issues in LAPACK for some singular matrices. transformations() :relative translations between centroids now given, rather than just translating the original to have centroid at the origin. shapes/MD50000644000176200001440000001075514367300611012056 0ustar liggesusers358c60d912af32d1d7d2590cd9735a39 *DESCRIPTION f939fc30003967907f83c156288a15f7 *NAMESPACE 664328ebcf77fae1fcb6c7175f298913 *NEWS.md 201fdbc6d0c6d370720c156f24381886 *R/shapes.R d3ea1fb9cda2630710f536c2d38c9727 *README.md 3b8a5f28d25227ed088213782b9ab8b9 *data/apes.rda d99db52cca55fa71ae7512fec7573f64 *data/brains.rda 9e395979fde055644a44e87a23c96cab *data/cortical.rda c6c43cb33d0547bd72f03f53529f6cd9 *data/digit3.dat.rda 5b2b226749f413174a1112853cba0d7e *data/dna.dat.rda 47131b86b06facacf61af030ff41a82b *data/gels.rda 485968fecb7c9b83db63dba94aa34ad0 *data/gorf.dat.rda 5d8c69052b4b68c876a67fb547b45e52 *data/gorm.dat.rda 1a4e88ff75c2eecd54ef949f8fac19ac *data/humanmove.rda bdd5cb3728bca4461f410f80c2c71e36 *data/macaques.rda 1fb26de115ba687c157d12cc3d2e50c1 *data/macf.dat.rda 7d668582b8081e57f74fa58cf2e0b5d2 *data/macm.dat.rda 04368be5827674c284ba4531b2636bce *data/mice.rda aba93dbe3e09b7d3983a340487b80997 *data/nsa.rda f7bc46c4e4a76a5dbacaa90b69146c10 *data/panf.dat.rda 0a8dacd8cbc869724073314e81920b91 *data/panm.dat.rda ce6d25a412c466694c9f52cfe0548775 *data/pongof.dat.rda b6d8c7078f6f5e13a97ba360e6fd531f *data/pongom.dat.rda 876a13e0c3dd4c53d2de7ff7a85dccde *data/protein.rda 9c5948cdd794c8dc1f08d37116274c26 *data/qcet2.dat.rda a8e68d54a0b7d6dce842d10bfee27dc6 *data/qlet2.dat.rda c36707142e4cb9be90fe7c52240c3186 *data/qset2.dat.rda f5fdc220f49a80d15a50b158eedc2329 *data/rats.rda 14bc0ee6c953aaa741a3aeecb2510381 *data/sand.rda b1eaafce3805e2c6be68698188098c50 *data/schizophrenia.dat.rda c281d62a3d542cd8058d308d8232e19b *data/schizophrenia.rda 7e49958784ea7e98541f40d1849a3252 *data/shells.rda af60207bc80e5703fdf18d3011f159ce *data/sooty.dat.rda 6e8c734e0dd1f8fbcb3b66ab7a554c6f *data/sooty.rda a78b351ed63f3d69852870cc4df13fd4 *data/steroids.rda 410cc000136d80ba87a663749aa276f2 *demo/00Index 5d448fe971892a3483515f40c5402a34 *demo/shapes.R 187661cd9bc47f539fe11488ee86ac25 *man/apes.Rd 774f9635e9fd367a3b1a74148965a2ab *man/backfit.Rd 8590d9043d9ab4ddbbf1b5615de2b6e2 *man/bookstein2d.Rd 43caf534efe53a155446b090fe16e932 *man/brains.Rd 1d98459f215fe87530fb33add80df3e2 *man/centroid.size.Rd bcd0f6edaa55805087fa425408721fdd *man/cortical.Rd 920cc57da48fc9f6ceff230f225bc89b *man/digit3.dat.Rd 70a3c688480c2c9aa1960d8ea8514b35 *man/distcov.Rd 78ae2e39a70b583ec19450667ff6d074 *man/dna.dat.Rd 745a3aa086294f219a2cc75a16607395 *man/estcov.Rd 0aa7454ac472b856572ad8f6935dff25 *man/frechet.Rd b4b6d3b94500e52e99fa346602c3ac4d *man/gels.Rd 30184d8c7803fa4b71e7d6b15e3ec8b7 *man/gorf.dat.Rd 619abe9a5bf87ecc32867ac3087f04dd *man/gorm.dat.Rd cb39b12f6e3aaf82bb2bf9fb09d9cadd *man/groupstack.Rd a560acbbe582cda4285edac716530a1d *man/humanmove.Rd b83ca76894d6959bcdc293101ed786f5 *man/macaques.Rd eae66ac549b345476fd3eb683e14696d *man/macf.dat.Rd 0fcd203a740a02c44ba423d990710de6 *man/macm.dat.Rd 7e8ec886d6c34ebdb81ab5b2d3d3c784 *man/mice.Rd c93330db34d3d22fe366b408ed7283e0 *man/panf.dat.Rd d611183f846a3d4ff67ef7e3969e82c1 *man/panm.dat.Rd aa923c97df9c4982094b54e1c95ecb33 *man/plot3darcs.Rd 8eb794436eea3ed408878f0f550f596e *man/plotshapes.Rd 3c533a8e7a56f598438dc40e78bdcba0 *man/pns.Rd f49c8f2a4ba8d8e60cf201fd4b191cff *man/pns4pc.Rd 6fb8c922c21cd17b516bfdc455183295 *man/pnss3d.Rd d7f329a153fc31189ffa89da13d6d1e8 *man/pongof.dat.Rd a97ac227ce1bf25de273abbd3a71608c *man/pongom.dat.Rd da19be8a7a8e2a687cb9faea228d7ed9 *man/procGPA.Rd 7cbedd3ee0a06fd232231d43114b27cf *man/procOPA.Rd 69f39b16127ff402d7623bd258a9d5d1 *man/procWGPA.Rd 5da5984fe879dc6d5b55cc0d69472e81 *man/procdist.Rd 368e229764a3341fd8a5c98b50e01005 *man/qcet2.dat.Rd 366347b1da7d6bbdf058f178e6d55cce *man/qlet2.dat.Rd 3850b0377362e2b587c44b4a587e2bf0 *man/qset2.dat.Rd f56a338357e5ad51782ebe29dee83664 *man/rats.Rd 48966fa9148a8bdc9d21130220487de2 *man/resampletest.Rd 2185b7b48c610ab1a10686e6a52a898f *man/riemdist.Rd 687e6994dd5e5b355dba77933b60c995 *man/rigidbody.Rd 36f7c49ad5f162187046f9101041b64e *man/sand.Rd c0c2ec3509ba14a0d765eb0a73172bf1 *man/schizophrenia.Rd ed8fda94455439858da784dc70b9385e *man/schizophrenia.dat.Rd b9571afd18359f92c5724c6d44637424 *man/shapepca.Rd e82a2e2c1a04cd69dd4118d39ffe84a4 *man/shapes-internal.Rd 7d9320fd3693191ebfff65300711c78c *man/shapes.cva.Rd e4ac610121f516f3737e3ac990253345 *man/shapes3d.Rd f23d5fc6b98042f0a441f549ee5c7020 *man/shells.Rd 01a0125ce0a534ae27c4922aa5e33876 *man/sooty.Rd 6b0467ae3d2530d8c6cad96dedd2d69c *man/ssriemdist.Rd 56f0de6b0747cebfe637d52107077290 *man/steroids.Rd 89e8e5ea592bf16f5c2a06f217320fd4 *man/testmeanshapes.Rd f2b16307f2c8faa20e1f8515a132d1a0 *man/tpsgrid.Rd 4427eddd390f9e67158f4e694e5c4990 *man/transformations.Rd