mixtools/0000755000176200001440000000000014343400153012125 5ustar liggesusersmixtools/NAMESPACE0000644000176200001440000000702114343056250013351 0ustar liggesusersuseDynLib(mixtools, .registration = TRUE, .fixes="C_") # Export all names export("aug.x") export("boot.comp") export("boot.se") export("compCDF") export("dexpmixt") export("ddirichlet") export("density.npEM") export("density.spEM") export("depth") export("dmvnorm") export("ellipse") export("expRMM_EM") export("flaremix.init") export("flaremixEM") export("gammamix.init") export("gammamixEM") export("hmeEM") export("ise.npEM") export("lambda") export("lambda.pert") export("ldmult") export("logdmvnorm") export("logisregmix.init") export("logisregmixEM") export("makemultdata") export("matsqrt") export("mixturegram") export("multmix.init") export("multmixEM") export("multmixmodel.sel") export("mvnormalmix.init") export("mvnormalmixEM") export("mvnpEM") export("normalmix.init") export("normalmixEM") export("normalmixEM2comp") export("normalmixMMlc") export("normmix.sim") export("normmixrm.sim") export("npEM") export("npEMindrep") export("npEMindrepbw") export("npMSL") export("parse.constraints") export("perm") export("plot.mixEM") export("plot.mixMCMC") export("plot.mvnpEM") export("plot.npEM") export("plot.spEM") export("plot.spEMN01") export("plotexpRMM") export("plotFDR") export("plotly_compCDF") export("plotly_ellipse") export("plotly_expRMM") export("plotly_FDR") export("plotly_ise.npEM") export("plotly_mixEM") export("plotly_mixMCMC") export("plotly_mixturegram") export("plotly_npEM") export("plotly_post.beta") export("plotly_seq.npEM") export("plotly_spEMN01") export("plotly_spRMM") export("plotly_weibullRMM") export("plotseq.npEM") export("plotseq") export("plotspRMM") export("plotweibullRMM") export("poisregmix.init") export("poisregmixEM") export("post.beta") export("print.mvnpEM") export("print.npEM") export("print.summary.mvnpEM") export("print.summary.npEM") export("regcr") export("regmix.init") export("regmix.lambda.init") export("regmix.mixed.init") export("regmixEM") export("regmixEM.lambda") export("regmixEM.loc") export("regmixEM.mixed") export("regmixMH") export("regmixmodel.sel") export("repnormmix.init") export("repnormmixEM") export("repnormmixmodel.sel") export("rexpmix") export("rlnormscalemix") export("rmvnorm") export("rmvnormmix") export("rnormmix") export("rweibullmix") export("segregmix.init") export("segregmixEM") export("spEM") export("spEMsymloc") export("spEMsymlocN01") export("spregmix") export("spRMM_SEM") export("summary.mixEM") export("summary.mvnpEM") export("summary.npEM") export("summary.spRMM") export("tauequivnormalmixEM") export("test.equality") export("test.equality.mixed") export("try.flare") export("weibullRMM_SEM") export("wIQR") export("wkde") export("wquantile") # Import all packages listed as Imports or Depends import( plotly, segmented, survival ) import(MASS, except=c(select)) import(stats, except=c(filter)) # S3 methods S3method(density, npEM) S3method(density, spEM) S3method(plot, mixEM) S3method(plot, mixMCMC) S3method(plot, mvnpEM) S3method(plot, npEM) S3method(plot, spEM) S3method(plot, spEMN01) S3method(plotseq, npEM) S3method(print, mvnpEM) S3method(print, npEM) S3method(print, summary.mvnpEM) S3method(print, summary.npEM) S3method(summary, mixEM) S3method(summary, mvnpEM) S3method(summary, npEM) S3method(summary, spRMM) # Import from importFrom("kernlab", "kpca", "pcv", "Q") importFrom("grDevices", "chull", "adjustcolor", "colors") importFrom("graphics", "abline", "barplot", "hist", "layout.show", "legend", "lines", "par", "plot", "points", "segments", "title", "axis", "polygon", "rect") importFrom("scales", "hue_pal") importFrom("utils", "packageDescription", "tail")mixtools/data/0000755000176200001440000000000014343400152013035 5ustar liggesusersmixtools/data/RodFramedata.RData0000755000176200001440000001375714342153463016334 0ustar liggesusersBZh91AY&SY&O 7Fۭ E'$oȸؠ"<>0o/-ւKX@0LLmOI)@hihޔPm hS 44@%24ڀPR?Rh<ЍM'&TO)jz4@4 @4z=LLP!h!J%4ڦziG@i@4 4d&ѐM1 4hhN!0O{lvp3uyQi*q|PNpHb*P lTt2Y_MD>0gfҪt3 HY1Ci٬z"O _[a#WzQ:g`!M pcDJ`  vU0 )r=$j膒 h(;l^cfpwM12"D"%D  8go{xPPٛyh@v5j '*D0 b_ 'V0>NX%0oDV`MpY ~@XX2+c,ĹޙneQu$8=MR8C8 \bmyߗ$v R/h/f΂KrQ:RfttYxqtWտɞ]: *؎u)؋ X( ?glB XC@Ub2(7KHH8JKG{҉ s =W*-5J}"mIau8;79ly 9mu9D)(9o=n9$5#8";i*mKi_v[pڑb>UgD[9tuiHtT F,WS)?&-›QSJjA"YYbh{9 -YCcpguxhwC~i&C¶#a *U|$Y/0MLسx {ln+{#KP+HAS.L< `3_Y|޼R!BtCJ@ni%D":<0ԍLOczB$xsjA!Cްz*ku1D0ٜo9gfff`JR)0- :j߱kD$Z4v1h@ڕVvEW \jL.2EuRB\;kZVJM=P"5< `D=]Ta:-bx8p043(9I\sDHl@n C G@W1R)m םbyǭ;:Ԯw-"si/VmʳׯA!D/,}aM^ ;bx'cMtH ʶR*IMhI18;_Esn3[W5鹨R%H5eY bS y<HxݯNV¯+: ]c/,ʵ2&"-!AT%D*jC{oDy[o.lOYեz-ZB(ZRx(\q0,r߮Ea B([Y9`7PH*3$I; ^iwdɕI1H6wGz"=NO ۺc!+J[cNm1~St_LTɅ\1^*WhJNF)Ű3@T!RР1iQUUP!ZbO fH- 4d_jtK5ʌFsyJx3aR- I&W5 W{J rE[pG>IDZ9)!/ᒙǙPVFs)axv@XdݘVF!ܛrXg`?X |CL[hC6;F*}ϱMEQD"Vnp:eLnv`iBډ[r rm@߂g㏝9rͭ=W '9%'Nrxn,vW`9@ؕD T&o9@Ɓ.[_bC8bTՂu\g\ !5[ZveF~IOnɘZA%0%p"wKSls`PGes_yyWzOx@C{m *B@*D|;;B2ɺc4#)1K3#3-+LLJXW $Zrb0> B" BeQi"7!rbiJ6T 4首4&CTRBB B# ":@vЫ@:%'*9+@) @ SB4 "rG D6Bsg QrU@/@B*u8drM&tD+#@ćf>N̎U_x}O:뭀`j2;4Sֽ mb1M Oz'8rSV !*IЉb9W L{^|6.wKYS$ˋ}֟{P* T$WOVEtK6*!@,B&^ BRCyf@%ZK3V ~ćEP[X} b$xF!\u6tD +VM -0yrZ~Bj+M]Yːw.*|f{I,Fۖܠ2\1b]%pO=.YacǔZ?s#sWT+'%벍YKw1xy2,b#qZrRw(6 'v6dQ"2 ‘MtvrR8oXbo X]7Uߎ]! Cݻ܉­Do8SgjMyNk=]r tv ' G)X\=Y1+lPpdj%qDm;8g.1Af4,y:.ž,z}p6 X6 [ EZ TH؀是tIH/4+ۈޗN(А2}IdifeUjXr۩} y˗ o87Nw5UPg c'O"-F12a[cRRab#ct8M@͇5a`B,,Ӿ -)X'RafscL(Nn(dhյФYmpÁ]yn^ği}ITvB㋛a'qB-Cq(9 >ǽ bŒvZtaUA4moa? *:^-{wm| Q-b2*^-jṼ (牬M0`369 U)=X8H>ѡr]ڃB(ۮJ!MjN=1C"r3oC-4%t dx9|D⣘'I~L6CKM@-+Db5"i3 ݙ)nhy_=ڷm ;QET\dV(֮dIu=RKܑN$1%mixtools/data/Habituationdata.RData0000755000176200001440000000117414342153463017072 0ustar liggesusers r0b```b`bf H01'{$&e&d$$200 30ނ׹ll!׭r;LvK8(>K;(_W*| A,qPffPPꡇiS?PఃB O;"b=<}.{4q 3qn積AAJ5,tqR[t8 ^V:A7k)y aM+VL`uډEdA`SuOM㛃16{ᆈ5!bP ' {-?w9V@MdOVFs ׀ګC'H<,4 uЄ R^ }9&\ Ww+A sw0O賵أ ?Pwj@c>Ɛ3SMvsh|+X?F4 _쥏+?:J 6e ^]{̡kNphٌ5/17f. S!e!9'&ʡziE@Дsn @8 mixtools/data/NOdata.RData0000755000176200001440000000222414342153463015134 0ustar liggesusers]TU̎;;.Yj~ȹQ2NJɶ殩!/BKYTDjfvvf7ﵫC;̽9sݲ!'R MӢZ&nƢ'G35]#wiZ)Z}ѡ7趕_ .]k_O@qsgbu$<8/ ,za͒w>nhA'k55A/w ]x0E~߷%,f}߲O|y< /:xUV3a?7X{9E0!jdӯ>WLpC>0u8šX _+em->Sa%r=\`rLsrא?\],T(v ,4D6WXmG^ۢ{N,<٪ʒ\T.9K/X|'8z^8[DΝb ƕu.2<%iRXb]E}2 JwB^s=gw'c Kޅ"_]qpȣNYn:P:UB=DA?(a/b}aP1Eu' 1K 8a=ze1 ƛA}GU?Ϲ F;^b2ՍVO>7=?dB\w qs7ڷ.D:CC #4аB '4XFyYddddYdd9ddC'N :1tbЉC'N 1 b0a A 1Lb0a$I &1Lbİa"E 1,bXİa&M 61lbİa&M 1b8p!C 1\bp%K .1\?2b mixtools/data/CO2data.RData0000755000176200001440000000117314342153463015205 0ustar liggesusers]MlAǗBak?(jCeh mB6 A8a?&=U^IzLzփzj3NB͐iO01^GaKӌ"S""G~ۉoy/}Ϩ>w??ṈZ88;O f)]7/>~I16>ͽ:J/ZC>ዟe(E~;sÓ+>ouƧaނ5~[< a<y8A]\7EG@?10a|ŕN}1e .x%i~Y"dɜ1guFĴ'kE:.˺qEUF,<9F#ޱ! 6^,=ڛcVűpت+6S@p*]Z[imVVѦQݦSکC[pᒔ;3za4^kjA'wZ;ܠ3i_8?^(K 3R+i B\&J1"(EBJ&#F<y0`ȃ˨2IHZqr^_]'mixtools/data/RanEffdata.RData0000755000176200001440000017427414342153463016000 0ustar liggesusers7zXZi"6!X])TW"nRʟXa%>"UGQNȐHRYrNăkGnS܆(%5۩%NCe S֛US{,Ƿk&j"=9F1VjWx<$k 5ة@\y* c"ؑD,>|v;&njJIqA)Pcg ?mouO4pF6@_B fOZLLy/Ҝw>t 3 3d V޿hC!#E@[e$[-ce.tMYBQ}՛`d ͒ɰya @{8*V[;p kp渌Et%2]!m!FGt64+9n{).(itG/r끈(,?Dm]i3Y3<4v+j4 m@Ř}H+fv7Lt7=j 4on~oXI %ItaՃO?JLHo xQΑ߶QX|ruyVw{ʇKY#^ó+1JK43M jM+UCHW$l{>{q&fC1@`γlmׅg4YiZVAL*5!_ź|f.gCuW<#ɰ#5Q}$an P!?ώyJk^5Rh@\ԝR2urfN`E}&. h7f$.@9>zon*p4sܳm/>WRDߖT;L27vRhcwsi1qzP*UȼG_CQ76Ucx/jB AʟYg&l;:#8˜BQ: r֒}jYs /sd?*9t5ĝ!=.},mj#^;TT/r#8X&I0Wm2Mj'%ɇZU~\FrB6čЦ -OrYOJ-Z7,ȃ˻aeȥrsI$exr5]_jzNͷn"p4h /Ts2kZVBCZMqp0FjnSg D0!EHhO2wy@p/ʝЕOlnM"C72~"pсnjsTx坧ɭ(z*TuǵJs3xlLN Xii9'1yG`^|D2IIt͝kXݱyfdz | if[SF,-/1tF2=.h@~JEAp<cq턌<&a49K5 60?p𺍧 ܞQ7X;E>ShѹР@̣gpuK~=]j@4 gA1TwZ#Uek?̋6ޢA`IurqLW}!SL:% wAZ4_Jr1~W@',4ۖl3P3!{)Ykf vcdjya\m]FWXds xWFt <70 dzq9fː|š`óBBLηQȂ@*gϔ 4 $rQAwxr8\vy :d]4)މPy5 :/eΦXbc$q3R ?Lqti54gH潂DKJ}$YOuXiOq &9ky^0D0@Mx!p*nR2Oεv,R[tK3EqԱy(6͕E1PEkпˇJ!yI~lsQk=Bl 8( GY(G05kQLcGT43SJCO=NR}ʉЋ V8{]mSjX{d: aij~&YuV{J,cDZ* 6!4yj - '+<#94Mz/f^(|ju ]\-^$^\S[G%eNd*hBNicӥlXɖۜy\By]`j`!!!( 驳6oiSRxom~. #q/)o.@0?d!ju3Sj_2 Sun`tMHkW ~FAngl7ۖd|QyKVBR5MPD| /pF2i@NZmP0Τ4^(ga~y{2m1&q(?/at4{a.:w;p9@/뮬aHzL /S]@x~ۆ#Qy:ˏz$Q^қe`}qqFլg?N دyV[B~ f?ouzw+KNѷ()!M Qkjy $ƫ&uL k)< kn!z䶫`l8|a X}YJ_iw e8yBD(F*[mLLv0>?ďKoNV-ɹ sJlֳQ1Okkx(f1q#8k6Oͧ9ހX>],<33 BYAۅ_ &E#"CUn._qq%n5m17 Ch/1hCu6@Ie`Mb_6:sg3}bwڴAZ.1Q݊IxN%ɮ8uiU8[PkID /g]0Zݨ4S?YU ͣ׬=}}oi^E59ߞIoXS$T6xmqAdp_2 >6΁f9&視sI(crAL~\7WԸegQ>ڔG-Yۃlwe1 y fݦ0.!V$lr+z`w*2 n߯J~ a? Z')Ojݰism׸?97&zjⲀ)e,HP<`⣹m @6 ݘn[u/d}DLSx)l +]˘MXܺ8 tU-Gbr~6*9&IgثL2-^ P̀ݔ3ីKu^ |a֚8(FTRm uL@H0":/42B~}HChLw2L} RSɢ>V6ȇ1͗YtRR2 _\g׺ǠNn`A 'An#嗺KM^C?ylTA 5J _42d@޹% c x;*x-2R᠎xc3q,NRog%*]Uk[ܺ7il+FT I떤x^OZ|jO j6/[zr!lqrSpm{2{›C`DP{>$5(m#-@s[7Z;|] #\b 3Rt2QzFʋ~. A!Җ{fʂǿa w{1NxY]󱭸J Οo^ͫGL(le6Z7 ]moWZ;V+kyö搊XU8:0+-jg+Jv_Co!?pX6;caBϲ ( /Em%)@-mx<\4!4}-NdFY!ڛ_NqAkH K+}evBCY#=8^(}3 h D S$kK( ! 8~.l kB>VcEQ63%GeW;gZx,.Sŵ'Հ.py܏;aUxRk`Lj4yC)m.ޙѕ9ۑ(ua[)sE*pISkfk9 DH|AJȟliy9j'lf梂WG0Yxve HOgO=..>nI+JZJVws 㘖o1*c\Tb+Rhcp+xN1xGhV.iĦ5b: 3ZT5|@5mu{C2HC @KA3}|{CF#[5׾ = _nA"FŗT}ÿ8KRv] VH{dxaNl.x[9vP#UK}0:q/b9ӱ5T7*=UUQDcQlpD 3DfE4{hu{HhUۛ8yh%5V_76M^[VԻR37a*(xoCKu~t^ܦPvZع =a|o6G|ki;za9@X$_yFqvyRjQ@Hsr!6IE3s2_u~٩Ȍ  ^aNE4sw"su[:Ȥs-<Z 40Dtki7$U7. |ҧ99.TUt nHG9s>9&6&gȣw2˳?WBb*j|E1ptyW UXEp$lz$Etm`>5㢝cdq'}Q H{>`oPַeQ.ѓ_V.q湋Fb A[aEtXԵb givw@?/Jo' O27 Pǘ3ei0W"Mtf~-Rt0Jc ]oo9f#7 f?]^\/VD2+66hs9k .FTY0wdb-R\:Awx~7bTc,LEI( \ fHkڬh<tN/AJɏ >_|?yXK>Y1?W[B28iIU4BACԊn~Z&( #D;)ZP"4RKꀟ,6T)ZJF;v2EЂzeV(&5UQ-ZőT 0yQ*1aSb`=NxS @qIwX !6>5R^d*X%t&bh׵I>KwB i~0OU =U9%۱5}m:E Yұ~%PVQAKըXg=ʝľV!\ IH`"=&VHq7DO.OF\vMq\DF:ZFK|7嘛rCcn܀ņ>zHEe"|Pj4w]7_&Rdh1UWw1Kp'?O,2Ć1x^VZKZ/ؙxL9ϼ%dW@V|G%.8e tS?!B;G״^RʚwiT" 0]M^dbD X[ B$V|141֨4; U%ӪNog25ُX]JX ?ZeOHx)QFN|boBEѩ\Ά]#9MQ5K dřĉdn3S |8-iO"2ПEs߰qZ~HZ ’"Ry onTl% ݫ*ľKg: 'Sގ?qbyiujXӪj2W0dCiX3F\[`acF mCT>F61 J-alؐT;$|]'nԯ?GR)(>&uU;RI.C|-X"Mל{uɚoKv*>|?i˕:J^]S t;2kXT1w]I4 ۑ4Z!j`vH]8C޷w~,,B:"%M#жa$b"ٴ2_ :m3{Do7Bu_(b!/dX\܁7M1`h?(:' Tb|LpLT愹TthS% ,]<ti/3O}O~,<ܔ^?GXZtƖ3F« tH(1ڼwDzd 6Ney61P&Sڒj+j?)Bh=ݪȖq]=_B܏0;ײ+x*bQ-cV\n"o㒻]^cd%!jݎ )&% j7G4NjW\LRKȜ*+O}v'u0r="J氭<'Gr&ՉS+ ~en\:5ǜELh]`zG$3]_/&7X>@F3(S5J#g>Rڶ' ?YFvadeeS d^:75-DxcuUp:w/_vِVT^ph-y If;a^?f" AE[$s!*M(z!h&;ך)qB[V1@=Ӕp(w7vc <сPHaح۴MxYRUQ;!V pM,f&Bear5 @S17BRE4E AVqu5ie/phLC2gήz(gDޙl+Cquv:/'Dz|]S`` 49\SSEK|P'R&%WlOЌMn3< ;Kv wnU\pR hpahkvZG_kpcVvv8QnQ$uWa¨ ʗ8Vӷ󗋯e2G{w<'^}XIF׺ь< U~,,|u>rPƴAS%I~6BAJ7ӽt{âeU_2U'Q_MqOwCcAڃsj_EPKд dY ~-Bh}|0QI>=$Gm!1QjW>$v4*_k2V!ڀŧ7um޸w4IieS'0Ck h1l7GO8#(1Q%*`"TAv\$鬽 7Gl_6Q7kMk<E%a%B{C {I.tB#QY{弑Tԏ':.Y# 0(ѥ'dCMIYՍ%Hǁ.1YNm @ f"nY%VGԦad  R1-z ߀?c<-cJ.KOfPюrFhYDhis39v_\GCLj}ph hhiy ظݽ(=g3Kd [ߎ3>YŻAYTʬ&@uVMHB~drqt Rg[=}J;8& w8 . D/8j: ʭh>/"l)6ؼ'z_~= SHAtsӱW{D;Du~v;*sI#7C]#XwM[s;t9JҘV:1Ӱv|2+.caG& S{ 8gs!ͫ=h֐~piҞ٬:l:FD^{^=:_ -Wm2{I F[Lq| vO>MLE=CuLs&1Ѻyصs*Jێ ?X\!s!,ѿ;`hcM꟡/Z1yP}6ɮ3#r߰nF9o'3w<1ѿ.yi#t8nd3d}%;lD {R2/3]n^PF4; B_/8Kl=pEfp>T٭=MTyPzR=uLS9JLȋڟc_`.ÿטA0K5G=c[8`a{,Vuo58jhaԼZfOn@`q yXvYNMçU7!Rg bRѧ҇JEܖMLdo*=Ml(UjM@eckYxroțCdcB~#k Rt*IVoL3,& NTuvN3_^Kws/jY#2! m'c}պN?}ǚx&>|In ۛ ؓ 2( kUޟxa?b4D{)h `2m.["Ӳ]cA=%>o Qsa e$g??&|>Cm h ^;0&s7URjv}Fc+}3jGe+D]1 Oq#ŬFJ}b4Dw)}RKS2?Vٷ=Y)i9_&eFDfHޠ,9sA:>zB a⇥Ok li agᣒxkQiH~ZFQOǿ/ǜs6ާҟ jѵ)Z?onr)jdY4+„/dac@iʧռ {| vXvi%qj`ͭ?Ը{>I2c :4C ˈVLsGNgo5 # [0CkVE>N ߉ ns$C$ 76J;O#nDЫÀX}dEjGyLk&DJgY (؂lu90}PL_MVʙD4!E^ BBRHƂnbDֹ61z7;BF!w2V<"Aq[|Dϕ#l-PǏǟ",߱< %rf G8I8㟗'D\6U5T:PpM1P=`| Q⮧Z*۝8 Ukc*JZRE>لC>c""wv6/Jm V/j ˙,!:;xuʲz:.;꒡+І a(!xx-D#L"R\"& SHP67F%y+@i7\z%웢G)g=n-7,359|Ig ŒZLh#xY%˟V#L_A]D\L_/=23͌i>32R*=f_/ԕNT+ṴۧP:OWAtdoӚnj/t="Bt7Oal{g)oKO 3'M5|-)|fcF >C PxNlXcNT;S 9eޚ39]Nj omKnk1D/}Uϋ]lŞi~Яσ.hx@h#hݨ~7X6 v14r>1ŰJ{u{wNBw-nz>rg}Oa3Ƨ8}URXq\Z֑wSIV&@˯(Z?{jTl!,&:4=%N`64K;Xc\=ZMGȌNǖ_ ;UGqI1V~vRU&G[j.xqm_f;e$pC]F.b+@,cs}1)(令f|Z/WE~~;-[k7=*z 1U\펪͒jg.:G{BҨu*$ S~t'Vѹ>˞ҋnp@&O29Fǀnu[oԡ}u4fn.F*LcKP-0iEExgߠeHLߢ9nG ZV4jJO> ohh638F|\Kft8B` K= |S@f@|&e(G;KϺ2ZPW=_u&aJb4aU_#&ؽbl!H 7Eo?_G!=瘄WIC9Z[Z,y F4N=C6qYJ^BAuǏ0O_W'YU٤痿0ѽux+Rq~<$m.63QEU$Y$RWft2[YFq$Vm+-|Od^ʥTOuj.wGeWDX0R]͐Zm\_)55K leg]sp5hr0%$x!]d0+Cn6rB[E>VǒNPC Y>vsP(3p vd[%zC(mD(5|c%/Xڜ,yXc[tnd0^"yQ{3]@WhrE)fG4ԹYOfn%)fg*aNjIոl|?zt`Ҳ]2 kS %LR#Rhlhac2^ZRkwԵϲ58?=_ S*ڤ՝sF6|Qջ!`VҗS:5FQܬeUKK6t qPi Py1 M>Glŵ KM8 AgEEQ]|ihh7+"stV e}^,-{z)MG9h0?:w5^nM˹eUfi8MjLּ1 ;T$4''#y$2K֕ +Ht;*\ mf&|]T,͉Fa@{{_|oj Yd؈?b%@MյL:G1qڧx㌗|h[ eN֪rs^I<+mc)(6SCVDxהP+.%<48r;qDues`\>G& ^H/=hl Açyi䷹G5%% ^Maf&,-rm>jO!#]4RgN 朰Et[,j0}wD/ZhqPè d\'>|#,Lُ4@z=҅3C ƌ`q{8y~ ?Zى _w?\J3ˬӼ:Ƒò>|Bw$gpNLS0.N@CǍ(E3VݺȶUΞnl%$V2%dQsP?:V(0i 6w'?|YKu)0U'.-F)T(XKظ0\$!dzrs5U%ڧK8[3eb|l)-meu"4}{piNa2m(ryb@r2O33bYˁbRտ`Qyx9ȅ#2 ) K̼mGph`4̥g;t11ci)FOs_/bmd|psMzO˱+̇{exj#׶ e9A}'NuG>mLgJcx1b%KT^lސ>fj[z@%GSy i3IO0}}ԞC[H0=?Vs< Ҩu߂رY lwY2g6G~t&Zb*:՗2yRd}E{wʈvtywO ]聂2wRh*`@KwN1+-JĊ2JA⁍<(^A&۱ΐSҠֽIu8Xpu.>҂du)6dqE 92T!}-ō&4<ΑFL2j[/KC)LjM5ǝZ'MBJ҅zE^͠M5w%ۢ׭t7Q0ޗ9YvHdvI5xΏ=AHW#ج .mX:a^AqQu>\&ӓk#_7Ca{h" u^=fWjj~8˽_I&@w!{X׉pP!V+&3?LyWu QJq AP#KVhEws~,6#q;&)m]a^3&d1r!zg0_s^@=+kQIB2ga0G^?d+,v= ud{/+g^ةPG}4]A<\U. Te+O;侵0d 4R'9 ( 4t¤ ;K; HKiYe 3j)z.V;0*ǚe)@,LT9F+m@TũSF?c!DKuVhȧ˒%KS(#d12@":_l:ZPA[S  `YbZ&Pؽ$:K/to@K50jijH&҂6D$'~,6ItONw/S2@2gidmA'%/-+l,:\]YIc$C3 'liZTXi,61ߔT RrmўMMiO䞸Ї&#lR>7n['xSp*oX] 4!0y@Sj_IȕJZr7pj5/o1ⷉ"͎@X[0CT-ix%1F?p/l}emIB _eMz]UP3 ʥ!*-Ć ai GFY5ٓ`2jbôz ))layȱ"yTa4fD턤on}x҅vL YV#)eTݫ64lքӜݔd8[D;mJ}k!?_(fkN[J Jǘȁ@PQu]lh.}<^E sz_H;O$ZƴX!;oi}a0 x Pzn'yBPiǡOkMTP֜Xs&P-c"^[j"b :rK^k&t=&jIx>W} d.6:'Ўg5 ] 8cw3\Hntiq.Ĝ\R28 8a۾x&r2E{^KXl5k6>1 rm@]-1{$Vb*&.e aYu gvI}tVgg [-$-bY3eF|B6UuZrrf(=@kn~r*x)CZqhz{%P6p=p15w2Լ' pA^5_ρY.ln%b&b^9%иBp,#qs>I*b;/0bdM#e T7\'Xt$3LU: r+DC8WNN3 qݰk iU*qN5q .dzEQX{Z}5^NKCZN.@%!@]%k;lKÉO2#MfvԌi&Jrbg0AHQ/#Kq {RHKP,20=<=jV/w9A{y""!( _M#z|%cԛ޷N.u}(Mp#ƼwL6}>#&{֖M97#)n\G rx4/'1s2y xxXUE+pE$t48 $/CQ1A 孧zT.~ 6^`Kgl̠ah(xM{ 8u"y(\8>:\zyAC)'H*yU/Ծup$82\AZsv|-q M^tfr,mȫ0Lu6ߜf[kpL&]U3.䆹ܸ{?z.V lY`Wr..4`a;o䧋2;@i+C!i7TWgSV$ZCF($OPDrبD"-x47aW gv3Xqv0 buOJd%J ``{ 3{PE]f89y ;TA叀6l0zT3^_ c+^c5gShcqIoj64]~ScŌ HL7bG.1M-$z1KyԠP, ~ϙGn}͍s 1*<(e7v$)l$S` YcMeK,=j-a-ެoR8 ùUs%~1uW;%~%ª+( L 9)T"#%1, I}qu+.lL)hTvʔBr҃$cx~G8)u-vm.>PSBS.ﯖ?54\ ѣ[>*|oGÒ,JPHqڤpГ^=oH>rf gU"ٸU؀٠UF쨻̥T08fcE]GKa^uv R:{d0Ŷ1ʅ5EDu73!#[ʉ&]<{obӱרY}SY"R\?%ǐί2(×!0Dъm';-pS7) NT1\>*Mi;R1 &LNʲC,x=n!e!eֿdD{OWC/Sgs>Nr{8CkﷺH~ig']u㮶ݧȄkSPs Gc)Teè9{'<A۟ѫd)VݑD)}F z[:/bgK;Ʉ2nOF,:1%9 ~ځѱ5VŁY?diUEOz?)c݀<ռnWF w:&+d¤ZV53?ԥWb=xm/[gFcBrйO'uB9o=? QFgV^;)E. ܻr@j";_*)ͥFJEN9/ P8%}˯?xWsk 3U֩8_C8FT`X-]# H _e9eUy[a6~LΛ ])rҜR@.BT>e8Ѡr|5#x [T}. }ߘi])NSЁɂ+>N|;v@g+CM{v H3t6v+ْi&}8193^$cW0#kqg[u cO%/) +R㪼y\Ğ'ʅVBFh%iu1kJ } Dӄ-n[>(.pwFH#ꡧBAg"VgWq (9)s`GbR?wLǵN9eMW] S ['b6[²xP1dMKϲ5 qgn>M8صIFqw3"$Nd 3g;#"PV %$ZQkT U5a;?KgO]lxy=rNC(܇^c];3ӻW*d;HXAr19G1˲sP~$Jb:`-J{9X_o#9G3^.Zג`51+ww_rtcf#޺l-oeB{)0O ,:B;j`'RW{8 %+/ $R+ZFb WVn[zӒԣǔ9"" {~[ϩvZysy^Ӭ ftDn^/#_IWC<&^ 7?-QIR&Ji6B{#X`+|&. `C[m$} ~*`U>7˔It&fe_"\/ZcJR$b RÁ-(.FRWz RՋs6s)7vі{6$(癕G%th%_"Q|*oj?B8VDhD?iqS>7%RmzAaQ @ToƆKrޓӃI&LzibjNc-6F v?<6(^e;Uj(uS1Z=dJcIxCF6.3$"(gMc} i#ۃFD8Jv(W2)~B]h&]pVss|QFKWeϵkg~ zڲdJ]5p"|/c8hiգ8@ 8x,\~Y.%~ n3R,Ac4hx._&*]e~OΠ;YS)YpgR][[5,bSԳAޚs'UNJ-n>dx4v6v5$b;%ݾ9b5酘M2C* xNV@j:%tEL6yMsk؜xw13eWȖ(n~d#OG\/]^BVQ.*2 UokcGȵ&\_xv@'u8n"v _\2 HouEH.yJk><Èl~y5A[`\bZ] md}!^Fs.6^l[JԀ7ƞyk{N[͍sq׈#KKxeã ό*`\~6z}eB/aW±~l mII0/9[=ݩ{C qbxg[0 ̔˜ã&ڔnoCOeio-\870=k|"};|~{8khC99MkB7!\Aժ#8U~ǍK4|>,ar$/ jZM($bg&|ZNdo\狵mpWE7& ȰNo2\2,iX6ȧ}q}Ǚy~Q_Sر#gϠYVey93wX$u7U8ᑪe˃nOC[=;_oni8Z)|^z``+Hju 0?S(nUKT>m~)n\.م ]K 6VIrhKB5hGQShOݹ-/+U55'*V1cTf$ 話_f4yIOK m;Dm:Ru*JK䗚t҆0MH]P^0"l -WsOM_KL rw&P)r2qjÅP*Z}̉Im^U1t{0=Clh 尶N<XlKEO_-%X8ҧ9d6=T^a"7/AÕMKQΗLODGSj LXcr|gD >.ۆ6TWA=caz+ 9уU*G&LH: (* +c/]h>E xK?n{޳-B41MwLYۑY}H@qt-!cSeH A|VZjRȝ,PGX6CU6f٠ej5N9B÷Ypga@j}T͝o`2,bЉu2V#w׈ძZGk}ӓLP je:EK-?I*sD9@,mMc FZ;Y(hxb,/ʞqSp>0BZZ!Ko @.hu?$Hq?mk-Ce^M;B `4T[|`^:ъA\Ds(׋;Ch?z#tǩm#d>iJ |8| 0I$55S4zȫypiBD6PJM&B٥ 3\pÔ*RKbgY^qÓHjxG6T[{?停"\ mXxa0zޑ0I܏yoM!gJtM&Մsfl4ka1#E͸ 'x$KVQ\\d) EC1,D^9z5OA[yτPC &9;W ,zwUyfvQNV6o_ɱu$ԛ:QqZ4xQ4ퟛvDjGs݂L$3V|-Knڤlt yH,ζB[fB^놷JP`trӜPEV$;.joPGj($&[;Y$5OV S;'Rcj@RJTy"#$ h’Bqۥ|QFxog=(8H -tHƾZ4$m/Dafo3-:`|(?d)B^cK63x^g݁cK&|8^YMS*{Xk1т`Ƣi`.A.ODzut%$OqnbKrd}=Vs$tW^%l`k!l0dXNF1s%Ȇ.?L$ԢgjtBv.ڧx?v;9@Br }q3nȄWXQk "խCSsyspm Kݬ}O30'sV+qLJ`Kfbe˫e 0"}Ê%YU ݀6 2Db˙%w8خh"SCDӂfOxhx!N}gHg˩/Dyq^UQƱnCzYډ,iuNTknq(f;d `=MΔ!,.[B &WgUl[v;\,U 괣y?3}Rt)#&: uéu^5e.C3V?Qu˾=ڽtXMz-c>3]#U^ OBDƆ7vjQ=J!!X3Ӌ ?%P|#'ױ6X4 Oj!1Ԡ$;}0}boOed}GD|X> \]*\:5kPL5`4iWpQ08DȈr25x.<+crE0L&͓a@ !(ԙ+>/ZOFG.dH&FG+'Ɠ/Bbm]VJƲrvN^[{0T |Ezlez H 0iT}O۔4q4mxUW`,WU#/ou4}4MчSLYhu\牜Ȉ"uJIW`G}/V4ݜXқcݙ*ܫ\:_%U~eX`?m M&Nt'`<2euɦ~-0g7/YW ŒB:Ӹ5UR]'ȷQmE? dz>I[>p!=W V"$E)$(s,< b`8Dg@i҇j!#ᦀ2U+@=5d3jFN@/e3KYc206Մ? ̈́X9TQYt(Q I~1bj8&=do~R`{S \Qxˬf֭mUWqt,@%cƵpoBg| !}/*R񅼉z "a|M3E_fxвTw])OܩȦvI/7ٖ /*~+(Ą\.eN/jW7l/K߃ș0ĵ\>ڱOِI$bVL>*+ -گ&2,.65<̇ŗ+NNS4DOoAXn3<}u|VOc9ֺgmIQ;*{ׅU5Ŕ;F N3I#e֝D/9":\d 9>$N)l3ך?}B{k6;cK P9,f2Zq3({j*OGT6ϨŬoۨ?Wp8 {5}cQ}|gu-*Tﱂr~;3Fι η*j4sQ LwSjXMwu~U->YYҦ QZ"eUN#qr:,a)GnM<NQ1c؋X&C%Fo3ΈPC0.azԘ0uxYviy\䛸<.N gd;ZliGպiz%3?qFK㌈{(gЩ ˠxdşGWr)9Q-g]֧.RegX|:Fx ڋEaz,آV\s}g@cTRF<:{&YҧNDY ,qRGf#IlGꁗr#{#Ik;{_ _Siq9q30nj̹ 7 "owcyI$${»? #ӑym%vzW3XQw۳N-ԸX*(@rtROKč9pf$subR8@'2]~gQ1PX2zn0S.oBk&C*GՄYG|n?Ky( A*HT3@HNf7=.UhׅR~hF41#'өM4r$:c- 1zO2l$2rƃY6E;2#u6dENү֒,? P#$)mE@V턮*Q+ TK~$$yƎS5zsN <I4rl\zYOi}`΍cXcPh0 i0<@Iɫ'h_G?B9ɥ h[;cS Ŋ8'6p=[<ģVf@җ|u2D^_ _Dْ&`B[XxQ }?A9NW#]a)nq){W{ wʁgLRYUÄ sɑ+C h6e:? JdbYKW( "le{A:yCE${bq#>_k۝}4±=J sfjWl41 H"I~HG:D$g!ms8Nu9G4/3\WrۨC+iw봸ҿ]8xJOJ-^`3’Bw̠tr,YhWĪ歬UĦ*=a趞p`73ʣmwٱ^s㈀˾恓GrZյ d9՗?NM?а˞09CV w*J-]?:='R^{=xEG 'uq[ Ie %&@v~bpQAE3aˮ.'+Kg<kٹj؇"a IO&c4y>hU-*؄g{"Ѭvv7mp l Cf )ex`!IrύtGq9[ksxP=[[C\A;H pɜ(MT$*ubu:h Ks=[jzd‚ rs{b+6x7CC*܊ ,QLfR?.Mm>-ۤ?vQ㎝3P>JUV~벗`UܚJ%dV}_=o70^p =ET+>- i8;+}Qa%0mdkf 9_pxfÿkZ.: u7[ 8.uI=B/M\^ N#Qg~)KObڴms[Nq_ hP9c AOQNݮ'4jj G0B 8"P #s V4j)•cOF:mJuaI(VHz =\"n^X-do_Jz௝g ܌1o9UctRu7  C"oMYux<gz5F(shcC͢B$CI"*cgAvo DRۡr'PRQ{z {I4+*ƚF4冶xs"K]X7m6b~'5`P}$QV&S|H2}mA]=<ܢ-^c+ϼ޲Nc0Ghʻt,P.:mmx-t<]^gX0hrh*yt*Ĕ*7 +BHaS _c[&k? \* MH=X* jd'8G;f-lIn ҸdN<= m߼$.~sS72 CBjUhB5Hvk.MnʷV*/ͧ3%LNƨHU~j28ڊo6QʍZsM•K"bV4$l9w_ &R9<2,FF7T1F\ jz%X,%ꭘjH(k|j?+(f@V㈻O Aʼlzk8_Lu UD4OρbwMԮ7R|,9g"pn'ir/49Aza'kOM@7Cv/ys#ʻK̗ =| "|dJKjTA|-"X&uox< \G3RrW:ϝmmJZ74Jt[yFH]3Ggg0 3\Yb"RYʈ38;Q_j eE,v +&Έx2YWhEc0SuDŖnCX?y4[s5i H{`@Nc;nereRgLW GJĈμEF`J_iӷѺß ;#EU= x#6ox{+nGvrUm\[}HR3!S-Q̅#40鑤yʈưyx죐}æ/.L F,MS^bV{!_ kIԊj 雩p07 ;H/XDR..tRAAh^(|W}j't8˂V o$'D<M>BX!E7O_1*wQ:[! š"Sq (:\'RkٹvAQgs82H#k͌v D,=,-Qhui+"oNz Hח?yKUJӂZQތVOOb32X.v:ͨ{WA-<^eoϮj%0]dc^fJmqo+49\qZ oDdbƐYr(O6sYbC^p4\Z⧖Vpock r3%t:Yтa=z%Ydڝb lWJIT窱d /5["Uʢa€WJIQW,;U G4!w.O<"Wfr ')+>osRցOۡP82fUd,4%2r6\mB؈=FRm;zjfv;k2Nnqo޵hՎsڞZW 9:k^;3;Dd˿V'><{X`a~e^^&W[ >'W\/(K]8{ƨ rss'/X0VdLp~H׀ɵQb{@#f)56-P00g2 tvM֣1BB@0E;*Y_Xr3cma` Pl >U\LF;9;22;Teu .h:`:( l#lZ)VDŽͰq޲6C{R-?{XC@a=,'MO:'#ZsݕwճLpx|.u_^U 4 mWL2M(>[xCvozCe/PjeA2_kT*zz-m^dvΊL9xAS]0ꆏ==2OиDLh LtE,Gn $fNd0\ZaIU=:}jMJ?ɢ#R>ys]4+2)JLRtI " h¡dZLF?6icBMMMA )i3cS #swvb]\L-Mj`z^HF/Xydu 5h. tx]\2+@/sdEa>杋Q9LGMֳt]@*ιXmȥJ\vHoq~כ*(aUKE(~YQêa^θMK^=_Ŵ.Kh0eHr+fڬpU>f)WAп6v{|_:%; l6Lh:+'5@KquOײRy'l9=E cH%%֫x׹RէUC3vx9 hr Lާu,Wd^Sm*Ռ0~g Z=H+ 7X=(6-짣iV&fc\; kڑ,W]?U*Rݧj6kxdm)ְu#gEZCI6f`u)WD #1_;BmOcwϐzQ$)/X7jvxS]ҧ'upoB8[tiʔ# _/UE*L6;wMtQQo*`V {"l#,lޛYB?o+= 'K9}2 +yXpUπDT~o 2{OF+vݕ'7H `S]nfZ^~IIWeŏ<Y*;)R@aA]9h#<І )_uR?2mQ9yafwvn}d w%];L5YRm̲+Ц}ti\- ɳe@3E_>/z+X$JƬP۟2 3Yei'jx.aՖd|K@eI鉍KIvG5q[w+şF^3c#WaU*]a;ATqJ s;7FBfcz<78aw, ÆtLj9PBAg|`c@D/a^WhGlrb9?oo \5,J1lKgx>i,e{jaey`/08`Hg%J39?FWqh+B.{(~ pwOX T5g\])/|L!WR#w`s[gTN} p[a-YʋI3+;x%Cc6c>9x(}jWwc =Hkk͉n 捣W6W gXw *=#5W|vӖmP/ցF Hm݃\za-U`_Fe+(1H kM; ,5^}#8nXpV' ;zNP=sT; gvz ^=wY碇žf!lf"6Mj[ޭ!x/!v + i@B̚6KL+`9Q-ag\=J-iq^lɍP:x>a'yU{w%9@% t9x(3Ä1P_PA/YU t/ʃX R;vgïDpSG`_=`]Ppd0"qW@P(6`_ۡv_7\H+Q`#| &R咴:-B*4 cO2q{an MbDV_C%]a_f5i8LiA)/3:"B"Upj9$$Nԁ=K0,.z[(Oख़X"ÐaSmm~M'Hy &Lۑ!bVk~j3%DX8i}4.k\P3'=,ȽZunR5Qp["X!">xG WO [!2b)7iIl55b,bdng-72QD79F?tkTLhB-l~wBB')EGs5 %G| vxlڶgV*\>`` FIDBmCb)h$[(wx-Nٝ;oz1Z?DDe*yqَ{iSD9d _R 7ݎcR0tV`ԷxU%u2a~?/ Qӑg<+YNP[Ȃs{ZC"Ty=Ő{ E[H'ݚھ*>0*{eo%.~PZ?'jKn4?͏*e26iIgj֛j*>+T FӍ #2Eq<ViB7f{ R=%Dzֽs焍?$u؅fդ`56`?xE<{$5o\DZW fRK Rw8K?TzJmq [`ƨ4qrMֈ6h"4GrݿЍD\eS@3y)O^h~qdRh Qާ![\"*e&K!3Ϝ|bE?jI~1s$XT.c ,پhX HɗQNڵ{ aMܴʧJouYiK Xo6Um:$ 6A9^m~{ݜ}i b1^O⡗YŖ\md|S[KckF",>s@,IP w]qσpCsrgML+K@Ep6B e1~ ts/d(*Փ5k8$H\y: Q.񳅦 uu:>{<9A=/Oz; ic(;"Ug?YIYNt Ba)`!}`v5ƇjMlU-3iZdEV>?8%FHcn7e}iL֦a qlP"W:pV2m؁e6ls2ʳ 5IeU'n܄PW72]OIn=T֓ 9s \2{oHyq4B#JIkR]}2Ӈ. U"7%Οwu[}c> ۊtc3[DqסIYzjwƾ0~_; |#U%FYGexRNh՚f5ʊ^ lhi m޲L|菗 p R<\$Nf/lZ39w•fѝ- %wwG>55e7?N7vzxTAOCz촠b 8[qLd|ۚ/U$phѠxG+MՊǪb1<}uRIfP Sv2I,v~>o9]s"~-Fd FVj#Y\Ȼ6FPW tƾZEK>WLv#Pح 7Ҩ)dCDR!9REtzmߝ}-d'^8 uHQ8-/ uuf,c-.GʑvvAdj&#ѓۮΛG1LiFJ'p58Ŷӿӂ}۹>P;?[%:ȣ`~%aɶ19Sj^ -] c芠}7/Y=NjmXHRAMڨp+wF4\ƌDÆzM7SE?ws8Ö*2 h dc(M%?ݮz+䫢`걣ۿgsBHs? LtJ9Ca g~XhS RΖu,0+!R4$JI"(%D:| Jeuנ,Mm1@m]=VM\R6t%Atr)n2Q;He_Jj$ SE8gU_Uʻv$%6f<ڥOt6X[!ů jxj׺"h :yzt7.)lFGqP؝aʊS _&g,`` >p喩/H#ڣ?@mS+_<\.#S+z6BSro(:TݛQqWVڬ\=韼zc@ :dI]2T+gf&m m3@c`^]J+ /dAt&ti {'ۃd}H[EmkǠ7L7zZ!aG1I7:݅`k'߸mX#n~=Zϵ)v"ՖUNba-s`2kX;x$dgsWnwqTb:0A2Fl `ϑβ@?c~_!Bet|) 5Mpb:t\Ǩ8lv&8Nr%v'j9dNI`P6kUNzpB4u;+9AWJP.e,t #754|VZ|=ƻHL~1!6„U/$9q 9zTIq$kf2<)݄{o=[[-f Ce Ez%'g][=y(PvM<#y+P ^Y;GŁ Hn!Wuƫ1K"@G}^z2^\FGuFB~Kfw#Rt~񅥷iE1"RwU\D٦sr*᫵*ٮ=WQ Ft)~i6R #,=^Q#a+/`%4޿*L`!u]1`/x&Јs bqCIYJލ٣".TckDx\Y)Vìꌍg8\>c(aC.R# 2!ge{&Ue_S Hv,ep75MdNd|HToGvŠkku)~2&J+nͷVq6*ȷJ> òh^16D GۂWթ ?z3 &ɵӉDLt``#Ó G`qmH37R=lζ9۝JBZz3.8~]=7dMЈ[f<9U+]zN-C1*"k`oyYͳDcBg$@}P WLS\!XZ:tfO+k==-yr.jGՆvH'`bSmvɕei[F9"NUtJ@%\B π.YA&k!3St>$V|c7NK_p >ouQ#i3ATPxPГq?oI3W+fF:>4KI IkM_:\ePcUr)"J\\{:L D%^vg ieS(Boմ]A޿aX&aXj{jʺ<9쥣A-A`@nmaݪZߨ>n<035 !i7H!"_aݛΆ*;+qPLR9 6F''fKOPMen:Yl-~2r|c[& |ɎwGB  5<#b-Bv?](gHHmƲt8V:XH O撿TaI%Aɸ۴P>4ѫlsE;|P"62إ6]$EhqLFT,!{^ulg#bJal; AcԍcbuSP5\~WdL0vX/a1[ZRS4lׯs[ nU;5cǥ+ D# 8gJ?lT\3z}b<(WNڌGe~ a kyl0kpݩ >: Qs +EisXy79Oa.!1U v[y Tm Ԟ;ʿ3_{) aSO'r-k> ]/rr^iyD%|HWѴ"QH] *# 1I3F?eƕY/f%_:@l<䠒eh[$V!& El6h~ܒ[ʏP3uuQ.Bdt6qxi84)J\0SvL#C!)lHא#iyb!]5b@zȭ EAYnFr Un7sCg 80AZh@ٯ߽P9^) :QЖjU1nɑ*[wARVQX'еL9uJbme~85aN>bb9X:*ixɏ&uyh}yٟ/uW4zÜG$Ud 5)I2S90Y֧J5(@9a #*I/PPovT#d!-L E#1VڑԀ d$M$?,;aZ3'Kҩn0)hCeӑ~L4hdiR*8bIwqbhYh `/D ڝk ZН,z\0Um׺:XA 1vK?ǏN/`^nyцR17$袅Cz$}6f||&z:M*j-@LeW㦀\L>5Ha~%m10HsdQ3nZWdf'(պ,򛦋ܗ@KB$J̨i2>Yy ggxԳ|?axcٟ~ECL{PU$tNά31N،UW|ah10ݹ[n]:]L]xGϟi"qZkk7%:҆R ".0=MOK0T\|B`[jєyWhHt hxׂt"AL2_r1܌^DWMWv3IPl56M}%Hnxՠ]<^5ꅋwq|F sc3(]Ϩʚ2| [D>If9㿑epW)vl57Vϔ?ZǧO$XOSO0و`J m;[ x\W v^A @ǦjmKLE_ņn}LI71+)d?*Cw웎))r|2KSxqѢm*mc#seEo\o?FRApw҅v"t-)_q^1 `ڜ}`]&t@Ꜯ!4\((4d?(}'zXej%N2_dk?ztƶ/Oïo *}5$H5жS֒<$J?fmF<:уp^KdIv% =;VEF͠-a j\]WoA7ps*1ZMS3Löv҇ᛙÓ1&Af&X s1v:͎"cS32r yok(opk"Mh3b˅rKw _OOaa nN: s"kxT΍Qn]ыCVj~Ө9~‚L0KBLDww`hMz$lC21*)l[cdn94K_!F awm=<9ϥ1KJvԓ3/H)f@yU}>1;#9ض ]*_ b'u5~ҧ^uCC{?L2ͽyU;Ase0@6}^'ۨ=m*v}L$)G[yOR%Tfb^ ='z(nvp5ܔ7ɲ#k/uVXX 1HwxⰗ}k=AmYAVZ4{Jᒤ//g#o9>q\UC9 5z{@|2 qD궴Yj)&6y꘷UPڟz#v%x7;6xܳT͋ e8%_Gy&Y[*dYB$AE7 cXMWPe6{vD2SY/MI줴/vcͰ=$ٟY"W |h^^FAgNMMuÕ??HEEѿcq< 2_Y]< Yu{" Y5aבr΢i-qCFaɂxꁒrȚWyqu7>0 K˸w ZY'ځwEMC3 R!82|0%b=Rj"H.³<{jU˛ !Kə}EUΕ~Re epw_$qA>!-3^3tzet`줤pKBBU*j"zHƓ2KcMp4{>d?kjdw/Л࿨|OE-̛*4I#W6X)ƥ< )b0۟+$=E'Te/[sUNɰ'aonYbԋʟCty8_USpmE6wӇ3pT 񴥪'~8$E(q#C,3(#\HDn~ ?A w ոީ BȄUw'ܡؐ -,ׅ` $ `nW#NWΎL>v֦AB$n} LbTl6t˜u({\s}-<@?*+caiZ1m#F 9eKՔ.wåV8`̢ OJ ?F{?p1Ly HV7F~B3WT"!;ZCEk 1M,Iҍ<8GiL4ʛ(&o"<Aǰng%K= %6 C+bX$ pm 6sٵNv_ ?&'p.JM!O~uݠM؍N^KMAfus%]e,S >F#*z*u ǹ=Dl<_h?{uV+Ƕ`)sALgœλ n)KY6-5ܿFՅ#$u(WD-6tًO|2K Z%aK؇7@bg|AmdNkTifIVɋ4^C#UaK`|S"):![ُF(\eYѡQڅ~;2 Q$pzK:07?C{[X/gcֳTh-?Zi?紽4Dpn[[Sj@{=]9vɺ(@jpFZKK=mz0) iPslO7k"K'D=WSZó_YmJPO:hT\TM<,!M='iv jT_ԀOfۑ?Tm+jRGk8gUs9ČX7Ik6`Jlk,J*MX%ڰ )N+2a@_$yUTDg"+՞\ ۪"Db5sD@ѥ?.Av멯+GKSٳĿE T(N^npbTuR[19Bp2ʱc >Ą:~I.qoٹI[ncKfl#')~;S:v _C !0MZ6-W-.,Myjx! x hC_kL%NDUsYaS7,ʐWjX"t$: t|+ Ͻy.cȮlu"`(_BDƫt<%"N"¤;2M) _^nbgLuuN0y'^HROp}u_,\ ؇a\Bmwi\eK4˟SmQU֌rA٬d!84ܕ1e)eA^խo ̍k vZDp9@N "y'v8|(⚷*{o!,xIJ̈w)V1YWv藇+ Z ٖYp`XBUduf+T1`e갲` z*t7X'3R@^*-Ԑ8޽`^4xupX8 QHP~Ҿj5/ZycZCTڄ^rI; (ά !mb'ׄj#oN95 ހ4;+BxY}1p-NrrBؠX*;Cف!l yu2u3e}43f"#>槎 4:/vS4Y+#>{4_P[Q_d|gT ^sCLȿ_h=nPl1CD| dc!3~0ׂ6TOՒa*PJي &Eh5&qۘ>.$%^꾾@>hXH~&:0>Mg ǩ`ٖpE lW"O}$ӼIrobߧz?t$KmB뢊 Ju;ܪ]GqM/{1kF:"iZ*p 6g}{- 5ju%£;R؋>aMhP*{ e^M $RjdIBG hc JSքmzёcyzoO7?XfXU3y/V̞CBl58B\cYGo9fS\hOJXoR0mfX?BJҋJJr:B[HNXoqd1 S*/s@~%n-> [dQ.}Q&MwJZ(Q&2X ջ 9GYj<+cx*ĬVwabF"{"mļoOĖ&t_+aЯ?nKU)Y&!wcPR#kcz'֕%Zq;Cn9=#'."+ߞQDt\xqv%esq J v䈰AwO_\I}x(y̰1O'ln/<a2 G (mɺH,^pIDݕ@7 "Ϯ[咪7ܟGQ q#Hae$DͲWF^ (D.1:$B›mpt[j7mExt\m(P$9s"=h6fFu`|q^k.A`f?U糕z>;w8yqiUPFBSC"ګJ@tMIޣfE*_] ܸp ͭ9C5,jhymv&- Dx8lxV5S+T?N 6b#2Ϲ<RQ7BIם>~I1.ajmN-:dxtUQM|)gJ牯!]Ɓ'|^ue%WE3]?(*β Z]("x[ORP/dHz,YՎIJt Vsg|څ+P;F&"LqU` |ЮԆC"6O^r #1s 9S~{{#DHýr'Cd]~:%Q*7_!A9mj 1? l{Ho 2Q[D>Q{59P,,/閵 d0R nգ$aKa=W2U{ؙP–^U7R p#?VNiL4_ LW@DL;/ϗz&_RbrxeXlr,fPf7DvM7݄69!ܾ)?ݵ S=tUvꗥɱq %to_ ث;- )"!c(V8G-;l3Jc.J"ᥥՅ/7[^, ͆/52K7M3p2{ֶ2A#^ĺzh-'S>`p Eu$~qhA!!%Zw^P_hU5\#)EyN1E!N!dOr?s|cYH򗮃$ᫍׄ39=z"SG6隂u@l+x4(GDS1 ]Vޅg(bkZ`oye,mCN8y#ZbJHEƹ;2/MF.}ZMH. }hC`aH6sr&YjIWZЧʃxFGh 1گa;*7Et+df; 5]sKwc#S1 ^}!8r*ju7@j%X/rW9to!%랂/'b9V7!~FKɛD8_;)ijۦ9}LcDZޔI1Vjj˅U@DJ}#qqWVJYm1]~jHZ>! j xSǍ˿iIɄUc}e.\bִT TmQ[ѧ8 (Iz=a5?*qH#` تJ~d BzZ.|.ҸvQ,WwDF~AZ(V琖HkzAy%PWX[e:YlΰMQգ(gl hFPU;-F7Ya6`$$mbh(5x'}施1$hMXo`9'+"pM,\DaU"S~|&m AWGb̄Qo~.㠾<]oC~x &lE kȁq>[® d:L HD5K_@@Eo^9|iI5%N3pA_s\lqOXyE&N_$]gûtJmאTO Lg _t9?E> *M:aU5K.#bRֻGʩ-.-`nݨj`# Q;l1^:G)TK'E 6D'-*x'?r]HK`wde16gTGpU Sk*{H _[t;x!+`dqMP\msO@Å/I:,Mby Fwj gc$nkșmX9‚= kaFO|0ي0䤊ELD .4|"};b[3'It׋_y[&!HϦSU&ml+e( ()%/RU,E Gg Bq{Ԑ)^#<X~D1BE.XP K/Q*d xAbt! -!(6 3C1Ъݸ9 ١ag 'RxͲ#bDq1%|" t׵͍Kޢ*k$tWR|?4 {V;>uȗUEr.I'+`&P(tv*a.*rU ,jTʋwJ,LD;AKU&ޝĶdn~gv#͘{Xo P ez3( S&|ěljhR<[Ss!hH)PrSefBڽꜥx=o.C4;+:h|t(@@^jusk(. 0!ۣx ɀ>]q[zL|{8h:q, ܢտ8##FeךC>0 YZmixtools/data/WaterdataFull.RData0000644000176200001440000001623714342153463016533 0ustar liggesusers_^Er{Hi# .|9Bkc`۰˥Œ\ KE9i@xM9$bȇU]]]]]]} }L{ٓO9 oշ{[{N2'ߛ_j?U9<sW9 —9| +gsxܞÿC ~~qk-Ɨ'=?><ϓq2ϓ?? .ϓO?IU.4_R|=>~>1h]p.xK_<$ח{K|GsH]]M'8%E=~-:z'm X9zw3m3_'| o4%toVE| |JDŽ7z:״S,o!rVzx͟sF~iZ ﲩ|z^-X.>A {Ѿww~0@>2./'@g>JtϼyGyR=~辬S?7qe<7/rZF^7}y ƛ-/֗G>2.Un*f'[Q?U<3+{ț5O7_nG@Gڽ$ =OWW誂Ṅ#ϡT=`Oh|ouy?NP{bw{<$I{~y"O:hyn(~=OWxh+=}~K=tA+ЫM_ڧ_蛩o$;CEOƋ>]r+ϛ>?x~+[i"Wcu OyUANC\dW/?ҢwVxyrЗ,c}O۫Gn=|auE'e'yh_vzȳ}֗7i[pˣoggv9ґGѵ~>v="쳽\^׳>R }nW=|뷔OUߋ}oi<+.#c^U~}x*]v΂HWaPt-Z?=vv} [_&U?݌sh}ǟdGoO{y>|_v\/QT'@av3|O _x2!((!.T?0T}Ǽ`=AS}ݪ]Od/ǕK.toB>[iߥ/"ЇЏ{3ԣٮo>GcJ /[7`_־)#э={ZY z9{CRD:dVlg6A#}:_Rj'r> >ڱ?$3q˃k/rK >orՑ|߷G{zEtN5;]9w~N?|g^8/o>-v|%ZgB|'G?Irry2ܵ}%EЏZW 8mkRyxc^33-Փ]4ӕ_p>uY? =K|a=z5g\XB_0yW!>tNkD>Wf>Cn(p$O5<6呧w?p>"_>4 W3v?>3;wۃ>e>O)?0#;|޹4m(M't<o9*XŜ_BNDZ`S{*-:ci9??ޢ7噗USkG3g Gx1|n8MOsUgge{!_;@?nESAбUA/c+V~Oe'?O>MJ^!w V~?~y?)}Bno5J|\kV=%kM`ʯ<ʥ}|t܌/<Сa?1(;n8^Vy6Rpz+yUGf~1nyG>oڏ"&i@ oa ;NW"z!g8/(+|GJnSqB#"2Y j>BOg*ϫ_W= [UMO8n=ҟO9ů,@<' 2U`|}8!n{ ;'[M.>AqϾ 8as%'/##t[Wl=CSlo\Qf?+:4G[g[2< ?5zu)YGOMA=GϮyD>XZ>Wʣǿ\!އ r _SoFͼGޱW?@.ԹatCWg௙ Cr9au(Hviec_>k:O)Y??<9g|q}zC+|Q.?'[ߓQ܂ >y>?zdWl*`Ǹ`ۗMt2?΃[<8^b[wLU%r7so Ac9')|^$sѓ}+g/ 8ꠇ >7(>cm;oe#Ǿo} 1+rn>b:O9TN~pӗxɷ}`Wa 8Ժhp_>6Sd>;*_to1 %>VBsҜg@ n*_~ <V|LO=~y,g<2ݨ]Wq"WI{ HcO6=+C\p*hzzig>d>(pY4.Lúq\GZD®cziPs{<7}*ۙp~FOׅBܛ!w3+ve>_I]C/N˹r{z1bo ? >o}]).4[ߦ+{jUqX`_{{g_aI< ;1SF=+~?U^ 9ₙg;O'}u{'C> _>U}9yD/6@ݾ^Ý]_::'_#CWI,e =c(<K1c G_q<}k39%t0o*!_7>{Wcu[2z*&C=s=zs־^{X":g}~1}ГP6g-{}O`s>mtٮ_Rm?JO9}ӬG>ׅ.rle >ߎzzQ܊~\ ~O?pُr9nf!1_#a_{蕊IK_B [nǀckhz;}S zz0~Ɵq}!~4ڹaX8ؿw\I/K{GrI{^KtEw1}ϹxUo+]99^fk?*NtX 3ߒ=SY>~?(^qw*W_ǜvt#y?q(|__ϋ|gxz};Ev*kj]SsNG;\}4(?ve!>T|@WPOS}Ž#? G~8W9y̞r{7u3̚>gq|VRx?c?EoErxM__;ABSx=9clzC\>KԷ8 DN{վ=93o7c?Ħw|?z>}o+_Z";{n<Whsč!cnXO =LWm*D;3zاN|c2xOB_a~l[ (~kS=^;B9@_mj{R~؇]aKn~(2mf<d|{+(_md{zF/طQ0|r|A|}r@`Fq^ ^G^?CjN>J]7y{.kSO|~d$GZ/~]xu.ki B}~.{^Ry]({6#4s^J;ةzanx:N)=`'+G{~z>6zS~Mi{0 e~:W<1mToGʸ9U']w~}wyp@c='/uެ|{ݏ;˃wEoIZ/."tpM/ʾcQZ{:g ?5ܟ;øNt>H_^)z8_m/?ߵwu< qOo!g~7꽿m<ﴇ|nho`׿gҬWRQi=HQ&~A:_>眘sį}Cw 2Vw+O[W|? !Ω-[K> b\>}1zxy)ȍ@B|C?v+Rf:|OqVye2.[kzOy:|$9wsh}_?ݗ }য়+>3/'1n+ +)S\Ry4rog>#/W3o,य़7^]_ s}Iy6vo+3_|/~3>^p|.Xx={zV9<.3V|Y^\WS8%re{?+~|K>μFrS*;CH?ufڿ {/ 9>=5;[s'B^|/x'*=owAxA? Sjʭc I9 ~py2}_՟k_?UƅJ_W> $SU(ɿgg}?=2__oO꟤G mixtools/data/RTdata2.RData0000755000176200001440000000666014342153463015237 0ustar liggesusersBZh91AY&SYאl y޽{3VִSws>sXH:20MpI"/[L1ɾy#+ҟͿuh-'"yi\yvdw~]TpY+fYcwFn"|;?s /,4c[VID 2'4˴+Q*o:M3K5#:`BΗ)?ˢigP_mLuU@,F`5b '$le[D u . %s}}*i wϒ'&ߧ_U|$On)Wjx5HBV5gˆE,Ucօbsz%ޠ%=W/;UpQ3< 2C*zV)Z:)9< y\ nob#% SI> ~p8ѼO_P߇=@2(n2f]#9RY[A0@1[zf0C%_M#L[]朵D5d#Yu}RrP*e稱nrYQiV[5>ш.+=}K_l#eב,oKv_HZ"n3yI4Bgrkd ‹˛cU4@^OӀ|wwpgI$AkzaD,Vt^ ۲K WԶ 7j#I#hV!}|Fg+ 0#,pٚZA8NB{I RƳOW68K|& 2`OZV@Gp޻p=.>ts_ DFb"W{Ed!>>{Z?tG8ېg~15ÓE~h_+$z>X]K񛒂Nz$HBնr5ZnU`KRİG6k_˷5 =TXx9}8~=H573KA!s$Di6ȑ5>)PfSό_] NZ+ٌ5yAMA 4u}(x`M1pvgYO ~$xKɓiB*7ڷsuYҼ^Xu)eA9āե7lx.6〮5znF>%0kVe^v<,f@S+[WKr҉blP^Sj龪b bWBZD$~eE>og!Q-o}~`e6|uvB'},nU9=,L1SԸ6f5W@[ $QP}{|4݄Y %#ٯM3ʻo9*ݱyԮ[v5*FJq#"%2S[n3CuGESK8>1K2sb>9*TtbWq?r#]&$(wٶYNmEUceK?>V;h+OQ 5 N+} '(-1bIC([6hknnۛÝ E4 M.c8!iԚ6zw*:e^5i;+nϜ 'N`* x㍋OH9by))lTCj TYx(BpȧN@JyDp.I*KԔJ|rR([LU*T^8RJBMRIF-*FIWJ@%U8SVIW%MjRT1DYfbU Mb&66C-6FDw `v@̔X4u4u2i ܱ!LnhRm11[h#P܌/P!FA51FNZz~OjզBޮM4צ`ٳf͛3ׯnp! :tM4x@(H1J$_81cBA$0:Hc16mnR۷f͛2ךg4MYA@Cc@VCpJИ:Є[ ce%46T Ɔ˘9xfQjFݪ*Vr: eE3 RR S?Xu Cʑ!WKv[ܒ}iGYOo׮EnKf&@T*"BhC*iRâ(D""D"V"""$${G\ AR-MW {@-/d9+}۹go~ڴK>"Ywp N“@Z9CGA>c5}&<{&>`'D5 ;[w\x ܿg1ƲˊƜIowӹe>wΥGȞ}0(7=|G`7ޮ5sdEo~m"( ĩN}!xܾ<+H18 w"o*f䯗7)$ͿT2初Nʑ U%$U">z@02\J=Jpyqȶ|5;?H0Q X 5;U!l@%wd| ,Sɯ'dh,u]Jz,q4Ϯ.@&-LA&չ82^G=E?+dYzh]\Q"#MXefy䝒q8]*!U,(_=u$w,v.m=d7&BvU~ITr.B6l`BfyhFwvz߳V?$0k޻Ww>~ ܠJjWs)}OsC;+<ݟuk#7-F1o?Q|#5mo$qf??>j{}Ri?G {~nV)+1ٔєFR:R+1{t?+)uϥ~z>K)ߜҵ~!~Оt!%k7VjJ Lk)5Sڇ:y4l]cҳ}4 l%,h&Oy/hdM>nHi*?5r[QƮaBOg!ٗ2|zz]0^A[=ᾼQRցBvziD[б]u19υt1,ޛm7KwMhv[A~Vчqr m~Gle~?X@lȇi G[Cg\E؞_f/5Ե2~tf#c`{̎hnOz'OfbKÅA\a$~eZ;ח~ & [:e:<w&ݺ1r崫8l6\~8>.@=`BAPʉ:]vR W:{Q~2;(,]_ؤc h7d1H~*%_0ﶤg*ݘuQk|z]Jg1{RM湔mlAŽڦR~RDͯdd9n؊|Z3Q~Dh{6BgMAOʟBwum:7yyl~v#mkR*ُdAl'r$_>]n7?|{N< ʼr}~=B8-zz]q-1ȳg g~/?8d< m7e<Azhlh&ou1Vzc9>rF`YϤbj]}' A]AWaikaClǻv`Mǻ; y {N~%CȷWe!_=Ţ~|2Ypy6CqqN\8P`DnzsZ#wCϻl(xrڟ@?G?L?K}Pq_rzGhEXUA=rpm>0}s 6}GON1!W.6Xom~ϧtj뉨ʿr3)CJjmwulM!Guhc卯&eX%FgQMsv2 7Q۷obƞEnul̾{.eD:=2d:.A]]=ny*VF_ Wq1l3~_Wqb, u60W Յ`9Σ8l0 ߱}̛(Ksju|Ԟ4pM&3_m]Ժs/eCyY/L\! 9e m<,^QU&s {Nq )m>n[CۯjLnKͨg6ٛ#ط9D/|(ɨ/\5/vKM6F&ƅ{2r 8:V!˛Q1ʙ NyZڛnw)# ^~vi-MEnkQYOc~GbT^[yE8˰`3n5ג`=5?c AiԘMX{+tzeg̓>͸ɳ([1NXN^fIYrթuh{|A1jMcϾy,-wQ{ ECӫ%~hq9qjOR:+5Y.BEѯʘ>!^؁r |U~o6{l &']A=;Z?YwuA`]ȩ7bA˅ >MЙ՝ߎU,n38ŕl: C\5?}|(j4܋(dgpl }m ~U/jǗSc+Nqyi[1FQ++Ns5cl~ Տ*2~ D[}}F`o͓;`ë&#|ۆzy~Ϯl>.G@I<_Ƹt laֺ.kZ(_d`^{?di)vUd'r6݂WP1'uޙ܎~lCyXMSQs3݋ze®gy^92l6]*P"Vs}s ׷EM~Ov-a 7X-k=fn|y4C= 㗡y'ި:34ĸbG;z3Ny,;mMF@OMW.:y&Z70VH]Z_FƢk; ~c)F.v:ojwRߐr 8bC |f~G <9yi;zyH⺇,Eq/(-NBmK_GAmvvfWWλ9YsqIE9r1XՙqXg;1Kc5/Dؚ wh0ͧ\ѾXoßaw KQ`>({w!}ñ'/ꓟ?o oA?F^>=,B^~p<_f"|(Ruk"g]g ǎ% ]c1*myvllr?o?CB\,SX?9߼w 6Ef! v-R7.;,uVx/@Qڟs]Gz滇&ϦЭu|Y||,w:o%+Xy<,Z;3|*ս\ 㦢OorT6I^{}.u`ڷq0 ]7>DZNUDT'gx<3{oVGYo9jjsÏ?MWMx8tmÏ~|z=9~m]ƺϢ=_,$O۰4oc3>c3>c2F!c2F!c2F=c3F=c3F=c3F=c3F=c3F#c42F#c42F#c42F#c42F#c42F3c43F3c43F3c43F3c43F3c43F+c2F+c2F+c2F+c2F+c2F;c3F;c3F;c3F;c3F;c3F'ct2F'ct2F'ct2F'ct2F'ct14}m֭mm] 6um[BڴЦ6-iM mZhBڴммммммммммЂЂЂЂЂЂЂЂЂЂB .B .B !Bk!Bk!КBk )КBk )КBk %ZBk %ZBk %Bk -Bk -Bk #:B#:B#4qxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqxqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqIqI]\R%uqI]\RO\.cɈN؟?O~K,}^mixtools/data/RTdata.RData0000755000176200001440000000527214342153463015153 0ustar liggesusersBZh91AY&SYq 0^HV[z$ڌ44h 4ɦDazjmFFOA4d3HzM4ѣi6L13DblBz!ɦI䞓G4F='zOQ' )!jz4ځi OSI413(=GiꞦS#hmC4oT 24@i~Ò`]nY mpMDyRq,-YiO I D"15_'eѺ `иnrf[舱Ւ.D{ !6-:wWrnG_ k2)U0(ũ܃4Y)Wn'$')-PF:1!c԰T[\{gy CĈ)@P#1?GxmbZb/ƹ#Pԟo HZr,({bhQC;^XO,Ta[1j<;`@ӠNLJb 52{#'Pu! Kyto e-GMg>jm0(Vx$-]4'h|`RUV)UA#A5SpXfYes![Z\D&S4Z[F4G?;Rvݚe|yQ\N% ig1j%`(fjދh2RR&ΣQnt900l}#JjKB,=M?v&jIU$k2rsr$5YƊoxdplgP΍"OMGSC5ciKd8rۥ-zMK.3x+VӬo!/dzJcFU 3r{XR{-*dC$/9.T}_gfecQ.S9&uaY*f9'kHbo ie]y*+Q]žjMʍ7°UO'|ĚTXd|_]@י.f1~^( e6 H=ϹOm|OeR%> -9p 1+6xqcb8n/J'KջK&bPt/TKM^2c 3h=fb9^j5="y 2րnʯ#F_ū">cAk.UtpZD`\:s;w 14Zq31c<̺[oзD9Xު=8 p  yQRP B` Ѕ(((̉@( (PGd)@>YHLZOTN.b )@ⴥ9jU1j'DRY^'h^ 'J ҙ6aqAAFU\e:| ^B+ctH́),V*1ahIRtġaNρ#`PL̢qP-h$PPAA&g3f( P31@foI<$51cƤI&k"D$̺8H!ad$I) @s:I%Rf3hAAdI%䓘ֵk\I$5tkZ$I(.l1c5$JZי,bŋ,V1$J_3 +ĈC:=DD6W +2EePU[.]`),Lغ 'bBsJ%`LJ5ሔPU9( U"l#C X `:"4<>-6bO3? `E%4D;1FH4r֚BTpɈ+ k-Zi 8< Um.-.f:eBuY1vS47=vdLASr^m[%m`O.II 39<HȖ+_+hTٞ[= EX)f#DChLD*$2e)a4_: nNqilƒPLssC7h,*\NlՀAI2zQL|ɮv WC&O]-Dw$S 7mixtools/man/0000755000176200001440000000000014343400152012677 5ustar liggesusersmixtools/man/Habituationdata.Rd0000755000176200001440000000276714342153463016317 0ustar liggesusers\name{Habituationdata} \alias{Habituationdata} \docType{data} \title{Infant habituation data} \author{Hoben Thomas} \description{ From Thomas et al (2011): "Habituation is a standard method of studying infant behaviors. Indeed, much of what is known about infant memory and perception rests on habituation methods. Six-month infants (n = 51) were habituated to a checker-board pattern on two occasions, one week apart. On each occasion, the infant was presented with the checkerboard pattern and the length of time the infant viewed the pattern before disengaging was recorded; this denoted the end of a trial. After disengagement, another trial was presented. The procedure was implemented for eleven trials. The conventional index of habituation performance is the summed observed fixation to the checkerboard pattern over the eleven trials. Thus, an index of reliability focuses on how these fixation times, in seconds, on the two assessment occasions correlate: \eqn{r = .29}."} \usage{data(Habituationdata)} \format{A data frame with two variables, \code{m1} and \code{m2}, and 51 cases. The two variables are the summed observations times for the two occasions described above.} \source{ Original source: Thomas et al. (2011). See references section. } \references{ Thomas, H., Lohaus, A., and Domsch, H. (2011), Extensions of Reliability Theory, in Nonparametric Statistics and Mixture Models: A Festschrift in Honor of Thomas Hettmansperger (Singapore: World Scientific), pp. 309-316. } \keyword{datasets} mixtools/man/RTdata2.Rd0000755000176200001440000000243014342153463014442 0ustar liggesusers\name{RTdata2} \docType{data} \title{Reaction Time (RT) Data Set (No. 2)} \alias{RTdata2} \usage{ data(RTdata2) } \description{ This data set involves normally developing children 9 years of age presented visual simuli on a computer monitor. There are three different experimental conditions, according to the length of the delay after which the stimulus was displayed on the screen. Each subject experienced each condition eight times, and these 24 trials were given in random order. These data give the 82 children for whom there are complete measurements among over 200 total subjects. } \format{This data frame consists of 82 children (the rows) and their 24 responses (the columns) to the stimulus presented. The response is recorded in milliseconds. The columns are not in the order in which the stimuli were presented to the children; rather, they are arranged into three blocks of eight columns each so that each eight-column block contains only trials from one of the three conditions. } \references{ Miller, C. A., Kail, R., Leonard, L. B. and Tomblin, J. B. (2001) Speed of Processing in Children with Specific Language Impairment, \emph{Journal of Speech, Language, and Hearing Research} \bold{44(2)}, 416--433. } \seealso{ \code{\link{RTdata}} } \keyword{datasets} mixtools/man/plotexpRMM.Rd0000644000176200001440000000467114343144304015251 0ustar liggesusers\name{plotexpRMM} \alias{plotexpRMM} %- Also NEED an '\alias' for EACH other topic documented here. \title{Plot sequences from the EM algorithm for censored mixture of exponentials } \description{Function for plotting sequences of estimates along iterations, from an object returned by the \code{\link{expRMM_EM}}, an EM algorithm for mixture of exponential distributions with randomly right censored data (see reference below). } \usage{ plotexpRMM(a, title=NULL, rowstyle=TRUE, subtitle=NULL, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{a}{An object returned by \code{\link{expRMM_EM}}.} \item{title}{The title of the plot, set to some default value if \code{NULL}.} \item{rowstyle}{Window organization, for plots in rows (the default) or columns.} \item{subtitle}{A subtitle for the plot, set to some default value if \code{NULL}.} \item{...}{Other parameters (such as \code{lwd}) passed to \code{plot}, \code{lines}, and \code{legend} commands.} } \value{The plot returned} \seealso{ Related functions: \code{\link{expRMM_EM}}, \code{\link{summary.mixEM}}, \code{\link{plot.mixEM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{weibullRMM_SEM}}, \code{\link{spRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \examples{ n=300 # sample size m=2 # number of mixture components lambda <- c(1/3,1-1/3); rate <- c(1,1/10) # mixture parameters set.seed(1234) x <- rexpmix(n, lambda, rate) # iid ~ exponential mixture cs=runif(n,0,max(x)) # Censoring (uniform) and incomplete data t <- apply(cbind(x,cs),1,min) # observed or censored data d <- 1*(x <= cs) # censoring indicator ###### EM for RMM, exponential lifetimes l0 <- rep(1/m,m); r0 <- c(1, 0.5) # "arbitrary" initial values a <- expRMM_EM(t, d, lambda=l0, rate=r0, k = m) summary(a) # EM estimates etc plotexpRMM(a, lwd=2) # plot of EM sequences %%\dontrun{ %%} } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{file} mixtools/man/normalmixEM2comp.Rd0000755000176200001440000000633514342153463016402 0ustar liggesusers\name{normalmixEM2comp} \title{Fast EM Algorithm for 2-Component Mixtures of Univariate Normals} \alias{normalmixEM2comp} \usage{ normalmixEM2comp(x, lambda, mu, sigsqrd, eps= 1e-8, maxit = 1000, verb=FALSE) } \description{ Return EM algorithm output for mixtures of univariate normal distributions for the special case of 2 components, exploiting the simple structure of the problem to speed up the code. } \arguments{ \item{x}{A vector of length \eqn{n} consisting of the data.} \item{lambda}{Initial value of first-component mixing proportion.} \item{mu}{A 2-vector of initial values for the mean parameters.} \item{sigsqrd}{Either a scalar or a 2-vector with initial value(s) for the variance parameters. If a scalar, the algorithm assumes that the two components have equal variances; if a 2-vector, it assumes that the two components do not have equal variances.} \item{eps}{The convergence criterion. Convergence is declared when the change in the observed data log-likelihood increases by less than epsilon.} \item{maxit}{The maximum possible number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \details{ This code is written to be very fast, sometimes more than an order of magnitude faster than \code{\link{normalmixEM}} for the same problem. It is less numerically stable that \code{\link{normalmixEM}} in the sense that it does not safeguard against underflow as carefully. Note that when the two components are assumed to have unequal variances, the loglikelihood is unbounded. However, in practice this is rarely a problem and quite often the algorithm converges to a "nice" local maximum. } \value{ \code{normalmixEM2comp} returns a list of class \code{mixEM} with items: \item{x}{The raw data.} \item{lambda}{The final mixing proportions (lambda and 1-lambda).} \item{mu}{The final two mean parameters.} \item{sigma}{The final one or two standard deviations. } \item{loglik}{The final log-likelihood.} \item{posterior}{An nx2 matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood. This vector includes both the initial and the final values; thus, the number of iterations is one less than its length.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values (always zero).} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{mvnormalmixEM}}, \code{\link{normalmixEM}} } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. } \examples{ ##Analyzing the Old Faithful geyser data with a 2-component mixture of normals. data(faithful) attach(faithful) set.seed(100) system.time(out <- normalmixEM2comp(waiting, lambda=.5, mu=c(50,80), sigsqrd=100)) out$all.loglik # Note: must be monotone increasing # Compare elapsed time with more general version system.time(out2 <- normalmixEM(waiting, lambda=c(.5,.5), mu=c(50,80), sigma=c(10,10), arbvar=FALSE)) out2$all.loglik # Values should be identical to above } \keyword{file} mixtools/man/regmixEM.loc.Rd0000755000176200001440000000723414342153463015501 0ustar liggesusers\name{regmixEM.loc} \title{Iterative Algorithm Using EM Algorithm for Mixtures of Regressions with Local Lambda Estimates} \alias{regmixEM.loc} \usage{ regmixEM.loc(y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, addintercept = TRUE, kern.l = c("Gaussian", "Beta", "Triangle", "Cosinus", "Optcosinus"), epsilon = 1e-08, maxit = 10000, kernl.g = 0, kernl.h = 1, verb = FALSE) } \description{ Iterative algorithm returning EM algorithm output for mixtures of multiple regressions where the mixing proportions are estimated locally. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An nxp matrix of predictors. See \code{addintercept} below.} \item{lambda}{An nxk matrix of initial local values of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is simply one over the number of components.} \item{beta}{Initial global values of \code{beta} parameters. Should be a pxk matrix, where p is the number of columns of x and \code{k} is number of components. If NULL, then \code{beta} has uniform standard normal entries. If both \code{lambda} and \code{beta} are NULL, then number of components is determined by \code{sigma}.} \item{sigma}{A k-vector of initial global values of standard deviations. If NULL, then \eqn{1/\code{sigma}^2} has random standard exponential entries. If \code{lambda}, \code{beta}, and \code{sigma} are NULL, then number of components determined by \code{k}.} \item{k}{Number of components. Ignored unless all of \code{lambda}, \code{beta}, and \code{sigma} are NULL.} \item{addintercept}{If TRUE, a column of ones is appended to the x matrix before the value of p is calculated.} \item{kern.l}{The type of kernel to use in the local estimation of \code{lambda}.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{kernl.g}{A shape parameter required for the symmetric beta kernel for local estimation of \code{lambda}. The default is g = 0 which yields the uniform kernel. Some common values are g = 1 for the Epanechnikov kernel, g = 2 for the biweight kernel, and g = 3 for the triweight kernel.} \item{kernl.h}{The bandwidth controlling the size of the window used in the local estimation of lambda around x.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{regmixEM.loc} returns a list of class \code{mixEM} with items: \item{x}{The set of predictors (which includes a column of 1's if \code{addintercept} = TRUE).} \item{y}{The response values.} \item{lambda.x}{The final local mixing proportions.} \item{beta}{The final global regression coefficients.} \item{sigma}{The final global standard deviations.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{regmixEM.lambda}} } \examples{ ## Compare a 2-component and 3-component fit to NOdata. data(NOdata) attach(NOdata) set.seed(100) out1 <- regmixEM.loc(Equivalence, NO, kernl.h = 2, epsilon = 1e-02, verb = TRUE) out2 <- regmixEM.loc(Equivalence, NO, kernl.h = 2, k = 3, epsilon = 1e-02, verb = TRUE) c(out1$loglik, out2$loglik) } \keyword{file} mixtools/man/ldmult.Rd0000755000176200001440000000145014342153463014503 0ustar liggesusers\name{ldmult} \title{Log-Density for Multinomial Distribution} \alias{ldmult} \usage{ ldmult(y, theta) } \description{ Return the logarithm of the multinomial density function. } \arguments{ \item{y}{A vector of multinomial counts.} \item{theta}{A vector of multinomial probabilities. May have same number of components as or one fewer component than \code{y}. In the latter case, an extra component is appended so that theta sums to one.} } \value{ \code{ldmult} returns the logarithm of the multinomial density with parameter \code{theta}, evaluated at \code{y}. } \details{ This function is called by \code{multmixEM}. } \seealso{ \code{\link{multmixEM}} } \examples{ y <- c(2, 2, 10) theta <- c(0.2, 0.3, 0.5) ldmult(y, theta) } \keyword{internal} mixtools/man/plotly_mixEM.Rd0000644000176200001440000001462714342425456015637 0ustar liggesusers\name{plotly_mixEM} \alias{plotly_mixEM} \title{Visualization of output of \code{mixEM} function using \code{plotly}} \description{This is an updated version of \code{plot.mixEM}. For more technical details, please refer to \code{plot.mixEM}.} \usage{ plotly_mixEM(x, loglik = TRUE, density = FALSE, xlab1="Iteration", xlab1.size=15 , xtick1.size=15, ylab1="Log-Likelihood", ylab1.size=15 , ytick1.size=15, title1="Observed Data Log-Likelihood", title1.size=15, title1.x = 0.5,title1.y=0.95, col1="#1f77b4", lwd1=3, cex1=6, xlab2=NULL, xlab2.size=15 , xtick2.size=15, ylab2=NULL, ylab2.size=15 , ytick2.size=15, title2=NULL, title2.size=15, title2.x = 0.5,title2.y=0.95, col.hist = "#1f77b4", col2=NULL, lwd2=3, cex2=6, alpha = 0.05, marginal = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{An object of class \code{mixEM}.} \item{loglik}{If TRUE, a plot of the log-likelihood versus the EM iterations is given.} \item{density}{Graphics pertaining to certain mixture models. The details are given below.} \item{xlab1}{Label of x-axis to be passed to the loglikelihood plot. Trying to change these parameters using \code{xlab} result in an error.} \item{xlab1.size}{Font of \code{xlab1}.} \item{xtick1.size}{Font of tick labels of x-axis to be passed to the loglikelihood plot.} \item{ylab1}{Label of y-axis to be passed to the loglikelihood plot. Trying to change these parameters using \code{ylab} result in an error.} \item{ylab1.size}{Font of \code{ylab1}.} \item{ytick1.size}{Font of tick labels of y-axis to be passed to the loglikelihood plot.} \item{title1}{Title to be passed to the loglikelihood plot.} \item{title1.size}{Tile size of the loglikelihood plot.} \item{title1.x}{Horizontal position of the loglikelihood plot.} \item{title1.y}{Verticle position of the loglikelihood plot.} \item{col1}{Color of the loglikelihood plot.} \item{lwd1}{Width of the density curve of the loglikelihood plot.} \item{cex1}{Dot size of the loglikelihood plot.} \item{xlab2}{Label of x-axis to be passed to the density plot. Trying to change these parameters using \code{xlab} result in an error.} \item{xlab2.size}{Font of \code{xlab2}.} \item{xtick2.size}{Font of tick labels of x-axis to be passed to the density plot.} \item{ylab2}{Label of y-axis to be passed to the density plot. Trying to change these parameters using \code{ylab} result in an error.} \item{ylab2.size}{Font of \code{ylab2}.} \item{ytick2.size}{Font of tick labels of y-axis to be passed to the density plot.} \item{title2}{Title to be passed to the density plot.} \item{title2.size}{Tile size of the density plot.} \item{title2.x}{Horizontal position of the density plot.} \item{title2.y}{Verticle position of the density plot.} \item{col2}{Color of the density plot.} \item{lwd2}{Width of the density curve of the density plot.} \item{cex2}{Dot size of the density plot.} \item{col.hist}{Color of the histogram of the density plot} \item{alpha}{A vector of significance levels when constructing confidence ellipses and confidence bands for the mixture of multivariate normals and mixture of regressions cases, respectively. The default is 0.05} \item{marginal}{If \code{TRUE}, marginal density is presented on the side of the corresponding variable.} } \value{A plot of the output of \code{mixEM} function is presented depends on output type.} \seealso{ \code{\link{post.beta}}} \examples{ \dontrun{ ## EM output for data generated from a 2-component binary logistic regression model. beta <- matrix(c(-10, .1, 20, -.1), 2, 2) x <- runif(500, 50, 250) x1 <- cbind(1, x) xbeta <- x1%*%beta w <- rbinom(500, 1, .3) y <- w*rbinom(500, size = 1, prob = (1/(1+exp(-xbeta[, 1]))))+ (1-w)*rbinom(500, size = 1, prob = (1/(1+exp(-xbeta[, 2])))) out.2 <- logisregmixEM(y, x, beta = beta, lambda = c(.3, .7), verb = TRUE, epsilon = 1e-01) plotly_mixEM(out.2 , col2 = c("red" , "green") , density = TRUE) ## Fitting randomly generated data with a 2-component location mixture of bivariate normals. set.seed(100) x.1 <- rmvnorm(40, c(0, 0)) x.2 <- rmvnorm(60, c(3, 4)) X.1 <- rbind(x.1, x.2) mu <- list(c(0, 0), c(3, 4)) out.1 <- mvnormalmixEM(X.1, arbvar = FALSE, mu = mu, epsilon = 1e-02) plotly_mixEM(out.1 , col2 = c("brown" , "blue") , alpha = c(0.01 , 0.05 , 0.1), density = TRUE , marginal = FALSE) ## Fitting randomly generated data with a 2-component scale mixture of bivariate normals. x.3 <- rmvnorm(40, c(0, 0), sigma = matrix(c(200, 1, 1, 150), 2, 2)) x.4 <- rmvnorm(60, c(0, 0)) X.2 <- rbind(x.3, x.4) lambda <- c(0.40, 0.60) sigma <- list(diag(1, 2), matrix(c(200, 1, 1, 150), 2, 2)) out.2 <- mvnormalmixEM(X.2, arbmean = FALSE, sigma = sigma, lambda = lambda, epsilon = 1e-02) plotly_mixEM(out.1 , col2 = c("brown" , "blue") , alpha = c(0.01 , 0.05 , 0.1), density = TRUE , marginal = TRUE) ## EM output for simulated data from 2-component mixture of random effects. data(RanEffdata) set.seed(100) x <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 2:3], ncol = 2)) x <- x[1:20] y <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 1], ncol = 1)) y <- y[1:20] lambda <- c(0.45, 0.55) mu <- matrix(c(0, 4, 100, 12), 2, 2) sigma <- 2 R <- list(diag(1, 2), diag(1, 2)) em.out <- regmixEM.mixed(y, x, sigma = sigma, arb.sigma = FALSE, lambda = lambda, mu = mu, R = R, addintercept.random = FALSE, epsilon = 1e-02, verb = TRUE) plotly_mixEM(em.out , col2 = c("gold" , "purple") , density = TRUE , lwd2 = 1 , cex2 =9) ## Analyzing the Old Faithful geyser data with a 2-component mixture of normals. data(faithful) attach(faithful) set.seed(100) out <- normalmixEM(waiting, arbvar = FALSE, verb = TRUE, epsilon = 1e-04) plotly_mixEM(out, density = TRUE , col2 = c("gold" , "purple")) ## EM output for the water-level task data set. data(Waterdata) set.seed(100) water <- t(as.matrix(Waterdata[,3:10])) em.out <- repnormmixEM(water, k = 2, verb = TRUE, epsilon = 1e-03) plotly_mixEM(em.out, density = TRUE , col2 = c("gold" , "purple")) } } % \keyword{file}mixtools/man/plotly_FDR.Rd0000644000176200001440000000747214342375644015236 0ustar liggesusers\name{plotly_FDR} \alias{plotly_FDR} \title{Plot False Discovery Rate (FDR) estimates from output by EM-like strategies using \code{plotly}} \description{This is an updated version of \code{plotFDR}. For more technical details, please refer to \code{plotFDR}.} \usage{ plotly_FDR(post1, post2=NULL, lg1="FDR 1", lg2=NULL, compH0=1, alpha=0.1, complete.data =NULL, pctfdr=0.3, col = NULL, width = 3 , title = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "Index" , xlab.size = 15 , xtick.size = 15, ylab = "Probability" , ylab.size = 15 , ytick.size = 15, legend.text = "" , legend.text.size = 15 , legend.size = 15) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{post1}{The matrix of posterior probabilities from objects such as the output from \code{\link{spEMsymlocN01}}. The rows need to be sorted by increasing pvalues.} \item{post2}{A second object like \code{post1} if comparison is desired, also sorted by increasing pvalues.} \item{lg1}{Text describing the FDR estimate in \code{post1}.} \item{lg2}{Text describing the FDR estimate in \code{post2} if provided.} \item{compH0}{The component indicator associated to the null hypothesis H0, normally 1 since it is defined in this way in \code{\link{spEMsymlocN01}}, but in case of label switching in other algorithms it can be set to \code{2}.} \item{alpha}{The target FDR level; the index at which the FDR estimate crosses the horizontal line for level \code{alpha} gives the maximum number of cases to reject.} \item{complete.data}{An array with \eqn{n} lines and 2 columns, with the component indicator in column 1 and the p-values in column 2, sorted by p-values.} \item{pctfdr}{The level up to which the FDR is plotted, i.e. the scale of the vertical axis.} \item{col}{Color of traces.} \item{width}{Width of traces.} \item{title}{Text of the main title.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{legend.text}{Title of legend.} \item{legend.text.size}{Size of the legend title.} \item{legend.size}{Size of legend.} } \value{A plot of one or two FDR estimates, with the true FDR if available} \references{ \itemize{ \item Chauveau, D., Saby, N., Orton, T. G., Lemercier B., Walter, C. and Arrouys, D. Large-scale simultaneous hypothesis testing in monitoring carbon content from French soil database -- A semi-parametric mixture approach, Geoderma 219-220 (2014), 117-124. } } \author{Didier Chauveau} \seealso{ \code{\link{spEMsymlocN01}}, \code{\link{plotFDR}}} \examples{ ## Probit transform of p-values ## from a Beta-Uniform mixture model ## comparion of parametric and semiparametric EM fit ## Note: in actual situations n=thousands set.seed(50) n=300 # nb of multiple tests m=2 # 2 mixture components a=c(1,0.1); b=c(1,1); lambda=c(0.6,0.4) # parameters z=sample(1:m, n, rep=TRUE, prob = lambda) p <- rbeta(n, shape1 = a[z], shape2 = b[z]) # p-values o <- order(p) cpd <- cbind(z,p)[o,] # sorted complete data, z=1 if H0, 2 if H1 p <- cpd[,2] # sorted p-values y <- qnorm(p) # probit transform of the pvalues # gaussian EM fit with component 1 constrained to N(0,1) s1 <- normalmixEM(y, mu=c(0,-4), mean.constr = c(0,NA), sd.constr = c(1,NA)) s2 <- spEMsymlocN01(y, mu0 = c(0,-3)) # spEM with N(0,1) fit plotly_FDR(s1$post, s2$post, lg1 = "normalmixEM", lg2 = "spEMsymlocN01", complete.data = cpd) # with true FDR computed from z } % \keyword{file}mixtools/man/spEM.Rd0000755000176200001440000001464214342153463014055 0ustar liggesusers\name{spEM} \title{Semiparametric EM-like Algorithm for Mixtures of Independent Repeated Measurements} \alias{spEM} \usage{ spEM(x, mu0, blockid = 1:ncol(x), bw = bw.nrd0(as.vector(as.matrix(x))), constbw = TRUE, h = bw, eps = 1e-8, maxiter = 500, stochastic = FALSE, verb = TRUE) } \description{ Returns semiparametric EM algorithm output (Benaglia et al, 2009) for mixtures of multivariate (repeated measures) data where the coordinates of a row (case) in the data matrix are assumed to be independent, conditional on the mixture component (subpopulation) from which they are drawn. For now, this algorithm only implements model (4.7) in Benaglia et al, in which each component and block has exactly the same (nonparametric) shape and they differ only by location and scale. } \arguments{ \item{x}{An \eqn{n\times r}{n x r} matrix of data. Each of the \eqn{n} rows is a case, and each case has \eqn{r} repeated measurements. These measurements are assumed to be conditionally independent, conditional on the mixture component (subpopulation) from which the case is drawn.} \item{mu0}{Either an \eqn{m\times r}{m x r} matrix specifying the initial centers for the \link{kmeans} function, or an integer \eqn{m} specifying the number of initial centers, which are then choosen randomly in \link{kmeans}} \item{blockid}{A vector of length \eqn{r} identifying coordinates (columns of \code{x}) that are assumed to be identically distributed (i.e., in the same block). For instance, the default has all distinct elements, indicating that no two coordinates are assumed identically distributed and thus a separate set of \eqn{m} density estimates is produced for each column of \eqn{x}. On the other hand, if \code{blockid=rep(1,ncol(x))}, then the coordinates in each row are assumed conditionally i.i.d.} \item{bw}{Bandwidth for density estimation, equal to the standard deviation of the kernel density. By default, a simplistic application of the default \code{\link{bw.nrd0}} bandwidth used by \code{\link{density}} to the entire dataset.} \item{constbw}{Logical: If \code{TRUE}, use the same bandwidth for each iteration and for each component and block. If \code{FALSE}, use a separate bandwidth for each component and block, and update this bandwidth at each iteration of the algorithm using a suitably modified \code{\link{bw.nrd0}} method as described in Benaglia et al (2011).} \item{h}{Alternative way to specify the bandwidth, to provide backward compatibility.} \item{eps}{Tolerance limit for declaring algorithm convergence. Convergence is declared whenever the maximum change in any coordinate of the \code{lambda} vector (of mixing proportion estimates) does not exceed \code{eps}.} \item{maxiter}{The maximum number of iterations allowed, for both stochastic and non-stochastic versions; for non-stochastic algorithms (\code{stochastic = FALSE}), convergence may be declared before \code{maxiter} iterations (see \code{eps} above).} \item{stochastic}{Flag, if FALSE (the default), runs the non-stochastic version of the npEM algorithm, as in Benaglia et al (2009). Set to TRUE to run a stochastic version which simulates the posteriors at each iteration, and runs for \code{maxiter} iterations.} \item{verb}{If TRUE, print updates for every iteration of the algorithm as it runs} } \value{ \code{spEM} returns a list of class \code{spEM} with the following items: \item{data}{The raw data (an \eqn{n\times r}{n x r} matrix).} \item{posteriors}{An \eqn{n\times m}{n x m} matrix of posterior probabilities for observation. If \code{stochastic = TRUE}, this matrix is computed from an average over the \code{maxiter} iterations.} \item{bandwidth}{If \code{constbw==TRUE}, same as the \code{bw} input argument; otherwise, value of \code{bw} matrix at final iteration (since for now this algorithm only implements model (4.7) in Benaglia et al, the bandwidth matrix is reduced to a single bandwith scalar). This information is needed by any method that produces density estimates from the output.} \item{blockid}{Same as the \code{blockid} input argument, but recoded to have positive integer values. Also needed by any method that produces density estimates from the output.} \item{lambda}{The sequence of mixing proportions over iterations.} \item{lambdahat}{The final mixing proportions if \code{stochastic = FALSE}, or the average mixing proportions if \code{stochastic = TRUE}.} \item{mu}{The sequence of location parameters over iterations.} \item{muhat}{The final location parameters if \code{stochastic = FALSE}, or the average location parameters if \code{stochastic = TRUE}.} \item{sigma}{The sequence of scale parameters over iterations.} \item{sigmahat}{The final scale parameters if \code{stochastic = FALSE}, or the average scale parameters if \code{stochastic = TRUE}.} \item{loglik}{The sequence of log-likelihoods over iterations.} } \seealso{ \code{\link{plot.spEM}}, \code{\link{normmixrm.sim}}, \code{\link{spEMsymloc}}, \code{\link{npEM}}, \code{\link{plotseq.npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R., An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526, 2009. \item Benaglia, T., Chauveau, D. and Hunter, D.R. Bandwidth Selection in an EM-like algorithm for nonparametric multivariate mixtures. Nonparametric Statistics and Mixture Models: A Festschrift in Honor of Thomas P. Hettmansperger. World Scientific Publishing Co., pages 15-27, 2011. \item Bordes, L., Chauveau, D., and Vandekerkhove, P., An EM algorithm for a semiparametric mixture model, Computational Statistics and Data Analysis, 51: 5429-5443, 2007. } } \examples{\dontrun{ ## simulate a 2-component gaussian mixture with 3 iid repeated measures set.seed(100) mu <- matrix(c(0, 15), 2, 3) sigma <- matrix(c(1, 5), 2, 3) x <- rmvnormmix(300, lambda = c(.4,.6), mu = mu, sigma = sigma) ## apply spEM with or without an iterative bandwidth selection d <- spEM(x, mu0 = 2, blockid = rep(1,3), constbw = FALSE) d2 <- spEM(x, mu0 = 2, blockid = rep(1,3), constbw = TRUE) plot(d, xlim=c(-10, 40), ylim = c(0, .16), xlab = "", breaks = 30, cex.lab=1.5, cex.axis=1.5, addlegend=FALSE) plot(d2, newplot=FALSE, addlegend=FALSE, lty=2)} } \keyword{file} mixtools/man/ddirichlet.Rd0000755000176200001440000000071714342153463015322 0ustar liggesusers\name{ddirichlet} \alias{ddirichlet} \title{Density Function for the Dirichlet Distribution} \description{ Density function for the Dirichlet distribution. } \usage{ ddirichlet(x, alpha) } \arguments{ \item{x}{A k-dimensional vector of values that sum to 1 for which to calculate the density} \item{alpha}{A k-dimensional vector of the Dirichlet distribution parameters.} } \details{ This is usually not to be called by the user. } \keyword{internal} mixtools/man/parseconstraint.Rd0000755000176200001440000000076014342153463016424 0ustar liggesusers\name{parse.constraints} \title{Constraint Function} \alias{parse.constraints} \usage{ parse.constraints(constr, k = 2, allsame = FALSE) } \description{ Constraint function for some mixture EM algorithms. } \arguments{ \item{constr}{Vector indicating constrained/unconstrained means.} \item{k}{Number of components.} \item{allsame}{Logical indicating for processing the constraints.} } \details{ This function is not intended to be called by the user. } \keyword{internal} mixtools/man/plotly_spEMN01.Rd0000644000176200001440000000620414342453732015731 0ustar liggesusers\name{plotly_spEMN01} \alias{plotly_spEMN01} \title{Plot mixture pdf for the semiparametric mixture model output by \code{spEMsymlocN01} using \code{plotly}.} \description{This is an updated version of \code{plotlspEMN01} function by using \code{plotly}. For technical details, please refer to \code{\link{plot.spEMN01}}.} \usage{ plotly_spEMN01(x, bw=x$bandwidth, knownpdf=dnorm, add.plot=FALSE, width = 3 , col.dens = NULL, col.hist = '#1f77b4', title = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "t" , xlab.size = 15 , xtick.size = 15, ylab = "Density" , ylab.size = 15 , ytick.size = 15, legend.text = "Densities" , legend.text.size = 15 , legend.size = 15) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{An object of class "spEMN01" as returned by spEMsymlocN01} \item{bw}{Bandwidth for weighted kernel density estimation.} \item{knownpdf}{The known density of component 1, default to \code{dnorm}.} \item{add.plot}{Set to TRUE to add to an existing plot.} \item{width}{Line width.} \item{col.dens}{Color of density lines. Number of colors specified needs to be consistent with number of components.} \item{col.hist}{Color of histogram.} \item{title}{Text of the main title.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{legend.text}{Title of legend.} \item{legend.text.size}{Size of the legend title.} \item{legend.size}{Size of legend.} } \value{A plot of the density of the mixture} \references{ \itemize{ \item Chauveau, D., Saby, N., Orton, T. G., Lemercier B., Walter, C. and Arrouys, D. Large-scale simultaneous hypothesis testing in soil monitoring: A semi-parametric mixture approach, preprint (2013). } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{spEMsymlocN01}}, \code{\link{plot.spEMN01}}} % \examples{ ## Probit transform of p-values ## from a Beta-Uniform mixture model ## comparion of parametric and semiparametric EM fit ## Note: in actual situations n=thousands set.seed(50) n=300 # nb of multiple tests m=2 # 2 mixture components a=c(1,0.1); b=c(1,1); lambda=c(0.6,0.4) # parameters z=sample(1:m, n, rep=TRUE, prob = lambda) p <- rbeta(n, shape1 = a[z], shape2 = b[z]) # p-values o <- order(p) cpd <- cbind(z,p)[o,] # sorted complete data, z=1 if H0, 2 if H1 p <- cpd[,2] # sorted p-values y <- qnorm(p) # probit transform of the pvalues # gaussian EM fit with component 1 constrained to N(0,1) s1 <- normalmixEM(y, mu=c(0,-4), mean.constr = c(0,NA), sd.constr = c(1,NA)) s2 <- spEMsymlocN01(y, mu0 = c(0,-3)) # spEM with N(0,1) fit plotly_spEMN01(s2 , add.plot = FALSE) %%\dontrun{ %%} } \keyword{file}mixtools/man/regmixMH.Rd0000755000176200001440000000661014342153463014725 0ustar liggesusers\name{regmixMH} \title{Metropolis-Hastings Algorithm for Mixtures of Regressions} \alias{regmixMH} \usage{ regmixMH(y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, addintercept = TRUE, mu = NULL, sig = NULL, lam.hyp = NULL, sampsize = 1000, omega = 0.01, thin = 1) } \description{ Return Metropolis-Hastings (M-H) algorithm output for mixtures of multiple regressions with arbitrarily many components. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An nxp matrix of predictors. See \code{addintercept} below.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and number of components is determined by \code{beta}.} \item{beta}{Initial value of \code{beta} parameters. Should be a pxk matrix, where p is the number of columns of x and k is number of components. If NULL, then \code{beta} has uniform standard normal entries. If both \code{lambda} and \code{beta} are NULL, then number of components is determined by \code{s}.} \item{s}{k-vector of standard deviations. If NULL, then \eqn{1/\code{s}^2} has random standard exponential entries. If \code{lambda}, \code{beta}, and \code{s} are NULL, then number of components determined by \code{k}.} \item{k}{Number of components. Ignored unless all of \code{lambda}, \code{beta}, and \code{s} are NULL.} \item{addintercept}{If TRUE, a column of ones is appended to the x matrix before the value of p is calculated.} \item{mu}{The prior hyperparameter of same size as \code{beta}; the means of \code{beta} components. If NULL, these are set to zero.} \item{sig}{The prior hyperparameter of same size as \code{beta}; the standard deviations of \code{beta} components. If NULL, these are all set to five times the overall standard deviation of y.} \item{lam.hyp}{The prior hyperparameter of length \code{k} for the mixing proportions (i.e., these are hyperparameters for the Dirichlet distribution). If NULL, these are generated from a standard uniform distribution and then scaled to sum to 1.} \item{sampsize}{Size of posterior sample returned.} \item{omega}{Multiplier of step size to control M-H acceptance rate. Values closer to zero result in higher acceptance rates, generally.} \item{thin}{Lag between parameter vectors that will be kept.} } \value{ \code{regmixMH} returns a list of class \code{mixMCMC} with items: \item{x}{A nxp matrix of the predictors.} \item{y}{A vector of the responses.} \item{theta}{A (\code{sampsize}/\code{thin}) x q matrix of MCMC-sampled q-vectors, where q is the total number of parameters in \code{beta}, \code{s}, and \code{lambda}.} \item{k}{The number of components.} } \seealso{ \code{\link{regcr}} } \references{ Hurn, M., Justel, A. and Robert, C. P. (2003) Estimating Mixtures of Regressions, \emph{Journal of Computational and Graphical Statistics} \bold{12(1)}, 55--79. } \examples{ ## M-H algorithm for NOdata with acceptance rate about 40\%. data(NOdata) attach(NOdata) set.seed(100) beta <- matrix(c(1.3, -0.1, 0.6, 0.1), 2, 2) sigma <- c(.02, .05) MH.out <- regmixMH(Equivalence, NO, beta = beta, s = sigma, sampsize = 2500, omega = .0013) MH.out$theta[2400:2499,] } \keyword{file} mixtools/man/plotly_ellipse.Rd0000644000176200001440000000374714341210764016247 0ustar liggesusers\name{plotly_ellipse} \title{Draw Two-Dimensional Ellipse Based on Mean and Covariance using \code{plotly}} \alias{plotly_ellipse} \usage{ plotly_ellipse(mu, sigma, alpha=.05, npoints=250, draw=TRUE, cex = 3, col = "#1f77b4", lwd = 3, title = "", title.x = 0.5, title.y = 0.95, title.size = 15, xlab = "X", xlab.size = 15, xtick.size = 15, ylab = "Y", ylab.size = 15, ytick.size = 15) } \description{ This is an updated version of \code{ellipse}. For more technical details, please refer to \code{ellipse}. } \arguments{ \item{mu}{A 2-vector giving the mean.} \item{sigma}{A 2x2 matrix giving the covariance matrix.} \item{alpha}{Probability to be excluded from the ellipse. The default value is alpha = .05, which results in a 95\% ellipse.} \item{npoints}{Number of points comprising the border of the ellipse.} \item{draw}{If TRUE, draw the ellipse.} \item{cex}{Size of markers.} \item{lwd}{Line width of the ellipse.} \item{col}{Color of both markers and lines.} \item{title}{Text of the main title.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} } \value{ \code{plotly_ellipse} returns an \code{npoints}x2 matrix of the points forming the border of the ellipse. } \references{ Johnson, R. A. and Wichern, D. W. (2002) \emph{Applied Multivariate Statistical Analysis, Fifth Edition}, Prentice Hall. } \seealso{ \code{\link{regcr}}, \code{\link{ellipse}} } \examples{ ## Produce a 95% ellipse with the specified mean and covariance structure. mu <- c(1, 3) sigma <- matrix(c(1, .3, .3, 1.5), 2, 2) plotly_ellipse(mu, sigma, npoints = 200) } \keyword{file} mixtools/man/plotseq.npEM.Rd0000644000176200001440000000277614342153463015540 0ustar liggesusers\name{plotseq.npEM} \alias{plotseq.npEM} \title{Plotting sequences of estimates from non- or semiparametric EM-like Algorithm} \usage{ \method{plotseq}{npEM}(x, \dots) } \description{ Returns plots of the sequences of scalar parameter estimates along iterations from an object of class \code{npEM}. } \arguments{ \item{x}{an object of class \code{npEM}, as output by \code{\link{npEM}} or \code{\link{spEMsymloc}}} \item{\dots}{further parameters that are passed to \code{\link{plot}}} } \details{ \code{plotseq.npEM} returns a figure with one plot for each component proportion, and, in the case of \code{\link{spEMsymloc}}, one plot for each component mean. } \seealso{ \code{\link{plot.npEM}}, \code{\link{rnormmix}}, \code{\link{npEM}}, \code{\link{spEMsymloc}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics (to appear). \item Bordes, L., Chauveau, D., and Vandekerkhove, P. (2007), An EM algorithm for a semiparametric mixture model, Computational Statistics and Data Analysis, 51: 5429-5443. } } \examples{ ## Example from a normal location mixture n <- 200 set.seed(100) lambda <- c(1/3,2/3) mu <- c(0, 4); sigma<-rep(1, 2) x <- rnormmix(n, lambda, mu, sigma) b <- spEMsymloc(x, mu0=c(-1, 2), stochastic=FALSE) plotseq(b) bst <- spEMsymloc(x, mu0=c(-1, 2), stochastic=TRUE) plotseq(bst) } \keyword{file} mixtools/man/rweibullmix.Rd0000644000176200001440000000223614342153463015545 0ustar liggesusers\name{rweibullmix} \title{Simulate from Mixtures of Weibull distributions} \alias{rweibullmix} \usage{ rweibullmix(n, lambda = 1, shape = 1, scale = 1) } \description{ Simulate from a mixture of univariate Weibull distributions. } \arguments{ \item{n}{Number of cases to simulate.} \item{lambda}{Vector of mixture probabilities, with length equal to \eqn{m}, the desired number of components (subpopulations). This is assumed to sum to 1.} \item{shape}{Vector of component shapes.} \item{scale}{Vector of component scales.} } \value{ \code{rexpmix} returns an \eqn{n}-vector sampled from an \eqn{m}-component mixture of univariate Weibull distributions. } %%\details{This function simply calls \code{\link{sample}} and \code{\link{rexp}}.} \seealso{ \code{\link{rnormmix}} and \code{\link{rmvnormmix}} for Gaussian mixtures, \code{\link{rexpmix}} for mixture of exponentials. } \examples{ n = 500 # sample size m = 2 # nb components lambda=c(0.4, 0.6) shape <- c(0.5,5); scale <- c(1,20) # model parameters set.seed(321) x <- rweibullmix(n, lambda, shape, scale) # iid ~ weibull mixture ## histogram of the simulated data. hist(x, col=8) } \keyword{file} mixtools/man/plotly_seq.npEM.Rd0000644000176200001440000000441214342427003016223 0ustar liggesusers\name{plotly_seq.npEM} \alias{plotly_seq.npEM} \title{Plotting sequences of estimates from non- or semiparametric EM-like Algorithm using \code{plotly}} \description{This is an updated version of \code{\link{plotseq.npEM}}. For technical details, please refer to \code{\link{plotseq.npEM}}. } \usage{ plotly_seq.npEM (x, col = '#1f77b4' , width = 6, xlab = "Iteration" , xlab.size = 15 , xtick.size = 15, ylab.size = 15 , ytick.size = 15, title.size = 15 , title.x = 0.5 , title.y = 0.95) } \arguments{ \item{x}{an object of class \code{npEM}, as output by \code{\link{npEM}} or \code{\link{spEMsymloc}}} \item{col}{Line color.} \item{width}{Line width.} \item{title}{Text of the main title.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} } \value{\code{plotly_seq.npEM} returns a figure with one plot for each component proportion, and, in the case of \code{\link{spEMsymloc}}, one plot for each component mean.} \seealso{ \code{\link{plot.npEM}}, \code{\link{rnormmix}}, \code{\link{npEM}}, \code{\link{spEMsymloc}}, \code{\link{plotly_seq.npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics (to appear). \item Bordes, L., Chauveau, D., and Vandekerkhove, P. (2007), An EM algorithm for a semiparametric mixture model, Computational Statistics and Data Analysis, 51: 5429-5443. } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \examples{ \dontrun{ ## Examine and plot water-level task data set. ## First, try a 3-component solution where no two coordinates are ## assumed i.d. data(Waterdata) set.seed(100) ## Not run: a <- npEM(Waterdata[,3:10], mu0=3, bw=4) # Assume indep but not iid plotly_seq.npEM(a) } } \keyword{file} mixtools/man/makemultdata.Rd0000755000176200001440000000521514342153463015656 0ustar liggesusers\name{makemultdata} \title{Produce Cutpoint Multinomial Data} \alias{makemultdata} \usage{ makemultdata(..., cuts) } \description{ Change data into a matrix of multinomial counts using the cutpoint method and generate EM algorithm starting values for a k-component mixture of multinomials. } \arguments{ \item{...}{Either vectors (possibly of different lengths) of raw data or an nxm matrix (or data frame) of data. If \code{...} are vectors of varying length, then \code{makemultdata} will create a matrix of size nxm where n is the sample size and m is the length of the vector with maximum length. Those vectors with length less than m will have \code{NA}s to make the corresponding row in the matrix of length m. If \code{...} is a matrix (or data frame), then the rows must correspond to the sample and the columns the repeated measures.} \item{cuts}{A vector of cutpoints. This vector is sorted by the algorithm.} } \value{ \code{makemultdata} returns an object which is a list with components: \item{x}{An nxm matrix of the raw data.} \item{y}{An nxp matrix of the discretized data where p is one more than the number of cutpoints. Each row is a multinomial vector of counts. In particular, each row should sum to the number of repeated measures for that sample.} } \details{ The (i, j)th entry of the matrix \code{y} (for j < p) is equal to the number of entries in the ith column of \code{x} that are less than or equal to \code{cuts}[j]. The (i, p)th entry is equal to the number of entries greater than \code{cuts}[j]. } \seealso{ \code{\link{compCDF}}, \code{\link{multmixmodel.sel}}, \code{\link{multmixEM}} } \references{ Elmore, R. T., Hettmansperger, T. P. and Xuan, F. (2004) The Sign Statistic, One-Way Layouts and Mixture Models, \emph{Statistical Science} \bold{19(4)}, 579--587. } \examples{ ## Randomly generated data. set.seed(100) y <- matrix(rpois(70, 6), 10, 7) cuts <- c(2, 5, 7) out1 <- makemultdata(y, cuts = cuts) out1 ## The sulfur content of the coal seams in Texas. A <- c(1.51, 1.92, 1.08, 2.04, 2.14, 1.76, 1.17) B <- c(1.69, 0.64, .9, 1.41, 1.01, .84, 1.28, 1.59) C <- c(1.56, 1.22, 1.32, 1.39, 1.33, 1.54, 1.04, 2.25, 1.49) D <- c(1.3, .75, 1.26, .69, .62, .9, 1.2, .32) E <- c(.73, .8, .9, 1.24, .82, .72, .57, 1.18, .54, 1.3) out2 <- makemultdata(A, B, C, D, E, cuts = median(c(A, B, C, D, E))) out2 ## The reaction time data. data(RTdata) out3 <- makemultdata(RTdata, cuts = 100*c(5, 10, 12, 14, 16, 20, 25, 30, 40, 50)) dim(out3$y) out3$y[1:10,] } \keyword{file} mixtools/man/boot.comp.Rd0000755000176200001440000001153214342153463015104 0ustar liggesusers\name{boot.comp} \title{Performs Parametric Bootstrap for Sequentially Testing the Number of Components in Various Mixture Models} \alias{boot.comp} \usage{ boot.comp(y, x = NULL, N = NULL, max.comp = 2, B = 100, sig = 0.05, arbmean = TRUE, arbvar = TRUE, mix.type = c("logisregmix", "multmix", "mvnormalmix", "normalmix", "poisregmix", "regmix", "regmix.mixed", "repnormmix"), hist = TRUE, ...) } \description{ Performs a parametric bootstrap by producing B bootstrap realizations of the likelihood ratio statistic for testing the null hypothesis of a k-component fit versus the alternative hypothesis of a (k+1)-component fit to various mixture models. This is performed for up to a specified number of maximum components, k. A p-value is calculated for each test and once the p-value is above a specified significance level, the testing terminates. An optional histogram showing the distribution of the likelihood ratio statistic along with the observed statistic can also be produced. } \arguments{ \item{y}{The raw data for \code{multmix}, \code{mvnormalmix}, \code{normalmix}, and \code{repnormmix} and the response values for \code{logisregmix}, \code{poisregmix}, and \code{regmix}. See the documentation concerning their respective EM algorithms for specific structure of the raw data.} \item{x}{The predictor values required only for the regression mixtures \code{logisregmix}, \code{poisregmix}, and \code{regmix}. A column of 1s for the intercept term must not be included! See the documentation concerning their respective EM algorithms for specific structure of the predictor values.} \item{N}{An n-vector of number of trials for the logistic regression type \code{logisregmix}. If NULL, then \code{N} is an n-vector of 1s for binary logistic regression.} \item{max.comp}{The maximum number of components to test for. The default is 2. This function will perform a test of k-components versus (k+1)-components sequentially until we fail to reject the null hypothesis. This decision rule is governed by the calculated p-value and \code{sig}.} \item{B}{The number of bootstrap realizations of the likelihood ratio statistic to produce. The default is 100, but ideally, values of 1000 or more would be more acceptable.} \item{sig}{The significance level for which to compare the p-value against when performing the test of k-components versus (k+1)-components.} \item{arbmean}{If FALSE, then a scale mixture analysis can be performed for \code{mvnormalmix}, \code{normalmix}, \code{regmix}, or \code{repnormmix}. The default is TRUE.} \item{arbvar}{If FALSE, then a location mixture analysis can be performed for \code{mvnormalmix}, \code{normalmix}, \code{regmix}, or \code{repnormmix}. The default is TRUE.} \item{mix.type}{The type of mixture analysis you wish to perform. The data inputted for \code{y} and \code{x} depend on which type of mixture is selected. \code{logisregmix} corresponds to a mixture of logistic regressions. \code{multmix} corresponds to a mixture of multinomials with data determined by the cut-point method. \code{mvnormalmix} corresponds to a mixture of multivariate normals. \code{normalmix} corresponds to a mixture of univariate normals. \code{poisregmix} corresponds to a mixture of Poisson regressions. \code{regmix} corresponds to a mixture of regressions with normal components. \code{regmix.mixed} corresponds to a mixture of regressions with random or mixed effects. \code{repnormmix} corresponds to a mixture of normals with repeated measurements.} \item{hist}{An argument to provide a matrix plot of histograms for the boostrapped likelihood ratio statistic.} \item{...}{Additional arguments passed to the various EM algorithms for the mixture of interest.} } \value{ \code{boot.comp} returns a list with items: \item{p.values}{The p-values for each test of k-components versus (k+1)-components.} \item{log.lik}{The B bootstrap realizations of the likelihood ratio statistic.} \item{obs.log.lik}{The observed likelihood ratio statistic for each test which is used in determining the p-values.} } \seealso{ \code{\link{logisregmixEM}}, \code{\link{multmixEM}}, \code{\link{mvnormalmixEM}}, \code{\link{normalmixEM}}, \code{\link{poisregmixEM}}, \code{\link{regmixEM}}, \code{\link{regmixEM.mixed}}, \code{\link{repnormmixEM}} } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. } \examples{ ## Bootstrapping to test the number of components on the RTdata. data(RTdata) set.seed(100) x <- as.matrix(RTdata[, 1:3]) y <- makemultdata(x, cuts = quantile(x, (1:9)/10))$y a <- boot.comp(y = y, max.comp = 1, B = 5, mix.type = "multmix", epsilon = 1e-3) a$p.values } \keyword{file} mixtools/man/plotly_expRMM.Rd0000644000176200001440000000615314343144323015753 0ustar liggesusers\name{plotly_expRMM} \alias{plotly_expRMM} %- Also NEED an '\alias' for EACH other topic documented here. \title{Plot sequences from the EM algorithm for censored mixture of exponentials using \code{plotly} } \description{This is an updated function of \code{plotexpRMM}. For more technical details, please refer to \code{plotexpRMM}. } \usage{ plotly_expRMM(a , title = NULL , rowstyle = TRUE , subtitle=NULL, width = 2 , cex = 2 , col.comp = NULL, legend.text = NULL, legend.text.size = 15, legend.size = 15, title.x = 0.5, title.y = 0.95, title.size = 15, xlab.size = 15, xtick.size = 15, ylab.size = 15, ytick.size = 15) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{a}{An object returned by \code{\link{expRMM_EM}}.} \item{title}{The title of the plot, set to some default value if \code{NULL}.} \item{rowstyle}{Window organization, for plots in rows (the default) or columns.} \item{subtitle}{A subtitle for the plot, set to some default value if \code{NULL}.} \item{width}{Line width.} \item{cex}{Size of dots.} \item{col.comp}{Color of different components. Number of color specified needs to be consistent with number of components.} \item{legend.text}{Title of legend.} \item{legend.text.size}{Size of the legend title.} \item{legend.size}{Size of legend.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} } \value{The plot returned} \seealso{ Related functions: \code{\link{expRMM_EM}}, \code{\link{summary.mixEM}}, \code{\link{plot.mixEM}}, \code{\link{plotexpRMM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{weibullRMM_SEM}}, \code{\link{spRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \examples{ n=300 # sample size m=2 # number of mixture components lambda <- c(1/3,1-1/3); rate <- c(1,1/10) # mixture parameters set.seed(1234) x <- rexpmix(n, lambda, rate) # iid ~ exponential mixture cs=runif(n,0,max(x)) # Censoring (uniform) and incomplete data t <- apply(cbind(x,cs),1,min) # observed or censored data d <- 1*(x <= cs) # censoring indicator ###### EM for RMM, exponential lifetimes l0 <- rep(1/m,m); r0 <- c(1, 0.5) # "arbitrary" initial values a <- expRMM_EM(t, d, lambda=l0, rate=r0, k = m) summary(a) # EM estimates etc plotly_expRMM(a , rowstyle = TRUE) # plot of EM sequences %%\dontrun{ %%} } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{file} mixtools/man/spEMsymloc.Rd0000644000176200001440000000773414342153463015305 0ustar liggesusers\name{spEMsymloc} \title{Semiparametric EM-like Algorithm for univariate symmetric location mixture} \alias{spEMsymloc} \usage{ spEMsymloc(x, mu0, bw = bw.nrd0(x), h=bw, eps = 1e-8, maxiter = 100, stochastic = FALSE, verbose = FALSE) } \description{ Returns semiparametric EM algorithm output (Bordes et al, 2007, and Benaglia et al, 2009) for location mixtures of univariate data and symmetric component density. } \arguments{ \item{x}{A vector of length \eqn{n}{n} consisting of the data.} \item{mu0}{Either a vector specifying the initial centers for the \link{kmeans} function, and from which the number of component is obtained, or an integer \eqn{m} specifying the number of initial centers, which are then choosen randomly in \link{kmeans}.} \item{bw}{Bandwidth for density estimation, equal to the standard deviation of the kernel density.} \item{h}{Alternative way to specify the bandwidth, to provide backward compatibility.} \item{eps}{Tolerance limit for declaring algorithm convergence. Convergence is declared before \code{maxiter} iterations whenever the maximum change in any coordinate of the \code{lambda} (mixing proportion estimates) and \code{mu} (means) vector does not exceed \code{eps}.} \item{maxiter}{The maximum number of iterations allowed, for both stochastic and non-stochastic versions; for non-stochastic algorithms (\code{stochastic = FALSE}), convergence may be declared before \code{maxiter} iterations (see \code{eps} above).} \item{stochastic}{Flag, if FALSE (the default), runs the non-stochastic version of the algorithm, as in Benaglia et al (2009). Set to TRUE to run a stochastic version which simulates the posteriors at each iteration (as in Bordes et al, 2007), and runs for \code{maxiter} iterations.} \item{verbose}{If TRUE, print updates for every iteration of the algorithm as it runs} } \value{ \code{spEMsymloc} returns a list of class \code{npEM} with the following items: \item{data}{The raw data (an \eqn{n\times r}{n x r} matrix).} \item{posteriors}{An \eqn{n\times m}{n x m} matrix of posterior probabilities for observations. If \code{stochastic = TRUE}, this matrix is computed from an average over the \code{maxiter} iterations.} \item{bandwidth}{Same as the \code{bw} input argument, returned because this information is needed by any method that produces density estimates from the output.} \item{lambda}{The sequence of mixing proportions over iterations.} \item{lambdahat}{The final estimate for mixing proportions if \code{stochastic = FALSE}, the average over the sequence if \code{stochastic = TRUE}.} \item{mu}{the sequence of component means over iterations.} \item{muhat}{the final estimate of component means if \code{stochastic = FALSE}, the average over the sequence if \code{stochastic = TRUE}.} \item{symmetric}{Flag indicating that the kernel density estimate is using a symmetry assumption.} } \seealso{ \code{\link{plot.npEM}}, \code{\link{rnormmix}}, \code{\link{npEM}}, \code{\link{spEMsymlocN01}}, \code{\link{plotseq.npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R., An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526, 2009. \item Benaglia, T., Chauveau, D., Hunter, D. R., and Young, D. mixtools: An R package for analyzing finite mixture models. Journal of Statistical Software, 32(6):1-29, 2009. \item Bordes, L., Chauveau, D., and Vandekerkhove, P. (2007), An EM algorithm for a semiparametric mixture model, Computational Statistics and Data Analysis, 51: 5429-5443. } } \examples{ ## Example from a normal location mixture set.seed(100) n <- 200 lambda <- c(1/3,2/3) mu <- c(0, 4); sigma<-rep(1, 2) x <- rnormmix(n, lambda, mu, sigma) out.stoc <- spEMsymloc(x, mu0=c(-1, 2), stochastic=TRUE) out.nonstoc <- spEMsymloc(x, mu0=c(-1, 2)) } \keyword{file} mixtools/man/weibullRMM_SEM.Rd0000644000176200001440000001102614343144476015727 0ustar liggesusers\name{weibullRMM_SEM} \title{St-EM algorithm for Reliability Mixture Models (RMM) of Weibull with right Censoring} \alias{weibullRMM_SEM} \usage{ weibullRMM_SEM(x, d = NULL, lambda = NULL, shape = NULL, scale = NULL, k = 2, maxit = 200, maxit.survreg = 200, epsilon = 1e-03, averaged = TRUE, verb = FALSE) } \description{ Parametric Stochastic EM (St-EM) algorithm for univariate finite mixture of Weibull distributions with randomly right censored data. } \arguments{ \item{x}{A vector of \eqn{n}{n} real positive lifetime (possibly censored) durations. If \code{d} is not \code{NULL} then a vector of random censoring times \code{c} occured, so that \eqn{x= min(x,c)} and \eqn{d = I(x <= c)}.} \item{d}{The vector of censoring indication, where 1 means observed lifetime data, and 0 means censored lifetime data.} \item{lambda}{Initial value of mixing proportions. If \code{NULL}, then \code{lambda} is set to \code{rep(1/k,k)}.} \item{shape}{Initial value of Weibull component shapes, all set to 1 if \code{NULL}.} \item{scale}{Initial value of Weibull component scales, all set to 1 if \code{NULL}.} \item{k}{Number of components of the mixture.} \item{maxit}{The number of iterations allowed, since for St-EM algorithms convergence is not based on stabilization, exactly \code{maxit} iterations are performed (see Bordes L. and Chauveau D. (2016) reference below).} \item{maxit.survreg}{The number of iterations allowed in the computations of the MLE for censored weibull data from the \code{survival} package (see Bordes L. and Chauveau D. (2016) reference below).} \item{epsilon}{Tolerance parameter used in the numerical computations of the MLE for censored weibull data by \code{survreg} from the \code{survival} package (see Bordes L. and Chauveau D. (2016) reference below).} \item{averaged}{The way of updating parameters at each iteration: if \code{TRUE}, current values of the parameters are obtained by averaging the sequence (see Bordes L. and Chauveau D. (2016) reference below).} \item{verb}{If TRUE, print updates for every iteration of the algorithm as it runs} } \details{This St-EM algorithm calls functions from the \code{survival} package to compute parametric MLE for censored weibull data.} \value{ \code{weibullRMM_SEM} returns a list of class "mixEM" with the following items: \item{x}{The input data.} \item{d}{The input censoring indicator.} \item{lambda}{The estimates for the mixing proportions.} \item{scale}{The estimates for the Weibull component scales.} \item{shape}{The estimates for the Weibull component shapes.} \item{loglik}{The log-likelihood value at convergence of the algorithm.} \item{posterior}{An \eqn{n\times k}{n x k} matrix of posterior probabilities for observation, after convergence of the algorithm.} \item{all.loglik}{The sequence of log-likelihoods over iterations.} \item{all.lambda}{The sequence of mixing proportions over iterations.} \item{all.scale}{The sequence of component scales over iterations.} \item{all.shape}{The sequence of component shapes over iterations.} \item{ft}{A character vector giving the name of the function called.} } \seealso{ Related functions: \code{\link{plotweibullRMM}}, \code{\link{summary.mixEM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{expRMM_EM}}, \code{\link{spRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} \examples{ n = 500 # sample size m = 2 # nb components lambda=c(0.4, 0.6) shape <- c(0.5,5); scale <- c(1,20) # model parameters set.seed(321) x <- rweibullmix(n, lambda, shape, scale) # iid ~ weibull mixture cs=runif(n,0,max(x)+10) # iid censoring times t <- apply(cbind(x,cs),1,min) # censored observations d <- 1*(x <= cs) # censoring indicator ## set arbitrary or "reasonable" (e.g., data-driven) initial values l0 <- rep(1/m,m); sh0 <- c(1, 2); sc0 <- c(2,10) # Stochastic EM algorithm a <- weibullRMM_SEM(t, d, lambda = l0, shape = sh0, scale = sc0, maxit = 200) summary(a) # Parameters estimates etc plotweibullRMM(a) # plot of St-EM sequences plot(a, which=2) # or equivalently, S3 method for "mixEM" object %%\dontrun{ %%} } \keyword{file} mixtools/man/plot.npEM.Rd0000755000176200001440000000730514342153463015023 0ustar liggesusers\name{plot.npEM} \title{Plot Nonparametric or Semiparametric EM Output} \alias{plot.npEM} \alias{plot.spEM} \usage{ \method{plot}{npEM}(x, blocks = NULL, hist=TRUE, addlegend = TRUE, scale=TRUE, title=NULL, breaks="Sturges", ylim=NULL, dens.col, newplot = TRUE, pos.legend = "topright", cex.legend = 1, \dots) \method{plot}{spEM}(x, blocks = NULL, hist=TRUE, addlegend = TRUE, scale=TRUE, title=NULL, breaks="Sturges", ylim=NULL, dens.col, newplot = TRUE, pos.legend = "topright", cex.legend = 1, \dots) } \description{ Takes an object of class \code{npEM} and returns a set of plots of the density estimates for each block and each component. There is one plot per block, with all the components displayed on each block so it is possible to see the mixture structure for each block. } \arguments{ \item{x}{An object of class \code{npEM} such as the output of the \code{\link{npEM}} function} \item{blocks}{Blocks (of repeated measures coordinates) to plot; not relevant for univariate case. Default is to plot all blocks.} \item{hist}{If TRUE, superimpose density estimate plots on a histogram of the data} \item{addlegend}{If TRUE, adds legend to the plot.} \item{scale}{If TRUE, scale each density estimate by its corresponding estimated mixing proportion, so that the total area under all densities equals 1 and the densities plotted may be added to produce an estimate of the mixture density. When FALSE, each density curve has area 1 in the plot.} \item{title}{Alternative vector of main titles for plots (recycled as many times as needed)} \item{breaks}{Passed directly to the \code{\link{hist}} function} \item{ylim}{\code{ylim} parameter to use for all plots, if desired. If not given, each plot uses its own ylim that ensures that no part of the plot will go past the top of the plotting area.} \item{dens.col}{Color values to use for the individual component density functions, repeated as necessary. Default value is \code{2:(m+1)}.} \item{newplot}{If TRUE, creates a new plot.} \item{pos.legend}{Single argument specifying the position of the legend. See `Details' section of \code{\link{legend}}.} \item{cex.legend}{Character expansion factor for \code{\link{legend}}.} \item{\dots}{Any remaining arguments are passed to the \code{\link{hist}} and \code{\link{lines}} functions.} } \value{ \code{plot.npEM} returns a list with two elements: % \item{means}{A \eqn{B\times m}{B x m} matrix of estimated population means, % where \eqn{B} is the number of blocks and \eqn{m} is the number of mixture components % (subpopulations)} % \item{variances}{A \eqn{B\times m}{B x m} matrix of estimated population variances} \item{x}{List of matrices. The \eqn{j}th column of the \eqn{i}th matrix is the vector of \eqn{x}-values for the \eqn{j}th density in the \eqn{i}th plot.} \item{y}{\eqn{y}-values, given in the same form as the \eqn{x}-values.} } \seealso{ \code{\link{npEM}}, \code{\link{density.npEM}}, \code{\link{spEMsymloc}}, \code{\link{plotseq.npEM}} } \examples{ ## Examine and plot water-level task data set. ## First, try a 3-component solution where no two coordinates are ## assumed i.d. data(Waterdata) set.seed(100) \dontrun{ a <- npEM(Waterdata[,3:10], 3, bw=4) par(mfrow=c(2,4)) plot(a) # This produces 8 plots, one for each coordinate } \dontrun{ ## Next, same thing but pairing clock angles that are directly opposite one ## another (1:00 with 7:00, 2:00 with 8:00, etc.) b <- npEM(Waterdata[,3:10], 3, blockid=c(4,3,2,1,3,4,1,2), bw=4) par(mfrow=c(2,2)) plot(b) # Now only 4 plots, one for each block } } \keyword{file} mixtools/man/mixtools-internal.Rd0000755000176200001440000001047614342153463016702 0ustar liggesusers\name{mixtools-internal} \alias{inv.logit} \alias{dexpmixt} \alias{HRkde} \alias{kern.B} \alias{kern.C} \alias{kern.G} \alias{kern.O} \alias{kern.T} \alias{kfoldCV} \alias{KMintegrate} \alias{KMod} \alias{ldc} \alias{logit} \alias{npMSL_old} \alias{plotseq} \alias{rlnormscalemix} \alias{splitsample} \alias{triang_wkde} \alias{wbw.kCV} \title{Internal 'mixtools' Functions} \description{ Internal kernel, semiparametric-related, and miscellaneous functions for the package \code{mixtools}. } \usage{ dexpmixt(t, lam, rate) HRkde(cpd, u = cpd[,1], kernelft = triang_wkde, bw = rep(bw.nrd0(as.vector(cpd[,1])), length(cpd[,1]))) inv.logit(eta) kern.B(x, xi, h, g = 0) kern.C(x, xi, h) kern.G(x, xi, h) kern.O(x, xi, h) kern.T(x, xi, h) kfoldCV(h, x, nbsets = 2, w = rep(1, length(x)), lower = mean(x) - 5*sd(x), upper = mean(x) + 5*sd(x)) KMintegrate(s) KMod(cpd, already.ordered = TRUE) ldc(data, class, score) logit(mu) npMSL_old(x, mu0, blockid = 1:ncol(x), bw=bw.nrd0(as.vector(as.matrix(x))), samebw = TRUE, h=bw, eps=1e-8, maxiter=500, bwiter = maxiter, ngrid = 200, post = NULL, verb = TRUE) plotseq(x, ...) rlnormscalemix(n, lambda=1, meanlog=1, sdlog=1, scale=0.1) splitsample(n, nbsets = 2) triang_wkde(t, u=t, w=rep(1/length(t),length(t)), bw=rep(bw.nrd0(t), length(t))) wbw.kCV(x, nbfold = 5, w = rep(1, length(x)), hmin = 0.1*hmax, hmax = NULL) } \arguments{ \item{x}{A vector of values to which local modeling techniques are applied.} \item{xi}{An n-vector of data values.} \item{h}{The bandwidth controlling the size of the window used for the local estimation around \code{x}. This pertains to its usage in the kernel functionns \code{kern.B}, \code{kern.C}, \code{kern.G}, \code{kern.O}, and \code{kern.T}. For its usage in the \code{kfoldCV} function, see updated arguments in the \code{npMSL} function.} \item{g}{A shape parameter required for the symmetric beta kernel. The default is \code{g} = 0 which yields the uniform kernel. Some common values are \code{g} = 1 for the Epanechnikov kernel, \code{g} = 2 for the biweight kernel, and \code{g} = 3 for the triweight kernel.} \item{mu0}{See updated arguments in the \code{npMSL} function.} \item{blockid}{See updated arguments in the \code{npMSL} function.} \item{bw}{See updated arguments in the \code{npMSL} function.} \item{samebw}{See updated arguments in the \code{npMSL} function.} \item{eps}{See updated arguments in the \code{npMSL} function.} \item{maxiter}{See updated arguments in the \code{npMSL} function.} \item{bwiter}{See updated arguments in the \code{npMSL} function.} \item{ngrid}{See updated arguments in the \code{npMSL} function.} \item{post}{See updated arguments in the \code{npMSL} function.} \item{verb}{See updated arguments in the \code{npMSL} function.} \item{n}{See updated arguments in the \code{npMSL} function.} \item{nbsets}{See updated arguments in the \code{npMSL} function.} \item{w}{See updated arguments in the \code{npMSL} function.} \item{lower}{See updated arguments in the \code{npMSL} function.} \item{upper}{See updated arguments in the \code{npMSL} function.} \item{nbfold}{See updated arguments in the \code{npMSL} function.} \item{hmin}{See updated arguments in the \code{npMSL} function.} \item{hmax}{See updated arguments in the \code{npMSL} function.} \item{data}{Data, possibly multivariate, fed to the \code{mixturegram} function.} \item{class}{The number of classes, inputted based on number of components in the \code{mixturegram} function.} \item{score}{The score vector from LDA used in constructing a mixturegram.} \item{lam}{A vector of mixture proportions, should sum to one.} \item{rate}{A vector of mixture component rates.} \item{t}{Argument for \code{dexpmixt}.} \item{mu}{A proportion for which to calculate the logit function; i.e., \code{log(mu / (1 - mu))}.} \item{eta}{Any real value for which to calculate the inverse logit function; i.e., \code{1 / (1 + exp(eta))}.} \item{cpd}{Argument for \code{HRkde}.} \item{kernelft}{Argument for \code{HRkde}.} \item{s}{Argument for \code{KMintegrate}.} \item{meanlog}{Argument for \code{rlnormscalemix}.} \item{sdlog}{Argument for \code{rlnormscalemix}.} } \details{ These are usually not to be called by the user. } \seealso{ \code{\link{npMSL}} } \keyword{internal} mixtools/man/plotweibullRMM.Rd0000644000176200001440000000475614343144421016124 0ustar liggesusers\name{plotweibullRMM} \alias{plotweibullRMM} %- Also NEED an '\alias' for EACH other topic documented here. \title{Plot sequences from the Stochastic EM algorithm for mixture of Weibull } \description{Function for plotting sequences of estimates along iterations, from an object returned by \code{\link{weibullRMM_SEM}}, a Stochastic EM algorithm for mixture of Weibull distributions with randomly right censored data (see reference below). } \usage{ plotweibullRMM(a, title = NULL, rowstyle = TRUE, subtitle = NULL, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{a}{An object returned by \code{\link{weibullRMM_SEM}}.} \item{title}{The title of the plot, set to some default value if \code{NULL}.} \item{rowstyle}{Window organization, for plots in rows (the default) or columns.} \item{subtitle}{A subtitle for the plot, set to some default value if \code{NULL}.} \item{...}{Other parameters (such as \code{lwd}) passed to \code{plot}, \code{lines}, and \code{legend} commands.} } \value{The plot returned} \seealso{ Related functions: \code{\link{weibullRMM_SEM}}, \code{\link{summary.mixEM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{expRMM_EM}}, \code{\link{spRMM_SEM}} . } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \examples{ n = 500 # sample size m = 2 # nb components lambda=c(0.4, 0.6) shape <- c(0.5,5); scale <- c(1,20) # model parameters set.seed(321) x <- rweibullmix(n, lambda, shape, scale) # iid ~ weibull mixture cs=runif(n,0,max(x)+10) # iid censoring times t <- apply(cbind(x,cs),1,min) # censored observations d <- 1*(x <= cs) # censoring indicator ## set arbitrary or "reasonable" (e.g., data-driven) initial values l0 <- rep(1/m,m); sh0 <- c(1, 2); sc0 <- c(2,10) # Stochastic EM algorithm a <- weibullRMM_SEM(t, d, lambda = l0, shape = sh0, scale = sc0, maxit = 200) summary(a) # Parameters estimates etc plotweibullRMM(a) # default plot of St-EM sequences %%\dontrun{ %%} } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{file} mixtools/man/spEMsymlocN01.Rd0000644000176200001440000001257714342153463015565 0ustar liggesusers\name{spEMsymlocN01} \alias{spEMsymlocN01} \title{semiparametric EM-like algorithm for univariate mixture in False Discovery Rate (FDR) estimation} \description{Return semiparametric EM-like algorithm output for a 2-components mixture model with one component set to Normal(0,1), and the other component being a unspecified but symmetric density with a location parameter. This model is tailored to FDR estimation on probit transform (\code{qnorm}) of p-values arising from multiple testing.} \usage{ spEMsymlocN01(x, mu0 = 2, bw = bw.nrd0(x), h=bw, eps = 1e-8, maxiter = 100, verbose = FALSE, plotf = FALSE)} \arguments{ \item{x}{A vector of length n consisting of the data, probit transform of pvalues, preferably sorted.} \item{mu0}{Starting value of vector of component means. If not set then the initial value is randomly generated by a \code{kmeans} of the data in two bins. Since component 1 is theoretically normal(0,1), \code{mu[1]} must be 0 and \code{mu[2]} some negative value (see details).} \item{bw}{Bandwidth for weighted kernel density estimation.} \item{h}{Alternative way to specify the bandwidth, to provide backward compatibility.} \item{eps}{Tolerance limit for declaring algorithm convergence. Convergence is declared before \code{maxiter} iterations whenever the maximum change in any coordinate of the \code{lambda} (mixing proportion estimates) and \code{mu} (mean of the semiparametric component) vector does not exceed \code{eps}} \item{maxiter}{The maximum number of iterations allowed; convergence may be declared before \code{maxiter} iterations (see \code{eps} above).} \item{verbose}{If TRUE, print updates for every iteration of the algorithm as it runs.} \item{plotf}{If TRUE, plots successive updates of the nonparametric density estimate over iterations. Mostly for testing purpose.} } \details{This algorithm is a specific version of semiparametric EM-like algorithm similar in spirit to \code{\link{spEMsymloc}}, but specialized for FDR estimation on probit transform (\code{qnorm}) of p-values in multiple testing framework. In this model, component 1 corresponds to the individuals under the null hypothesis, i.e. theoretically normal(0,1) distributed, whereas component 2 corresponds to individuals in the alternative hypothesis, with typically very small p-values and consequently negative values for probit(p) data. This model only assumes that these individuals come from an unspecified but symmetric density with a location parameter, as in Bordes and Vandekerkhove (2010) and Chauveau et al. (2014).} \value{ \code{spEMsymlocN01} returns a list of class \code{spEMN01} with the following items: \item{data}{The raw data (an \eqn{n\times r}{n x r} matrix).} \item{posteriors}{An \eqn{n\times 2}{n x 2} matrix of posterior probabilities for observations. This can be used in, e.g., \code{\link{plotFDR}} to plot False Discovery Rate estimates.} \item{bandwidth}{Same as the \code{bw} input argument, returned because this information is needed by any method that produces density estimates from the output.} \item{lambda}{The sequence of mixing proportions over iterations.} \item{lambdahat}{The final estimate for mixing proportions.} \item{mu}{the sequence of second component mean over iterations.} \item{muhat}{the final estimate of second component mean.} \item{symmetric}{Flag indicating that the kernel density estimate is using a symmetry assumption.} } \references{ \itemize{ \item Bordes, L. and Vandekerkhove, P. (2010). Semiparametric two-component mixture model with a known component: an asymptotically normal estimator. Mathematical Methods of Statistics, 19(1):22-41 \item Chauveau, D., Saby, N., Orton, T. G., Lemercier B., Walter, C. and Arrouys, D. (2014) Large-scale simultaneous hypothesis testing in monitoring carbon content from french soil database: A semi-parametric mixture approach. Geoderma 219-220 (2014): 117-124. } } \author{Didier Chauveau} \seealso{ \code{\link{spEMsymloc}}, \code{\link{normalmixEM}}, \code{\link{npEM}}, \code{\link{plot.spEMN01}}, \code{\link{plotFDR}} } \examples{ ## Probit transform of p-values ## from a Beta-Uniform mixture model ## comparion of parametric and semiparametric EM fit ## Note: in actual situations n=thousands set.seed(50) n=300 # nb of multiple tests m=2 # 2 mixture components a=c(1,0.1); b=c(1,1); lambda=c(0.6,0.4) # parameters z=sample(1:m, n, rep=TRUE, prob = lambda) p <- rbeta(n, shape1 = a[z], shape2 = b[z]) # p-values o <- order(p) cpd <- cbind(z,p)[o,] # sorted complete data, z=1 if H0, 2 if H1 p <- cpd[,2] # sorted p-values y <- qnorm(p) # probit transform of the pvalues # gaussian EM fit with component 1 constrained to N(0,1) s1 <- normalmixEM(y, mu=c(0,-4), mean.constr = c(0,NA), sd.constr = c(1,NA)) s2 <- spEMsymlocN01(y, mu0 = c(0,-3)) # spEM with N(0,1) fit hist(y, freq = FALSE, col = 8, main = "histogram of probit(pvalues)") plot(s2, add.plot = TRUE, lwd = 2) # Exemples of plot capabilities # Note: posteriors must be ordered by p for plot.FDR # plotFDR(s1$post) # when true complete data not observed # plotFDR(s1$post, s2$post) # comparing 2 strategies plotFDR(s1$post, s2$post, lg1 = "normalmixEM", lg2 = "spEMsymlocN01", complete.data = cpd) # with true FDR computed from z } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{file} mixtools/man/regmixmodel.sel.Rd0000755000176200001440000000451014342153463016300 0ustar liggesusers\name{regmixmodel.sel} \title{Model Selection in Mixtures of Regressions} \alias{regmixmodel.sel} \usage{ regmixmodel.sel(x, y, w = NULL, k = 2, type = c("fixed", "random", "mixed"), ...) } \description{ Assess the number of components in a mixture of regressions model using the Akaike's information criterion (AIC), Schwartz's Bayesian information criterion (BIC), Bozdogan's consistent AIC (CAIC), and Integrated Completed Likelihood (ICL). } \arguments{ \item{x}{An nxp matrix (or list) of predictors. If an intercept is required, then \code{x} must NOT include a column of 1's! Requiring an intercept may be controlled through arguments specified in \code{...}.} \item{y}{An n-vector (or list) of response values.} \item{w}{An optional list of fixed effects predictors for type "mixed" or "random".} \item{k}{The maximum number of components to assess.} \item{type}{The type of regression mixture to use. If "fixed", then a mixture of regressions with fixed effects will be used. If "random", then a mixture of regressions where the random effects regression coefficients are assumed to come from a mixture will be used. If "mixed", the mixture structure used is the same as "random", except a coefficient of fixed effects is also assumed.} \item{...}{Additional arguments passed to the EM algorithm used for calculating the type of regression mixture specified in \code{type}.} } \value{ \code{regmixmodel.sel} returns a matrix of the AIC, BIC, CAIC, and ICL values along with the winner (i.e., the highest value given by the model selection criterion) for various types of regression mixtures. } \seealso{ \code{\link{regmixEM}}, \code{\link{regmixEM.mixed}} } \references{ Biernacki, C., Celeux, G. and Govaert, G. (2000) Assessing a Mixture Model for Clustering with the Integrated Completed Likelihood, \emph{IEEE Transactions on Pattern Analysis and Machine Intelligence} \bold{22(7)}, 719--725. Bozdogan, H. (1987) Model Selection and Akaike's Information Criterion (AIC): The General Theory and its Analytical Extensions, \emph{Psychometrika} \bold{52}, 345--370. } \examples{ ## Assessing the number of components for NOdata. data(NOdata) attach(NOdata) set.seed(100) regmixmodel.sel(x = NO, y = Equivalence, k = 3, type = "fixed") } \keyword{file} mixtools/man/plotly_npEM.Rd0000644000176200001440000001004014343061413015426 0ustar liggesusers\name{plotly_npEM} \title{Plot Nonparametric or Semiparametric EM Output} \alias{plotly_npEM} \alias{plotly_spEM} \usage{ plotly_npEM(x, blocks = NULL, hist=TRUE, addlegend=TRUE, scale = TRUE, title=NULL, breaks="Sturges", dens.col = NULL, newplot=TRUE, ylim = NULL , col.hist = "#1f77b4", width = 3, title.x = 0.5 , title.y = 0.95, title.size = 15, xlab = "X" , xlab.size = 15 , xtick.size = 15, ylab = "Density" , ylab.size = 15 , ytick.size = 15, legend.text = "Posteriors", legend.text.size = 15, legend.size = 15) plotly_spEM(x, blocks = NULL, hist=TRUE, addlegend=TRUE, scale = TRUE, title=NULL, breaks="Sturges", dens.col = NULL, newplot=TRUE, ylim = NULL , col.hist = "#1f77b4", width = 3, title.x = 0.5 , title.y = 0.95, title.size = 15, xlab = "X" , xlab.size = 15 , xtick.size = 15, ylab = "Density" , ylab.size = 15 , ytick.size = 15, legend.text = "Posteriors", legend.text.size = 15, legend.size = 15) } \description{ This is an updater version of \code{plot.npEM} function by using \code{plotly}. For technical details, please refer to \code{plot.npEM}. } \arguments{ \item{x}{An object of class \code{npEM} such as the output of the \code{\link{npEM}} function} \item{blocks}{Blocks (of repeated measures coordinates) to plot; not relevant for univariate case. Default is to plot all blocks.} \item{hist}{If TRUE, superimpose density estimate plots on a histogram of the data} \item{addlegend}{If TRUE, adds legend to the plot.} \item{scale}{If TRUE, scale each density estimate by its corresponding estimated mixing proportion, so that the total area under all densities equals 1 and the densities plotted may be added to produce an estimate of the mixture density. When FALSE, each density curve has area 1 in the plot.} \item{title}{Alternative vector of main titles for plots (recycled as many times as needed)} \item{breaks}{Passed directly to the \code{\link{hist}} function} \item{ylim}{\code{ylim} parameter to use for all plots, if desired. If not given, each plot uses its own ylim that ensures that no part of the plot will go past the top of the plotting area.} \item{dens.col}{Color values to use for the individual component density functions, repeated as necessary. Default value is \code{2:(m+1)}.} \item{newplot}{If TRUE, creates a new plot.} \item{col.hist}{Color of the histogram to plot.} \item{width}{Line width.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{legend.text}{Title of legend.} \item{legend.text.size}{Size of the legend title.} \item{legend.size}{Size of legend.} } \value{ \code{plotly_npEM} returns a list with two elements: \item{x}{List of matrices. The \eqn{j}th column of the \eqn{i}th matrix is the vector of \eqn{x}-values for the \eqn{j}th density in the \eqn{i}th plot.} \item{y}{\eqn{y}-values, given in the same form as the \eqn{x}-values.} } \seealso{ \code{\link{npEM}}, \code{\link{density.npEM}}, \code{\link{spEMsymloc}}, \code{\link{plotseq.npEM}}, \code{plot.npEM} } \examples{ \dontrun{ ## Examine and plot water-level task data set. ## First, try a 3-component solution where no two coordinates are ## assumed i.d. data(Waterdata) set.seed(100) a <- npEM(Waterdata[,3:10], 3, bw=4) plotly_npEM(a , newplot = FALSE) ## Next, same thing but pairing clock angles that are directly opposite one ## another (1:00 with 7:00, 2:00 with 8:00, etc.) b <- npEM(Waterdata[,3:10], 3, blockid=c(4,3,2,1,3,4,1,2), bw=4) plotly_npEM(b , newplot = FALSE) } } \keyword{file} mixtools/man/print.npEM.Rd0000755000176200001440000000171114342153463015174 0ustar liggesusers\name{print.npEM} \alias{print.npEM} \title{Printing non- and semi-parametric multivariate mixture model fits} \usage{ \method{print}{npEM}(x, \dots) } \arguments{ \item{x}{an object of class \code{npEM} such as a result of a call to \code{\link{npEM}}} \item{\dots}{Additional arguments to \code{\link{print}}} } \description{ \code{\link[base]{print}} method for class \code{npEM}. } \details{ \code{print.npEM} prints the elements of an \code{npEM} object without printing the data or the posterior probabilities. (These may still be accessed as \code{x$data} and \code{x$posteriors}.) } \value{ \code{print.npEM} returns (invisibly) the full value of \code{x} itself, including the \code{data} and \code{posteriors} elements. } \seealso{ \code{\link{npEM}}, \code{\link{plot.npEM}} \code{\link{summary.npEM}} } \examples{ data(Waterdata) set.seed(100) \dontrun{npEM(Waterdata[,3:10], 3, bw=4, verb=FALSE) # Assume indep but not iid} } \keyword{file} mixtools/man/plotly_compCDF.Rd0000644000176200001440000000636614342374741016074 0ustar liggesusers\name{plotly_compCDF} \title{Plot the Component CDF using \code{plotly}} \alias{plotly_compCDF} \usage{ plotly_compCDF(data, weights, x=seq(min(data, na.rm=TRUE), max(data, na.rm=TRUE), len=250), comp=1:NCOL(weights), makeplot=TRUE, cex = 3, width = 3, legend.text = "Composition", legend.text.size = 15, legend.size = 15, title = "Empirical CDF", title.x = 0.5, title.y = 0.95, title.size = 15, xlab = "Data", xlab.size = 15, xtick.size = 15, ylab = "Probability", ylab.size = 15, ytick.size = 15, col.comp = NULL) } \description{ Plot the components' CDF via the posterior probabilities using \code{plotly}. } \arguments{ \item{data}{A matrix containing the raw data. Rows are subjects and columns are repeated measurements.} \item{weights}{The weights to compute the empirical CDF; however, most of time they are the posterior probabilities.} \item{x}{The points at which the CDFs are to be evaluated.} \item{comp}{The mixture components for which CDFs are desired.} \item{makeplot}{Logical: Should a plot be produced as a side effect?} \item{cex}{Size of markers.} \item{width}{Line width.} \item{title}{Text of the main title.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{legend.text}{Title of legend.} \item{legend.text.size}{Size of the legend title.} \item{legend.size}{Size of legend.} \item{col.comp}{Color of compositions. Number of color specified needs to be consistent with number of compositions.} } \value{ A matrix with \code{length(comp)} rows and \code{length(x)} columns in which each row gives the CDF evaluated at each point of \code{x}. } \details{ When \code{makeplot} is \code{TRUE}, a line plot is produced of the CDFs evaluated at \code{x}. The plot is not a step function plot; the points \eqn{(x, CDF(x))} are simply joined by line segments. } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. Elmore, R. T., Hettmansperger, T. P. and Xuan, F. (2004) The Sign Statistic, One-Way Layouts and Mixture Models, \emph{Statistical Science} \bold{19(4)}, 579--587. } \seealso{ \code{\link{makemultdata}}, \code{\link{multmixmodel.sel}}, \code{\link{multmixEM}}, \code{\link{compCDF}}. } \examples{ ## The sulfur content of the coal seams in Texas set.seed(100) A <- c(1.51, 1.92, 1.08, 2.04, 2.14, 1.76, 1.17) B <- c(1.69, 0.64, .9, 1.41, 1.01, .84, 1.28, 1.59) C <- c(1.56, 1.22, 1.32, 1.39, 1.33, 1.54, 1.04, 2.25, 1.49) D <- c(1.3, .75, 1.26, .69, .62, .9, 1.2, .32) E <- c(.73, .8, .9, 1.24, .82, .72, .57, 1.18, .54, 1.3) dis.coal <- makemultdata(A, B, C, D, E, cuts = median(c(A, B, C, D, E))) temp <- multmixEM(dis.coal) ## Now plot the components' CDF via the posterior probabilities plotly_compCDF(dis.coal$x, temp$posterior, xlab="Sulfur") } \keyword{file} mixtools/man/summary.npEM.Rd0000644000176200001440000000367014342153463015540 0ustar liggesusers\name{summary.npEM} \alias{summary.npEM} \alias{print.summary.npEM} \title{Summarizing non- and semi-parametric multivariate mixture model fits} \usage{ \method{summary}{npEM}(object, \dots) \method{print}{summary.npEM}(x, digits=3, \dots) } \arguments{ \item{object,x}{an object of class \code{npEM} such as a result of a call to \code{\link{npEM}}} \item{digits}{Significant digits for printing values} \item{\dots}{further arguments passed to or from other methods.} } \description{ \code{\link[base]{summary}} method for class \code{npEM}. } \details{ \code{\link{summary.npEM}} prints means and variances of each block for each component. These quantities might not be part of the model, but they are estimated nonparametrically based on the posterior probabilities and the data. } \value{ The function \code{\link{summary.npEM}} returns a list of type \code{summary.npEM} with the following components: \item{n}{The number of observations} \item{m}{The number of mixture components} \item{B}{The number of blocks} \item{blockid}{The block ID (from 1 through B) for each of the coordinates of the multivariate observations. The \code{blockid} component is of length \eqn{r}, the dimension of each observation.} \item{means}{A \eqn{B\times m}{B x m} matrix giving the estimated mean of each block in each component.} \item{variances}{Same as \code{means} but giving the estimated variances instead.} } \references{ Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, \emph{Journal of Computational and Graphical Statistics}, \bold{18(2)}, 505--526. } \seealso{ \code{\link{npEM}}, \code{\link{plot.npEM}} } \examples{ data(Waterdata) set.seed(100) \dontrun{ a <- npEM(Waterdata[,3:10], 3, bw=4) # Assume indep but not iid summary(a) b <- npEM(Waterdata[,3:10], 3, bw=4, blockid=rep(1,8)) # Now assume iid summary(b) } } \keyword{file} mixtools/man/RanEffdata.Rd0000755000176200001440000000103014342153463015167 0ustar liggesusers\name{RanEffdata} \docType{data} \title{Simulated Data from 2-Component Mixture of Regressions with Random Effects} \alias{RanEffdata} \usage{ data(RanEffdata) } \description{ This data set was generated from a 2-component mixture of regressions with random effects. } \format{This data set consists of a list with 100 25x3 matrices. The first column is the response variable, the second column is a column of 1's and the last column is the predictor variable. } \seealso{ \code{\link{regmixEM.mixed}} } \keyword{datasets} mixtools/man/post.beta.Rd0000755000176200001440000000464014342153463015105 0ustar liggesusers\name{post.beta} \title{Summary of Posterior Regression Coefficients in Mixtures of Random Effects Regressions} \alias{post.beta} \usage{ post.beta(y, x, p.beta, p.z) } \description{ Returns a 2x2 matrix of plots summarizing the posterior intercept and slope terms in a mixture of random effects regression with arbitrarily many components. } \arguments{ \item{y}{A list of N response trajectories with (possibly) varying dimensions of length \eqn{n_i}.} \item{x}{A list of N predictor values of dimension \eqn{n_i}. Each trajectory in y has its own design vector.} \item{p.beta}{A list of N 2xk matrices giving the posterior intercept and slope values from the output of an EM algorithm.} \item{p.z}{An Nxk matrix of posterior membership probabilities from the output of an EM algorithm.} } \value{ \code{post.beta} returns a 2x2 matrix of plots giving: \item{(1, 1)}{The data plotted on the x-y axes with all posterior regression lines.} \item{(1, 2)}{The data plotted on the x-y axes with most probable posterior regression lines.} \item{(2, 1)}{A beta-space plot of all posterior regression coefficients.} \item{(1, 1)}{A beta-space plot of most probable posterior regression coefficients.} } \seealso{ \code{\link{regmixEM.mixed}}, \code{\link{plot.mixEM}} } \references{ Young, D. S. and Hunter, D. R. (2015) Random Effects Regression Mixtures for Analyzing Infant Habituation, \emph{Journal of Applied Statistics}, \bold{42(7)}, 1421--1441. } \examples{ \dontrun{ ## EM output for simulated data from 2-component mixture of random effects. data(RanEffdata) set.seed(100) x <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 2:3], ncol = 2)) x <- x[1:20] y <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 1], ncol = 1)) y <- y[1:20] lambda <- c(0.45, 0.55) mu <- matrix(c(0, 4, 100, 12), 2, 2) sigma <- 2 R <- list(diag(1, 2), diag(1, 2)) em.out <- regmixEM.mixed(y, x, sigma = sigma, arb.sigma = FALSE, lambda = lambda, mu = mu, R = R, addintercept.random = FALSE, epsilon = 1e-02, verb = TRUE) ## Obtaining the 2x2 matrix of plots. x.ran <- lapply(1:length(x), function(i) x[[i]][, 2]) p.beta <- em.out$posterior.beta p.z <- em.out$posterior.z post.beta(y, x.ran, p.beta = p.beta, p.z = p.z) } } \details{ This is primarily used for within \code{plot.mixEM}. } \keyword{file} mixtools/man/perm.Rd0000755000176200001440000000143414342153463014147 0ustar liggesusers\name{perm} \title{Permutation Function} \alias{perm} \usage{ perm(n, r, v = 1:n) } \description{ Enumerates the possible permutations of a specified size from the elements of a vector having the same size. } \arguments{ \item{n}{Size of the source vector.} \item{r}{Size of the target vector.} \item{v}{Source vector. Must be a vector of length \code{n}.} } \value{ \code{perm} returns a matrix where each row contains one of the permutations of length \code{r}. } \details{ This function is called by \code{segregmixEM} and the associated internal functions. This is also a simplified version of the function \code{permutations} found in the package \code{gtools}. } \seealso{ \code{\link{segregmixEM}} } \examples{ perm(3, 3, 2:4) } \keyword{internal} mixtools/man/plotFDR.Rd0000644000176200001440000000457314342153463014522 0ustar liggesusers\name{plotFDR} \alias{plotFDR} \title{Plot False Discovery Rate (FDR) estimates from output by EM-like strategies} \description{Plot FDR\eqn{(p_i)} estimates against index of sorted p-values from, e.g., normalmixEM or the semiparametric mixture model posterior probabilities output by \code{\link{spEMsymlocN01}}, or any EM-algorithm like \code{\link{normalmixEM}} which returns posterior probabilities. The function can simultaneously plot FDR estimates from two strategies for comparison. Plot of the true FDR can be added if complete data are available (typically in simulation studies).} \usage{ plotFDR(post1, post2 = NULL, lg1 = "FDR 1", lg2 = NULL, title = NULL, compH0 = 1, alpha = 0.1, complete.data = NULL, pctfdr = 0.3) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{post1}{The matrix of posterior probabilities from objects such as the output from \code{\link{spEMsymlocN01}}. The rows need to be sorted by increasing pvalues.} \item{post2}{A second object like \code{post1} if comparison is desired, also sorted by increasing pvalues.} \item{lg1}{Text describing the FDR estimate in \code{post1}.} \item{lg2}{Text describing the FDR estimate in \code{post2} if provided.} \item{title}{Plot title, a default is provided if \code{NULL}.} \item{compH0}{The component indicator associated to the null hypothesis H0, normally 1 since it is defined in this way in \code{\link{spEMsymlocN01}}, but in case of label switching in other algorithms it can be set to \code{2}.} \item{alpha}{The target FDR level; the index at which the FDR estimate crosses the horizontal line for level \code{alpha} gives the maximum number of cases to reject.} \item{complete.data}{An array with \eqn{n} lines and 2 columns, with the component indicator in column 1 and the p-values in column 2, sorted by p-values.} \item{pctfdr}{The level up to which the FDR is plotted, i.e. the scale of the vertical axis.} } \value{A plot of one or two FDR estimates, with the true FDR if available} \references{ \itemize{ \item Chauveau, D., Saby, N., Orton, T. G., Lemercier B., Walter, C. and Arrouys, D. Large-scale simultaneous hypothesis testing in monitoring carbon content from French soil database -- A semi-parametric mixture approach, Geoderma 219-220 (2014), 117-124. } } \author{Didier Chauveau} \seealso{ \code{\link{spEMsymlocN01}}} % \keyword{file}mixtools/man/wquantile.Rd0000644000176200001440000000261614342153463015215 0ustar liggesusers\name{wquantile} \alias{wIQR} \alias{wquantile} \title{Weighted quantiles} \description{ Functions to compute weighted quantiles and the weighted interquartile range. } \usage{ wquantile(wt = rep(1,length(x)), x, probs, already.sorted = FALSE, already.normalized = FALSE) wIQR(wt = rep(1,length(x)), x, already.sorted = FALSE, already.normalized = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{wt}{ Vector of weights } \item{x}{ Vector of data, same length as \code{wt} } \item{probs}{ Numeric vector of probabilities with values in [0,1].} \item{already.sorted}{ If FALSE, sort \code{wt} and \code{x} in increasing order of \code{x}. If TRUE, it is assumed that \code{wt} and \code{x} are already sorted.} \item{already.normalized}{ If FALSE, normalize \code{wt} by diving each entry by the sum of all entries. If TRUE, it is assumed that \code{sum(wt)==1}} } \details{ \code{wquantile} uses the \code{\link{findInterval}} function. \code{wIQR} calls the \code{wquantile} function. } \value{ Returns the sample quantiles or interquartile range of a discrete distribution with support points \code{x} and corresponding probability masses \code{wt} } \seealso{ \code{\link{npEM}}} \examples{ IQR(1:10) wIQR(x=1:10) # Note: Different algorithm than IQR function wIQR(1:10,1:10) # Weighted quartiles are now 4 and 8 } \keyword{robust} mixtools/man/summary.spRMM.Rd0000644000176200001440000000317514343144454015700 0ustar liggesusers\name{summary.spRMM} \alias{summary.spRMM} \title{Summarizing fits from Stochastic EM algorithm for semiparametric scaled mixture of censored data} \usage{ \method{summary}{spRMM}(object, digits = 6, ...) } \arguments{ \item{object}{an object of class \code{spRMM} such as a result of a call to \code{\link{spRMM_SEM}}} \item{digits}{Significant digits for printing values} \item{...}{Additional parameters passed to \code{print}.} } \description{ \code{\link[base]{summary}} method for class \code{spRMM}. } \details{ \code{\link{summary.spRMM}} prints scalar parameter estimates for a fitted mixture model: each component weight and the scaling factor, see reference below. The functional (nonparametric) estimates of survival and hazard rate funcions can be obtained using \code{\link{plotspRMM}}. } \value{ The function \code{\link{summary.spRMM}} prints the final loglikelihood value at the solution as well as The estimated mixing weights and the scaling parameter. } \seealso{ Function for plotting functional (nonparametric) estimates: \code{\link{plotspRMM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{expRMM_EM}}, \code{\link{weibullRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} \examples{ # See example(spRMM_SEM) } \keyword{file} mixtools/man/mvnpEM.Rd0000755000176200001440000001272214342153463014410 0ustar liggesusers\name{mvnpEM} \title{EM-like Algorithm for Nonparametric Mixture Models with Conditionally Independent Multivariate Component Densities} \alias{mvnpEM} \usage{ mvnpEM(x, mu0, blockid = 1:ncol(x), samebw = TRUE, bwdefault = apply(x,2,bw.nrd0), init = NULL, eps = 1e-8, maxiter = 500, verb = TRUE) } \description{ An extension of the original \code{\link{npEM}} algorithm, for mixtures of multivariate data where the coordinates of a row (case) in the data matrix are assumed to be made of independent but multivariate blocks (instead of just coordinates), conditional on the mixture component (subpopulation) from which they are drawn (Chauveau and Hoang 2015). } \arguments{ \item{x}{An \eqn{n\times r}{n x r} matrix of data. Each of the \eqn{n} rows is a case, and each case has \eqn{r} repeated measurements. These measurements are assumed to be conditionally independent, conditional on the mixture component (subpopulation) from which the case is drawn.} \item{mu0}{Either an \eqn{m\times r}{m x r} matrix specifying the initial centers for the \link{kmeans} function, or an integer \eqn{m} specifying the number of initial centers, which are then chosen randomly in \link{kmeans}} \item{blockid}{A vector of length \eqn{r} identifying coordinates (columns of \code{x}) that are in the same block. The default has all distinct elements, indicating that the model has \eqn{r} blocks of dimension 1, in which case the model is handled directly by the \code{\link{npEM}} algorithm. See example below for actual multivariate blocks example.} \item{samebw}{Logical: If \code{TRUE}, use the same bandwidth per coordinate for all iteration and all components. If \code{FALSE}, use a separate bandwidth for each component and coordinate, and update this bandwidth at each iteration of the algorithm using a suitably modified \code{\link{bw.nrd0}} method as described in Benaglia et al (2011) and Chauveau and Hoang (2015).} \item{bwdefault}{Bandwidth default for density estimation,a simplistic application of the default \code{\link{bw.nrd0}} for each coordinate (column) of the data.} \item{init}{Initialization method, based on an initial \eqn{n\times m}{n x m} matrix for the posterior probabilities. If \code{NULL}, a \code{\link{kmeans}} clustering with \code{mu0} initial centers is applied to the data and the initial matrix of posteriors is built from the result.} \item{eps}{Tolerance limit for declaring algorithm convergence. Convergence is declared whenever the maximum change in any coordinate of the \code{lambda} vector (of mixing proportion estimates) does not exceed \code{eps}.} \item{maxiter}{The maximum number of iterations allowed; convergence may be declared before \code{maxiter} iterations (see \code{eps} above).} \item{verb}{Verbose mode; if TRUE, print updates for every iteration of the algorithm as it runs} } \value{ \code{mvnpEM} returns a list of class \code{mvnpEM} with the following items: \item{data}{The raw data (an \eqn{n\times r}{n x r} matrix).} \item{posteriors}{An \eqn{n\times m}{n x m} matrix of posterior probabilities for each observation (row).} \item{lambda}{The sequence of mixing proportions over iterations.} \item{blockid}{The \code{blockid} input argument. Needed by any method that produces density estimates from the output, like \code{\link{plot.mvnpEM}}.} \item{samebw}{The \code{samebw} input argument. Needed by any method that produces density estimates from the output, like \code{\link{plot.mvnpEM}}.} \item{bandwidth}{The final bandwidth matrix after convergence of the algorithm. Its shape depends on the \code{samebw} input argument. If \code{samebw = TRUE}, a vectors with the bandwidth value for each of the \code{r} coordinates (same for all components and iterations). If \code{samebw = FALSE}, a \eqn{m\times r}{m x r} matrix, where each row is associated to one component and gives the \eqn{r} bandwidth values, one for each coordinate. Needed by any method that produces density estimates from the output, like \code{\link{plot.mvnpEM}}.} \item{lambdahat}{The final mixing proportions.} \item{loglik}{The sequence of pseudo log-likelihood values over iterations.} } \seealso{ \code{\link{plot.mvnpEM}}, \code{\link{npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526. \item Benaglia, T., Chauveau, D. and Hunter, D.R. (2011), Bandwidth Selection in an EM-like algorithm for nonparametric multivariate mixtures. Nonparametric Statistics and Mixture Models: A Festschrift in Honor of Thomas P. Hettmansperger. World Scientific Publishing Co., pages 15-27. \item Chauveau, D., and Hoang, V. T. L. (2015), Nonparametric mixture models with conditionally independent multivariate component densities, Preprint under revision. \url{https://hal.archives-ouvertes.fr/hal-01094837} } } \examples{ # Example as in Chauveau and Hoang (2015) with 6 coordinates \dontrun{ m=2; r=6; blockid <-c(1,1,2,2,3,3) # 3 bivariate blocks # generate some data x ... a <- mvnpEM(x, mu0=2, blockid, samebw=F) # adaptive bandwidth plot(a) # this S3 method produces 6 plots of univariate marginals summary(a)} } \keyword{file} mixtools/man/plot.mixEM.Rd0000755000176200001440000001022514342153463015176 0ustar liggesusers\name{plot.mixEM} \title{Various Plots Pertaining to Mixture Models} \alias{plot.mixEM} \usage{ \method{plot}{mixEM}(x, whichplots = 1, loglik = 1 \%in\% whichplots, density = 2 \%in\% whichplots, xlab1="Iteration", ylab1="Log-Likelihood", main1="Observed Data Log-Likelihood", col1=1, lwd1=2, xlab2=NULL, ylab2=NULL, main2=NULL, col2=NULL, lwd2=2, alpha = 0.05, marginal = FALSE, ...) } \description{ Takes an object of class \code{mixEM} and returns various graphical output for select mixture models. } \arguments{ \item{x}{An object of class \code{mixEM}.} \item{whichplots}{vector telling which plots to produce: 1 = loglikelihood plot, 2 = density plot. Irrelevant if \code{loglik} and \code{density} are specified.} \item{loglik}{If TRUE, a plot of the log-likelihood versus the EM iterations is given.} \item{density}{Graphics pertaining to certain mixture models. The details are given below.} \item{xlab1, ylab1, main1, col1, lwd1}{Graphical parameters \code{xlab}, ..., \code{lwd} to be passed to the loglikelihood plot. Trying to change these parameters using \code{xlab}, ..., \code{lwd} will result in an error, but all other graphical parameters are passed directly to the plotting functions via ...} \item{xlab2, ylab2, main2, col2, lwd2}{Same as \code{xlab1} etc. but for the density plot} \item{alpha}{A vector of significance levels when constructing confidence ellipses and confidence bands for the mixture of multivariate normals and mixture of regressions cases, respectively. The default is 0.05.} \item{marginal}{For the mixture of bivariate normals, should optional marginal histograms be included?} \item{...}{Graphical parameters passed to \code{plot} command.} } \value{ \code{plot.mixEM} returns a plot of the log-likelihood versus the EM iterations by default for all objects of class \code{mixEM}. In addition, other plots may be produced for the following k-component mixture model functions: \item{normalmixEM}{A histogram of the raw data is produced along with k density curves determined by \code{normalmixEM}.} \item{repnormmixEM}{A histogram of the raw data produced in a similar manner as for \code{normalmixEM}.} \item{mvnormalmixEM}{A 2-dimensional plot with each point color-coded to denote its most probable component membership. In addition, the estimated component means are plotted along with (1 - \code{alpha})\% bivariate normal density contours. These ellipses are constructed by assigning each value to their component of most probable membership and then using normal theory. Optional marginal histograms may also be produced.} \item{regmixEM}{A plot of the response versus the predictor with each point color-coded to denote its most probable component membership. In addition, the estimated component regression lines are plotted along with (1 - \code{alpha})\% Working-Hotelling confidence bands. These bands are constructed by assigning each value to their component of most probable membership and then performing least squares estimation.} \item{logisregmixEM}{A plot of the binary response versus the predictor with each point color-coded to denote its most probable compopnent membership. In addition, the estimate component logistic regression lines are plotted.} \item{regmixEM.mixed}{Provides a 2x2 matrix of plots summarizing the posterior slope and posterior intercept terms from a mixture of random effects regression. See \code{post.beta} for a more detailed description.} } \seealso{ \code{\link{post.beta}} } \examples{ ##Analyzing the Old Faithful geyser data with a 2-component mixture of normals. data(faithful) attach(faithful) set.seed(100) out <- normalmixEM(waiting, arbvar = FALSE, verb = TRUE, epsilon = 1e-04) plot(out, density = TRUE, w = 1.1) ##Fitting randomly generated data with a 2-component location mixture of bivariate normals. x.1 <- rmvnorm(40, c(0, 0)) x.2 <- rmvnorm(60, c(3, 4)) X.1 <- rbind(x.1, x.2) out.1 <- mvnormalmixEM(X.1, arbvar = FALSE, verb = TRUE, epsilon = 1e-03) plot(out.1, density = TRUE, alpha = c(0.01, 0.05, 0.10), marginal = TRUE) } \keyword{file} mixtools/man/plotly_post.beta.Rd0000644000176200001440000000557414342426712016514 0ustar liggesusers\name{plotly_post.beta} \title{Visualization of Posterior Regression Coefficients in Mixtures of Random Effects Regressions using \code{plotly}} \alias{plotly_post.beta} \usage{ plotly_post.beta(y, x, p.beta, p.z, cex = 6,lwd=1, title.size = 15, xlab.size = 15 , xtick.size = 15, ylab.size = 15 , ytick.size = 15, col.data = "#1f77b4", col.comp = NULL) } \description{ Returns a 2x2 matrix of plots summarizing the posterior intercept and slope terms in a mixture of random effects regression with arbitrarily many components. } \arguments{ \item{y}{A list of N response trajectories with (possibly) varying dimensions of length \eqn{n_i}.} \item{x}{A list of N predictor values of dimension \eqn{n_i}. Each trajectory in y has its own design vector.} \item{p.beta}{A list of N 2xk matrices giving the posterior intercept and slope values from the output of an EM algorithm.} \item{p.z}{An Nxk matrix of posterior membership probabilities from the output of an EM algorithm.} \item{cex}{Size of dots of posterior Coefficients.} \item{lwd}{Width of lines.} \item{title.size}{Size of the main title.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{col.data}{Color of original data points.} \item{col.comp}{Color of points and lines of components. Number of colors specified needs to be consistent with number of components.} } \value{ Plots returned. } \seealso{ \code{\link{regmixEM.mixed}}, \code{\link{plot.mixEM}}, \code{\link{post.beta}} } \references{ Young, D. S. and Hunter, D. R. (2015) Random Effects Regression Mixtures for Analyzing Infant Habituation, \emph{Journal of Applied Statistics}, \bold{42(7)}, 1421--1441. } \examples{ data(RanEffdata) set.seed(100) x <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 2:3], ncol = 2)) x <- x[1:20] y <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 1], ncol = 1)) y <- y[1:20] lambda <- c(0.45, 0.55) mu <- matrix(c(0, 4, 100, 12), 2, 2) sigma <- 2 R <- list(diag(1, 2), diag(1, 2)) em.out <- regmixEM.mixed(y, x, sigma = sigma, arb.sigma = FALSE, lambda = lambda, mu = mu, R = R, addintercept.random = FALSE, epsilon = 1e-02, verb = TRUE) x.1 = em.out$x n = sum(sapply(x.1, nrow)) x.1.sum = sum(sapply(1:length(x.1), function(i) length(x.1[[i]][,1]))) if (x.1.sum == n) { x = lapply(1:length(x.1), function(i) matrix(x.1[[i]][,-1], ncol = 1)) } else { x = x.1 } plotly_post.beta(x = x, y = em.out$y, p.beta = em.out$posterior.beta, p.z = em.out$posterior.z) } \details{ This is primarily used for within \code{plot.mixEM}. } \keyword{internal} mixtools/man/test.equality.Rd0000755000176200001440000000443114342153463016017 0ustar liggesusers\name{test.equality} \title{Performs Chi-Square Tests for Scale and Location Mixtures} \alias{test.equality} \usage{ test.equality(y, x = NULL, arbmean = TRUE, arbvar = FALSE, mu = NULL, sigma = NULL, beta = NULL, lambda = NULL, ...) } \description{ Performs a likelihood ratio test of a location (or scale) normal or regression mixture versus the more general model. For a normal mixture, the alternative hypothesis is that each component has its own mean and variance, whereas the null is that all means (in the case of a scale mixture) or all variances (in the case of a location mixture) are equal. This test is asymptotically chi-square with degrees of freedom equal to k-1, where k is the number of components. } \arguments{ \item{y}{The responses for \code{regmixEM} or the data for \code{normalmixEM}.} \item{x}{The predictors for \code{regmixEM}.} \item{arbmean}{If FALSE, then a scale mixture analysis is performed for \code{normalmixEM} or \code{regmixEM}.} \item{arbvar}{If FALSE, then a location mixture analysis is performed for \code{normalmixEM} or \code{regmixEM}.} \item{mu}{An optional vector for starting values (under the null hypothesis) for \code{mu} in \code{normalmixEM}.} \item{sigma}{An optional vector for starting values (under the null hypothesis) for \code{sigma} in \code{normalmixEM} or \code{regmixEM}.} \item{beta}{An optional matrix for starting values (under the null hypothesis) for \code{beta} in \code{regmixEM}.} \item{lambda}{An otional vector for starting values (under the null hypothesis) for \code{lambda} in \code{normalmixEM} or \code{regmixEM}.} \item{...}{Additional arguments passed to the various EM algorithms for the mixture of interest.} } \value{ \code{test.equality} returns a list with the following items: \item{chi.sq}{The chi-squared test statistic.} \item{df}{The degrees of freedom for the chi-squared test statistic.} \item{p.value}{The p-value corresponding to this likelihood ratio test.} } \seealso{ \code{\link{test.equality.mixed}} } \examples{ ## Should a location mixture be used for the Old Faithful data? data(faithful) attach(faithful) set.seed(100) test.equality(y = waiting, arbmean = FALSE, arbvar = TRUE) } \keyword{file} mixtools/man/repnormmixmodel.sel.Rd0000755000176200001440000000323114342153463017204 0ustar liggesusers\name{repnormmixmodel.sel} \title{Model Selection in Mixtures of Normals with Repeated Measures} \alias{repnormmixmodel.sel} \usage{ repnormmixmodel.sel(x, k = 2, ...) } \description{ Assess the number of components in a mixture model with normal components and repeated measures using the Akaike's information criterion (AIC), Schwartz's Bayesian information criterion (BIC), Bozdogan's consistent AIC (CAIC), and Integrated Completed Likelihood (ICL). } \arguments{ \item{x}{An mxn matrix of observations. The rows correspond to the repeated measures and the columns correspond to the subject.} \item{k}{The maximum number of components to assess.} \item{...}{Additional arguments passed to \code{repnormmixEM}.} } \value{ \code{repnormmixmodel.sel} returns a matrix of the AIC, BIC, CAIC, and ICL values along with the winner (i.e., the highest value given by the model selection criterion) for a mixture of normals with repeated measures. } \seealso{ \code{\link{repnormmixEM}} } \references{ Biernacki, C., Celeux, G., and Govaert, G. (2000). Assessing a Mixture Model for Clustering with the Integrated Completed Likelihood. \emph{IEEE Transactions on Pattern Analysis and Machine Intelligence}, 22(7):719-725. Bozdogan, H. (1987). Model Selection and Akaike's Information Criterion (AIC): The General Theory and its Analytical Extensions. \emph{Psychometrika}, 52:345-370. } \examples{ ## Assessing the number of components for the water-level task data set. data(Waterdata) water<-t(as.matrix(Waterdata[,3:10])) set.seed(100) out <- repnormmixmodel.sel(water, k = 3, epsilon = 5e-01) out } \keyword{file} mixtools/man/density.spEM.Rd0000755000176200001440000000365014342153463015530 0ustar liggesusers\name{density.spEM} \title{Normal kernel density estimate for semiparametric EM output} \alias{density.spEM} \usage{ \method{density}{spEM}(x, u=NULL, component=1, block=1, scale=FALSE, \dots) } \description{ Takes an object of class \code{spEM} and returns an object of class \code{\link{density}} giving the kernel density estimate. } \arguments{ \item{x}{An object of class \code{npEM} such as the output of the \code{\link{npEM}} or \code{\link{spEMsymloc}} functions.} \item{u}{Vector of points at which the density is to be evaluated} \item{component}{Mixture component number; should be an integer from 1 to the number of columns of \code{x$posteriors}.} \item{block}{Block of repeated measures. Only applicable in repeated measures case, for which \code{x$blockid} exists; should be an integer from 1 to \code{max(x$blockid)}.} \item{scale}{Logical: If TRUE, multiply the density values by the corresponding mixing proportions found in \code{x$lambdahat}} \item{\dots}{Additional arguments; not used by this method.} } \details{ The bandwidth is taken to be the same as that used to produce the \code{npEM} object, which is given by \code{x$bandwidth}. } \value{ \code{density.spEM} returns a list of type \code{"density"}. See \code{\link{density}} for details. In particular, the output of \code{density.spEM} may be used directly by functions such as \code{\link{plot}} or \code{\link{lines}}. } \seealso{ \code{\link{spEM}}, \code{\link{spEMsymloc}}, \code{\link{plot.spEM}} } \examples{ set.seed(100) mu <- matrix(c(0, 15), 2, 3) sigma <- matrix(c(1, 5), 2, 3) x <- rmvnormmix(300, lambda = c(.4,.6), mu = mu, sigma = sigma) d <- spEM(x, mu0 = 2, blockid = rep(1,3), constbw = TRUE) plot(d, xlim=c(-10, 40), ylim = c(0, .16), xlab = "", breaks = 30, cex.lab=1.5, cex.axis=1.5) # plot.spEM calls density.spEM here } \keyword{file} mixtools/man/ise.npEM.Rd0000755000176200001440000001027714342153463014627 0ustar liggesusers\name{ise.npEM} \title{Integrated Squared Error for a selected density from npEM output} \alias{ise.npEM} \usage{ ise.npEM(npEMout, component=1, block=1, truepdf, lower=-Inf, upper=Inf, plots = TRUE, ...) } \description{ Computes the integrated squared error for a selected estimated density from \code{\link{npEM}} output (selected by specifying the component and block number), relative to a true pdf that must be specified by the user. The range for the numerical integration must be specified. This function also returns (by default) a plot of the true and estimated densities. } \arguments{ \item{npEMout}{An object of class \code{npEM} such as the output of the \code{\link{npEM}} function} \item{component, block}{Component and block of particular density to analyze from \code{npEMout}.} \item{truepdf}{an \R function taking a numeric first argument and returning a numeric vector of the same length. Returning a non-finite element will generate an error.} \item{lower, upper}{the limits of integration. Can be infinite.} \item{plots}{logical: Should plots be produced?} \item{...}{additional arguments to be passed to \code{truepdf} (and that may be mandatory like, e.g., the \code{df = } argument of \code{dt}). Remember to use argument names not matching those of \code{ise.npRM}.} } \value{ Just as for the \code{\link{integrate}} function, a list of class \code{"integrate"} with components \item{value}{the final estimate of the integral.} \item{abs.error}{estimate of the modulus of the absolute error.} \item{subdivisions}{the number of subintervals produced in the subdivision process.} \item{message}{\code{"OK"} or a character string giving the error message.} \item{call}{the matched call.} } \details{This function calls the \code{\link{wkde}} (weighted kernel density estimate) function. } \seealso{ \code{\link{npEM}}, \code{\link{wkde}}, \code{\link{integrate}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526. \item Benaglia, T., Chauveau, D., Hunter, D. R., and Young, D. (2009), mixtools: An R package for analyzing finite mixture models. Journal of Statistical Software, 32(6):1-29. } } \examples{ # Mixture with mv gaussian model set.seed(100) m <- 2 # no. of components r <- 3 # no. of repeated measures (coordinates) lambda <- c(0.4, 0.6) # Note: Need first 2 coordinates conditionally iid due to block structure mu <- matrix(c(0, 0, 0, 3, 3, 5), m, r, byrow=TRUE) # means sigma <- matrix(rep(1, 6), m, r, byrow=TRUE) # stdevs blockid = c(1,1,2) # block structure of coordinates n <- 200 x <- rmvnormmix(n, lambda, mu, sigma) # simulated data # fit the model with "arbitrary" initial centers centers <- matrix(c(0, 0, 0, 4, 4, 4), 2, 3, byrow=TRUE) a <- npEM(x, centers, blockid, eps=1e-8, verb=FALSE) # Calculate integrated squared error for j=2, b=1: j <- 2 # component b <- 1 # block coords <- a$blockid == b ise.npEM(a, j, b, dnorm, lower=0, upper=10, plots=TRUE, mean=mu[j,coords][1], sd=sigma[j, coords][1]) # The following (lengthy) example recreates the normal multivariate # mixture model simulation from Benaglia et al (2009). mu <- matrix(c(0, 0, 0, 3, 4, 5), m, r, byrow=TRUE) nbrep <- 5 # Benaglia et al use 300 replications # matrix for storing sums of Integrated Squared Errors ISE <- matrix(0,m,r,dimnames=list(Components=1:m, Blocks=1:r)) nblabsw <- 0 # no. of label switches for (mc in 1:nbrep) { print(paste("REPETITION", mc)) x <- rmvnormmix(n,lambda,mu,sigma) # simulated data a <- npEM(x, centers, verb=FALSE) #default: if (a$lambda[1] > a$lambda[2]) nblabsw <- nblabsw + 1 for (j in 1:m) { # for each component for (k in 1:r) { # for each coordinate; not assuming iid! # dnorm with correct mean, sd is the true density: ISE[j,k] <- ISE[j,k] + ise.npEM(a, j, k, dnorm, lower=mu[j,k]-5, upper=mu[j,k]+5, plots=FALSE, mean=mu[j,k], sd=sigma[j,k])$value } } MISE <- ISE/nbrep # Mean ISE sqMISE <- sqrt(MISE) # root-mean-integrated-squared error } sqMISE } \keyword{file} mixtools/man/depth.Rd0000755000176200001440000000201014342153463014277 0ustar liggesusers\name{depth} \alias{depth} \title{Elliptical and Spherical Depth} \description{ Computation of spherical or elliptical depth. } \usage{ depth(pts, x, Cx = var(x)) } \arguments{ \item{pts}{A kxd matrix containing the k points that one wants to compute the depth. Each row is a point. } \item{x}{A nxd matrix containing the reference data. Each row is an observation.} \item{Cx}{A dxd scatter matrix for the data x where the default is var(x). When Cx = I(d), it returns the sphercial depth.} } \value{ \code{depth} returns a k-vector where each entry is the elliptical depth of a point in \code{pts}. } \references{ Elmore, R. T., Hettmansperger, T. P. and Xuan, F. (2000) Spherical Data Depth and a Multivariate Median, \emph{Proceedings of Data Depth: Robust Multivariate Statistical Analysis, Computational Geometry and Applications}. } \seealso{\code{\link{regcr}} } \examples{ set.seed(100) x <- matrix(rnorm(200),nc = 2) depth(x[1:3, ], x) } \note{\code{depth} is used in \code{regcr}.} \keyword{file} mixtools/man/tonedata.Rd0000644000176200001440000000330514342153463014777 0ustar liggesusers\name{tonedata} \alias{tonedata} \docType{data} \title{Tone perception data} \author{Christian Hennig} \description{ The tone perception data stem from an experiment of Cohen (1980) and have been analyzed in de Veaux (1989) and Viele and Tong (2002). The dataset and this documentation file were copied from the fpc package by Christian Hennig. A pure fundamental tone was played to a trained musician. Electronically generated overtones were added, determined by a stretching ratio of \code{stretchratio}. \code{stretchratio=2.0} corresponds to the harmonic pattern usually heard in traditional definite pitched instruments. The musician was asked to tune an adjustable tone to the octave above the fundamental tone. \code{tuned} gives the ratio of the adjusted tone to the fundamental, i.e. \code{tuned=2.0} would be the correct tuning for all \code{stretchratio}-values. The data analyzed here belong to 150 trials with the same musician. In the original study, there were four further musicians. } \usage{data(tonedata)} \format{A data frame with 2 variables, \code{stretchratio} and \code{tuned}, and 150 cases.} \source{ Original source: Cohen, E. A. (1980), \emph{Inharmonic tone perception}. Unpublished Ph.D. dissertation, Stanford University R source: Hennig, Christian (2010), fpc: Flexible procedures for clustering, R package version 2.0-2. \url{https://cran.r-project.org/package=fpc} } \references{ de Veaux, R. D. (1989), Mixtures of Linear Regressions, \emph{Computational Statistics and Data Analysis} 8, 227-245. Viele, K. and Tong, B. (2002), Modeling with Mixtures of Linear Regressions, \emph{Statistics and Computing} 12, 315-330. } \keyword{datasets} mixtools/man/ellipse.Rd0000755000176200001440000000274114342153463014643 0ustar liggesusers\name{ellipse} \title{Draw Two-Dimensional Ellipse Based on Mean and Covariance} \alias{ellipse} \usage{ ellipse(mu, sigma, alpha = .05, npoints = 250, newplot = FALSE, draw = TRUE, ...) } \description{ Draw a two-dimensional ellipse that traces a bivariate normal density contour for a given mean vector, covariance matrix, and probability content. } \arguments{ \item{mu}{A 2-vector giving the mean.} \item{sigma}{A 2x2 matrix giving the covariance matrix.} \item{alpha}{Probability to be excluded from the ellipse. The default value is alpha = .05, which results in a 95\% ellipse.} \item{npoints}{Number of points comprising the border of the ellipse.} \item{newplot}{If newplot = TRUE and draw = TRUE, plot the ellipse on a new plot. If newplot = FALSE and draw = TRUE, add the ellipse to an existing plot.} \item{draw}{If TRUE, draw the ellipse.} \item{...}{Graphical parameters passed to \code{lines} or \code{plot} command.} } \value{ \code{ellipse} returns an \code{npoints}x2 matrix of the points forming the border of the ellipse. } \references{ Johnson, R. A. and Wichern, D. W. (2002) \emph{Applied Multivariate Statistical Analysis, Fifth Edition}, Prentice Hall. } \seealso{ \code{\link{regcr}} } \examples{ ## Produce a 95\% ellipse with the specified mean and covariance structure. mu <- c(1, 3) sigma <- matrix(c(1, .3, .3, 1.5), 2, 2) ellipse(mu, sigma, npoints = 200, newplot = TRUE) } \keyword{file} mixtools/man/npEM.Rd0000755000176200001440000001361014342153463014042 0ustar liggesusers\name{npEM} \title{Nonparametric EM-like Algorithm for Mixtures of Independent Repeated Measurements} \alias{npEM} \alias{npEMindrep} \alias{npEMindrepbw} \usage{ npEM(x, mu0, blockid = 1:ncol(x), bw = bw.nrd0(as.vector(as.matrix(x))), samebw = TRUE, h = bw, eps = 1e-8, maxiter = 500, stochastic = FALSE, verb = TRUE) } \description{ Returns nonparametric EM algorithm output (Benaglia et al, 2009) for mixtures of multivariate (repeated measures) data where the coordinates of a row (case) in the data matrix are assumed to be independent, conditional on the mixture component (subpopulation) from which they are drawn. } \arguments{ \item{x}{An \eqn{n\times r}{n x r} matrix of data. Each of the \eqn{n} rows is a case, and each case has \eqn{r} repeated measurements. These measurements are assumed to be conditionally independent, conditional on the mixture component (subpopulation) from which the case is drawn.} \item{mu0}{Either an \eqn{m\times r}{m x r} matrix specifying the initial centers for the \link{kmeans} function, or an integer \eqn{m} specifying the number of initial centers, which are then choosen randomly in \link{kmeans}} \item{blockid}{A vector of length \eqn{r} identifying coordinates (columns of \code{x}) that are assumed to be identically distributed (i.e., in the same block). For instance, the default has all distinct elements, indicating that no two coordinates are assumed identically distributed and thus a separate set of \eqn{m} density estimates is produced for each column of \eqn{x}. On the other hand, if \code{blockid=rep(1,ncol(x))}, then the coordinates in each row are assumed conditionally i.i.d.} \item{bw}{Bandwidth for density estimation, equal to the standard deviation of the kernel density. By default, a simplistic application of the default \code{\link{bw.nrd0}} bandwidth used by \code{\link{density}} to the entire dataset.} \item{samebw}{Logical: If \code{TRUE}, use the same bandwidth for each iteration and for each component and block. If \code{FALSE}, use a separate bandwidth for each component and block, and update this bandwidth at each iteration of the algorithm using a suitably modified \code{\link{bw.nrd0}} method as described in Benaglia et al (2011).} \item{h}{Alternative way to specify the bandwidth, to provide backward compatibility.} \item{eps}{Tolerance limit for declaring algorithm convergence. Convergence is declared whenever the maximum change in any coordinate of the \code{lambda} vector (of mixing proportion estimates) does not exceed \code{eps}.} \item{maxiter}{The maximum number of iterations allowed, for both stochastic and non-stochastic versions; for non-stochastic algorithms (\code{stochastic = FALSE}), convergence may be declared before \code{maxiter} iterations (see \code{eps} above).} \item{stochastic}{Flag, if FALSE (the default), runs the non-stochastic version of the npEM algorithm, as in Benaglia et al (2009). Set to TRUE to run a stochastic version which simulates the posteriors at each iteration, and runs for \code{maxiter} iterations.} \item{verb}{If TRUE, print updates for every iteration of the algorithm as it runs} } \value{ \code{npEM} returns a list of class \code{npEM} with the following items: \item{data}{The raw data (an \eqn{n\times r}{n x r} matrix).} \item{posteriors}{An \eqn{n\times m}{n x m} matrix of posterior probabilities for observation. If \code{stochastic = TRUE}, this matrix is computed from an average over the \code{maxiter} iterations.} \item{bandwidth}{If \code{samebw==TRUE}, same as the \code{bw} input argument; otherwise, value of \code{bw} matrix at final iteration. This information is needed by any method that produces density estimates from the output.} \item{blockid}{Same as the \code{blockid} input argument, but recoded to have positive integer values. Also needed by any method that produces density estimates from the output.} \item{lambda}{The sequence of mixing proportions over iterations.} \item{lambdahat}{The final mixing proportions if \code{stochastic = FALSE}, or the average mixing proportions if \code{stochastic = TRUE}.} \item{loglik}{The sequence of log-likelihoods over iterations.} } \seealso{ \code{\link{plot.npEM}}, \code{\link{normmixrm.sim}}, \code{\link{spEMsymloc}}, \code{\link{spEM}}, \code{\link{plotseq.npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526. \item Benaglia, T., Chauveau, D., Hunter, D. R., and Young, D. (2009), mixtools: An R package for analyzing finite mixture models. Journal of Statistical Software, 32(6):1-29. \item Benaglia, T., Chauveau, D. and Hunter, D.R. (2011), Bandwidth Selection in an EM-like algorithm for nonparametric multivariate mixtures. Nonparametric Statistics and Mixture Models: A Festschrift in Honor of Thomas P. Hettmansperger. World Scientific Publishing Co., pages 15-27. \item Bordes, L., Chauveau, D., and Vandekerkhove, P. (2007), An EM algorithm for a semiparametric mixture model, Computational Statistics and Data Analysis, 51: 5429-5443. } } \examples{ ## Examine and plot water-level task data set. ## First, try a 3-component solution where no two coordinates are ## assumed i.d. data(Waterdata) set.seed(100) \dontrun{ a <- npEM(Waterdata[,3:10], mu0=3, bw=4) # Assume indep but not iid plot(a) # This produces 8 plots, one for each coordinate } ## Next, same thing but pairing clock angles that are directly opposite one ## another (1:00 with 7:00, 2:00 with 8:00, etc.) \dontrun{ b <- npEM(Waterdata[,3:10], mu0=3, blockid=c(4,3,2,1,3,4,1,2), bw=4) # iid in pairs plot(b) # Now only 4 plots, one for each block } } \keyword{file} mixtools/man/summary.mvnpEM.Rd0000755000176200001440000000450014342153463016077 0ustar liggesusers\name{summary.mvnpEM} \alias{summary.mvnpEM} \alias{print.summary.mvnpEM} \title{Summarizing Fits for Nonparametric Mixture Models with Conditionally Independent Multivariate Component Densities} \usage{ \method{summary}{mvnpEM}(object, \dots) \method{print}{summary.mvnpEM}(x, digits=3, \dots) } \arguments{ \item{object,x}{an object of class \code{mvnpEM} such as a result of a call to \code{\link{mvnpEM}}} \item{digits}{Significant digits for printing values} \item{\dots}{further arguments passed to or from other methods.} } \description{ \code{\link[base]{summary}} method for class \code{mvnpEM}. } \details{ \code{\link{summary.mvnpEM}} prints means and variances of each block for each component. These quantities might not be part of the model, but they are estimated nonparametrically based on the posterior probabilities and the data. } \value{ The function \code{\link{summary.mvnpEM}} returns a list of type \code{summary.mvnpEM} with the following components: \item{n}{The number of observations} \item{m}{The number of mixture components} \item{B}{The number of blocks} \item{blockid}{The block ID (from 1 through B) for each of the coordinates of the multivariate observations. The \code{blockid} component is of length \eqn{r}, the dimension of each observation.} \item{means}{A \eqn{B\times m}{B x m} matrix giving the estimated mean of each block in each component.} \item{variances}{Same as \code{means} but giving the estimated variances instead.} } \references{ Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, \emph{Journal of Computational and Graphical Statistics}, \bold{18(2)}, 505--526. Chauveau, D., and Hoang, V. T. L. (2015), Nonparametric mixture models with conditionally independent multivariate component densities, Preprint under revision. \url{https://hal.archives-ouvertes.fr/hal-01094837} } \seealso{ \code{\link{mvnpEM}}, \code{\link{plot.mvnpEM}} } \examples{ # Example as in Chauveau and Hoang (2015) with 6 coordinates \dontrun{ m=2; r=6; blockid <-c(1,1,2,2,3,3) # 3 bivariate blocks # generate some data x ... a <- mvnpEM(x, mu0=2, blockid, samebw=F) # adaptive bandwidth plot(a) # this S3 method produces 6 plots of univariate marginals summary(a)} } \keyword{file} mixtools/man/regcr.Rd0000755000176200001440000000652014342153463014307 0ustar liggesusers\name{regcr} \title{Add a Confidence Region or Bayesian Credible Region for Regression Lines to a Scatterplot} \alias{regcr} \usage{ regcr(beta, x, em.beta = NULL, em.sigma = NULL, alpha = .05, nonparametric = FALSE, plot = FALSE, xyaxes = TRUE, ...) } \description{ Produce a confidence or credible region for regression lines based on a sample of bootstrap beta values or posterior beta values. The beta parameters are the intercept and slope from a simple linear regression. } \arguments{ \item{beta}{An nx2 matrix of regression parameters. The first column gives the intercepts and the second column gives the slopes.} \item{x}{An n-vector of the predictor variable which is necessary when nonparametric = TRUE.} \item{em.beta}{The estimates for beta required when obtaining confidence regions. This is required for performing the standardization necessary when obtaining nonparametric confidence regions.} \item{em.sigma}{The estimates for the regression standard deviation required when obtaining confidence regions. This is required for performing the standardization necessary when obtaining nonparametric confidence regions.} \item{alpha}{The proportion of the beta sample to remove. In other words, 1-alpha is the level of the credible region.} \item{nonparametric}{ If nonparametric = TRUE, then the region is based on the convex hull of the remaining beta after trimming, which is accomplished using a data depth technique. If nonparametric = FALSE, then the region is based on the asymptotic normal approximation.} \item{plot}{If plot = TRUE, lines are added to the existing plot. The type of plot created depends on the value of xyaxes.} \item{xyaxes}{If xyaxes = TRUE and plot = TRUE, then a confidence or credible region for the regression lines is plotted on the x-y axes, presumably overlaid on a scatterplot of the data. If xyaxes = FALSE and plot = TRUE, the (convex) credible region for the regression line is plotted on the beta, or intercept-slope, axes, presumably overlaid on a scatterplot of beta.} \item{...}{Graphical parameters passed to \code{lines} or \code{plot} command.} } \value{ \code{regcr} returns a list containing the following items: \item{boundary}{A matrix of points in beta, or intercept-slope, space arrayed along the boundary of the confidence or credible region.} \item{upper}{A matrix of points in x-y space arrayed along the upper confidence or credible limit for the regression line.} \item{lower}{A matrix of points in x-y space arrayed along the lower confidence or credible limit for the regression line.} } \seealso{ \code{\link{regmixEM}}, \code{\link{regmixMH}} } \examples{ ## Nonparametric credible regions fit to NOdata. data(NOdata) attach(NOdata) set.seed(100) beta <- matrix(c(1.3, -0.1, 0.6, 0.1), 2, 2) sigma <- c(.02, .05) MH.out <- regmixMH(Equivalence, NO, beta = beta, s = sigma, sampsize = 2500, omega = .0013) attach(data.frame(MH.out$theta)) beta.c1 <- cbind(beta0.1[2400:2499], beta1.1[2400:2499]) beta.c2 <- cbind(beta0.2[2400:2499], beta1.2[2400:2499]) plot(NO, Equivalence) regcr(beta.c1, x = NO, nonparametric = TRUE, plot = TRUE, col = 2) regcr(beta.c2, x = NO, nonparametric = TRUE, plot = TRUE, col = 3) } \keyword{file} mixtools/man/plot.MCMC.Rd0000755000176200001440000000315214342153463014677 0ustar liggesusers\name{plot.mixMCMC} \title{Various Plots Pertaining to Mixture Model Output Using MCMC Methods} \alias{plot.mixMCMC} \usage{ \method{plot}{mixMCMC}(x, trace.plots = TRUE, summary.plots = FALSE, burnin = 2000, \dots) } \description{ Takes an object of class \code{mixMCMC} and returns various graphical output for select mixture models. } \arguments{ \item{x}{An object of class \code{mixMCMC}.} \item{trace.plots}{If TRUE, trace plots of the various parameters estimated by the MCMC methods is given.} \item{summary.plots}{Graphics pertaining to certain mixture models. The details are given below.} \item{burnin}{The values 1 to \code{burnin} are dropped when producing the plots in \code{summary.plots}.} \item{...}{Graphical parameters passed to \code{regcr} function.} } \value{ \code{plot.mixMCMC} returns trace plots of the various parameters estimated by the MCMC methods for all objects of class \code{mixMCMC}. In addition, other plots may be produced for the following k-component mixture model functions: \item{regmixMH}{Credible bands for the regression lines in a mixture of linear regressions. See \code{regcr} for more details.} } \seealso{ \code{\link{regcr}} } \examples{ ## M-H algorithm for NOdata with acceptance rate about 40\%. data(NOdata) attach(NOdata) set.seed(100) beta <- matrix(c(1.3, -0.1, 0.6, 0.1), 2, 2) sigma <- c(.02, .05) MH.out <- regmixMH(Equivalence, NO, beta = beta, s = sigma, sampsize = 2500, omega = .0013) plot(MH.out, summary.plots = TRUE, burnin = 2450, alpha = 0.01) } \keyword{file} mixtools/man/lambda.pert.Rd0000755000176200001440000000173614342153463015402 0ustar liggesusers\name{lambda.pert} \title{Perturbation of Mixing Proportions} \alias{lambda.pert} \usage{ lambda.pert(lambda, pert) } \description{ Perturbs a set of mixing proportions by first scaling the mixing proportions, then taking the logit of the scaled values, perturbing them, and inverting back to produce a set of new mixing proportions. } \arguments{ \item{lambda}{A vector of length k giving the mixing proportions which are to be perturbed.} \item{pert}{A vector (possibly of length k-1) for which to perturb \code{lambda}. If the length is less than k, then values of the vector are recycled. If length is greater than k, then only the first k values are used.} } \value{ \code{lambda.pert} returns new \code{lambda} values perturbed by \code{pert}. } \details{ This function is called by \code{regmixMH}. } \seealso{ \code{\link{regmixMH}} } \examples{ set.seed(100) x <- c(0.5, 0.2, 0.3) lambda.pert(x, rcauchy(3)) } \keyword{internal} mixtools/man/matsqrt.Rd0000755000176200001440000000076514342153463014705 0ustar liggesusers\name{matsqrt} \title{Calculates the Square Root of a Diagonalizable Matrix} \alias{matsqrt} \usage{ matsqrt(x) } \description{ Returns the square root of a diagonalizable matrix. } \arguments{ \item{x}{An nxn diagonalizable matrix.} } \value{ \code{matsqrt} returns the square root of \code{x}. } \details{ This function is called by \code{regcr}. } \seealso{ \code{\link{regcr}} } \examples{ a <- matrix(c(1, -0.2, -0.2, 1), 2, 2) matsqrt(a) } \keyword{internal} mixtools/man/plotly_ise.npEM.Rd0000644000176200001440000000651614343061463016227 0ustar liggesusers\name{plotly_ise.npEM} \title{Visualization of Integrated Squared Error for a selected density from npEM output using \code{plotly}} \alias{plotly_ise.npEM} \usage{ plotly_ise.npEM(npEMout, component=1, block=1, truepdf=dnorm, lower=-Inf, upper=Inf, plots = TRUE , col = NULL , width = 3, title = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "t" , xlab.size = 15 , xtick.size = 15, ylab = "" , ylab.size = 15 , ytick.size = 15, legend.text = "" , legend.text.size = 15 , legend.size = 15, ...) } \description{ This is an updated visualization function for \code{ise.npEM}. For more technical details, please refer to \code{ise.npEM}. } \arguments{ \item{npEMout}{An object of class \code{npEM} such as the output of the \code{\link{npEM}} function} \item{component, block}{Component and block of particular density to analyze from \code{npEMout}.} \item{truepdf}{an \R function taking a numeric first argument and returning a numeric vector of the same length. Returning a non-finite element will generate an error.} \item{lower, upper}{the limits of integration. Can be infinite.} \item{plots}{logical: Should plots be produced?} \item{...}{additional arguments to be passed to \code{truepdf} (and that may be mandatory like, e.g., the \code{df = } argument of \code{dt}). Remember to use argument names not matching those of \code{ise.npRM}.} \item{col}{Color of traces.} \item{width}{Line width of traces.} \item{title}{Text of the main title.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{legend.text}{Title of legend.} \item{legend.text.size}{Size of the legend title.} \item{legend.size}{Size of legend.} } \value{ Just as for the \code{\link{integrate}} function, a list of class \code{"integrate"} with components \item{value}{the final estimate of the integral.} \item{abs.error}{estimate of the modulus of the absolute error.} \item{subdivisions}{the number of subintervals produced in the subdivision process.} \item{message}{\code{"OK"} or a character string giving the error message.} \item{call}{the matched call.} } \details{This function calls the \code{\link{wkde}} (weighted kernel density estimate) function. } \seealso{ \code{\link{npEM}}, \code{\link{wkde}}, \code{\link{integrate}}, \code{\link{ise.npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526. \item Benaglia, T., Chauveau, D., Hunter, D. R., and Young, D. (2009), mixtools: An R package for analyzing finite mixture models. Journal of Statistical Software, 32(6):1-29. } } \examples{ \dontrun{ data(Waterdata) set.seed(100) a <- npEM(Waterdata[,3:10], mu0=3, bw=4) # Assume indep but not iid plotly_ise.npEM(a , plots = TRUE) } } \keyword{file} mixtools/man/plotly_mixMCMC.Rd0000644000176200001440000000770114343037574016051 0ustar liggesusers\name{plotly_mixMCMC} \title{Various Plots Pertaining to Mixture Model Output Using MCMC Methods using \code{plotly}} \alias{plotly_mixMCMC} \usage{ plotly_mixMCMC(x, trace.plot = TRUE, summary.plot = FALSE, burnin = 2000, credit.region = 0.95, col.cr = NULL, cex.trace = 3, width.trace = 3, cex.summary = 3, width.summary = 1, title.trace = "", title.trace.x = 0.5, title.trace.y = 0.95, title.trace.size = 15, xlab.trace = "Index", xlab.trace.size = 15, xtick.trace.size = 15, ylab.trace = NULL, ylab.trace.size = 15, ytick.trace.size = 15, title.summary = "Credible Regions", title.summary.x = 0.5, title.summary.y = 0.95, title.summary.size = 15, xlab.summary = "Predictor", xlab.summary.size = 15, xtick.summary.size = 15, ylab.summary = "Response", ylab.summary.size = 15, ytick.summary.size = 15 ) } \description{ This is an updated version of \code{plot.mixMCMC}. For technical details, please refer to \code{plot.mixMCMC}. } \arguments{ \item{x}{An object of class \code{mixMCMC}.} \item{trace.plot}{If TRUE, trace plots of the various parameters estimated by the MCMC methods is given.} \item{summary.plot}{Graphics pertaining to certain mixture models. The details are given below.} \item{burnin}{The values 1 to \code{burnin} are dropped when producing the plots in \code{summary.plots}.} \item{credit.region}{Confidence level of credit region.} \item{col.cr}{Color of credit region. Number of color specified needs to be consistent with number of components.} \item{cex.trace}{Dot size of trace plots.} \item{width.trace}{Line width of trace plots.} \item{cex.summary}{Dot size of summary plots.} \item{width.summary}{Line width of summary plots.} \item{title.trace}{Text of the main title of trace plots.} \item{title.trace.x}{Horizontal position of main title of trace plots.} \item{title.trace.y}{Vertical position of main title of trace plots.} \item{title.trace.size}{Text sise of main title of trace plots.} \item{xlab.trace}{Label of X-axis of trace plots.} \item{xlab.trace.size}{Size of the lable of X-axis of trace plots.} \item{xtick.trace.size}{Size of tick lables of X-axis of trace plots.} \item{ylab.trace}{Label of Y-axis of trace plots.} \item{ylab.trace.size}{Size of the lable of Y-axis of trace plots.} \item{ytick.trace.size}{Size of tick lables of Y-axis of trace plots.} \item{title.summary}{Text of the main title of summar plot.} \item{title.summary.x}{Horizontal position of main title of summary plot.} \item{title.summary.y}{Vertical position of main title of summary plot.} \item{title.summary.size}{Text sise of main title of summary plot.} \item{xlab.summary}{Label of X-axis of summary plot.} \item{xlab.summary.size}{Size of the lable of X-axis of summary plot.} \item{xtick.summary.size}{Size of tick lables of X-axis of summary plot.} \item{ylab.summary}{Label of Y-axis of summary plot.} \item{ylab.summary.size}{Size of the lable of Y-axis of summary plot.} \item{ytick.summary.size}{Size of tick lables of Y-axis of summary plot.} } \value{ \code{plotly_mixMCMC} returns trace plots of the various parameters estimated by the MCMC methods for all objects of class \code{mixMCMC}. In addition, other plots may be produced for the following k-component mixture model functions: \item{regmixMH}{Credible bands for the regression lines in a mixture of linear regressions. See \code{regcr} for more details.} } \seealso{ \code{\link{regcr}}, \code{plot.mixMCMC} } \examples{ \dontrun{ data(NOdata) attach(NOdata) set.seed(100) beta <- matrix(c(1.3, -0.1, 0.6, 0.1), 2, 2) sigma <- c(.02, .05) MH.out <- regmixMH(Equivalence, NO, beta = beta, s = sigma, sampsize = 2500, omega = .0013) plotly_mixMCMC(x = MH.out, summary.plot = TRUE, col.cr = c("red", "green")) } } \keyword{file} mixtools/man/multmixEM.Rd0000755000176200001440000000602614342153463015127 0ustar liggesusers\name{multmixEM} \title{EM Algorithm for Mixtures of Multinomials} \alias{multmixEM} \usage{ multmixEM(y, lambda = NULL, theta = NULL, k = 2, maxit = 10000, epsilon = 1e-08, verb = FALSE) } \description{ Return EM algorithm output for mixtures of multinomial distributions. } \arguments{ \item{y}{Either An nxp matrix of data (multinomial counts), where n is the sample size and p is the number of multinomial bins, or the output of the \code{\link{makemultdata}} function. It is not necessary that all of the rows contain the same number of multinomial trials (i.e., the row sums of \code{y} need not be identical).} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and number of components is determined by \code{theta}.} \item{theta}{Initial value of \code{theta} parameters. Should be a kxp matrix, where p is the number of columns of y and k is number of components. Each row of \code{theta} should sum to 1. If NULL, then each row is random from uniform Dirichlet. If both \code{lambda} and \code{theta} are NULL, then number of components is determined by k.} \item{k}{Number of components. Ignored unless \code{lambda} and \code{theta} are NULL.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{multmixEM} returns a list of class \code{mixEM} with items: \item{y}{The raw data.} \item{lambda}{The final mixing proportions.} \item{theta}{The final multinomial parameters.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{compCDF}}, \code{\link{makemultdata}}, \code{\link{multmixmodel.sel}} } \references{ \itemize{ \item McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. \item Elmore, R. T., Hettmansperger, T. P. and Xuan, F. (2004) The Sign Statistic, One-Way Layouts and Mixture Models, \emph{Statistical Science} \bold{19(4)}, 579--587. } } \examples{ ## The sulfur content of the coal seams in Texas set.seed(100) A <- c(1.51, 1.92, 1.08, 2.04, 2.14, 1.76, 1.17) B <- c(1.69, 0.64, .9, 1.41, 1.01, .84, 1.28, 1.59) C <- c(1.56, 1.22, 1.32, 1.39, 1.33, 1.54, 1.04, 2.25, 1.49) D <- c(1.3, .75, 1.26, .69, .62, .9, 1.2, .32) E <- c(.73, .8, .9, 1.24, .82, .72, .57, 1.18, .54, 1.3) dis.coal <- makemultdata(A, B, C, D, E, cuts = median(c(A, B, C, D, E))) em.out <- multmixEM(dis.coal) em.out[1:4] } \keyword{file} mixtools/man/mvnormalmixEM.Rd0000755000176200001440000000704614342153463016004 0ustar liggesusers\name{mvnormalmixEM} \title{EM Algorithm for Mixtures of Multivariate Normals} \alias{mvnormalmixEM} \usage{ mvnormalmixEM(x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) } \description{ Return EM algorithm output for mixtures of multivariate normal distributions. } \arguments{ \item{x}{A matrix of size nxp consisting of the data.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and number of components is determined by \code{mu}.} \item{mu}{A list of size k consisting of initial values for the p-vector mean parameters. If NULL, then the vectors are generated from a normal distribution with mean and standard deviation according to a binning method done on the data. If both \code{lambda} and \code{mu} are NULL, then number of components is determined by \code{sigma}.} \item{sigma}{A list of size k consisting of initial values for the pxp variance-covariance matrices. If NULL, then \code{sigma} is generated using the data. If \code{lambda}, \code{mu}, and \code{sigma} are NULL, then number of components is determined by \code{k}.} \item{k}{Number of components. Ignored unless \code{lambda}, \code{mu}, and \code{sigma} are all NULL.} \item{arbmean}{If TRUE, then the component densities are allowed to have different \code{mu}s. If FALSE, then a scale mixture will be fit.} \item{arbvar}{If TRUE, then the component densities are allowed to have different \code{sigma}s. If FALSE, then a location mixture will be fit.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{normalmixEM} returns a list of class \code{mixEM} with items: \item{x}{The raw data.} \item{lambda}{The final mixing proportions.} \item{mu}{A list of with the final mean vectors.} \item{sigma}{A list with the final variance-covariance matrices.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{normalmixEM}} } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. } \examples{ ##Fitting randomly generated data with a 2-component location mixture of bivariate normals. set.seed(100) x.1 <- rmvnorm(40, c(0, 0)) x.2 <- rmvnorm(60, c(3, 4)) X.1 <- rbind(x.1, x.2) mu <- list(c(0, 0), c(3, 4)) out.1 <- mvnormalmixEM(X.1, arbvar = FALSE, mu = mu, epsilon = 1e-02) out.1[2:5] ##Fitting randomly generated data with a 2-component scale mixture of bivariate normals. x.3 <- rmvnorm(40, c(0, 0), sigma = matrix(c(200, 1, 1, 150), 2, 2)) x.4 <- rmvnorm(60, c(0, 0)) X.2 <- rbind(x.3, x.4) lambda <- c(0.40, 0.60) sigma <- list(diag(1, 2), matrix(c(200, 1, 1, 150), 2, 2)) out.2 <- mvnormalmixEM(X.2, arbmean = FALSE, sigma = sigma, lambda = lambda, epsilon = 1e-02) out.2[2:5] } \keyword{file} mixtools/man/NOdata.Rd0000755000176200001440000000147114342153463014353 0ustar liggesusers\name{NOdata} \docType{data} \alias{NOdata} \title{Ethanol Fuel Data Set} \description{ This data set gives the equivalence ratios and peak nitrogen oxide emissions in a study using pure ethanol as a spark-ignition engine fuel. } \usage{ data(NOdata) } \format{This data frame consists of: \itemize{ \item{\code{NO}}{The peak nitrogen oxide emission levels.} \item{\code{Equivalence}}{The equivalence ratios for the engine at compression ratios from 7.5 to 18.} } } \source{Brinkman, N. D. (1981) Ethanol Fuel -- A Single-Cylinder Engine Study of Efficiency and Exhaust Emissions, \emph{S.A.E. Transactions}, 68. } \references{ Hurn, M., Justel, A. and Robert, C. P. (2003) Estimating Mixtures of Regressions, \emph{Journal of Computational and Graphical Statistics} \bold{12(1)}, 55--79. } \keyword{datasets} mixtools/man/rnormmix.Rd0000755000176200001440000000214014342153463015052 0ustar liggesusers\name{rnormmix} \title{Simulate from Mixtures of Normals} \alias{normmix.sim} \alias{rnormmix} \usage{ rnormmix(n, lambda=1, mu=0, sigma=1) } \description{ Simulate from a mixture of univariate normal distributions. } \arguments{ \item{n}{Number of cases to simulate.} \item{lambda}{Vector of mixture probabilities, with length equal to \eqn{m}, the desired number of components (subpopulations). This is assumed to sum to 1; if not, it is normalized.} \item{mu}{Vector of means.} \item{sigma}{Vector of standard deviations.} } \value{ \code{rnormmix} returns an \eqn{n}-vector sampled from an \eqn{m}-component mixture of univariate normal distributions. } \details{This function simply calls \code{\link{rmvnormmix}}.} \seealso{ \code{\link{makemultdata}}, \code{\link{rmvnormmix}} } \examples{ ##Generate data from a 2-component mixture of normals. set.seed(100) n <- 500 lambda <- rep(1, 2)/2 mu <- c(0, 5) sigma <- rep(1, 2) mixnorm.data <- rnormmix(n, lambda, mu, sigma) ##A histogram of the simulated data. hist(mixnorm.data) } \keyword{file} mixtools/man/rmvnorm.Rd0000755000176200001440000000141314342153463014701 0ustar liggesusers\name{rmvnorm} \alias{rmvnorm} \title{Simulate from a Multivariate Normal Distribution} \description{ Simulate from a multiviate normal distribution } \usage{ rmvnorm(n, mu=NULL, sigma=NULL) } \arguments{ \item{n}{Number of vectors to simulate} \item{mu}{mean vector} \item{sigma}{covariance matrix, assumed symmetric and nonnegative definite} } \value{ An \eqn{n \times d}{n x d} matrix in which each row is an independently generated realization from the desired multivariate normal distribution } \details{ This function uses an \code{\link{eigen}} decomposition assuming \code{sigma} is symmetric. In particular, the upper triangle of \code{sigma} is ignored. } \seealso{ \code{\link{eigen}}, \code{\link{dnorm}}, \code{\link{dmvnorm}} } \keyword{distribution} mixtools/man/Waterdata.Rd0000755000176200001440000000657614342153463015134 0ustar liggesusers\name{Waterdata} \docType{data} \title{Water-Level Task Data Set} \alias{Waterdata} \alias{WaterdataFull} \usage{ data(Waterdata) } \description{ This data set arises from the water-level task proposed by the Swiss psychologist Jean Piaget to assess children's understanding of the physical world. This involves presenting a child with a rectangular vessel with a cap, affixed to a wall, that can be tilted (like the minute hand of a clock) to point in any direction. A separate disk with a water line indicated on it, which can similarly be spun so that the water line may assume any desired angle with the horizontal, is positioned so that by spinning this disk, the child subject may make the hypothetical surface of water inside the vessel assume any desired orientation. For each of eight different orientations of the vessel, corresponding to the clock angles at 1:00, 2:00, 4:00, 5:00, 7:00, 8:00, 10:00, and 11:00, the child subject is asked to position the water level as it would appear in reality if water were in the vessel. The measurement is the acute angle with the horizontal, in degrees, assumed by the water line after it is positioned by the child. A sign is attached to the measurement to indicate whether the line slopes up (positive) or down (negative) from left to right. Thus, each child has 8 repeated measurements, one for each vessel angle, and the range of possible values are from -90 to 90. The setup of the experiment, along with a photograph of the testing apparatus, is given by Thomas and Jamison (1975). A more detailed analysis using a subset of 405 of the original 579 subjects is given by Thomas and Lohaus (1993); further analyses using the functions in \code{mixtools} are given by Benaglia et al (2008) and Levine et al (2011), among others. There are two versions of the dataset included in \code{mixtools}. The full dataset, called \code{WaterdataFull}, has 579 individuals. The dataset called \code{Waterdata} is a subset of 405 individuals, comprising all children aged 11 years or more and omitting any individuals with any observations equal to 100, which in this context indicates a missing value (since all of the degree measurements should be in the range from -90 to +90, 100 is not a possible value). } \format{These data frames consist of 405 or 579 rows, one row for each child. There are ten columns: The age (in years) and sex (where 1=male and 0=female) are given for each individual along with the degree of deviation from the horizontal for 8 specified clock-hour orientations (11, 4, 2, 7, 10, 5, 1, and 8 o'clock, in order). } \source{ Benaglia, T., Chauveau, D., and Hunter, D.R. (2009), An EM-Like Algorithm for Semi- and Non-Parametric Estimation in Multivariate Mixtures, \emph{Journal of Computational and Graphical Statistics}, 18: 505-526. Levine, M., Hunter, D.R., and Chauveau, D. (2011), Maximum Smoothed Likelihood for Multivariate Mixtures, \emph{Biometrika}, 98(2): 403-416. Thomas, H. and Jamison, W. (1975), On the Acquisition of Understanding that Still Water is Horizontal, \emph{Merrill-Palmer Quarterly of Behavior and Development}, 21(1): 31-44. Thomas, H. and Lohaus, A. (1993), \emph{Modeling Growth and Individual Differences in Spatial Tasks}, University of Chicago Press, Chicago, available on JSTOR. } \keyword{datasets} mixtools/man/lambda.Rd0000755000176200001440000000245614342153463014431 0ustar liggesusers\name{lambda} \title{Local Estimation for Lambda in Mixtures of Regressions} \alias{lambda} \usage{ lambda(z, x, xi, h = NULL, kernel = c("Gaussian", "Beta", "Triangle", "Cosinus", "Optcosinus"), g = 0) } \description{ Return local estimates of the mixing proportions from each component of a mixture of regressions model using output from an EM algorithm. } \arguments{ \item{z}{An nxk matrix of posterior probabilities obtained from the EM algorithm.} \item{x}{A vector of values for which the local estimation is calculated.} \item{xi}{An nx(p-1) matrix of the predictor values.} \item{h}{The bandwidth controlling the size of the window used for the local estimation.} \item{kernel}{The type of kernel to be used for the local estimation.} \item{g}{A shape parameter required for the symmetric beta kernel. The default is \code{g} = 0 which yields the uniform kernel. Some common values are \code{g} = 1 for the Epanechnikov kernel, \code{g} = 2 for the biweight kernel, and \code{g} = 3 for the triweight kernel.} } \value{ \code{lambda} returns local estimates of the mixing proportions for the inputted \code{x} vector. } \seealso{ \code{\link{regmixEM.loc}} } \note{\code{lambda} is for use within \code{regmixEM.loc}.} \keyword{internal} mixtools/man/RTdata.Rd0000755000176200001440000000233214342153463014361 0ustar liggesusers\name{RTdata} \docType{data} \title{Reaction Time (RT) Data Set} \alias{RTdata} \usage{ data(RTdata) } \description{ This data set involves normally developing children 9 years of age presented with two visual simuli on a computer monitor. The left image is the target stimuli and on the right is either an exact copy or a mirror image of the target stimuli. The child must press one key if it is a copy or another key if it is a mirror image. The data consists of the reaction times (RT) of the 197 children who provided correct responses for all 6 task trials. } \format{This data frame consists of 197 children (the rows) and their 6 responses (the columns) to the stimulus presented. The response (RT) is recorded in milliseconds. } \references{ Cruz-Medina, I. R., Hettmansperger, T. P. and Thomas, H. (2004) Semiparametric Mixture Models and Repeated Measures: The Multinomial Cut Point Model, \emph{Applied Statistics} \bold{53(3)}, 463--474. Miller, C. A., Kail, R., Leonard, L. B. and Tomblin, J. B. (2001) Speed of Processing in Children with Specific Language Impairment, \emph{Journal of Speech, Language, and Hearing Research} \bold{44(2)}, 416--433. } \seealso{ \code{\link{RTdata2}} } \keyword{datasets} mixtools/man/density.npEM.Rd0000755000176200001440000000456014342153463015524 0ustar liggesusers\name{density.npEM} \title{Normal kernel density estimate for nonparametric EM output} \alias{density.npEM} \usage{ \method{density}{npEM}(x, u=NULL, component=1, block=1, scale=FALSE, \dots) } \description{ Takes an object of class \code{npEM} and returns an object of class \code{\link{density}} giving the kernel density estimate for the selected component and, if applicable, the selected block. } \arguments{ \item{x}{An object of class \code{npEM} such as the output of the \code{\link{npEM}} or \code{\link{spEMsymloc}} functions.} \item{u}{Vector of points at which the density is to be evaluated} \item{component}{Mixture component number; should be an integer from 1 to the number of columns of \code{x$posteriors}.} \item{block}{Block of repeated measures. Only applicable in repeated measures case, for which \code{x$blockid} exists; should be an integer from 1 to \code{max(x$blockid)}.} \item{scale}{Logical: If TRUE, multiply the density values by the corresponding mixing proportions found in \code{x$lambdahat}} \item{\dots}{Additional arguments; not used by this method.} } \details{ The bandwidth is taken to be the same as that used to produce the \code{npEM} object, which is given by \code{x$bandwidth}. } \value{ \code{density.npEM} returns a list of type \code{"density"}. See \code{\link{density}} for details. In particular, the output of \code{density.npEM} may be used directly by functions such as \code{\link{plot}} or \code{\link{lines}}. } \seealso{ \code{\link{npEM}}, \code{\link{spEMsymloc}}, \code{\link{plot.npEM}} } \examples{ ## Look at histogram of Old Faithful waiting times data(faithful) Minutes <- faithful$waiting hist(Minutes, freq=FALSE) ## Superimpose equal-variance normal mixture fit: set.seed(100) nm <- normalmixEM(Minutes, mu=c(50,80), sigma=5, arbvar=FALSE, fast=TRUE) x <- seq(min(Minutes), max(Minutes), len=200) for (j in 1:2) lines(x, nm$lambda[j]*dnorm(x, mean=nm$mu[j], sd=nm$sigma), lwd=3, lty=2) ## Superimpose several semiparametric fits with different bandwidths: bw <- c(1, 3, 5) for (i in 1:3) { sp <- spEMsymloc(Minutes, c(50,80), bw=bw[i], eps=1e-3) for (j in 1:2) lines(density(sp, component=j, scale=TRUE), col=1+i, lwd=2) } legend("topleft", legend=paste("Bandwidth =",bw), fill=2:4) } \keyword{file} mixtools/man/figures/0000755000176200001440000000000014343400152014343 5ustar liggesusersmixtools/man/figures/mixtools.png0000644000176200001440000005542214342153463016750 0ustar liggesusersJFIFExifMM*JR(iZ8Photoshop 3.08BIM8BIM%ُ B~ICC_PROFILEappl mntrRGB XYZ   acspAPPLappl-appl descodscmxcprt8wtptLrXYZ`gXYZtbXYZrTRCchad,bTRCgTRCdescGeneric RGB ProfileGeneric RGB Profilemluc skSK(daDK.caES$viVN$ptBR&"ukUA*HfrFU(rhuHU(zhTWnbNO&csCZ"heIL itIT(>roRO$fdeDE,koKRsvSE&zhCNjaJPelGR"ptPO&nlNL(DesES&thTH$ltrTR"fiFI(hrHR(plPL,ruRU".arEG&PenUS&vVaeobecn RGB profilGenerel RGB-beskrivelsePerfil RGB genricCu hnh RGB ChungPerfil RGB Genrico030;L=89 ?@>D09; RGBProfil gnrique RVBltalnos RGB profilu( RGB r_icϏGenerisk RGB-profilObecn RGB profil RGB Profilo RGB genericoProfil RGB genericAllgemeines RGB-Profil| RGB \ |fn RGB cϏeNN, RGB 000000  RGBPerfil RGB genricoAlgemeen RGB-profielB#D%L RGB 1H'DGenel RGB ProfiliYleinen RGB-profiiliGeneri ki RGB profilUniwersalny profil RGB1I89 ?@>D8;L RGBEDA *91JA RGB 'D9'EGeneric RGB ProfiletextCopyright 2007 Apple Inc., all rights reserved.XYZ RXYZ tM=XYZ Zus4XYZ (6curvsf32 B&l" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyzC C   ?((((((Oq gHKvD@݁hPZiQWmIjp%+[N95cvN^Hu c2ZhR'2Blt(cCiSE[ _I%?qW_7x_$2]< 4Kx>Wf-G4LOըcIkZ~Ikkrn}aiVyWC[~-u5|zӥ^iVqF҃ǝv_/֯>> i7oi\ԭS8"6џOUdQ|Cu|5K}p dQ{X ~YsoHi>>WxY<8fmO?9[Kssht+ʿܞ}W*_?Qf;?ʤ<$1*sſ`8ZҢfuk& xJ~ЫL$ pfpx'T'9RRx#}h5Mo_G=YxCKጣcuSץWuTRTEQvi4F8Jp[ ( ((((((((P-CQlfI㶶FYe`(fc$_??l2WD$Vh\tS|n=Ts_hO GxkKܰ>ӕ-%q)*%B+0hh永%SKkߣmEm}>U؜T>jiyK./u$$i6T pg9jQ|Slj6x~$fjm*qyOǍ|simLoM" ƾ=CĉoS5x$rvW^-5=Iq+Ӽufեv]=oXcg a[u!_?1*8=YV~?f,V:TmKZ.N*"^nR{Pq\ί[G]Tt9UftFO>sqȯ[o? X4k>9k+$g>&cJX(?O4ꎜ&2T/- O~!|^+UuHT\Ҳ$نzzao8 _S |O&؆C{B}&-q_\1 H9C־Q[x^V֚(.عx,U}8w) Ƹg8JI|FwO*{OʬvQn[-N-GN.-dX::0ʲA_|w1n-h#'͵s#m?R΋eQڴH7܎->.4(i`dxR%I7ӔVW3kl;N?ShQAEPEPEP(((/χ%u㿉Ŧٌw{*A=XUf<M7_g~ǖd ]N n> $pk8_s~ ɗѼW7#.J=|"f3CNzEz]MƝz+ &Bֶ~ba 0K|aa}|;k2I,scRNF% ~ H.⿟?75+xɹԯ&yc敉i1*ȯxŞ<α/%\dA&C'QK0ǮߖMys;9|#?X믉_}KiڅV'qOkgڶ<]wI4]}n-#T_/oVrZB?Ogf/0ϊ-_G GSQY&>] Gp|v K>Ǎ$CTi`$uu2 %Y$8X5X*(Rmfyn9=EqCy2ƅ!Bx \%Zo;Bq޺qO"?$;㟧 moV\ks KuǡA=}ԟM ѐSR\8+#^st|+]_e<{pkj/%ѣɸT_Uf~O8;m/NƛS*Evg Z?wrw@$P1_hO0K}XBؿoݾt 6 6a''xᶥ+,A?<^v54B5:u_Xm + *)'[09R%(BaqOoo3hK >KU,k&qHz(kkK?YAWxD]^Lr^ k{,҃Q ִ.y]%p?+ɋd/諸 (?(8_߶Gc%Z-K'|^A;U,'fx22QIunu:*R}(RBI:_?_/'{H|wXFn->XHC=|do5q<19Xú[0I<~鱂w0FB->j<*E*J7R/{'?W3^+ŕ&XjNJ_8{c.ʒTҔἜ?Y?lo(/Mķ>'q!-Տ ."c 9k'GO|Ng֦y?-g?'6{IO=WGoOTR֊=#njޖQ}O#6|V2šT譡 Ȋ 6)v"]փ\O+1R$IG>%R \aGZdO.FG]q?,1̻%}E#Ìڻ*I#isgw9 R-/ݹrtyC5Sim7x|y`r^A5U};|¿w# C=Ս|oY"UnntUqg(CWkG~05 H#k(NMj7 ME<(ifO=? ѻqY4 h0,n6w Jr T#ٻŷ> L$U8"H@~R*ousi*d`t zk{4fxE|zS2^2Wl;zy7{zj/~ߴ{YX>x]'E|͹8'd( XWmuo{]ZH!Ws|#W$Gʾc %>րp$>F/&cma^Oo 3% cm"NY7OZv~~MyCc٩yfs[!SwFo_uî;]E~e~V?豃HVÚ,Wݳ:c;Œ.q_ҿ 2L~U2*UcdWt5t3qFFևw|YO UuRijzs\<+db_\eI%f2jwK31壍bN~y>5_n'>+jp&|14c*֬ܢz}e+C&֖ͥURJ_^lnx\55mj[뙿K;v=ŽWY(=MyzrT9jTI9ͷ'oVݷ՟JNMN풤WC`>ssui}1)23E#@LuzUi"IF~5%޳C3BY * ֆA|sU嵋dE8\39Y6_ęvqW#@w4m::W~Mj¼^μ-$f8O_})YxSHN|swM[u;YH2ae3*| )ҝIrӋoW <7 _zo)C€3ߥy(Ǐ KWb7GCY@oP%{օT<@żeLڊs[>QI >%뵊WAzZχ峺K m`3g8NANd$zu EZ#VdN5>u'NJpvk?N> -WP:,΅e7 G#8#Ҩ2eH8qV~Pd*nʼn9'&lYr˞xh\: ED<5:ː>+ݡSA#Z&ey<Jk-@.3|FĠ $W2JŘ&_;GQ8>r5xЩy&8GVyQ@6~ ?2K^(_>U״P47wC"H#tnp9 ⿺f/ڗ6MQwt Vbn%w%E7? T|P~%?;Z Fi]E#"y3ڤs|yKtu;xrn嶳"iQ8Գs<O('o./}PR*l3|ms"eI^7Lzm] wP7*>ke-? υ5(Wq$2cCEj}scbfWxƼOʹ8沉$֦AP;-eW)E<(ȒGkJ'+6IN: 'Ǡ(U?a&*SkPo4SIgw?l$ N}d<-d&2-~ڷb?OH [%vZ՞tJꤝɮe >(ou=T?Q]u%ݸOCjkMPA!Gj`ہ ֤zVbk*] I|& Gc5F!UMUծﲬvGxP@2+o;B?n]k2ZZa1,H hg>^ԵXuҹI9<_kOڻ mej~%QԢԖK{i%P;y9|O@ 2I5$ *k 4BFIި!aP/ZY|,Ҵ8mN0 U0k}ZlgaLξJZܴ+iry~Gj:ZԴNi7Ң0|>Fxfk8P:I+^go olzwyZ.#vB  >FsGs|n~[ޫ\Ш95f_}k<2;9jTsFs@J}PEP_][‡D_u 5տ(LuK_ ?w?lm[?QȶIQo"Fa_ 8~OH!ꯤvJ}ǥY.lR> {V@6,RVB*A@㚷@7~Gw{X$y1f5ݳ#>k[GL:w}szۧn;( ̨2YE8ߣ:&os<szWkOc Aq O7Z ג^A*|;Wێ9# -gK?ǯ7# 潌F#݊<l*®O-O.$qgCObghFg\+y!hO>^Ĩ5_nSׯ^ʣI-~KЄ;%O+\7p%%\zW?_=Vy!~K6>?>3<>|W}GIT7~Lsn| wx;ߓsiǫN`&X+ zYJrkOI'Oξb~ř^Q@ t|u҆:\/ z&h4(((>mw€8Ťg֭eth.V%?K_w87Z/4|GF;+tW567~/iZ2arfc8gy|i_:i,O:/ қBbyEw'Y>QAkj3=kFW*?G\Zٟٳ7?އ3ŷ|Us-$[Ur/X;\6?=? £Zxi$ab>HWO Y:Xx$FᮧQĶ@T`Wi 9\HΫ[]61 pb%bYّ0Q<~}#Zr]T}xS-cs I^NJWʷU1+C4|ltI{|Ehdy-sxl?]G(-(/sAs kj+̚lpf=[Sk/{/_}cUXtmGu3A<0+1S%)vnW~|Sff9cIEQEQEW7$V1]~~Muo ~uƗ*,O2an4Ozٷm{D藯b@H,kFOH(qw=t6'-SҩQ_ ujs\F q֫E4? aU[r*sM@7F T?Չ,'3oS֢C0U,rI(r]]4vi>|c~9_ YCx[TVܥl {q69sŽHWJ_~ݒZ铘N|T9tgpվk>2KХph|[lc..єr >_1NQqY5wӲ8qم-79z.~8~bӻ~p]>c %W<.M@% o/ 9RIEY-~eZԕI[%C+wyЏgj̸5s+78/(u?#BV{}!* (6 CkF{++D`<-€0T~(RÚ>czni{\YN1$2G ) qkcC5kH㲹U v<: Wf%z-o^zpM:U.Y>ε6۷)"K׎}f=*&DJH2= gΓ͋ZKȧ g_ًÿ/{~_ڕƣ~.mŵޡ+_ I69_;dk;.9|%|UqXa5qqo ۜp2L |D"Lzቬn4,2!F/ )7Zz}g;~{eUjGz¢)!}Sp}?B9yQEQE 5տ(LuW_][‡D_}䱥 K?@Gp #\mOtXߟ>/_#9-<AK}~IqS#MENqT$2h_M [ݍm.$SVS<աv36F9ROJ_w~_vsv? =:}ĖHSFo69Oʘ@P(sୀ~=x[S_,P1+G$ۻbv[+`><Ǐ.c/όx?Z9"2u8*/'/:E@4]'z?Z^+6\_1̧]^+.Fs\?*/|)+_{jY]}I`Cطk) G%hd-̞l' (*}@nҠpH? CVQEQEW7$V1]~~Muo ~uƗ*,O2Wn/o?zDa_߷Z7D~[' %S$O,KM$GI(i3`庰BxUmW?*;(TqQK,9ΪQ<]-}ބ\Ieiy\<}Rhkv={u5#|@ѿ਱x`ݵ$':̨DR/8'8g Oz7[&jWÝf4CN%Wz]ʖxCOkpTE&ϝ_*?P:N#z.poS4bK9܍y>S 0`lҶɽ=L=U rqMr}^)--kzk5T:+W#܍Yy#3 ~~jsO^kg /*ʿ?-힯|,~7WJ[+[L#m_^!7,~S:;[}\_j1-:}o&϶@-2\ן,bNN6DzY'wmne.Frp}wRψ1#' ,WCi.漛X~:<|fo#*!{o| xv/j{vV0̒Hhm#_ZKT0F.qIsErsNQim˚+G{uGj9tݴӫjI-:~5Nh_lc/j>$mm8 U|C#BÜW`f$o(G#a?_],ƑmL^BAW?gO(~J|DvLzm{˵ʑy$18J8c1[˖mv\7{;+Frypwd]}Ǡ^XNۨ5^}LGsM[U%l{mUӠ W7 =U2PGFGa{>5 yɂd;@$rFYTߗWKٴ2IBN*JV{~K\='wp*4Ic^_::?Fm*Mζr7)A;dÌ~mw=9ʖ߶oM"Kh/Zk{DneS4e_%/ʵ bSk~Xnڽ9V]^ᜩiEiwVO_uj$g>4I5R=,+|7ns?>5~*]h^<ҭ乌[]_l(%LBw :3N߰_'[̿m[Aeͥoulxf@JFWt9SP~kGf9j&D?cCH]mhM'ᯆm|y{:]zTWRt#2x$z0#aL))ӽ M'ſQ?C/pgXa5ءM#saYq3y:5oEMьSo^GR>ך[I%op˹QDAk=/+ck%ʳ])̧a?15mg/" x}ߋS5thçZ$>%idDTuV*\bPJiI/4SOJI_Hqh3 T?&:OoIaCcݾXO%xi#_U?n|g?zwg9c_ßA5=ɸxONqƿEت|UWhm=COcʳPvJ~]JzQ$'CE~~v~__?~0x>YOsRגdo.e nF2kK !_C~? J/ھ3v R;+?B˟ky-"ض$QcP~_⇎ B(xZjKVmjs@r~CDQB_ٷY$vD+9%f{?.I,W<w_K*?]_Z~#~ÿ=~l rƟ}֑,dt$achjg?MB~xBKoXʹpɣ UQ}+cQ/+-V~:k.uqh9Exl*g*kQzVMz-JS":_9C :N^jͿft?}c#WWΟaexFqk5Kn/E0Xakn,85;Avnۅ\\$(gwl7I>%"i:]శfhZc6kYIS7_ 3x ~k{6ղ x%^֌6?%:_K(m4\ťqih=eKUqZiek]sqi|~,^/LkKBp2"5's^G{ӼWjWї%mѮ",:˞:?vx[ֺvckoWo)Xn#+Q+ ܿ"W_'?Ec~ېYx:]7Lh#Gs<QE,% *iJ'҄iՍIJ|Ey=aRhewnz-vG_T֫O|?%KVԣay%{Yt"޽;`->?6á3ģe٭-=1ʹ#w(N}\^W_tE(9$ _g.iu613AgsC,ÓǙ\ >؞l h^ Ry.`;DKy$HUB/ğugux=JY~Ϥͨ[8)u{ۈ0`H2 ֙!K¹)U\vi\1mue+tVۥo))ӽHo(LۻßͮZ̉q-?5;_|It]`-e-$'B8lx8Bi6SM%;7~5(rMvޗ~QAOoIaCc˽;J5k^y;c5.}@$5(|3(. BgT1d%z:8ةLqp'JSqMga6U$c+h?o?!\=~Ɵu;ΫO-XeW_027~nO\a5&-+kQRNHm =|doE|s}ொ^x6E6IDcM aE}&/0LU兪jG-WqzuW8~'i/F_6}?GgZ+eYabDd5f}K?m!5eĂj bm'/c,0N(>>w|Sė]jܷ2dyZi$l74pqW);G;z~|A~eK_ط_}Oὕ:keN%]\0wNNTdxog߱Owl]@`XSzѰ8P?+Oϙ}uᄀ{}/WOMxM-A P`*jl۳scWMuڃp&H"%qncq M foڋcN=$m}ȩ*,cuä ֿnP)x+4}x$gy5ż0'e|b7cS&G?Ş g?<>E[@_`!y"-s䟙kc~(]I)}x!I fEPF,I(QI# ) xHcx_CLx.I-@H&k?,[9>,k>#d̗LUt(`'2FqaE V,1wrYI'&?']k]kOڠ$&( |3E ?h>=_V;W ~&lf/c!т7$i;_9U uw=yX:p*w;?`u_c6mUķvR%I%Sd 0pXCx|DSC]jK{iΞ bۥCF} eI\(3,,+y߇~_m{QSö˦ .qMdLkl/ R?7ㅤ/^GK},GUT'z_*N#OU]/q.j)I.}SYse|yW:+*jz Z0sijK* C$Tq_|xW}XF!`5ƀ*(81ee ThMߪI'q+O(}ckZꕓ}(+7VX|}ͧg]; 1$/#_BQ]8Le|-h0*EJ-t՚5Z%Nz3r>Zj>.F>tuxc;?p$#nMak^FNk#>z0!" 0 +~r۟Ko?Ӧe o-,,:A)[dNklŬ:+*k%Zn]m͟>:qiHN?x',峺;0RErH?ɦ^1c-C27rI/?cOu>jk6u0Ƽ#n¼߅kv '#(ne(&QQW߉y8^ZHjugsg3ܣ#0 )Ad>QE" ( ( ( ( (Z}qm$UR{$j M]-"uG. !TqA]٧,M*I֟]{^Pf1?GgQ9xG2| <onwQ$1ifoQ_u5ΤܤmmkT7RmŠ(s3(((X re`AA_GiV? e)21:M܄ˏ)A,ѹ+8s\N"TIv^^M>YbQ^[?&k(('{c_sh3,@.Hyr Ċ̪k/߅MIyn "ry_q_kׁ>*Jt{=wFPse A*8PyYo_7 K՚'+|ršمKWGpH$ҭ4MMEkcc [ƒF*'ż#1tx^c܋qտև<&ȗ&Uo__ _I߰w__c7a"e}շe=%q TTQuqFi35J]hYEy$m*l]G)y켒/@+<ࢊ(((((((gO G3knH-1$g8$VW v4ӵ/QwLxx(t?z~yOaj{L;-qև|U%)sR{ZӧsN>3~musw.&vJdnܩ@y";C}º>i-$e( LI_?紟\nYu-%;a\0(ȵAHeKϊ~O&&G.C0ʹ~c] "zE_4>;$ܾ?zž/ؠ,P.wAğTd՟_NJ|R!|xϤY8 !7n/e~yQ-{龇ͮ >?nf}|5/UDS}آ]F@Ϡ<@ѯ\_mB8t=ϺG8UvQBā&&4]O 9Vzlʟ%n 2)⿷{ Q'|:7UYoIa-@1^3}k0c.`uU$z{HOd,F%}ާt0S<[LiTxh#U'Q-4b?f+|M͂#nF7NVBPpt8e90vROG&C*揖i"i+Q_8QEQEQEQE((((((*ݝwLr#<E4w@4T"O쭯Lgm;0aa3$%+S<7C|]CŴzǦnM νH~~߿f? 'ɧ;+9xįVrW i۞Ͷh}\Rĭ˾役+|c+{x-aK{tUUG@aSQE~6>$((((((mixtools/man/poisregmixEM.Rd0000755000176200001440000000554414342153463015622 0ustar liggesusers\name{poisregmixEM} \title{EM Algorithm for Mixtures of Poisson Regressions} \alias{poisregmixEM} \usage{ poisregmixEM(y, x, lambda = NULL, beta = NULL, k = 2, addintercept = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) } \description{ Returns EM algorithm output for mixtures of Poisson regressions with arbitrarily many components. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An nxp matrix of predictors. See \code{addintercept} below.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and number of components is determined by \code{beta}.} \item{beta}{Initial value of \code{beta} parameters. Should be a pxk matrix, where p is the number of columns of x and k is number of components. If NULL, then \code{beta} is generated by binning the data into k bins and using \code{glm} on the values in each of the bins. If both \code{lambda} and \code{beta} are NULL, then number of components is determined by \code{k}.} \item{k}{Number of components. Ignored unless \code{lambda} and \code{beta} are both NULL.} \item{addintercept}{If TRUE, a column of ones is appended to the x matrix before the value of p is calculated.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{poisregmixEM} returns a list of class \code{mixEM} with items: \item{x}{The predictor values.} \item{y}{The response values.} \item{lambda}{The final mixing proportions.} \item{beta}{The final Poisson regression coefficients.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{logisregmixEM}} } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. Wang, P., Puterman, M. L., Cockburn, I. and Le, N. (1996) Mixed Poisson Regression Models with Covariate Dependent Rates, \emph{Biometrics}, \bold{52(2)}, 381--400. } \examples{ ## EM output for data generated from a 2-component model. set.seed(100) beta <- matrix(c(1, .5, .7, -.8), 2, 2) x <- runif(50, 0, 10) xbeta <- cbind(1, x)\%*\%beta w <- rbinom(50, 1, .5) y <- w*rpois(50, exp(xbeta[, 1]))+(1-w)*rpois(50, exp(xbeta[, 2])) out <- poisregmixEM(y, x, verb = TRUE, epsilon = 1e-03) out } \keyword{file} mixtools/man/plot.mvnpEM.Rd0000755000176200001440000000344614342153463015370 0ustar liggesusers\name{plot.mvnpEM} \title{Plots of Marginal Density Estimates from the mvnpEM Algorithm Output} \alias{plot.mvnpEM} \usage{ \method{plot}{mvnpEM}(x, truenorm = FALSE, lambda = NULL, mu = NULL, v = NULL, lgdcex = 1, \dots) } \description{ Takes an object of class \code{mvnpEM}, as the one returned by the \code{\link{mvnpEM}} algorithm, and returns a set of plots of the density estimates for each coordinate within each multivariate block. All the components are displayed on each plot so it is possible to see the mixture structure for each coordinate and block. The final bandwidth values are also displayed, in a format depending on the bandwidth strategy . } \arguments{ \item{x}{An object of class \code{mvnpEM} such as the output of the \code{\link{mvnpEM}} function} \item{truenorm}{Mostly for checking purpose, if the nonparametric model is to be compared with a multivariate Gaussian mixture as the true model.} \item{lambda}{true weight parameters, for Gaussian models only (see above)} \item{mu}{true mean parameters, for Gaussian models only (see above)} \item{v}{true covariance matrices, for Gaussian models only (see above)} \item{lgdcex}{Character expansion factor for \code{\link{legend}}.} \item{\dots}{Any remaining arguments are passed to \code{\link{hist}}.} } \value{ \code{plot.mvnpEM} currently just plots the figure. } \seealso{ \code{\link{mvnpEM}}, \code{\link{npEM}}, \code{\link{density.npEM}} } \examples{ # example as in Chauveau and Hoang (2015) with 6 coordinates \dontrun{ m=2; r=6; blockid <-c(1,1,2,2,3,3) # 3 bivariate blocks # generate some data x ... a <- mvnpEM(x, mu0=2, blockid, samebw=F) # adaptive bandwidth plot(a) # this S3 method produces 6 plots of univariate marginals summary(a)} } \keyword{file} mixtools/man/CO2data.Rd0000755000176200001440000000154014342153463014417 0ustar liggesusers\name{CO2data} \docType{data} \title{GNP and CO2 Data Set} \alias{CO2data} \usage{ data(CO2data) } \description{ This data set gives the gross national product (GNP) per capita in 1996 for various countries as well as their estimated carbon dioxide (CO2) emission per capita for the same year. } \format{This data frame consists of 28 countries and the following columns: \itemize{ \item{\code{GNP}}{The gross national product per capita in 1996.} \item{\code{CO2}}{The estimated carbon dioxide emission per capita in 1996.} \item{\code{country}}{An abbreviation pertaining to the country measured (e.g., "GRC" = Greece and "CH" = Switzerland).} } } \references{ Hurn, M., Justel, A. and Robert, C. P. (2003) Estimating Mixtures of Regressions, \emph{Journal of Computational and Graphical Statistics} \bold{12(1)}, 55--79. } \keyword{datasets} mixtools/man/plotly_mixturegram.Rd0000644000176200001440000001117014342426212017141 0ustar liggesusers\name{plotly_mixturegram} \title{Mixturegrams} \alias{plotly_mixturegram} \usage{ plotly_mixturegram(data, pmbs, method=c("pca","kpca","lda"), all.n=FALSE, id.con=NULL, score=1, iter.max=50, nstart=25, xlab = "K", xlab.size = 15, xtick.size = 15, ylab = NULL, ylab.size = 15, ytick.size = 15, cex = 12, col.dot = "red", width = 1, title = "Mixturegram", title.size = 15, title.x = 0.5, title.y = 0.95) } \description{ Construct a mixturegram for determining an apporpriate number of components using \code{plotly}. } \arguments{ \item{data}{The data, which must either be a vector or a matrix. If a matrix, then the rows correspond to the observations.} \item{pmbs}{A list of length (K-1) such that each element is an nxk matrix of the posterior membership probabilities. These are obtained from each of the "best" estimated k-component mixture models, k = 2,...,K. } \item{method}{The dimension reduction method used. \code{method = "pca"} implements principal components analysis. \code{method = "kpca"} implements kernel principal components analysis. \code{method = "lda"} implements reduced rank linear discriminant analysis. } \item{all.n}{A logical specifying whether the mixturegram should plot the profiles of all observations (\code{TRUE}) or just the K-profile summaries (\code{FALSE}). The default is \code{FALSE}.} \item{id.con}{An argument that allows one to impose some sort of (meaningful) identifiability constraint so that the mixture components are in some sort of comparable order between mixture models with different numbers of components. If \code{NULL}, then the components are ordered by the component means for univariate data or ordered by the first dimension of the component means for multivariate data.} \item{score}{The value for the specified dimension reduction technique's score, which is used for constructing the mixturegram. By default, this value is \code{1}, which is the value that will typically be used. Larger values will result in more variability displayed on the mixturegram. Note that the largest value that can be calculated at each value of k>1 on the mixturegram is p+k-1, where p is the number of columns of \code{data}. } \item{iter.max}{The maximum number of iterations allowed for the k-means clustering algorithm, which is passed to the \code{\link{kmeans}} function. The default is \code{50}. } \item{nstart}{The number of random sets chosen based on k centers, which is passed to the \code{\link{kmeans}} function. The default is \code{25}.} \item{title}{Text of the main title.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{cex}{Size of dots.} \item{col.dot}{Color of dots.} \item{width}{Line width.} } \value{ \code{plotly_mixturegram} returns a mixturegram where the profiles are plotted over component values of k = 1,...,K. } \seealso{ \code{\link{boot.comp}}, \code{\link{mixturegram}} } \references{ Young, D. S., Ke, C., and Zeng, X. (2018) The Mixturegram: A Visualization Tool for Assessing the Number of Components in Finite Mixture Models, \emph{Journal of Computational and Graphical Statistics}, \bold{27(3)}, 564--575. } \examples{ \dontrun{ ##Data generated from a 2-component mixture of normals. set.seed(100) n <- 100 w <- rmultinom(n,1,c(.3,.7)) y <- sapply(1:n,function(i) w[1,i]*rnorm(1,-6,1) + w[2,i]*rnorm(1,0,1)) selection <- function(i,data,rep=30){ out <- replicate(rep,normalmixEM(data,epsilon=1e-06, k=i,maxit=5000),simplify=FALSE) counts <- lapply(1:rep,function(j) table(apply(out[[j]]$posterior,1, which.max))) counts.length <- sapply(counts, length) counts.min <- sapply(counts, min) counts.test <- (counts.length != i)|(counts.min < 5) if(sum(counts.test) > 0 & sum(counts.test) < rep) out <- out[!counts.test] l <- unlist(lapply(out, function(x) x$loglik)) tmp <- out[[which.max(l)]] } all.out <- lapply(2:5, selection, data = y, rep = 2) pmbs <- lapply(1:length(all.out), function(i) all.out[[i]]$post) plotly_mixturegram(y, pmbs, method = "pca", all.n = TRUE, id.con = NULL, score = 1, title = "Mixturegram (Well-Separated Data)") } } \keyword{file}mixtools/man/boot.se.Rd0000755000176200001440000000345514342153463014562 0ustar liggesusers\name{boot.se} \title{Performs Parametric Bootstrap for Standard Error Approximation} \alias{boot.se} \usage{ boot.se(em.fit, B = 100, arbmean = TRUE, arbvar = TRUE, N = NULL, ...) } \description{ Performs a parametric bootstrap by producing B bootstrap samples for the parameters in the specified mixture model. } \arguments{ \item{em.fit}{An object of class \code{mixEM}. The estimates produced in \code{em.fit} will be used as the parameters for the distribution from which we generate the bootstrap data.} \item{B}{The number of bootstrap samples to produce. The default is 100, but ideally, values of 1000 or more would be more acceptable.} \item{arbmean}{If FALSE, then a scale mixture analysis can be performed for \code{mvnormalmix}, \code{normalmix}, \code{regmix}, or \code{repnormmix}. The default is TRUE.} \item{arbvar}{If FALSE, then a location mixture analysis can be performed for \code{mvnormalmix}, \code{normalmix}, \code{regmix}, or \code{repnormmix}. The default is TRUE.} \item{N}{An n-vector of number of trials for the logistic regression type \code{logisregmix}. If NULL, then \code{N} is an n-vector of 1s for binary logistic regression.} \item{...}{Additional arguments passed to the various EM algorithms for the mixture of interest.} } \value{ \code{boot.se} returns a list with the bootstrap samples and standard errors for the mixture of interest. } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. } \examples{ ## Bootstrapping standard errors for a regression mixture case. data(NOdata) attach(NOdata) set.seed(100) em.out <- regmixEM(Equivalence, NO, arbvar = FALSE) out.bs <- boot.se(em.out, B = 10, arbvar = FALSE) out.bs } \keyword{file} mixtools/man/hmeEM.Rd0000755000176200001440000000627214342153463014204 0ustar liggesusers\name{hmeEM} \title{EM Algorithm for Mixtures-of-Experts} \alias{hmeEM} \usage{ hmeEM(y, x, lambda = NULL, beta = NULL, sigma = NULL, w = NULL, k = 2, addintercept = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) } \description{ Returns EM algorithm output for a mixture-of-experts model. Currently, this code only handles a 2-component mixture-of-experts, but will be extended to the general k-component hierarchical mixture-of-experts. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An nxp matrix of predictors. See \code{addintercept} below.} \item{lambda}{Initial value of mixing proportions, which are modeled as an inverse logit function of the predictors. Entries should sum to 1. If NULL, then \code{lambda} is taken as 1/\code{k} for each \code{x}.} \item{beta}{Initial value of \code{beta} parameters. Should be a pxk matrix, where p is the number of columns of x and k is number of components. If NULL, then \code{beta} has standard normal entries according to a binning method done on the data.} \item{sigma}{A vector of standard deviations. If NULL, then \eqn{1/\code{sigma}^2} has random standard exponential entries according to a binning method done on the data.} \item{w}{A p-vector of coefficients for the way the mixing proportions are modeled. See \code{lambda}.} \item{k}{Number of components. Currently, only \code{k}=2 is accepted.} \item{addintercept}{If TRUE, a column of ones is appended to the x matrix before the value of p is calculated.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{hmeEM} returns a list of class \code{mixEM} with items: \item{x}{The set of predictors (which includes a column of 1's if \code{addintercept} = TRUE).} \item{y}{The response values.} \item{w}{The final coefficients for the functional form of the mixing proportions.} \item{lambda}{An nxk matrix of the final mixing proportions.} \item{beta}{The final regression coefficients.} \item{sigma}{The final standard deviations. If \code{arbmean} = FALSE, then only the smallest standard deviation is returned. See \code{scale} below.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{regmixEM}} } \references{ Jacobs, R. A., Jordan, M. I., Nowlan, S. J. and Hinton, G. E. (1991) Adaptive Mixtures of Local Experts, \emph{Neural Computation} \bold{3(1)}, 79--87. McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. } \examples{ ## EM output for NOdata. data(NOdata) attach(NOdata) set.seed(100) em.out <- regmixEM(Equivalence, NO) hme.out <- hmeEM(Equivalence, NO, beta = em.out$beta) hme.out[3:7] } \keyword{file} mixtools/man/flaremixEM.Rd0000755000176200001440000000550214342153463015235 0ustar liggesusers\name{flaremixEM} \title{EM Algorithm for Mixtures of Regressions with Flare} \alias{flaremixEM} \usage{ flaremixEM(y, x, lambda = NULL, beta = NULL, sigma = NULL, alpha = NULL, nu = NULL, epsilon = 1e-04, maxit = 10000, verb = FALSE, restart = 50) } \description{ Returns output for 2-component mixture of regressions with flaring using an EM algorithm with one step of Newton-Raphson requiring an adaptive barrier for maximization of the objective function. A mixture of regressions with flare occurs when there appears to be a common regression relationship for the data, but the error terms have a mixture structure of one normal component and one exponential component. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An n-vector of predictor values. An intercept term will be added by default.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1.} \item{beta}{Initial value of \code{beta} parameters. Should be a 2x2 matrix where the columns correspond to the component.} \item{sigma}{A vector of standard deviations.} \item{alpha}{A scalar for the exponential component's rate.} \item{nu}{A vector specifying the barrier constants to use. The first barrier constant where the algorithm converges is used.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} \item{restart}{The number of times to restart the algorithm in case convergence is not attained. The default is 50.} } \value{ \code{flaremixEM} returns a list of class \code{mixEM} with items: \item{x}{The set of predictors (which includes a column of 1's).} \item{y}{The response values.} \item{posterior}{An nx2 matrix of posterior probabilities for observations.} \item{lambda}{The final mixing proportions.} \item{beta}{The final regression coefficients.} \item{sigma}{The final standard deviations.} \item{alpha}{The final exponential rate.} \item{loglik}{The final log-likelihood.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{regmixEM}} } \examples{ ## Simulation output. set.seed(100) j=1 while(j == 1){ x1 <- runif(30, 0, 10) x2 <- runif(20, 10, 20) x3 <- runif(30, 20, 30) y1 <- 3+4*x1+rnorm(30, sd = 1) y2 <- 3+4*x2+rexp(20, rate = .05) y3 <- 3+4*x3+rnorm(30, sd = 1) x <- c(x1, x2, x3) y <- c(y1, y2, y3) nu <- (1:30)/2 out <- try(flaremixEM(y, x, beta = c(3, 4), nu = nu, lambda = c(.75, .25), sigma = 1), silent = TRUE) if(any(class(out) == "try-error")){ j <- 1 } else j <- 2 } out[4:7] plot(x, y, pch = 19) abline(out$beta) } \keyword{file} mixtools/man/aug.x.Rd0000755000176200001440000000236314342153463014230 0ustar liggesusers\name{aug.x} \title{Augmented Predictor Function} \alias{aug.x} \usage{ aug.x(X, cp.locs, cp, delta = NULL) } \description{ Creates the augmented predictor matrix based on an appropriately defined changepoint structure. } \arguments{ \item{X}{The raw matrix of predictor values. Note that the raw data matrix should not include a columns of 1's.} \item{cp.locs}{The locations of the changepoints. The length of this vector must be equal to the sum of the entries of \code{cp}.} \item{cp}{A vector having length equal to the number of predictors.} \item{delta}{A vector to accommodate discontinuities. If NULL, then no discontinuities are included. Otherwise, this must be a vector of the same length as \code{cp.locs}.} } \value{ \code{aug.x} returns a matrix of the original matrix \code{X} with the predictor adjusted for changepoints and (optional) discontinuities. } \details{ This function is called by \code{segregmixEM} and the associated internal functions. } \seealso{ \code{\link{segregmixEM}} } \examples{ x <- matrix(1:30, nrow = 10) cp <- c(1, 3, 0) cp.locs <- c(3, 12, 14, 16) d <- rep(0, 4) x1 <- aug.x(x, cp.locs, cp, delta = NULL) x1 x2 <- aug.x(x, cp.locs, cp, delta = d) x2 } \keyword{internal} mixtools/man/plot.spEMN01.Rd0000755000176200001440000000250014342153463015277 0ustar liggesusers\name{plot.spEMN01} \alias{plot.spEMN01} \title{Plot mixture pdf for the semiparametric mixture model output by spEMsymlocN01} \description{Plot mixture density for the semiparametric mixture model output by spEMsymlocN01, with one component known and set to normal(0,1), and a symmetric nonparametric density with location parameter.} \usage{ \method{plot}{spEMN01}(x, bw = x$bandwidth, knownpdf = dnorm, add.plot = FALSE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{An object of class "spEMN01" as returned by spEMsymlocN01} \item{bw}{Bandwidth for weighted kernel density estimation.} \item{knownpdf}{The known density of component 1, default to \code{dnorm}.} \item{add.plot}{Set to TRUE to add to an existing plot.} \item{...}{further arguments passed to \code{plot} if \code{add.plot = FALSE}, and to \code{lines} if \code{add.plot = TRUE}.} } \value{A plot of the density of the mixture} \references{ \itemize{ \item Chauveau, D., Saby, N., Orton, T. G., Lemercier B., Walter, C. and Arrouys, D. Large-scale simultaneous hypothesis testing in soil monitoring: A semi-parametric mixture approach, preprint (2013). } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{spEMsymlocN01}}} % \keyword{file}mixtools/man/regmixEM.mixed.Rd0000755000176200001440000001272414342153463016032 0ustar liggesusers\name{regmixEM.mixed} \title{EM Algorithm for Mixtures of Regressions with Random Effects} \alias{regmixEM.mixed} \usage{ regmixEM.mixed(y, x, w = NULL, sigma = NULL, arb.sigma = TRUE, alpha = NULL, lambda = NULL, mu = NULL, rho = NULL, R = NULL, arb.R = TRUE, k = 2, ar.1 = FALSE, addintercept.fixed = FALSE, addintercept.random = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) } \description{ Returns EM algorithm output for mixtures of multiple regressions with random effects and an option to incorporate fixed effects and/or AR(1) errors. } \arguments{ \item{y}{A list of N response trajectories with (possibly) varying dimensions of length \eqn{n_i}.} \item{x}{A list of N design matrices of dimensions \eqn{(n_i)\times p}{(n_i) x p}. Each trajectory in y has its own design matrix.} \item{w}{A list of N known explanatory variables having dimensions \eqn{(n_i)\times q}{(n-1) x q}. If \code{mixed} = FALSE, then \code{w} is replaced by a list of N zeros.} \item{sigma}{A vector of standard deviations. If NULL, then \eqn{1/s^2} has random standard exponential entries according to a binning method done on the data.} \item{arb.sigma}{If TRUE, then \code{sigma} is k-dimensional. Else a common standard deviation is assumed.} \item{alpha}{A q-vector of unknown regression parameters for the fixed effects. If NULL and \code{mixed} = TRUE, then \code{alpha} is random from a normal distribution with mean and variance according to a binning method done on the data. If \code{mixed} = FALSE, then \code{alpha} = 0.} \item{lambda}{Initial value of mixing proportions for the assumed mixture structure on the regression coefficients. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and the number of components is determined by \code{mu}.} \item{mu}{A pxk matrix of the mean for the mixture components of the random regression coefficients. If NULL, then the columns of \code{mu} are random from a multivariate normal distribution with mean and variance determined by a binning method done on the data.} \item{rho}{An Nxk matrix giving initial values for the correlation term in an AR(1) process. If NULL, then these values are simulated from a uniform distribution on the interval (-1, 1).} \item{R}{A list of N pxp covariance matrices for the mixture components of the random regression coefficients. If NULL, then each matrix is random from a standard Wishart distribution according to a binning method done on the data.} \item{arb.R}{If TRUE, then \code{R} is a list of N pxp covariance matrices. Else, one common covariance matrix is assumed.} \item{k}{Number of components. Ignored unless \code{lambda} is NULL.} \item{ar.1}{If TRUE, then an AR(1) process on the error terms is included. The default is FALSE.} \item{addintercept.fixed}{If TRUE, a column of ones is appended to the matrices in w.} \item{addintercept.random}{If TRUE, a column of ones is appended to the matrices in x before p is calculated.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{regmixEM} returns a list of class \code{mixEM} with items: \item{x}{The predictor values corresponding to the random effects.} \item{y}{The response values.} \item{w}{The predictor values corresponding to the (optional) fixed effects.} \item{lambda}{The final mixing proportions.} \item{mu}{The final mean vectors.} \item{R}{The final covariance matrices.} \item{sigma}{The final component error standard deviations.} \item{alpha}{The final regression coefficients for the fixed effects.} \item{rho}{The final error correlation values if an AR(1) process is included.} \item{loglik}{The final log-likelihood.} \item{posterior.z}{An Nxk matrix of posterior membership probabilities.} \item{posterior.beta}{A list of N pxk matrices giving the posterior regression coefficient values.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{regmixEM}}, \code{\link{post.beta}} } \references{ Xu, W. and Hedeker, D. (2001) A Random-Effects Mixture Model for Classifying Treatment Response in Longitudinal Clinical Trials, \emph{Journal of Biopharmaceutical Statistics}, \bold{11(4)}, 253--273. Young, D. S. and Hunter, D. R. (2015) Random Effects Regression Mixtures for Analyzing Infant Habituation, \emph{Journal of Applied Statistics}, \bold{42(7)}, 1421--1441. } \examples{ ## EM output for simulated data from 2-component mixture of random effects. data(RanEffdata) set.seed(100) x <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 2:3], ncol = 2)) x <- x[1:20] y <- lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 1], ncol = 1)) y <- y[1:20] lambda <- c(0.45, 0.55) mu <- matrix(c(0, 4, 100, 12), 2, 2) sigma <- 2 R <- list(diag(1, 2), diag(1, 2)) em.out <- regmixEM.mixed(y, x, sigma = sigma, arb.sigma = FALSE, lambda = lambda, mu = mu, R = R, addintercept.random = FALSE, epsilon = 1e-02, verb = TRUE) em.out[4:10] } \keyword{file} mixtools/man/test.equality.mixed.Rd0000755000176200001440000000523314342153463017125 0ustar liggesusers\name{test.equality.mixed} \title{Performs Chi-Square Test for Mixed Effects Mixtures} \alias{test.equality.mixed} \usage{ test.equality.mixed(y, x, w=NULL, arb.R = TRUE, arb.sigma = FALSE, lambda = NULL, mu = NULL, sigma = NULL, R = NULL, alpha = NULL, ...) } \description{ Performs a likelihood ratio test of either common variance terms between the response trajectories in a mixture of random (or mixed) effects regressions or for common variance-covariance matrices for the random effects mixture distribution.} \arguments{ \item{y}{The responses for \code{regmixEM.mixed}.} \item{x}{The predictors for the random effects in \code{regmixEM.mixed}.} \item{w}{The predictors for the (optional) fixed effects in \code{regmixEM.mixed}.} \item{arb.R}{If FALSE, then a test for different variance-covariance matrices for the random effects mixture is performed.} \item{arb.sigma}{If FALSE, then a test for different variance terms between the response trajectories is performed.} \item{lambda}{A vector of mixing proportions (under the null hypothesis) with same purpose as outlined in \code{regmixEM.mixed}.} \item{mu}{A matrix of the means (under the null hypothesis) with same purpose as outlined in \code{regmixEM.mixed}.} \item{sigma}{A vector of standard deviations (under the null hypothesis) with same purpose as outlined in \code{regmixEM.mixed}.} \item{R}{A list of covariance matrices (under the null hypothesis) with same purpose as outlined in \code{regmixEM.mixed}.} \item{alpha}{An optional vector of fixed effects regression coefficients (under the null hypothesis) with same purpose as outlined in \code{regmixEM.mixed}.} \item{...}{Additional arguments passed to \code{regmixEM.mixed}.} } \value{ \code{test.equality.mixed} returns a list with the following items: \item{chi.sq}{The chi-squared test statistic.} \item{df}{The degrees of freedom for the chi-squared test statistic.} \item{p.value}{The p-value corresponding to this likelihood ratio test.} } \seealso{ \code{\link{test.equality}} } \examples{ ##Test of equal variances in the simulated data set. data(RanEffdata) set.seed(100) x<-lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 2:3], ncol = 2)) x<-x[1:15] y<-lapply(1:length(RanEffdata), function(i) matrix(RanEffdata[[i]][, 1], ncol = 1)) y<-y[1:15] out<-test.equality.mixed(y, x, arb.R = TRUE, arb.sigma = FALSE, epsilon = 1e-1, verb = TRUE, maxit = 50, addintercept.random = FALSE) out } \keyword{file} mixtools/man/dmvnorm.Rd0000755000176200001440000000235414342153463014670 0ustar liggesusers\name{dmvnorm} \alias{dmvnorm} \alias{logdmvnorm} \title{The Multivariate Normal Density} \description{ Density and log-density for the multivariate normal distribution with mean equal to \code{mu} and variance matrix equal to \code{sigma}. } \usage{ dmvnorm(y, mu=NULL, sigma=NULL) logdmvnorm(y, mu=NULL, sigma=NULL) } \arguments{ \item{y}{Either a \eqn{d} - vector or an \eqn{n\times d}{n x d} matrix, where \eqn{d} is the dimension of the normal distribution and \eqn{n} is the number of points at which the density is to be evaluated.} \item{mu}{\eqn{d} - vector: Mean of the normal distribution (or NULL uses the origin as default)} \item{sigma}{This \eqn{d\times d}{d x d} matrix is the variance matrix of the normal distribution (or NULL uses the identity matrix as default)} } \value{ \code{dmvnorm} gives the densities, while \code{logdmvnorm} gives the logarithm of the densities. } \details{ This code is written to be efficient, using the qr-decomposition of the covariance matrix (and using it only once, rather than recalculating it for both the determinant and the inverse of \code{sigma}). } \seealso{ \code{\link{qr}}, \code{\link{qr.solve}}, \code{\link{dnorm}}, \code{\link{rmvnorm}} } \keyword{distribution} mixtools/man/tauequivnormalmixEM.Rd0000644000176200001440000002055314342153463017220 0ustar liggesusers\name{tauequivnormalmixEM} \title{Special EM Algorithm for three-component tau equivalence model} \alias{tauequivnormalmixEM} \usage{ tauequivnormalmixEM (x, lambda = NULL, mu = NULL, sigma = NULL, k = 3, mean.constr = NULL, sd.constr = NULL, gparam = NULL, epsilon = 1e-08, maxit = 10000, maxrestarts=20, verb = FALSE, fast=FALSE, ECM = TRUE, arbmean = TRUE, arbvar = TRUE) } \description{ Return ECM algorithm output for a specific case of a three-component tau equivalence model } \details{ The \code{tauequivnormalmixEM} function is merely a wrapper for the \code{\link{normalmixMMlc}} function. # This is the standard EM algorithm for normal mixtures that maximizes # the conditional expected complete-data # log-likelihood at each M-step of the algorithm. # If desired, the # EM algorithm may be replaced by an ECM algorithm (see \code{ECM} argument) # that alternates between maximizing with respect to the \code{mu} # and \code{lambda} while holding \code{sigma} fixed, and maximizing with # respect to \code{sigma} and \code{lambda} while holding \code{mu} # fixed. In the case where \code{arbmean} is \code{FALSE} # and \code{arbvar} is \code{TRUE}, there is no closed-form EM algorithm, # so the ECM option is forced in this case. } \arguments{ \item{x}{A vector of length n consisting of the data, passed directly to \code{\link{normalmixMMlc}}.} \item{lambda}{Initial value of mixing proportions, passed directly to \code{\link{normalmixMMlc}}. Automatically repeated as necessary to produce a vector of length \code{k}, then normalized to sum to 1. If \code{NULL}, then \code{lambda} is random from a uniform Dirichlet distribution (i.e., its entries are uniform random and then it is normalized to sum to 1).} \item{mu}{Starting value of vector of component means for algorithm, passed directly to \code{\link{normalmixMMlc}}. If non-NULL and a vector, \code{k} is set to \code{length(mu)}. If NULL, then the initial value is randomly generated from a normal distribution with center(s) determined by binning the data.} \item{sigma}{Starting value of vector of component standard deviations for algorithm, passed directly to \code{\link{normalmixMMlc}}. Obsolete for linear constraint on the inverse variances, use \code{gparam} instead to specify a starting value. Note: This needs more precision} \item{k}{Number of components, passed directly to \code{\link{normalmixMMlc}}. Initial value ignored unless \code{mu} and \code{sigma} are both NULL. Also, initial value is ignored if \code{mean.constr} is NULL, since in that case we presume \code{k=3}.} \item{mean.constr}{If non-NULL, this parameter is passed directly to \code{\link{normalmixMMlc}} and both \code{mean.lincstr} and \code{var.lincstr} are passed as NULL to \code{\link{normalmixMMlc}}. If NULL, then it is assumed that \code{k=3} and the means must take the form \eqn{\alpha}, \eqn{\alpha-\delta}, and \eqn{\alpha+\delta} for unknown parameters \eqn{\alpha} and \eqn{\delta}. Furthermore, the reciprocal variances are assumed to be \eqn{\gamma_1+\gamma_2}, \eqn{\gamma_1}, and \eqn{\gamma_1} for unknown positive parameters \eqn{\gamma_1} and \eqn{\gamma_2}. These constraints are passed to the \code{\link{normalmixMMlc}} function using the \code{mean.lincstr} and \code{var.lincstr} arguments as shown in the examples for the \code{\link{normalmixMMlc}} help file.} \item{sd.constr}{Deprecated.} \item{gparam}{This argument is passed directly to \code{\link{normalmixMMlc}.} } \item{epsilon}{The convergence criterion. Convergence is declared when the change in the observed data log-likelihood increases by less than epsilon.} \item{maxit}{The maximum number of iterations.} \item{maxrestarts}{The maximum number of restarts allowed in case of a problem with the particular starting values chosen due to one of the variance estimates getting too small (each restart uses randomly chosen starting values). It is well-known that when each component of a normal mixture may have its own mean and variance, the likelihood has no maximizer; in such cases, we hope to find a "nice" local maximum with this algorithm instead, but occasionally the algorithm finds a "not nice" solution and one of the variances goes to zero, driving the likelihood to infinity.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} \item{fast}{If TRUE and k==2 and arbmean==TRUE, then use \code{\link{normalmixEM2comp}}, which is a much faster version of the EM algorithm for this case. This version is less protected against certain kinds of underflow that can cause numerical problems and it does not permit any restarts. If k>2, \code{fast} is ignored.} \item{ECM}{logical: Should this algorithm be an ECM algorithm in the sense of Meng and Rubin (1993)? If FALSE, the algorithm is a true EM algorithm; if TRUE, then every half-iteration alternately updates the means conditional on the variances or the variances conditional on the means, with an extra E-step in between these updates. For \code{tauequivnormalmixEM}, it must be TRUE.} \item{arbmean}{Deprecated.} \item{arbvar}{Deprecated.} } \value{ \code{normalmixEM} returns a list of class \code{mixEM} with items: \item{x}{The raw data.} \item{lambda}{The final mixing proportions.} \item{mu}{The final mean parameters.} \item{sigma}{The final standard deviation(s)} \item{scale}{Scale factor for the component standard deviations, if applicable.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood. This vector includes both the initial and the final values; thus, the number of iterations is one less than its length.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{normalmixMMlc}}, \code{\link{normalmixEM}}, \code{\link{mvnormalmixEM}}, \code{\link{normalmixEM2comp}} } \references{ \itemize{ \item Thomas, H., Lohaus, A., and Domsch, H. (2011) Stable Unstable Reliability Theory, \emph{British Journal of Mathematical and Statistical Psychology} 65(2): 201-221. \item Meng, X.-L. and Rubin, D. B. (1993) Maximum Likelihood Estimation Via the ECM Algorithm: A General Framework, \emph{Biometrika} 80(2): 267-278. } } \examples{ ## Analyzing synthetic data as in the tau equivalent model ## From Thomas et al (2011), see also Chauveau and Hunter (2013) ## a 3-component mixture of normals with linear constraints. lbd <- c(0.6,0.3,0.1); m <- length(lbd) sigma <- sig0 <- sqrt(c(1,9,9)) # means constaints mu = M beta M <- matrix(c(1,1,1,0,1,-1), 3, 2) beta <- c(1,5) # unknown constained mean mu0 <- mu <- as.vector(M \%*\% beta) # linear constraint on the inverse variances pi = A.g A <- matrix(c(1,1,1,0,1,0), m, 2, byrow=TRUE) iv0 <- 1/(sig0^2) g0 <- c(iv0[2],iv0[1] - iv0[2]) # gamma^0 init # simulation and EM fits set.seed(40); n=100; x <- rnormmix(n,lbd,mu,sigma) s <- normalmixEM(x,mu=mu0,sigma=sig0,maxit=2000) # plain EM # EM with var and mean linear constraints sc <- normalmixMMlc(x, lambda=lbd, mu=mu0, sigma=sig0, mean.lincstr=M, var.lincstr=A, gparam=g0) # Using tauequivnormalmixEM function to call normalmixMMlc tau <- tauequivnormalmixEM (x, lambda=lbd, mu=mu0, gparam=g0) # plot and compare both estimates dnormmixt <- function(t, lam, mu, sig){ m <- length(lam); f <- 0 for (j in 1:m) f <- f + lam[j]*dnorm(t,mean=mu[j],sd=sig[j]) f} t <- seq(min(x)-2, max(x)+2, len=200) hist(x, freq=FALSE, col="lightgrey", ylim=c(0,0.3), ylab="density",main="") lines(t, dnormmixt(t, lbd, mu, sigma), col="darkgrey", lwd=2) # true lines(t, dnormmixt(t, s$lambda, s$mu, s$sigma), lty=2) lines(t, dnormmixt(t, sc$lambda, sc$mu, sc$sigma), col=1, lty=3) lines(t, dnormmixt(t, tau$lambda, tau$mu, tau$sigma), col=2, lty=4) legend("topleft", c("true","plain EM","constr EM", "Tau Equiv"), col=c("darkgrey",1,1,2), lty=c(1,2,3,4), lwd=c(2,1,1,1)) } \keyword{file} mixtools/man/rexpmix.Rd0000644000176200001440000000216314342153463014675 0ustar liggesusers\name{rexpmix} \title{Simulate from Mixtures of Exponentials} \alias{rexpmix} \usage{ rexpmix(n, lambda = 1, rate = 1) } \description{ Simulate from a mixture of univariate exponential distributions. } \arguments{ \item{n}{Number of cases to simulate.} \item{lambda}{Vector of mixture probabilities, with length equal to \eqn{m}, the desired number of components (subpopulations). This is assumed to sum to 1.} \item{rate}{Vector of component rates.} } \value{ \code{rexpmix} returns an \eqn{n}-vector sampled from an \eqn{m}-component mixture of univariate exponential distributions. } %%\details{This function simply calls \code{\link{sample}} and \code{\link{rexp}}.} \seealso{ \code{\link{rnormmix}}, \code{\link{rmvnormmix}} for Gaussian mixtures, \code{\link{rweibullmix}} for mixture of Weibull distributions. } \examples{ ## Generate data from a 2-component mixture of exponentials. n=300 # sample size m=2 # nb components lambda=c(1/3, 2/3); rate = c(1,1/10) # parameters set.seed(1234) x <- rexpmix(n, lambda, rate) # iid ~ exp mixture ## histogram of the simulated data. hist(x, col=8) } \keyword{file} mixtools/man/normalmixEM.Rd0000755000176200001440000001624414342153463015441 0ustar liggesusers\name{normalmixEM} \title{EM Algorithm for Mixtures of Univariate Normals} \alias{normalmixEM} \usage{ normalmixEM(x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, mean.constr = NULL, sd.constr = NULL, epsilon = 1e-08, maxit = 1000, maxrestarts = 20, verb = FALSE, fast = FALSE, ECM = FALSE, arbmean = TRUE, arbvar = TRUE) } \description{ Return EM algorithm output for mixtures of normal distributions. } \details{ This is the standard EM algorithm for normal mixtures that maximizes the conditional expected complete-data log-likelihood at each M-step of the algorithm. If desired, the EM algorithm may be replaced by an ECM algorithm (see \code{ECM} argument) that alternates between maximizing with respect to the \code{mu} and \code{lambda} while holding \code{sigma} fixed, and maximizing with respect to \code{sigma} and \code{lambda} while holding \code{mu} fixed. In the case where \code{arbmean} is \code{FALSE} and \code{arbvar} is \code{TRUE}, there is no closed-form EM algorithm, so the ECM option is forced in this case. } \arguments{ \item{x}{A vector of length n consisting of the data.} \item{lambda}{Initial value of mixing proportions. Automatically repeated as necessary to produce a vector of length \code{k}, then normalized to sum to 1. If \code{NULL}, then \code{lambda} is random from a uniform Dirichlet distribution (i.e., its entries are uniform random and then it is normalized to sum to 1).} \item{mu}{Starting value of vector of component means. If non-NULL and a scalar, \code{arbmean} is set to \code{FALSE}. If non-NULL and a vector, \code{k} is set to \code{length(mu)}. If NULL, then the initial value is randomly generated from a normal distribution with center(s) determined by binning the data.} \item{sigma}{Starting value of vector of component standard deviations for algorithm. If non-NULL and a scalar, \code{arbvar} is set to \code{FALSE}. If non-NULL and a vector, \code{arbvar} is set to \code{TRUE} and \code{k} is set to \code{length(sigma)}. If NULL, then the initial value is the reciprocal of the square root of a vector of random exponential-distribution values whose means are determined according to a binning method done on the data.} \item{k}{Number of components. Initial value ignored unless \code{mu} and \code{sigma} are both NULL.} \item{mean.constr}{Equality constraints on the mean parameters, given as a vector of length \code{k}. Each vector entry helps specify the constraints, if any, on the corresponding mean parameter: If \code{NA}, the corresponding parameter is unconstrained. If numeric, the corresponding parameter is fixed at that value. If a character string consisting of a single character preceded by a coefficient, such as \code{"0.5a"} or \code{"-b"}, all parameters using the same single character in their constraints will fix these parameters equal to the coefficient times some the same free parameter. For instance, if \code{mean.constr = c(NA, 0, "a", "-a")}, then the first mean parameter is unconstrained, the second is fixed at zero, and the third and forth are constrained to be equal and opposite in sign.} \item{sd.constr}{Equality constraints on the standard deviation parameters. See \code{mean.constr}.} \item{epsilon}{The convergence criterion. Convergence is declared when the change in the observed data log-likelihood increases by less than epsilon.} \item{maxit}{The maximum number of iterations.} \item{maxrestarts}{The maximum number of restarts allowed in case of a problem with the particular starting values chosen due to one of the variance estimates getting too small (each restart uses randomly chosen starting values). It is well-known that when each component of a normal mixture may have its own mean and variance, the likelihood has no maximizer; in such cases, we hope to find a "nice" local maximum with this algorithm instead, but occasionally the algorithm finds a "not nice" solution and one of the variances goes to zero, driving the likelihood to infinity.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} \item{fast}{If TRUE and k==2 and arbmean==TRUE, then use \code{\link{normalmixEM2comp}}, which is a much faster version of the EM algorithm for this case. This version is less protected against certain kinds of underflow that can cause numerical problems and it does not permit any restarts. If k>2, \code{fast} is ignored.} \item{ECM}{logical: Should this algorithm be an ECM algorithm in the sense of Meng and Rubin (1993)? If FALSE, the algorithm is a true EM algorithm; if TRUE, then every half-iteration alternately updates the means conditional on the variances or the variances conditional on the means, with an extra E-step in between these updates.} \item{arbmean}{If TRUE, then the component densities are allowed to have different \code{mu}s. If FALSE, then a scale mixture will be fit. Initial value ignored unless \code{mu} is NULL.} \item{arbvar}{If TRUE, then the component densities are allowed to have different \code{sigma}s. If FALSE, then a location mixture will be fit. Initial value ignored unless \code{sigma} is NULL.} } \value{ \code{normalmixEM} returns a list of class \code{mixEM} with items: \item{x}{The raw data.} \item{lambda}{The final mixing proportions.} \item{mu}{The final mean parameters.} \item{sigma}{The final standard deviations. If \code{arbmean} = FALSE, then only the smallest standard deviation is returned. See \code{scale} below.} \item{scale}{If \code{arbmean} = FALSE, then the scale factor for the component standard deviations is returned. Otherwise, this is omitted from the output.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood. This vector includes both the initial and the final values; thus, the number of iterations is one less than its length.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{mvnormalmixEM}}, \code{\link{normalmixEM2comp}}, \code{\link{normalmixMMlc}}, \code{\link{spEMsymloc}} } \references{ \itemize{ \item McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. \item Meng, X.-L. and Rubin, D. B. (1993) Maximum Likelihood Estimation Via the ECM Algorithm: A General Framework, \emph{Biometrika} 80(2): 267-278. \item Benaglia, T., Chauveau, D., Hunter, D. R., and Young, D. mixtools: An R package for analyzing finite mixture models. Journal of Statistical Software, 32(6):1-29, 2009. } } \examples{ ##Analyzing the Old Faithful geyser data with a 2-component mixture of normals. data(faithful) attach(faithful) set.seed(100) system.time(out<-normalmixEM(waiting, arbvar = FALSE, epsilon = 1e-03)) out system.time(out2<-normalmixEM(waiting, arbvar = FALSE, epsilon = 1e-03, fast=TRUE)) out2 # same thing but much faster } \keyword{file} mixtools/man/plotspRMM.Rd0000644000176200001440000000307414343144402015072 0ustar liggesusers\name{plotspRMM} \alias{plotspRMM} %- Also NEED an '\alias' for EACH other topic documented here. \title{Plot output from Stochastic EM algorithm for semiparametric scaled mixture of censored data } \description{Function for plotting various results from an object returned by \code{\link{spRMM_SEM}}, a Stochastic EM algorithm for semiparametric scaled mixture of randomly right censored lifetime data. Four plots of sequences of estimates along iterations, survival and density estimates (see reference below). } \usage{ plotspRMM(sem, tmax = NULL) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{sem}{An object returned by \code{\link{spRMM_SEM}}.} \item{tmax}{The max time for \eqn{x} axis, set to some default value if \code{NULL}.} } \value{The four plots returned} \seealso{ Related functions: \code{\link{spRMM_SEM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{expRMM_EM}}, \code{\link{weibullRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \examples{ # See example(spRMM_SEM) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{file} mixtools/man/plotly_weibullRMM.Rd0000644000176200001440000000632414343144365016630 0ustar liggesusers\name{plotly_weibullRMM} \alias{plotly_weibullRMM} %- Also NEED an '\alias' for EACH other topic documented here. \title{Plot sequences from the Stochastic EM algorithm for mixture of Weibull using \code{plotly} } \description{This is an updated version of \code{plotweibullRMM} function by using \code{plotly} function. For technical details, please refer to \code{\link{plotweibullRMM}}. } \usage{ plotly_weibullRMM(a, title=NULL, rowstyle=TRUE, subtitle=NULL, width = 3 , col = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "Iterations" , xlab.size = 15 , xtick.size = 15, ylab = "Estimates" , ylab.size = 15 , ytick.size = 15, legend.size = 15) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{a}{An object returned by \code{\link{weibullRMM_SEM}}.} \item{title}{The title of the plot, set to some default value if \code{NULL}.} \item{rowstyle}{Window organization, for plots in rows (the default) or columns.} \item{subtitle}{A subtitle for the plot, set to some default value if \code{NULL}.} \item{width}{Line width.} \item{col}{Color of lines. Number of colors specified needs to be consistent with number of components.} \item{title.size}{Size of the main title.} \item{title.x}{Horsizontal position of the main title.} \item{title.y}{Vertical posotion of the main title.} \item{xlab}{Label of X-axis.} \item{xlab.size}{Size of the lable of X-axis.} \item{xtick.size}{Size of tick lables of X-axis.} \item{ylab}{Label of Y-axis.} \item{ylab.size}{Size of the lable of Y-axis.} \item{ytick.size}{Size of tick lables of Y-axis.} \item{legend.size}{Size of legend.} } \value{The plot returned.} \seealso{ Related functions: \code{\link{weibullRMM_SEM}}, \code{\link{summary.mixEM}}, \code{\link{plotweibullRMM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{expRMM_EM}}, \code{\link{spRMM_SEM}} . } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \examples{ n = 500 # sample size m = 2 # nb components lambda=c(0.4, 0.6) shape <- c(0.5,5); scale <- c(1,20) # model parameters set.seed(321) x <- rweibullmix(n, lambda, shape, scale) # iid ~ weibull mixture cs=runif(n,0,max(x)+10) # iid censoring times t <- apply(cbind(x,cs),1,min) # censored observations d <- 1*(x <= cs) # censoring indicator ## set arbitrary or "reasonable" (e.g., data-driven) initial values l0 <- rep(1/m,m); sh0 <- c(1, 2); sc0 <- c(2,10) # Stochastic EM algorithm a <- weibullRMM_SEM(t, d, lambda = l0, shape = sh0, scale = sc0, maxit = 200) summary(a) # Parameters estimates etc plotly_weibullRMM(a , legend.size = 20) # plot of St-EM sequences %%\dontrun{ %%} } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{file} mixtools/man/rmvnormmix.Rd0000755000176200001440000000450114342153463015420 0ustar liggesusers\name{rmvnormmix} \title{Simulate from Multivariate (repeated measures) Mixtures of Normals} \alias{normmixrm.sim} \alias{rmvnormmix} \usage{ rmvnormmix(n, lambda=1, mu=0, sigma=1) } \description{ Simulate from a mixture of multivariate zero-correlation normal distributions } \arguments{ \item{n}{Number of cases to simulate.} \item{lambda}{Vector of mixture probabilities with length equal to \eqn{m}, the desired number of components. This is assumed to sum to 1; if not, it is normalized.} \item{mu}{Matrix of means of dimensions \eqn{m\times r}{m x r}, where \eqn{m} is the number of components (subpopulations) and \eqn{r} is the number of coordinates (repeated measurements) per case. Note: \code{mu} is automatically coerced to a matrix with \eqn{m} rows even if it is not given in this form, which can lead to unexpected behavior in some cases.} \item{sigma}{Matrix of standard deviations, same dimensions as \code{mu}. The coordinates within a case are independent, conditional on the mixture component. (There is marginal correlation among the coordinates, but this is due to the mixture structure only.) Note: \code{sigma} is automatically coerced to a matrix with \eqn{m} rows even if it is not given in this form, which can lead to unexpected behavior in some cases.} } \details{ It is possible to generate univariate standard normal random variables using the default values (but why bother?). The case of conditionally iid coordinates is covered by the situation in which all columns in mu and sigma are identical. } \value{ \code{rmvnormmix} returns an \eqn{n\times r}{n x r} matrix in which each row is a sample from one of the components of a mixture of zero-correlation multivariate normals. The mixture structure induces nonzero correlations among the coordinates. } \seealso{ \code{\link{rnormmix}} } \examples{ ##Generate data from a 2-component mixture of trivariate normals. set.seed(100) n <- 200 lambda <- rep(1, 2)/2 mu <- matrix(2*(1:6), 2, 3) sigma <- matrix(1,2,3) mydata<-rmvnormmix(n, lambda, mu, sigma) ## Now check to see if we can estimate mixture densities well: title <- paste("Does this resemble N(", mu[1,], ",1) and N(", mu[2,],",1)?", sep="") plot(npEM(mydata, 2), title=title) } \keyword{file} mixtools/man/regmixEM.Rd0000755000176200001440000000732514342153463014726 0ustar liggesusers\name{regmixEM} \title{EM Algorithm for Mixtures of Regressions} \alias{regmixEM} \usage{ regmixEM(y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) } \description{ Returns EM algorithm output for mixtures of multiple regressions with arbitrarily many components. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An nxp matrix of predictors. See \code{addintercept} below.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and number of components is determined by \code{beta}.} \item{beta}{Initial value of \code{beta} parameters. Should be a pxk matrix, where p is the number of columns of x and k is number of components. If NULL, then \code{beta} has standard normal entries according to a binning method done on the data. If both \code{lambda} and \code{beta} are NULL, then number of components is determined by \code{sigma}.} \item{sigma}{A vector of standard deviations. If NULL, then 1/\code{sigma}^2 has random standard exponential entries according to a binning method done on the data. If \code{lambda}, \code{beta}, and \code{sigma} are NULL, then number of components is determined by \code{k}.} \item{k}{Number of components. Ignored unless all of \code{lambda}, \code{beta}, and \code{sigma} are NULL.} \item{addintercept}{If TRUE, a column of ones is appended to the x matrix before the value of p is calculated.} \item{arbmean}{If TRUE, each mixture component is assumed to have a different set of regression coefficients (i.e., the \code{beta}s).} \item{arbvar}{If TRUE, each mixture component is assumed to have a different \code{sigma}.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{regmixEM} returns a list of class \code{mixEM} with items: \item{x}{The set of predictors (which includes a column of 1's if \code{addintercept} = TRUE).} \item{y}{The response values.} \item{lambda}{The final mixing proportions.} \item{beta}{The final regression coefficients.} \item{sigma}{The final standard deviations. If \code{arbmean} = FALSE, then only the smallest standard deviation is returned. See \code{scale} below.} \item{scale}{If \code{arbmean} = FALSE, then the scale factor for the component standard deviations is returned. Otherwise, this is omitted from the output.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{regcr}}, \code{\link{regmixMH}} } \references{ de Veaux, R. D. (1989), Mixtures of Linear Regressions, \emph{Computational Statistics and Data Analysis} 8, 227-245. Hurn, M., Justel, A. and Robert, C. P. (2003) Estimating Mixtures of Regressions, \emph{Journal of Computational and Graphical Statistics} \bold{12(1)}, 55--79. McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. } \examples{ ## EM output for NOdata. data(NOdata) attach(NOdata) set.seed(100) em.out <- regmixEM(Equivalence, NO, verb = TRUE, epsilon = 1e-04) em.out[3:6] } \keyword{file} mixtools/man/print.mvnpEM.Rd0000755000176200001440000000211014342153463015531 0ustar liggesusers\name{print.mvnpEM} \alias{print.mvnpEM} \title{Printing of Results from the mvnpEM Algorithm Output} \usage{ \method{print}{mvnpEM}(x, \dots) } \arguments{ \item{x}{an object of class \code{mvnpEM} such as a result of a call to \code{\link{mvnpEM}}} \item{\dots}{Additional arguments to \code{\link{print}}} } \description{ \code{\link[base]{print}} method for class \code{mvnpEM}. } \details{ \code{print.mvnpEM} prints the elements of an \code{mvnpEM} object without printing the data or the posterior probabilities. (These may still be accessed as \code{x$data} and \code{x$posteriors}.) } \value{ \code{print.mvnpEM} returns (invisibly) the full value of \code{x} itself, including the \code{data} and \code{posteriors} elements. } \seealso{ \code{\link{mvnpEM}}, \code{\link{plot.mvnpEM}} \code{\link{summary.mvnpEM}} } \examples{ # Example as in Chauveau and Hoang (2015) with 6 coordinates \dontrun{ m=2; r=6; blockid <-c(1,1,2,2,3,3) # 3 bivariate blocks # generate some data x ... a <- mvnpEM(x, mu0=2, blockid, samebw=F) # adaptive bandwidth print(a)} } \keyword{file} mixtools/man/mixturegram.Rd0000755000176200001440000000742414342153463015555 0ustar liggesusers\name{mixturegram} \title{Mixturegrams} \alias{mixturegram} \usage{ mixturegram(data, pmbs, method = c("pca", "kpca", "lda"), all.n = FALSE, id.con = NULL, score = 1, iter.max = 50, nstart = 25, ...) } \description{ Construct a mixturegram for determining an apporpriate number of components. } \arguments{ \item{data}{The data, which must either be a vector or a matrix. If a matrix, then the rows correspond to the observations.} \item{pmbs}{A list of length (K-1) such that each element is an nxk matrix of the posterior membership probabilities. These are obtained from each of the "best" estimated k-component mixture models, k = 2,...,K. } \item{method}{The dimension reduction method used. \code{method = "pca"} implements principal components analysis. \code{method = "kpca"} implements kernel principal components analysis. \code{method = "lda"} implements reduced rank linear discriminant analysis. } \item{all.n}{A logical specifying whether the mixturegram should plot the profiles of all observations (\code{TRUE}) or just the K-profile summaries (\code{FALSE}). The default is \code{FALSE}.} \item{id.con}{An argument that allows one to impose some sort of (meaningful) identifiability constraint so that the mixture components are in some sort of comparable order between mixture models with different numbers of components. If \code{NULL}, then the components are ordered by the component means for univariate data or ordered by the first dimension of the component means for multivariate data.} \item{score}{The value for the specified dimension reduction technique's score, which is used for constructing the mixturegram. By default, this value is \code{1}, which is the value that will typically be used. Larger values will result in more variability displayed on the mixturegram. Note that the largest value that can be calculated at each value of k>1 on the mixturegram is p+k-1, where p is the number of columns of \code{data}. } \item{iter.max}{The maximum number of iterations allowed for the k-means clustering algorithm, which is passed to the \code{\link{kmeans}} function. The default is \code{50}. } \item{nstart}{The number of random sets chosen based on k centers, which is passed to the \code{\link{kmeans}} function. The default is \code{25}.} \item{...}{Additional arguments that can be passed to the underlying \code{\link{plot}} function.} } \value{ \code{mixturegram} returns a mixturegram where the profiles are plotted over component values of k = 1,...,K. } \seealso{ \code{\link{boot.comp}} } \references{ Young, D. S., Ke, C., and Zeng, X. (2018) The Mixturegram: A Visualization Tool for Assessing the Number of Components in Finite Mixture Models, \emph{Journal of Computational and Graphical Statistics}, \bold{27(3)}, 564--575. } \examples{ ##Data generated from a 2-component mixture of normals. set.seed(100) n <- 100 w <- rmultinom(n,1,c(.3,.7)) y <- sapply(1:n,function(i) w[1,i]*rnorm(1,-6,1) + w[2,i]*rnorm(1,0,1)) selection <- function(i,data,rep=30){ out <- replicate(rep,normalmixEM(data,epsilon=1e-06, k=i,maxit=5000),simplify=FALSE) counts <- lapply(1:rep,function(j) table(apply(out[[j]]$posterior,1, which.max))) counts.length <- sapply(counts, length) counts.min <- sapply(counts, min) counts.test <- (counts.length != i)|(counts.min < 5) if(sum(counts.test) > 0 & sum(counts.test) < rep) out <- out[!counts.test] l <- unlist(lapply(out, function(x) x$loglik)) tmp <- out[[which.max(l)]] } all.out <- lapply(2:5, selection, data = y, rep = 2) pmbs <- lapply(1:length(all.out), function(i) all.out[[i]]$post) mixturegram(y, pmbs, method = "pca", all.n = FALSE, id.con = NULL, score = 1, main = "Mixturegram (Well-Separated Data)") } \keyword{file} mixtools/man/npMSL.Rd0000755000176200001440000001661514342153463014204 0ustar liggesusers\name{npMSL} \title{Nonparametric EM-like Algorithm for Mixtures of Independent Repeated Measurements - Maximum Smoothed Likelihood version} \alias{npMSL} \usage{ npMSL(x, mu0, blockid = 1:ncol(x), bw = bw.nrd0(as.vector(as.matrix(x))), samebw = TRUE, bwmethod = "S", h = bw, eps = 1e-8, maxiter=500, bwiter = maxiter, nbfold = NULL, ngrid=200, post=NULL, verb = TRUE) } \description{ Returns nonparametric Smoothed Likelihood algorithm output (Levine et al, 2011) for mixtures of multivariate (repeated measures) data where the coordinates of a row (case) in the data matrix are assumed to be independent, conditional on the mixture component (subpopulation) from which they are drawn. } \arguments{ \item{x}{An \eqn{n\times r}{n x r} matrix of data. Each of the \eqn{n} rows is a case, and each case has \eqn{r} repeated measurements. These measurements are assumed to be conditionally independent, conditional on the mixture component (subpopulation) from which the case is drawn.} \item{mu0}{Either an \eqn{m\times r}{m x r} matrix specifying the initial centers for the \link{kmeans} function, or an integer \eqn{m} specifying the number of initial centers, which are then choosen randomly in \link{kmeans}} \item{blockid}{A vector of length \eqn{r} identifying coordinates (columns of \code{x}) that are assumed to be identically distributed (i.e., in the same block). For instance, the default has all distinct elements, indicating that no two coordinates are assumed identically distributed and thus a separate set of \eqn{m} density estimates is produced for each column of \eqn{x}. On the other hand, if \code{blockid=rep(1,ncol(x))}, then the coordinates in each row are assumed conditionally i.i.d.} \item{bw}{Bandwidth for density estimation, equal to the standard deviation of the kernel density. By default, a simplistic application of the default \code{\link{bw.nrd0}} bandwidth used by \code{\link{density}} to the entire dataset.} \item{samebw}{Logical: If \code{TRUE}, use the same bandwidth for each iteration and for each component and block. If \code{FALSE}, use a separate bandwidth for each component and block, and update this bandwidth at each iteration of the algorithm until \code{bwiter} is reached (see below). Two adaptation methods are provided, see \code{bwmethod} below.} \item{bwmethod}{Define the adaptive bandwidth strategy when \code{samebw = FALSE}, in which case the bandwidth depends on each component, block, and iteration of the algorithm. If set to "S" (the default), adaptation is done using a suitably modified \code{\link{bw.nrd0}} method as described in Benaglia et al (2011). If set to "CV", an adaptive \eqn{k}-fold Cross Validation method is applied, as described in Chauveau et al (2014), where \code{nbfold} is the number of subsamples. This corresponds to a Leave-\eqn{[n/nbfold]}-Out CV. } \item{h}{Alternative way to specify the bandwidth, to provide backward compatibility.} \item{eps}{Tolerance limit for declaring algorithm convergence. Convergence is declared whenever the maximum change in any coordinate of the \code{lambda} vector (of mixing proportion estimates) does not exceed \code{eps}.} \item{maxiter}{The maximum number of iterations allowed, convergence may be declared before \code{maxiter} iterations (see \code{eps} above).} \item{bwiter}{The maximum number of iterations allowed for adaptive bandwidth stage, when \code{samebw = FALSE}. If set to \code{0}, then the initial bandwidth matrix is used without adaptation.} \item{nbfold}{A parameter passed to the internal function \code{wbs.kCV}, which controls the weighted bandwidth selection by k-fold cross-validation.} \item{ngrid}{Number of points in the discretization of the intervals over which are approximated the (univariate) integrals for non linear smoothing of the log-densities, as required in the E step of the npMSL algorithm, see Levine et al (2011).} \item{post}{If non-NULL, an \eqn{n\times m}{n x m} matrix specifying the initial posterior probability vectors for each of the observations, i.e., the initial values to start the EM-like algorithm.} \item{verb}{If TRUE, print updates for every iteration of the algorithm as it runs} } \value{ \code{npMSL} returns a list of class \code{npEM} with the following items: \item{data}{The raw data (an \eqn{n\times r}{n x r} matrix).} \item{posteriors}{An \eqn{n\times m}{n x m} matrix of posterior probabilities for observation.} \item{bandwidth}{If \code{samebw==TRUE}, same as the \code{bw} input argument; otherwise, value of \code{bw} matrix at final iteration. This information is needed by any method that produces density estimates from the output.} \item{blockid}{Same as the \code{blockid} input argument, but recoded to have positive integer values. Also needed by any method that produces density estimates from the output.} \item{lambda}{The sequence of mixing proportions over iterations.} \item{lambdahat}{The final mixing proportions.} \item{loglik}{The sequence of log-likelihoods over iterations.} \item{f}{An array of size \eqn{ngrid \times m \times l}{ngrid x m x l}, returning last values of density for component \eqn{j} and block \eqn{k} over \code{grid} points.} \item{meanNaN}{Average number of \code{NaN} that occured over iterations (for internal testing and control purpose).} \item{meanUdfl}{Average number of "underflow" that occured over iterations (for internal testing and control purpose).} } \seealso{ \code{\link{npEM}}, \code{\link{plot.npEM}}, \code{\link{normmixrm.sim}}, \code{\link{spEMsymloc}}, \code{\link{spEM}}, \code{\link{plotseq.npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526. \item Benaglia, T., Chauveau, D. and Hunter, D.R. (2011), Bandwidth Selection in an EM-like algorithm for nonparametric multivariate mixtures. Nonparametric Statistics and Mixture Models: A Festschrift in Honor of Thomas P. Hettmansperger. World Scientific Publishing Co., pages 15-27. \item Chauveau D., Hunter D. R. and Levine M. (2014), Semi-Parametric Estimation for Conditional Independence Multivariate Finite Mixture Models. Preprint (under revision). \item Levine, M., Hunter, D. and Chauveau, D. (2011), Maximum Smoothed Likelihood for Multivariate Mixtures, Biometrika 98(2): 403-416. } } \examples{ ## Examine and plot water-level task data set. ## Block structure pairing clock angles that are directly opposite one ## another (1:00 with 7:00, 2:00 with 8:00, etc.) set.seed(111) # Ensure that results are exactly reproducible data(Waterdata) blockid <- c(4,3,2,1,3,4,1,2) # see Benaglia et al (2009a) \dontrun{ a <- npEM(Waterdata[,3:10], mu0=3, blockid=blockid, bw=4) # npEM solution b <- npMSL(Waterdata[,3:10], mu0=3, blockid=blockid, bw=4) # smoothed version # Comparisons on the 4 default plots, one for each block par(mfrow=c(2,2)) for (l in 1:4){ plot(a, blocks=l, breaks=5*(0:37)-92.5, xlim=c(-90,90), xaxt="n",ylim=c(0,.035), xlab="") plot(b, blocks=l, hist=FALSE, newplot=FALSE, addlegend=FALSE, lty=2, dens.col=1) axis(1, at=30*(1:7)-120, cex.axis=1) legend("topleft",c("npMSL"),lty=2, lwd=2)} } } \keyword{file} mixtools/man/spregmix.Rd0000755000176200001440000001321214342153463015037 0ustar liggesusers\name{spregmix} \title{EM-like Algorithm for Semiparametric Mixtures of Regressions} \alias{spregmix} \usage{ spregmix(lmformula, bw = NULL, constbw = FALSE, bwmult = 0.9, z.hat = NULL, symm = TRUE, betamethod = "LS", m = ifelse(is.null(z.hat), 2, ncol(z.hat)), epsilon = 1e-04, maxit = 1000, verbose = FALSE, \dots) } \description{ Returns parameter estimates for finite mixtures of linear regressions with unspecified error structure. Based on Hunter and Young (2012). } \arguments{ \item{lmformula}{Formula for a linear model, in the same format used by \code{\link{lm}}. Additional parameters may be passed to \code{\link{lm}} via the \code{...} argument.} \item{bw}{Initial bandwidth value. If NULL, this will be chosen automatically by the algorithm.} \item{constbw}{Logical: If TRUE, the bandwidth is held constant throughout the algorithm; if FALSE, it adapts at each iteration according to the rules given in Hunter and Young (2012).} \item{bwmult}{ Whenever it is updated automatically, the bandwidth is equal to \code{bwmult} divided by the fifth root of \eqn{n} times the smaller of s and IQR/1.34, where s and IQR are estimates of the standard deviation and interquartile range of the residuals, as explained in Hunter and Young (2012). The value of 0.9 gives the rule of Silverman (1986) and the value of 1.06 gives the rule of Scott (1992). Larger values lead to greater smoothing, whereas smaller values lead to less smoothing. } \item{z.hat}{Initial nxm matrix of posterior probabilities. If NULL, this is initialized randomly. As long as a parametric estimation method like least squares is used to estimate \code{beta} in each M-step, the \code{z.hat} values are the only values necessary to begin the EM iterations.} \item{symm}{Logical: If TRUE, the error density is assumed symmetric about zero. If FALSE, it is not. WARNING: If FALSE, the intercept parameter is not uniquely identifiable if it is included in the linear model.} \item{betamethod}{Method of calculating beta coefficients in the M-step. Current possible values are "LS" for least-squares; "L1" for least absolute deviation; "NP" for fully nonparametric; and "transition" for a transition from least squares to fully nonparametric. If something other than these four possibilities is used, then "NP" is assumed. For details of these methods, see Hunter and Young (2012).} \item{m}{Number of components in the mixture.} \item{epsilon}{Convergence is declared if the largest change in any lambda or beta coordinate is smaller than \code{epsilon}.} \item{maxit}{The maximum number of iterations; if convergence is never declared based on comparison with \code{epsilon}, then the algorithm stops after \code{maxit} iterations.} \item{verbose}{Logical: If TRUE, then various updates are printed during each iteration of the algorithm.} \item{\dots}{Additional parameters passed to the \code{\link{model.frame}} and \code{\link{model.matrix}} functions, which are used to obtain the response and predictor of the regression.} } \value{ \code{regmixEM} returns a list of class \code{npEM} with items: \item{x}{The set of predictors (which includes a column of 1's if \code{addintercept} = TRUE).} \item{y}{The response values.} \item{lambda}{The mixing proportions for every iteration in the form of a matrix with m columns and (#iterations) rows} \item{beta}{The final regression coefficients.} \item{posterior}{An nxm matrix of posterior probabilities for observations.} \item{np.stdev}{Nonparametric estimate of the standard deviation, as given in Hunter and Young (2012)} \item{bandwidth}{Final value of the bandwidth} \item{density.x}{Points at which the error density is estimated} \item{density.y}{Values of the error density at the points \code{density.x}} \item{symmetric}{Logical: Was the error density assumed symmetric?} \item{loglik}{A quantity similar to a log-likelihood, computed just like a standard loglikelihood would be, conditional on the component density functions being equal to the final density estimates.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{regmixEM}}, \code{\link{spEMsymloc}}, \code{\link{lm}} } \references{ Hunter, D. R. and Young, D. S. (2012) Semi-parametric Mixtures of Regressions, Journal of Nonparametric Statistics 24(1): 19-38. Scott, D. W. (1992) \emph{Multivariate Density Estimation}, John Wiley & Sons Inc., New York. Silverman, B. W. (1986). \emph{Density Estimation for Statistics and Data Analysis}, Chapman & Hall, London. } \examples{ data(tonedata) ## By default, the bandwidth will adapt and the error density is assumed symmetric set.seed(100) a=spregmix(tuned~stretchratio, bw=.2, data=tonedata, verb=TRUE) ## Look at the sp mixreg solution: plot(tonedata) abline(a=a$beta[1,1],b=a$beta[2,1], col=2) abline(a=a$beta[1,2],b=a$beta[2,2], col=3) ## Look at the nonparametric KD-based estimate of the error density, ## constrained to be zero-symmetric: plot(xx<-a$density.x, yy<-a$density.y, type="l") ## Compare to a normal density with mean 0 and NP-estimated stdev: z <- seq(min(xx), max(xx), len=200) lines(z, dnorm(z, sd=sqrt((a$np.stdev)^2+a$bandwidth^2)), col=2, lty=2) # Add bandwidth^2 to variance estimate to get estimated var of KDE ## Now add the sp mixreg estimate without assuming symmetric errors: b=spregmix(tuned~stretchratio, bw=.2, , symm=FALSE, data=tonedata, verb=TRUE) lines(b$density.x, b$density.y, col=3) } \keyword{file} mixtools/man/try.flare.Rd0000755000176200001440000000413314342153463015111 0ustar liggesusers\name{try.flare} \title{Mixtures of Regressions with Flare MM Algorithm} \alias{try.flare} \usage{ try.flare(y, x, lambda = NULL, beta = NULL, sigma = NULL, alpha = NULL, nu = 1, epsilon = 1e-04, maxit = 10000, verb = FALSE, restart = 50) } \description{ The function which \code{flaremixEM} actually calls. This only allows one barrier constant to be inputted at a time. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An n-vector of predictor values. An intercept term will be added by default.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1.} \item{beta}{Initial value of \code{beta} parameters. Should be a 2x2 matrix where the columns corresond to the component.} \item{sigma}{A vector of standard deviations.} \item{alpha}{A scalar for the exponential component's rate.} \item{nu}{A scalar specifying the barrier constant to use.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} \item{restart}{The number of times to restart the algorithm in case convergence is not attained. The default is 50.} } \value{ \code{try.flare} returns a list of class \code{mixEM} with items: \item{x}{The set of predictors (which includes a column of 1's).} \item{y}{The response values.} \item{posterior}{An nx2 matrix of posterior probabilities for observations.} \item{lambda}{The final mixing proportions.} \item{beta}{The final regression coefficients.} \item{sigma}{The final standard deviations.} \item{alpha}{The final exponential rate.} \item{loglik}{The final log-likelihood.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{flaremixEM}} } \details{ This usually is not called by the user. The user will likely want \code{flaremixEM}, which also has an example to demonstrate this algorithm. } \keyword{internal} mixtools/man/spRMM_SEM.Rd0000644000176200001440000001041214343144436014700 0ustar liggesusers\name{spRMM_SEM} \title{Stochastic EM algorithm for semiparametric scaled mixture of censored data} \alias{spRMM_SEM} \usage{ spRMM_SEM(t, d = NULL, lambda = NULL, scaling = NULL, centers = 2, kernelft = triang_wkde, bw = rep(bw.nrd0(t),length(t)), averaged = TRUE, epsilon = 1e-08, maxit = 100, batchsize = 1, verb = FALSE) } \description{ Stochastic EM algorithm for semiparametric scaled mixture for randomly right censored data. } \arguments{ \item{t}{A vector of \eqn{n}{n} real positive lifetime (possibly censored) durations. If \code{d} is not \code{NULL} then a vector of random censoring times \code{c} occurred, so that \eqn{x= min(x,c)} and \eqn{d = I(x <= c)}.} \item{d}{The vector of censoring indication, where 1 means observed lifetime data, and 0 means censored lifetime data.} \item{lambda}{Initial value of mixing proportions. If \code{NULL}, then \code{lambda} is set to \code{rep(1/k,k)}.} \item{scaling}{Initial value of scaling between components, set to 1 if \code{NULL}.} \item{centers}{initial centers for initial call to kmeans for initialization.} \item{kernelft}{.} \item{bw}{Bandwidth in the kernel hazard estimates.} \item{averaged}{averaged.} \item{epsilon}{Tolerance limit.} \item{maxit}{The number of iterations allowed.} \item{batchsize}{The batchsize (see reference below).} \item{verb}{If TRUE, print updates for every iteration of the algorithm as it runs} } \value{ \code{spRMM_SEM} returns a list of class \code{"spRMM"} with the following items: \item{t}{The input data.} \item{d}{The input censoring indicator.} \item{lambda}{The estimates for the mixing proportions.} \item{scaling}{The estimates for the components scaling.} \item{posterior}{An \eqn{n\times k}{n x 2} matrix of posterior probabilities for observation, after convergence of the algorithm.} \item{loglik}{The (pseudo) log-likelihood value at convergence of the algorithm.} \item{all.loglik}{The sequence of log-likelihood values over iterations.} \item{all.lambda}{The sequence of mixing proportions over iterations.} \item{all.scaling}{The sequence of scaling parameter over iterations.} \item{meanpost}{Posterior probabilities averaged over iterations.} \item{survival}{Kaplan-Meier last iteration estimate (a \code{stepfun} object).} \item{hazard}{Hazard rate last iteration estimate evaluated at \code{final.t}.} \item{final.t}{Last iteration unscaled sample (see reference).} \item{s.hat}{Kaplan-Meier average estimate.} \item{t.hat}{Ordered unscaled sample, for testing purpose.} \item{avg.od}{For testing purpose only.} \item{hazard.hat}{Hazard rate average estimate on \code{t.hat}.} \item{batch.t}{Batch sample (not ordered), see reference.} \item{batch.d}{Associated event indicators just \code{rep(d,batchsize)}, for testing purpose.} \item{sumNaNs}{Internal control of numerical stability.} \item{ft}{A character vector giving the name of the function.} } \seealso{ Related functions: \code{\link{plotspRMM}}, \code{\link{summary.spRMM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{expRMM_EM}}, \code{\link{weibullRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} \examples{ \dontrun{ n=500 # sample size m=2 # nb components lambda=c(0.4, 0.6) # parameters meanlog=3; sdlog=0.5; scale=0.1 set.seed(12) # simulate a scaled mixture of lognormals x <- rlnormscalemix(n, lambda, meanlog, sdlog, scale) cs=runif(n,20,max(x)+400) # Censoring (uniform) and incomplete data t <- apply(cbind(x,cs),1,min) d <- 1*(x <= cs) tauxc <- 100*round( 1-mean(d),3) cat(tauxc, "percents of data censored.\n") c0 <- c(25, 180) # data-driven initial centers (visible modes) sc0 <- 25/180 # and scaling s <- spRMM_SEM(t, d, scaling = sc0, centers = c0, bw = 15, maxit = 100) plotspRMM(s) # default summary(s) # S3 method for class "spRMM" } } \keyword{file} mixtools/man/wkde.Rd0000755000176200001440000000355214342153463014141 0ustar liggesusers\name{wkde} \title{Weighted Univariate (Normal) Kernel Density Estimate} \alias{wkde} \alias{wkde.symm} \usage{ wkde(x, u=x, w=rep(1, length(x)), bw=bw.nrd0(as.vector(x)), sym=FALSE) } \description{ Evaluates a weighted kernel density estimate, using a Gaussian kernel, at a specified vector of points. } \arguments{ \item{x}{Data} \item{u}{Points at which density is to be estimated} \item{w}{Weights (same length as \code{x})} \item{bw}{Bandwidth} \item{sym}{Logical: Symmetrize about zero?} } \value{A vector of the same length as \code{u} } \seealso{ \code{\link{npEM}}, \code{\link{ise.npEM}} } \references{ \itemize{ \item Benaglia, T., Chauveau, D., and Hunter, D. R. (2009), An EM-like algorithm for semi- and non-parametric estimation in multivariate mixtures, Journal of Computational and Graphical Statistics, 18, 505-526. \item Benaglia, T., Chauveau, D., Hunter, D. R., and Young, D. (2009), mixtools: An R package for analyzing finite mixture models. Journal of Statistical Software, 32(6):1-29. } } \examples{ # Mixture with mv gaussian model set.seed(100) m <- 2 # no. of components r <- 3 # no. of repeated measures (coordinates) lambda <- c(0.4, 0.6) mu <- matrix(c(0, 0, 0, 4, 4, 6), m, r, byrow=TRUE) # means sigma <- matrix(rep(1, 6), m, r, byrow=TRUE) # stdevs centers <- matrix(c(0, 0, 0, 4, 4, 4), 2, 3, byrow=TRUE) # initial centers for est blockid = c(1,1,2) # block structure of coordinates n = 100 x <- rmvnormmix(n, lambda, mu, sigma) # simulated data a <- npEM(x, centers, blockid, eps=1e-8, verb=FALSE) par(mfrow=c(2,2)) u <- seq(min(x), max(x), len=200) for(j in 1:2) { for(b in 1:2) { xx <- as.vector(x[,a$blockid==b]) wts <- rep(a$post[,j], length.out=length(xx)) bw <- a$bandwidth title <- paste("j =", j, "and b =", b) plot(u, wkde(xx, u, wts, bw), type="l", main=title) } } } \keyword{file} mixtools/man/expRMM_EM.Rd0000644000176200001440000000716414343144253014736 0ustar liggesusers\name{expRMM_EM} \title{EM algorithm for Reliability Mixture Models (RMM) with right Censoring} \alias{expRMM_EM} \usage{ expRMM_EM(x, d=NULL, lambda = NULL, rate = NULL, k = 2, complete = "tdz", epsilon = 1e-08, maxit = 1000, verb = FALSE) } \description{ Parametric EM algorithm for univariate finite mixture of exponentials distributions with randomly right censored data. } \arguments{ \item{x}{A vector of \eqn{n}{n} real positive lifetime (possibly censored) durations. If \code{d} is not \code{NULL} then a vector of random censoring times \code{c} occurred, so that \eqn{x= min(x,c)} and \eqn{d = I(x <= c)}.} \item{d}{The vector of censoring indication, where 1 means observed lifetime data, and 0 means censored lifetime data.} \item{lambda}{Initial value of mixing proportions. If \code{NULL}, then \code{lambda} is set to \code{rep(1/k,k)}.} \item{rate}{Initial value of component exponential rates, all set to 1 if \code{NULL}.} \item{k}{Number of components of the mixture.} \item{complete}{Nature of complete data involved within the EM machinery, can be "tdz" for \code{(t,d,z)} (the default), or "xz" for \code{(x,z)} (see Bordes L. and Chauveau D. (2016) reference below).} \item{epsilon}{Tolerance limit for declaring algorithm convergence based on the change between two consecutive iterations.} \item{maxit}{The maximum number of iterations allowed, convergence may be declared before \code{maxit} iterations (see \code{epsilon} above).} \item{verb}{If TRUE, print updates for every iteration of the algorithm as it runs} } \value{ \code{expRMM_EM} returns a list of class "mixEM" with the following items: \item{x}{The input data.} \item{d}{The input censoring indicator.} \item{lambda}{The estimates for the mixing proportions.} \item{rate}{The estimates for the component rates.} \item{loglik}{The log-likelihood value at convergence of the algorithm.} \item{posterior}{An \eqn{n\times k}{n x k} matrix of posterior probabilities for observation, after convergence of the algorithm.} \item{all.loglik}{The sequence of log-likelihoods over iterations.} \item{all.lambda}{The sequence of mixing proportions over iterations.} \item{all.rate}{The sequence of component rates over iterations.} \item{ft}{A character vector giving the name of the function.} } \seealso{ Related functions: \code{\link{plotexpRMM}}, \code{\link{summary.mixEM}}. Other models and algorithms for censored lifetime data: \code{\link{weibullRMM_SEM}}, \code{\link{spRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} \examples{ n <- 300 # sample size m <- 2 # number of mixture components lambda <- c(1/3,1-1/3); rate <- c(1,1/10) # mixture parameters set.seed(1234) x <- rexpmix(n, lambda, rate) # iid ~ exponential mixture cs <- runif(n,0,max(x)) # Censoring (uniform) and incomplete data t <- apply(cbind(x,cs),1,min) # observed or censored data d <- 1*(x <= cs) # censoring indicator ###### EM for RMM, exponential lifetimes l0 <- rep(1/m,m); r0 <- c(1, 0.5) # "arbitrary" initial values a <- expRMM_EM(t, d, lambda = l0, rate = r0, k = m) summary(a) # EM estimates etc plotexpRMM(a, lwd=2) # default plot of EM sequences plot(a, which=2) # or equivalently, S3 method for "mixEM" object %%\dontrun{ %%} } \keyword{file} mixtools/man/plotly_spRMM.Rd0000644000176200001440000000532714343144347015611 0ustar liggesusers\name{plotly_spRMM} \alias{plotly_spRMM} %- Also NEED an '\alias' for EACH other topic documented here. \title{Plot output from Stochastic EM algorithm for semiparametric scaled mixture of censored data using \code{plotly}. } \description{This is an updated version of \code{plotspRMM} function. For technical details, please refer to \code{\link{plotspRMM}. }} \usage{ plotly_spRMM(sem, tmax = NULL, width = 3 , col = '#1f77b4', cex = 3, title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab.size = 15 , xtick.size=15 , ylab.size = 15 , ytick.size=15) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{sem}{An object returned by \code{\link{spRMM_SEM}}.} \item{tmax}{The max time for \eqn{x} axis, set to some default value if \code{NULL}.} \item{width}{Width of lines.} \item{col}{Color of lines.} \item{cex}{Size of dots.} \item{title.size}{Size of the main title.} \item{title.x}{Horizontal position of the main title.} \item{title.y}{Vertical position of the main title.} \item{xlab.size}{Size of the label of X-axis.} \item{xtick.size}{Size of the tick of X-axis.} \item{ylab.size}{Size of the label of Y-axis.} \item{ytick.size}{Size of the tick of Y-axis.} } \value{The four plots returned.} \seealso{ Related functions: \code{\link{spRMM_SEM}} , \code{\link{plotspRMM}}. Other models and algorithms for censored lifetime data (name convention is model_algorithm): \code{\link{expRMM_EM}}, \code{\link{weibullRMM_SEM}}. } \references{ \itemize{ \item Bordes, L., and Chauveau, D. (2016), Stochastic EM algorithms for parametric and semiparametric mixture models for right-censored lifetime data, Computational Statistics, Volume 31, Issue 4, pages 1513-1538. \url{https://link.springer.com/article/10.1007/s00180-016-0661-7} } } \author{Didier Chauveau} %% ~Make other sections like Warning with \section{Warning }{....} ~ \examples{ \dontrun{ n=500 # sample size m=2 # nb components lambda=c(0.4, 0.6) # parameters meanlog=3; sdlog=0.5; scale=0.1 set.seed(12) # simulate a scaled mixture of lognormals x <- rlnormscalemix(n, lambda, meanlog, sdlog, scale) cs=runif(n,20,max(x)+400) # Censoring (uniform) and incomplete data t <- apply(cbind(x,cs),1,min) d <- 1*(x <= cs) tauxc <- 100*round( 1-mean(d),3) cat(tauxc, "percents of data censored.\n") c0 <- c(25, 180) # data-driven initial centers (visible modes) sc0 <- 25/180 # and scaling s <- spRMM_SEM(t, d, scaling = sc0, centers = c0, bw = 15, maxit = 100) plotly_spRMM(s) # default summary(s) # S3 method for class "spRMM" } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{file} mixtools/man/gammamixEM.Rd0000755000176200001440000000715014342153463015227 0ustar liggesusers\name{gammamixEM} \title{EM Algorithm for Mixtures of Gamma Distributions} \alias{gammamixEM} \usage{ gammamixEM(x, lambda = NULL, alpha = NULL, beta = NULL, k = 2, mom.start = TRUE, fix.alpha = FALSE, epsilon = 1e-08, maxit = 1000, maxrestarts = 20, verb = FALSE) } \description{ Return EM algorithm output for mixtures of gamma distributions. } \arguments{ \item{x}{A vector of length n consisting of the data.} \item{lambda}{Initial value of mixing proportions. If \code{NULL}, then \code{lambda} is random from a uniform Dirichlet distribution (i.e., its entries are uniform random and then it is normalized to sum to 1).} \item{alpha}{Starting value of vector of component shape parameters. If non-NULL, \code{alpha} must be of length \code{k} if allowing different component shape parameters, or a single value if \code{fix.alpha = TRUE}. If NULL, then the initial value is estimated by partitioning the data into \code{k} regions (with \code{lambda} determining the proportion of values in each region) and then calculating the method of moments estimates.} \item{beta}{Starting value of vector of component scale parameters. If non-NULL and a vector, \code{k} is set to \code{length(beta)}. If NULL, then the initial value is estimated the same method described for \code{alpha}.} \item{k}{Number of components. Initial value ignored unless \code{alpha} and \code{beta} are both NULL.} \item{mom.start}{Logical to indicate if a method of moments starting value strategy should be implemented. If \code{TRUE}, then only unspecified starting values will be generated according to this strategy.} \item{epsilon}{The convergence criterion. Convergence is declared when the change in the observed data log-likelihood increases by less than epsilon.} \item{fix.alpha}{Logical to indicate if the components should have a common shape parameter \code{alpha} estimated. The default is \code{FALSE}.} \item{maxit}{The maximum number of iterations.} \item{maxrestarts}{The maximum number of restarts allowed in case of a problem with the particular starting values chosen (each restart uses randomly chosen starting values).} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{gammamixEM} returns a list of class \code{mixEM} with items: \item{x}{The raw data.} \item{lambda}{The final mixing proportions.} \item{gamma.pars}{A 2xk matrix where each column provides the component estimates of \code{alpha} and \code{beta}.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood. This vector includes both the initial and the final values; thus, the number of iterations is one less than its length.} \item{ft}{A character vector giving the name of the function.} } \references{ Dempster, A. P., Laird, N. M., and Rubin, D. B. (1977) Maximum Likelihood From Incomplete Data Via the EM Algorithm, \emph{Journal of the Royal Statistical Society, Series B}, \bold{39(1)}, 1--38. Young, D. S., Chen, X., Hewage, D., and Nilo-Poyanco, R. (2019) Finite Mixture-of-Gamma Distributions: Estimation, Inference, and Model-Based Clustering, \emph{Advances in Data Analysis and Classification}, \bold{13(4)}, 1053--1082. } \examples{ ##Analyzing a 3-component mixture of gammas. set.seed(100) x <- c(rgamma(200, shape = 0.2, scale = 14), rgamma(200, shape = 32, scale = 10), rgamma(200, shape = 5, scale = 6)) out <- gammamixEM(x, lambda = c(1, 1, 1)/3, verb = TRUE) out[2:4] } \keyword{file} mixtools/man/logisregmixEM.Rd0000755000176200001440000000700014342153463015752 0ustar liggesusers\name{logisregmixEM} \title{EM Algorithm for Mixtures of Logistic Regressions} \alias{logisregmixEM} \usage{ logisregmixEM(y, x, N = NULL, lambda = NULL, beta = NULL, k = 2, addintercept = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) } \description{ Returns EM algorithm output for mixtures of logistic regressions with arbitrarily many components. } \arguments{ \item{y}{An n-vector of successes out of N trials.} \item{x}{An nxp matrix of predictors. See \code{addintercept} below.} \item{N}{An n-vector of number of trials for the logistic regression. If NULL, then \code{N} is an n-vector of 1s for binary logistic regression.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and number of components is determined by \code{beta}.} \item{beta}{Initial value of \code{beta} parameters. Should be a pxk matrix, where p is the number of columns of x and k is number of components. If NULL, then \code{beta} is generated by binning the data into k bins and using \code{glm} on the values in each of the bins. If both \code{lambda} and \code{beta} are NULL, then number of components is determined by \code{k}.} \item{k}{Number of components. Ignored unless \code{lambda} and \code{beta} are both NULL.} \item{addintercept}{If TRUE, a column of ones is appended to the x matrix before the value of p is calculated.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{logisregmixEM} returns a list of class \code{mixEM} with items: \item{x}{The predictor values.} \item{y}{The response values.} \item{lambda}{The final mixing proportions.} \item{beta}{The final logistic regression coefficients.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{poisregmixEM}} } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. } \examples{ ## EM output for data generated from a 2-component logistic regression model. set.seed(100) beta <- matrix(c(1, .5, 2, -.8), 2, 2) x <- runif(50, 0, 10) x1 <- cbind(1, x) xbeta <- x1\%*\%beta N <- ceiling(runif(50, 50, 75)) w <- rbinom(50, 1, .3) y <- w*rbinom(50, size = N, prob = (1/(1+exp(-xbeta[, 1]))))+ (1-w)*rbinom(50, size = N, prob = (1/(1+exp(-xbeta[, 2])))) out.1 <- logisregmixEM(y, x, N, verb = TRUE, epsilon = 1e-01) out.1 ## EM output for data generated from a 2-component binary logistic regression model. beta <- matrix(c(-10, .1, 20, -.1), 2, 2) x <- runif(500, 50, 250) x1 <- cbind(1, x) xbeta <- x1\%*\%beta w <- rbinom(500, 1, .3) y <- w*rbinom(500, size = 1, prob = (1/(1+exp(-xbeta[, 1]))))+ (1-w)*rbinom(500, size = 1, prob = (1/(1+exp(-xbeta[, 2])))) out.2 <- logisregmixEM(y, x, beta = beta, lambda = c(.3, .7), verb = TRUE, epsilon = 1e-01) out.2 } \keyword{file} mixtools/man/segregmixEM.Rd0000755000176200001440000001747014342153463015427 0ustar liggesusers\name{segregmixEM} \title{ECM Algorithm for Mixtures of Regressions with Changepoints} \alias{segregmixEM} \alias{regmixEM.chgpt} \usage{ segregmixEM(y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, seg.Z, psi, psi.locs = NULL, delta = NULL, epsilon = 1e-08, maxit = 10000, verb = FALSE, max.restarts = 15) } \description{ Returns ECM algorithm output for mixtures of multiple regressions with changepoints and arbitrarily many components. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An nxp matrix of predictors. Note that this model assumes the presence of an intercept.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and the number of components is determined by \code{beta}.} \item{beta}{Initial value of \code{beta} parameters. This is a list of length \code{k} such that each element must contain a vector having length consistent with the defined changepoint structure. See \code{seg.Z}, \code{psi}, and \code{psi.loc} below. If NULL, then \code{beta} has standard normal entries according to a binning method done on the data. If both \code{lambda} and \code{beta} are NULL, then number of components is determined by \code{sigma}.} \item{sigma}{A vector of standard deviations. If NULL, then 1/\code{sigma}^2 has random standard exponential entries according to a binning method done on the data. If \code{lambda}, \code{beta}, and \code{sigma} are NULL, then number of components is determined by \code{k}.} \item{k}{Number of components. Ignored unless all of \code{lambda}, \code{beta}, and \code{sigma} are NULL.} \item{seg.Z}{A list of length \code{k} whose elements are right-hand side formulas, which are additive linear models of the predictors that have changepoints in their respective components. See below for more details.} \item{psi}{A kxp matrix specifying the number of changepoints for each predictor in each component. See below for more details.} \item{psi.locs}{A list of length \code{k} that has initial estimates for the changepoint locations. Each element of the list must have length equal to the number of chanegpoints specified in the corresponding row of the \code{psi} matrix. For components with no changepoints, simply set that element equal to NULL. See below for more details.} \item{delta}{An optional list of values quantifying the amount of separation at each changepoint if assuming discontinuities at the changepoints. This has the same dimensions as \code{psi.locs}.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} \item{max.restarts}{The number of times to try restarting the ECM algorithm if estimation problems occur - such as choice of poor initial values or a poorly chosen changepoint structure.} } \value{ \code{segregmixEM} returns a list of class \code{segregmixEM} with items: \item{x}{The set of predictors.} \item{y}{The response values.} \item{lambda}{The final mixing proportions.} \item{beta}{The final regression coefficients.} \item{sigma}{The final standard deviations.} \item{seg.Z}{The list of right-hand side formulas as defined by the user.} \item{psi.locs}{A list of length k with the final estimates for the changepoint locations.} \item{delta}{A list of the delta values that were optionally specified by the user.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \details{ \code{seg.Z} is defined as a list of right-hand side linear model formulas that are used to identify which predictors have changepoints in each component. For example, suppose you have a dataframe with three predictors: \code{V1}, \code{V2}, \code{V3}. Suppose now that you wish to model a 3-component mixture of regressions with changepoints structure such that the first component has changepoints in V1 and V2, the second component has changepoints in \code{V3}, and the third component has no changepoints. Then you would define \code{seg.Z = list(~V1+V2, ~V3, NULL)}. Note that you MUST place the variables in order with respect to how they appear in the predictor matrix \code{x}. \code{psi} is a kxp matrix specifying the number of changepoints for each predictor in each component. For the example given above, suppose there are three changepoints for \code{V1}, two changepoints for \code{V2}, and four changepoints for \code{V3}. Then you would define \code{psi = rbind(c(3, 2, 0), c(0, 0, 4), c(0, 0, 0))}. \code{psi.locs} is a list of length k whose elements give the initial locations of the changepoints for each component. Each element of the list must have length equal to the total number of changepoints for that component's regression equation. For the example given above, in component 1, assume that the three changepoints for \code{V1} are at 3, 7, and 10 and the two changepoints for \code{V1} are at 5, 20, and 30. In component 2, assume that the four changepoints for \code{V3} are at 2, 4, 6, and 8. Then you would define \code{psi.locs = list(c(3, 7, 10, 5, 20, 30), c(2, 4, 6, 8), NULL)}. Note that the order of the changepoints is determined by first sorting the predictors by how they appear in the formulas in \code{seg.Z} and then sorting in increasing order within each predictor. } \seealso{ \code{\link{regmixEM}} } \references{ Young, D. S. (2014) Mixtures of Regressions with Changepoints, \emph{Statistics and Computing}, \bold{24(2)}, 265--281. } \note{ As of version 0.4.6, this more general function has replaced the now defunct \code{regmixEM.chgpt} and associated internal functions. } \examples{ \dontrun{ ## Simulated example. set.seed(100) x <- 1:20 y1 <- 3 + x + rnorm(20) y2 <- 3 - x - 5*(x - 15)*(x > 15) + rnorm(20) y <- c(y1, y2) x <- c(x, x) set.seed(100) be <- list(c(3, -1, -5), c(3, 1)) s <- c(1, 1) psi.locs <- list(comp.1 = list(x = 15), comp.2 = NULL) out <- segregmixEM(y, cbind(1,x), verb = TRUE, k = 2, beta = be, sigma = s, lambda = c(1, 1)/2, seg.Z = list(~x, NULL), psi = rbind(1, 0), psi.locs = psi.locs, epsilon = 0.9) z <- seq(0, 21, len = 40) plot(x, y, col = apply(out$post, 1, which.max) + 1, pch = 19, cex.lab = 1.4, cex = 1.4) b <- out$beta d <- out$psi.locs lines(z, b[[1]][1] + b[[1]][2] * z + b[[1]][3] * (z - d[[1]][[1]]) * (z > d[[1]][[1]]) , col = 2, lwd = 2) lines(z, b[[2]][1] + b[[2]][2] * z, col = 3, lwd = 2) abline(v = out$psi.locs[[1]][1], col = 2, lty = 2) } \dontrun{ ## Example using the NOdata. data(NOdata) attach(NOdata) set.seed(100) be <- list(c(1.30, -0.13, 0.08), c(0.56, 0.09)) s <- c(0.02, 0.04) psi.locs <- list(comp.1 = list(NO = 1.57), comp.2 = NULL) out <- segregmixEM(Equivalence, cbind(NO), verb = TRUE, k = 2, beta = be, sigma = s, lambda = c(1, 1)/2, seg.Z = list(~NO, NULL), psi = rbind(1, 0), psi.locs = psi.locs, epsilon = 0.1) z <- seq(0, 5, len = 1000) plot(NOdata, col = apply(out$post, 1, which.max) + 1, pch = 19, cex.lab = 1.4, cex = 1.4, ylab = "Equivalence Ratio") b <- out$beta d <- out$psi.locs lines(z, b[[1]][1] + b[[1]][2] * z + b[[1]][3] * (z - d[[1]][[1]]) * (z > d[[1]][[1]]) , col = 2, lwd = 2) lines(z, b[[2]][1] + b[[2]][2] * z, col = 3, lwd = 2) abline(v = out$psi.locs[[1]][1], col = 2, lty = 2) detach(NOdata) } } \keyword{file} mixtools/man/RodFramedata.Rd0000755000176200001440000000226514342153463015540 0ustar liggesusers\name{RodFramedata} \docType{data} \title{Rod and Frame Task Data Set} \alias{RodFramedata} \usage{ data(RodFramedata) } \description{ This data set involves assessing children longitudinally at 6 age points from ages 4 through 18 years for the rod and frame task. This task sits the child in a darkened room in front of a luminous square frame tilted at 28 degrees on its axis to the left or right. Centered inside the frame was a luminous rod also tilted 28 degrees to the left or right. The child's task was to adjust the rod to the vertical position and the absolute deviation from the vertical (in degrees) was the measured response. } \format{This data frame consists of 140 children (the rows). Column 1 is the subject number and column 2 is the sex (0=MALE and 1=FEMALE). Columns 3 through 26 give the 8 responses at each of the ages 4, 5, and 7. Columns 27 through 56 give the 10 responses at each of the ages 11, 14, and 18. A value of 99 denotes missing data. } \source{ Thomas, H. and Dahlin, M. P. (2005) Individual Development and Latent Groups: Analytical Tools for Interpreting Heterogeneity, \emph{Developmental Review} \bold{25(2)}, 133--154. } \keyword{datasets} mixtools/man/regmixEM.lambda.Rd0000755000176200001440000000675214342153463016150 0ustar liggesusers\name{regmixEM.lambda} \title{EM Algorithm for Mixtures of Regressions with Local Lambda Estimates} \alias{regmixEM.lambda} \usage{ regmixEM.lambda(y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-8, maxit = 10000, verb = FALSE) } \description{ Returns output for one step of an EM algorithm output for mixtures of multiple regressions where the mixing proportions are estimated locally. } \arguments{ \item{y}{An n-vector of response values.} \item{x}{An nxp matrix of predictors. See \code{addintercept} below.} \item{lambda}{An nxk matrix of initial local values of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is simply one over the number of components.} \item{beta}{Initial value of \code{beta} parameters. Should be a pxk matrix, where p is the number of columns of x and k is number of components. If NULL, then \code{beta} has uniform standard normal entries. If both \code{lambda} and \code{beta} are NULL, then number of components is determined by \code{sigma}.} \item{sigma}{k-vector of initial global values of standard deviations. If NULL, then \eqn{1/\code{sigma}^2} has random standard exponential entries. If \code{lambda}, \code{beta}, and \code{sigma} are NULL, then number of components is determined by \code{k}.} \item{k}{The number of components. Ignored unless all of \code{lambda}, \code{beta}, and \code{sigma} are NULL.} \item{addintercept}{If TRUE, a column of ones is appended to the x matrix before the value of p is calculated.} \item{arbmean}{If TRUE, each mixture component is assumed to have a different set of regression coefficients (i.e., the \code{beta}s).} \item{arbvar}{If TRUE, each mixture component is assumed to have a different \code{sigma}.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{regmixEM.lambda} returns a list of class \code{mixEM} with items: \item{x}{The set of predictors (which includes a column of 1's if \code{addintercept} = TRUE).} \item{y}{The response values.} \item{lambda}{The inputted mixing proportions.} \item{beta}{The final regression coefficients.} \item{sigma}{The final standard deviations. If \code{arbmean} = FALSE, then only the smallest standard deviation is returned. See \code{scale} below.} \item{scale}{If \code{arbmean} = FALSE, then the scale factor for the component standard deviations is returned. Otherwise, this is omitted from the output.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \details{ Primarily used within \code{regmixEM.loc}. } \seealso{ \code{\link{regmixEM.loc}} } \examples{ ## Compare a 2-component and 3-component fit to NOdata. data(NOdata) attach(NOdata) set.seed(100) out1 <- regmixEM.lambda(Equivalence, NO) out2 <- regmixEM.lambda(Equivalence, NO, k = 3) c(out1$loglik, out2$loglik) } \keyword{file} mixtools/man/compCDF.Rd0000755000176200001440000000447514342153463014467 0ustar liggesusers\name{compCDF} \title{Plot the Component CDF} \alias{compCDF} \usage{ compCDF(data, weights, x=seq(min(data, na.rm=TRUE), max(data, na.rm=TRUE), len=250), comp=1:NCOL(weights), makeplot=TRUE, ...) } \description{ Plot the components' CDF via the posterior probabilities. } \arguments{ \item{data}{A matrix containing the raw data. Rows are subjects and columns are repeated measurements.} \item{weights}{The weights to compute the empirical CDF; however, most of time they are the posterior probabilities.} \item{x}{The points at which the CDFs are to be evaluated.} \item{comp}{The mixture components for which CDFs are desired.} \item{makeplot}{Logical: Should a plot be produced as a side effect?} \item{...}{Additional arguments (other than \code{lty} and \code{type}, which are already used) to be passed directly to \code{plot} and \code{lines} functions.} } \value{ A matrix with \code{length(comp)} rows and \code{length(x)} columns in which each row gives the CDF evaluated at each point of \code{x}. } \details{ When \code{makeplot} is \code{TRUE}, a line plot is produced of the CDFs evaluated at \code{x}. The plot is not a step function plot; the points \eqn{(x, CDF(x))} are simply joined by line segments. } \references{ McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley and Sons, Inc. Elmore, R. T., Hettmansperger, T. P. and Xuan, F. (2004) The Sign Statistic, One-Way Layouts and Mixture Models, \emph{Statistical Science} \bold{19(4)}, 579--587. } \seealso{ \code{\link{makemultdata}}, \code{\link{multmixmodel.sel}}, \code{\link{multmixEM}}. } \examples{ ## The sulfur content of the coal seams in Texas set.seed(100) A <- c(1.51, 1.92, 1.08, 2.04, 2.14, 1.76, 1.17) B <- c(1.69, 0.64, .9, 1.41, 1.01, .84, 1.28, 1.59) C <- c(1.56, 1.22, 1.32, 1.39, 1.33, 1.54, 1.04, 2.25, 1.49) D <- c(1.3, .75, 1.26, .69, .62, .9, 1.2, .32) E <- c(.73, .8, .9, 1.24, .82, .72, .57, 1.18, .54, 1.3) dis.coal <- makemultdata(A, B, C, D, E, cuts = median(c(A, B, C, D, E))) temp <- multmixEM(dis.coal) ## Now plot the components' CDF via the posterior probabilities compCDF(dis.coal$x, temp$posterior, xlab="Sulfur", ylab="", main="empirical CDFs") } \keyword{file} mixtools/man/multmixmodel.sel.Rd0000755000176200001440000000313014342153463016501 0ustar liggesusers\name{multmixmodel.sel} \title{Model Selection Mixtures of Multinomials} \alias{multmixmodel.sel} \usage{ multmixmodel.sel(y, comps = NULL, ...) } \description{ Assess the number of components in a mixture of multinomials model using the Akaike's information criterion (AIC), Schwartz's Bayesian information criterion (BIC), Bozdogan's consistent AIC (CAIC), and Integrated Completed Likelihood (ICL). } \arguments{ \item{y}{Either An nxp matrix of data (multinomial counts), where n is the sample size and p is the number of multinomial bins, or the output of the \code{\link{makemultdata}} function. It is not necessary that all of the rows contain the same number of multinomial trials (i.e., the row sums of \code{y} need not be identical).} \item{comps}{Vector containing the numbers of components to consider. If NULL, this is set to be 1:(max possible), where (max possible) is floor((m+1)/2) and m is the minimum row sum of y.} \item{...}{Arguments passed to \code{multmixEM} that control convergence of the underlying EM algorithm.} } \value{ \code{multmixmodel.sel} returns a table summarizing the AIC, BIC, CAIC, ICL, and log-likelihood values along with the winner (the number with the lowest aforementioned values). } \seealso{ \code{\link{compCDF}}, \code{\link{makemultdata}}, \code{\link{multmixEM}} } \examples{ ##Data generated using the multinomial cutpoint method. set.seed(100) x <- matrix(rpois(70, 6), 10, 7) x.new <- makemultdata(x, cuts = 5) multmixmodel.sel(x.new$y, comps = c(1,2), epsilon = 1e-03) } \keyword{file} mixtools/man/initializations.Rd0000755000176200001440000000431614342153463016420 0ustar liggesusers%gammamix things temporarily commented out by DRH on 8-29-2008 %gammamix things uncommented by DSY on 10-2-2009 \name{mixtools initializations} \alias{flaremix.init} \alias{gammamix.init} \alias{logisregmix.init} \alias{multmix.init} \alias{mvnormalmix.init} \alias{normalmix.init} \alias{poisregmix.init} %\alias{regmix.chgpt.init} \alias{regmix.init} \alias{regmix.lambda.init} \alias{regmix.mixed.init} \alias{repnormmix.init} \alias{segregmix.init} \title{Initializations for Various EM Algorithms in 'mixtools'} \description{ Internal intialization functions for EM algorithms in the package \code{mixtools}. } \usage{ flaremix.init(y, x, lambda = NULL, beta = NULL, sigma = NULL, alpha = NULL) gammamix.init(x, lambda = NULL, alpha = NULL, beta = NULL, k = 2) logisregmix.init(y, x, N, lambda = NULL, beta = NULL, k = 2) multmix.init(y, lambda = NULL, theta = NULL, k = 2) mvnormalmix.init(x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, arbmean = TRUE, arbvar = TRUE) normalmix.init(x, lambda = NULL, mu = NULL, s = NULL, k = 2, arbmean = TRUE, arbvar = TRUE) poisregmix.init(y, x, lambda = NULL, beta = NULL, k = 2) %regmix.chgpt.init(y, x, lambda = NULL, beta = NULL, % gamma = NULL, sigma = NULL, t = NULL, k = 2) regmix.init(y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar=TRUE) regmix.lambda.init(y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar = TRUE) regmix.mixed.init(y, x, w = NULL, sigma = NULL, arb.sigma = TRUE, alpha = NULL, lambda = NULL, mu = NULL, R = NULL, arb.R = TRUE, k = 2, mixed = FALSE, addintercept.fixed = FALSE, addintercept.random = TRUE) repnormmix.init(x, lambda = NULL, mu = NULL, s = NULL, k = 2, arbmean = TRUE, arbvar = TRUE) segregmix.init(y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, seg.Z, psi, psi.locs = NULL) } \details{ These are usually not to be called by the user. Definitions of the arguments appear in the respective EM algorithms. } \keyword{internal} mixtools/man/summary.mixEM.Rd0000644000176200001440000000306414342153463015715 0ustar liggesusers\name{summary.mixEM} \alias{summary.mixEM} \title{Summarizing EM mixture model fits} \usage{ \method{summary}{mixEM}(object, digits=6, \dots) } \arguments{ \item{object}{an object of class \code{mixEM} such as a result of a call to \code{\link{normalmixEM}}} \item{digits}{Significant digits for printing values} \item{\dots}{further arguments passed to \code{print} method.} } \description{ \code{\link[base]{summary}} method for class \code{mixEM}. } \details{ \code{\link{summary.mixEM}} prints parameter estimates for each component of a fitted mixture model. The estimates printed vary with the type of model. } \value{ The function \code{\link{summary.mixEM}} prints the final loglikelihood value at the solution as well as a matrix of values for each component that could include: \item{lambda}{The estimated mixing weights} \item{mu}{The estimated mean parameters} \item{sigma}{The estimated standard deviations} \item{theta}{The estimated multinomial parameters} \item{beta}{The estimated regression parameters} } \seealso{ \code{\link{normalmixEM}}, \code{\link{logisregmixEM}}, \code{\link{multmixEM}}, \code{\link{mvnormalmixEM}}, \code{\link{poisregmixEM}}, \code{\link{regmixEM}}, \code{\link{regmixEM.lambda}}, \code{\link{regmixEM.loc}}, \code{\link{regmixEM.mixed}}, \code{\link{regmixEM.chgpt}}, \code{\link{repnormmixEM}}, \code{\link{expRMM_EM}}, \code{\link{weibullRMM_SEM}} } \examples{ data(faithful) attach(faithful) set.seed(100) out <- normalmixEM(waiting, mu=c(50,80), sigma=c(5,5), lambda=c(.5,.5)) summary(out) } \keyword{file} mixtools/man/repnormmixEM.Rd0000755000176200001440000000651714342153463015635 0ustar liggesusers\name{repnormmixEM} \title{EM Algorithm for Mixtures of Normals with Repeated Measurements} \alias{repnormmixEM} \usage{ repnormmixEM(x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) } \description{ Returns EM algorithm output for mixtures of normals with repeated measurements and arbitrarily many components. } \arguments{ \item{x}{An mxn matrix of data. The columns correspond to the subjects and the rows correspond to the repeated measurements.} \item{lambda}{Initial value of mixing proportions. Entries should sum to 1. This determines number of components. If NULL, then \code{lambda} is random from uniform Dirichlet and number of components is determined by \code{mu}.} \item{mu}{A k-vector of component means. If NULL, then \code{mu} is determined by a normal distribution according to a binning method done on the data. If both \code{lambda} and \code{mu} are NULL, then number of components is determined by \code{sigma}.} \item{sigma}{A vector of standard deviations. If NULL, then \eqn{1/\code{sigma}^2} has random standard exponential entries according to a binning method done on the data. If \code{lambda}, \code{mu}, and \code{sigma} are NULL, then number of components is determined by \code{k}.} \item{k}{Number of components. Ignored unless all of \code{lambda}, \code{mu}, and \code{sigma} are NULL.} \item{arbmean}{If TRUE, then the component densities are allowed to have different \code{mu}s. If FALSE, then a scale mixture will be fit.} \item{arbvar}{If TRUE, then the component densities are allowed to have different \code{sigma}s. If FALSE, then a location mixture will be fit.} \item{epsilon}{The convergence criterion.} \item{maxit}{The maximum number of iterations.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{repnormmixEM} returns a list of class \code{mixEM} with items: \item{x}{The raw data.} \item{lambda}{The final mixing proportions.} \item{mu}{The final mean parameters.} \item{sigma}{The final standard deviations. If \code{arbmean} = FALSE, then only the smallest standard deviation is returned. See \code{scale} below.} \item{scale}{If \code{arbmean} = FALSE, then the scale factor for the component standard deviations is returned. Otherwise, this is omitted from the output.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{normalmixEM}} } \references{ Hettmansperger, T. P. and Thomas, H. (2000) Almost Nonparametric Inference for Repeated Measures in Mixture Models, \emph{Journal of the Royals Statistical Society, Series B} \bold{62(4)} 811--825. } \examples{ ## EM output for the water-level task data set. data(Waterdata) set.seed(100) water <- t(as.matrix(Waterdata[,3:10])) em.out <- repnormmixEM(water, k = 2, verb = TRUE, epsilon = 1e-03) em.out } \keyword{file} mixtools/man/normalmixMMlc.Rd0000755000176200001440000002062414343144205015760 0ustar liggesusers\name{normalmixMMlc} \title{EC-MM Algorithm for Mixtures of Univariate Normals with linear constraints} \alias{normalmixMMlc} \usage{ normalmixMMlc(x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, mean.constr = NULL, mean.lincstr = NULL, mean.constant = NULL, var.lincstr = NULL, gparam = NULL, epsilon = 1e-08, maxit = 1000, maxrestarts=20, verb = FALSE) } \description{ Return EC-MM (see below) algorithm output for mixtures of normal distributions with linear constraints on the means and variances parameters, as in Chauveau and Hunter (2013). The linear constraint for the means is of the form \eqn{\mu = M \beta + C}, where \eqn{M} and \eqn{C} are matrix and vector specified as parameters. The linear constraints for the variances are actually specified on the inverse variances, by \eqn{\pi = A \gamma}, where \eqn{\pi} is the vector of inverse variances, and \eqn{A} is a matrix specified as a parameter (see below). } \details{ This is a specific "EC-MM" algorithm for normal mixtures with linear constraints on the means and variances parameters. EC-MM here means that this algorithm is similar to an ECM algorithm as in Meng and Rubin (1993), except that it uses conditional MM (Minorization-Maximization)-steps instead of simple M-steps. Conditional means that it alternates between maximizing with respect to the \code{mu} and \code{lambda} while holding \code{sigma} fixed, and maximizing with respect to \code{sigma} and \code{lambda} while holding \code{mu} fixed. This ECM generalization of EM is forced in the case of linear constraints because there is no closed-form EM algorithm. } \arguments{ \item{x}{A vector of length n consisting of the data.} \item{lambda}{Initial value of mixing proportions. Automatically repeated as necessary to produce a vector of length \code{k}, then normalized to sum to 1. If \code{NULL}, then \code{lambda} is random from a uniform Dirichlet distribution (i.e., its entries are uniform random and then it is normalized to sum to 1).} \item{mu}{Starting value of vector of component means. If non-NULL and a vector, \code{k} is set to \code{length(mu)}. If NULL, then the initial value is randomly generated from a normal distribution with center(s) determined by binning the data.} \item{sigma}{Starting value of vector of component standard deviations for algorithm. Obsolete for linear constraints on the inverse variances; use \code{gparam} instead to specify a starting value.} \item{k}{Number of components. Initial value ignored unless \code{mu} and \code{sigma} are both NULL.} \item{mean.constr}{First, simplest way to define equality constraints on the mean parameters, given as a vector of length \code{k}, as in \code{\link{normalmixEM}}. Each vector entry specifies the constraints, if any, on the corresponding mean parameter: If \code{NA}, the corresponding parameter is unconstrained. If numeric, the corresponding parameter is fixed at that value. If a character string consisting of a single character preceded by a coefficient, such as \code{"0.5a"} or \code{"-b"}, all parameters using the same single character in their constraints will fix these parameters equal to the coefficient times some the same free parameter. For instance, if \code{mean.constr = c(NA, 0, "a", "-a")}, then the first mean parameter is unconstrained, the second is fixed at zero, and the third and forth are constrained to be equal and opposite in sign. Note: if there are no linear constraints for the means, it is more efficient to use directly \code{\link{normalmixEM}}.} \item{mean.lincstr}{Matrix \eqn{M} \eqn{(k,p)} in the linear constraint for the means equation \eqn{\mu = M \beta + C}, with \eqn{p \le k}.} \item{mean.constant}{Vector of \eqn{k} constants \eqn{C} in the linear constraint for the means equation \eqn{\mu = M \beta + C}.} \item{var.lincstr}{Matrix \eqn{A} \eqn{(k,q)} in the linear constraint for the inverse variances equation \eqn{\pi = A \gamma}, with \eqn{q \le k}.} \item{gparam}{Vector of \eqn{q} starting values for the \eqn{\gamma} parameter in the linear constraint for the inverse variances; see \code{var.lincstr}. If NULL, a vector of randomly generated standard exponential variables is used.} \item{epsilon}{The convergence criterion. Convergence is declared when the change in the observed data log-likelihood increases by less than epsilon.} \item{maxit}{The maximum allowed number of iterations.} \item{maxrestarts}{The maximum number of restarts allowed in case of a problem with the particular starting values chosen due to one of the variance estimates getting too small (each restart uses randomly chosen starting values). It is well-known that when each component of a normal mixture may have its own mean and variance, the likelihood has no maximizer; in such cases, we hope to find a "nice" local maximum with this algorithm instead, but occasionally the algorithm finds a "not nice" solution and one of the variances goes to zero, driving the likelihood to infinity.} \item{verb}{If TRUE, then various updates are printed during each iteration of the algorithm.} } \value{ \code{normalmixMMlc} returns a list of class \code{mixEM} with items: \item{x}{The raw data.} \item{lambda}{The final mixing proportions.} \item{mu}{The final mean parameters.} \item{sigma}{The final standard deviation(s)} \item{scale}{Scale factor for the component standard deviations, if applicable.} \item{loglik}{The final log-likelihood.} \item{posterior}{An nxk matrix of posterior probabilities for observations.} \item{all.loglik}{A vector of each iteration's log-likelihood. This vector includes both the initial and the final values; thus, the number of iterations is one less than its length.} \item{restarts}{The number of times the algorithm restarted due to unacceptable choice of initial values.} \item{beta}{The final \eqn{\beta} parameter estimate.} \item{gamma}{The final \eqn{\gamma} parameter estimate.} \item{ft}{A character vector giving the name of the function.} } \seealso{ \code{\link{normalmixEM}}, \code{\link{mvnormalmixEM}}, \code{\link{normalmixEM2comp}}, \code{\link{tauequivnormalmixEM}} } \references{ \itemize{ \item McLachlan, G. J. and Peel, D. (2000) \emph{Finite Mixture Models}, John Wiley & Sons, Inc. \item Meng, X.-L. and Rubin, D. B. (1993) Maximum Likelihood Estimation Via the ECM Algorithm: A General Framework, \emph{Biometrika} 80(2): 267-278. \item Chauveau, D. and Hunter, D.R. (2013) ECM and MM algorithms for mixtures with constrained parameters, \emph{preprint \url{https://hal.archives-ouvertes.fr/hal-00625285}}. \item Thomas, H., Lohaus, A., and Domsch, H. (2011) Stable Unstable Reliability Theory, \emph{British Journal of Mathematical and Statistical Psychology} 65(2): 201-221. } } \author{Didier Chauveau} \examples{ ## Analyzing synthetic data as in the tau equivalent model ## From Thomas et al (2011), see also Chauveau and Hunter (2013) ## a 3-component mixture of normals with linear constraints. lbd <- c(0.6,0.3,0.1); m <- length(lbd) sigma <- sig0 <- sqrt(c(1,9,9)) # means constaints mu = M beta M <- matrix(c(1,1,1,0,-1,1), 3, 2) beta <- c(1,5) # unknown constrained mean mu0 <- mu <- as.vector(M \%*\% beta) # linear constraint on the inverse variances pi = A.g A <- matrix(c(1,1,1,0,1,0), m, 2, byrow=TRUE) iv0 <- 1/(sig0^2) g0 <- c(iv0[2],iv0[1] - iv0[2]) # gamma^0 init # simulation and EM fits set.seed(50); n=100; x <- rnormmix(n,lbd,mu,sigma) s <- normalmixEM(x,mu=mu0,sigma=sig0,maxit=2000) # plain EM # EM with var and mean linear constraints sc <- normalmixMMlc(x, lambda=lbd, mu=mu0, sigma=sig0, mean.lincstr=M, var.lincstr=A, gparam=g0) # plot and compare both estimates dnormmixt <- function(t, lam, mu, sig){ m <- length(lam); f <- 0 for (j in 1:m) f <- f + lam[j]*dnorm(t,mean=mu[j],sd=sig[j]) f} t <- seq(min(x)-2, max(x)+2, len=200) hist(x, freq=FALSE, col="lightgrey", ylim=c(0,0.3), ylab="density",main="") lines(t, dnormmixt(t, lbd, mu, sigma), col="darkgrey", lwd=2) # true lines(t, dnormmixt(t, s$lambda, s$mu, s$sigma), lty=2) lines(t, dnormmixt(t, sc$lambda, sc$mu, sc$sigma), col=1, lty=3) legend("topleft", c("true","plain EM","constr EM"), col=c("darkgrey",1,1), lty=c(1,2,3), lwd=c(2,1,1)) } \keyword{file} mixtools/DESCRIPTION0000755000176200001440000000414514343400152013641 0ustar liggesusersPackage: mixtools Version: 2.0.0 Date: 2022-12-04 Title: Tools for Analyzing Finite Mixture Models Authors@R: c(person("Derek", "Young", role = c("aut", "cre"), email = "derek.young@uky.edu", comment = c(ORCID = "0000-0002-3048-3803")), person("Tatiana", "Benaglia", role = "aut"), person("Didier", "Chauveau", role = "aut"), person("David", "Hunter", role = "aut"), person("Kedai", "Cheng", role = "aut"), person("Ryan", "Elmore", role = "ctb"), person("Thomas", "Hettmansperger", role = "ctb"), person("Hoben", "Thomas", role = "ctb"), person("Fengjuan", "Xuan", role = "ctb")) Depends: R (>= 4.0.0) Imports: kernlab, MASS, plotly, scales, segmented, stats, survival URL: https://github.com/dsy109/mixtools Description: Analyzes finite mixture models for various parametric and semiparametric settings. This includes mixtures of parametric distributions (normal, multivariate normal, multinomial, gamma), various Reliability Mixture Models (RMMs), mixtures-of-regressions settings (linear regression, logistic regression, Poisson regression, linear regression with changepoints, predictor-dependent mixing proportions, random effects regressions, hierarchical mixtures-of-experts), and tools for selecting the number of components (bootstrapping the likelihood ratio test statistic, mixturegrams, and model selection criteria). Bayesian estimation of mixtures-of-linear-regressions models is available as well as a novel data depth method for obtaining credible bands. This package is based upon work supported by the National Science Foundation under Grant No. SES-0518772 and the Chan Zuckerberg Initiative: Essential Open Source Software for Science (Grant No. 2020-255193). License: GPL (>= 2) NeedsCompilation: yes Packaged: 2022-12-05 06:17:17 UTC; derekyoung Author: Derek Young [aut, cre] (), Tatiana Benaglia [aut], Didier Chauveau [aut], David Hunter [aut], Kedai Cheng [aut], Ryan Elmore [ctb], Thomas Hettmansperger [ctb], Hoben Thomas [ctb], Fengjuan Xuan [ctb] Maintainer: Derek Young Repository: CRAN Date/Publication: 2022-12-05 14:30:02 UTC mixtools/build/0000755000176200001440000000000014343400152013223 5ustar liggesusersmixtools/build/vignette.rds0000644000176200001440000000032114343306355015570 0ustar liggesusersb```b`abb`b2 1# 'ͬ() +G))8E )98)HICBXt0XXT%榢Z]?4-ީE0=(jؠjX2sRad9.nP&c0Gq?gQ~oݣ9JI,IK+Lпmixtools/src/0000755000176200001440000000000014343306355012725 5ustar liggesusersmixtools/src/multinompost.c0000755000176200001440000000302414342153463015644 0ustar liggesusers#include #include /* Compute the matrix of "posterior" probabilities in a finite mixture of multinomial distributions. The algorithm used is fairly safe from a numerical perspective; it avoids over- or under-flow as long as the values of sigma are not too large or small. */ void multinompost( int *nn, /* sample size */ int *mm, /* number of components */ double *loglamcd, /* n by m matrix of log(lambda * component density) values */ double *post, /* n by m matrix of posterior probabilities */ double *loglik /* scalar loglikelihood value (input value is a constant, which is modified before return). */ ) { int n=*nn, m=*mm, i, j, maxj; double sum, max, *loglamcolumnptr; for (loglamcolumnptr=loglamcd, i=0; i max) { max = loglamcolumnptr[j]; maxj = j; } } sum = 1.0; for(j = 0; j #include /* Just like KDEsymloc2.c except that we do not symmetrize. This works because the assumption of symmetry is not necessary in the case of regression, where the (i,j) mean depends not only on the jth component but also on the ith predictor value */ void KDEloc2( int *n, /* Sample size */ int *m, /* Number of components */ double *mu, /* nn*mm vector of current mean estimates */ double *x, /* data: vector of length n */ double *h, /* bandwidth */ double *z, /* nn*mm vector of normalized posteriors (or indicators in stochastic case), normalized by "column" */ double *f /* KDE evaluated at n*m matrix of points, namely, x_i - mu_ij for 1<=i<=n and 1<=j<=m */ ) { int nn=*n, mm=*m, i, j, a, b; double sum, u1, u2, tmp1, hh=*h; double const1 = -1.0 / (2.0 * hh * hh); double const2 = 0.39894228040143267794/(hh*(double)nn); /* .3989...=1/(sqrt(2*pi)) */ /* Must loop n^2*m^2 times; each f entry requires n*m calculations */ for(a=0; a #include #include #include /* Simultaneously calculate m different multivariate weighted KDEs (mvwkde) 1 for each component, for a fixed value of block index l, and same bandwidth for all components (option samebw=TRUE) final value is a (n,m) matrix f where f[i,j]=\hat f_{jl}(u_i) */ void mvwkde_samebw ( int *nn, /* Sample size */ int *dd, /* Number of coordinates in l-th block */ int *mm, /* Number of components */ double *h, /* bandwidth d-vector */ double *x, /* data: vector of length nn*rr */ double *u, /* data: vector of length nn*rr (u=xfor now, ToDo for any u!) */ double *z, /* nn*mm vector of normalized posteriors */ double *f /* nxm matrix of weighted KDE - multidim */ ) { int n=*nn, d=*dd, dn=*dd*n, mn=*mm*n, iu, ix; int kn, jn, id; double tmp1, tmp2, sum1, sum2, xik, uik, hk; double c2, det_h; /*const float const1 = -0.5;*/ double const2 = 0.39894228040143267794; /* =1/(sqrt(2*pi)) */ /* computing the constant from bandwidth matrix and d */ det_h = 1.0; for (id=0; id #include #include #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void mudepth(void *, void *, void *, void *, void *, void *, void *); extern void KDEloc2(void *, void *, void *, void *, void *, void *, void *); extern void KDElocscale(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void KDErepeated(void *, void *, void *, void *, void *, void *, void *); extern void KDErepeatedbw(void *, void *, void *, void *, void *, void *, void *); extern void KDEsymloc(void *, void *, void *, void *, void *, void *, void *); extern void KDEsymloc1comp(void *, void *, void *, void *, void *, void *, void *); extern void KDEsymloc2(void *, void *, void *, void *, void *, void *, void *); extern void multinompost(void *, void *, void *, void *, void *); extern void mvwkde_adaptbw(void *, void *, void *, void *, void *, void *, void *, void *); extern void mvwkde_samebw(void *, void *, void *, void *, void *, void *, void *, void *); extern void newz(void *, void *, void *, void *, void *); extern void normpost(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void npMSL_Estep(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void npMSL_Estep_bw(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void npMSL_Mstep(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void npMSL_Mstep_bw(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"mudepth", (DL_FUNC) &mudepth, 7}, {"KDEloc2", (DL_FUNC) &KDEloc2, 7}, {"KDElocscale", (DL_FUNC) &KDElocscale, 10}, {"KDErepeated", (DL_FUNC) &KDErepeated, 7}, {"KDErepeatedbw", (DL_FUNC) &KDErepeatedbw, 7}, {"KDEsymloc", (DL_FUNC) &KDEsymloc, 7}, {"KDEsymloc1comp", (DL_FUNC) &KDEsymloc1comp, 7}, {"KDEsymloc2", (DL_FUNC) &KDEsymloc2, 7}, {"multinompost", (DL_FUNC) &multinompost, 5}, {"mvwkde_adaptbw", (DL_FUNC) &mvwkde_adaptbw, 8}, {"mvwkde_samebw", (DL_FUNC) &mvwkde_samebw, 8}, {"newz", (DL_FUNC) &newz, 5}, {"normpost", (DL_FUNC) &normpost, 10}, {"npMSL_Estep", (DL_FUNC) &npMSL_Estep, 15}, {"npMSL_Estep_bw",(DL_FUNC) &npMSL_Estep_bw, 15}, {"npMSL_Mstep", (DL_FUNC) &npMSL_Mstep, 13}, {"npMSL_Mstep_bw",(DL_FUNC) &npMSL_Mstep_bw, 13}, {NULL, NULL, 0} }; void R_init_mixtools(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } mixtools/src/KDErepeated.c0000755000176200001440000000331514342153463015212 0ustar liggesusers#include #include #include #include /* simultaneously calculate m different products of KDEs, 1 for each component, as in equation (8) of Benaglia et al for a fixed value of \ell. If r is the number of coordinates in block \ell, then each final value is the r-fold product of KDEs */ void KDErepeated( int *nn, /* Sample size */ int *mm, /* Number of components */ int *rr, /* size of current block */ double *x, /* data: vector of length nn*rr */ double *hh, /* scalar bandwidth (compare to KDErepeatedbw) */ double *z, /* nn*mm vector of normalized posteriors (or indicators in stochastic case), normalized by "column" */ double *f /* nxm matrix of KDE products */ ) { int n=*nn, i, ii; int rn = *rr*n, mn=*mm*n, jn, kn, kkn; double sum1, sum2, tmp, h=*hh, xik; double const1 = -0.5 / (h * h); double const2 = 0.39894228040143267794/(h*(double)(*rr)); /* .3989...=1/(sqrt(2*pi)) */ for(jn=0; jn #include /* Slightly modified version of KDEsymloc.c that can handle an nxm matrix of current mean estimates (instead of merely an m-vector). This is useful for the regression case, where the (i,j) mean depends not only on the jth component but also on the ith predictor value */ void KDEsymloc2( int *n, /* Sample size */ int *m, /* Number of components */ double *mu, /* nn*mm vector of current mean estimates */ double *x, /* data: vector of length n */ double *h, /* bandwidth */ double *z, /* nn*mm vector of normalized posteriors (or indicators in stochastic case), normalized by "column" */ double *f /* KDE evaluated at n*m matrix of points, namely, x_i - mu_ij for 1<=i<=n and 1<=j<=m */ ) { int nn=*n, mm=*m, i, j, a, b; double sum, u1, u2, tmp1, tmp2, hh=*h; double const1 = -1.0 / (2.0 * hh * hh); double const2 = 0.39894228040143267794/(2.0*hh*(double)nn); /* .3989...=1/(sqrt(2*pi)) */ /* Must loop n^2*m^2 times; each f entry requires n*m calculations */ for(a=0; a /* Translated from FORTRAN code written by Fengjuan Xuan */ void mudepth (int *nn, int *tt, int *dd, double *mpt, double *x, int *count, double *sdep) { int n=*nn, t=*tt, d=*dd; int i, j, k, l; double d1, d2, d3, d5, xik, xjk, mptlk; for (l=0; l #include /* Implement symmetric kernel density-estimation step for location mixture model, equation (20) in Benaglia et al (2008) */ void KDEsymloc( int *n, /* Sample size */ int *m, /* Number of components */ double *mu, /* m-vector of current mean estimates */ double *x, /* data: vector of length n */ double *h, /* bandwidth */ double *z, /* nn*mm vector of normalized posteriors (or indicators in stochastic case), normalized by "column" */ double *f /* KDE evaluated at n*m matrix of points, namely, x_i - mu_j for 1<=i<=n and 1<=j<=m */ ) { int nn=*n, mm=*m, i, j, a, b; double sum, u1, u2, tmp1, tmp2, hh=*h; double const1 = -1.0 / (2.0 * hh * hh); double const2 = 0.39894228040143267794/(2.0*hh*(double)nn); /* .3989...=1/(sqrt(2*pi)) */ /* Must loop n^2*m^2 times; each f entry requires n*m calculations */ for(a=0; a /* in order to make the sqrt function work */ /* First, create the function prototype (global declaration that there exists a function called new_svalues returning void and taking these arguments) */ void new_svalues (double *z, double *y, double *x, double *beta, int *k, int *n, int *p, double *out, double *sz, double *runsum); /* Next comes the function itself: */ void new_svalues (double *z, double *y, double *x, double *beta, int *k, int *n, int *p, double *out, double *sz, double *runsum) { int i, j, l; double sum; double xbeta; double diff; double diff2; double zdiff; double zdiff2; double zdiff3; /* Create the sz (column sum of z) vector */ for(j=0; j < *k ; j=j+1) { sum=0.0; for(i=0; i < *n; i=i+1) { sum += z[j * (*n) + i]; } sz[j]=sum; } for(j=0; j < *k ; j=j+1) { zdiff=0.0; for(i=0; i < *n; i=i+1) { xbeta=0.0; /* Calculate i,j component of x %*% beta */ for(l=0; l < *p; l++){ xbeta += x[l * (*n) + i] * beta[j * (*p) + l]; } /* Subtract it from the i component of y */ diff = y[i] - xbeta; /* square the difference */ diff2 = pow(diff,2); /* multiply by the i,j component of z */ zdiff += z[j * (*n) + i] * diff2; } /* keep track of running sum */ runsum[j] = zdiff; /* divide dot product by sz[j] */ zdiff2 = runsum[j] / sz[j]; /* take the square root */ zdiff3 = sqrt(zdiff2); /* put result in out[j] */ out[j] = zdiff3; } } mixtools/src/KDEsymloc1comp.c0000755000176200001440000000300614342153463015664 0ustar liggesusers#include #include /* Implement symmetric kernel density-estimation step for location mixture model with 1 component known , as in Bordes Delmas & Vandekerkhove (2006) normalization before symmetrization must be 1/(n\lambda_2)h */ void KDEsymloc1comp( int *n, /* Sample size */ double *mean, /* component 2 mean estimate, scalar */ double *lambda, /* component 2 weigtht, scalar */ double *x, /* data: vector of length n */ double *h, /* bandwidth */ double *z, /* nn*mm vector of normalized posteriors (or indicators in stochastic case), normalized by "column" */ double *f /* KDE evaluated at n vector of points, namely, x_i - mu for 1<=i<=n */ ) { int nn=*n, i, j, a; double sum, u1, u2, tmp1, tmp2, hh=*h, mu=*mean, lbd=*lambda; double const1 = -1.0 / (2.0 * hh * hh); double const2 = 0.39894228040143267794/(2.0*hh*(double)nn*lbd); /* .3989...=1/(sqrt(2*pi)) */ /* loop over each f entry evaluated at x_a - mu */ for(a=0; a #include /* Implement kernel density-estimation step for location-scale mixture model (17) in Benaglia et al (2008) where each component and block has the same shape but may differ from others by a location and scale, implementing equation (18) */ void KDElocscale( int *nn, /* Sample size */ int *mm, /* Number of components */ int *rr, /* Number of coordinates */ int *blockid, /* r-vector of block numbers */ double *mu, /* m by max(blockid) matrix of current mean estimates */ double *sigma, /* m by max(blockid) matrix of current stdev estimates */ double *x, /* n by r data matrix */ double *hh, /* scalar bandwidth */ double *z, /* n by m vector of normalized posteriors (or indicators in stochastic case), normalized by "column" */ double *f /* n by m matrix of KDE products */ ) { int n=*nn, m=*mm, r=*rr; int i, j, k, ii, kk, ell, ell2; double sum1, sum2, tmp, h=*hh, u; double const1 = -0.5 / (h * h); double const2; for(j=0; j #include #include void newz (int *n, int *k, double *V, double *W, double *z) { int i, j, l, ind1, ind2, nn=*n, kk=*k; double sum; for(i=0; i< nn; i++) { for(j=0; j< kk; j++) { sum=1.0; ind1 = i + nn * j; for(l = 0; l < kk; l++) { if (l != j) { ind2 = i + nn * l; sum += V[ind2]/V[ind1]*exp(W[ind1]-W[ind2]); } } z[ind1] = 1.0/sum; } } } mixtools/src/KDErepeatedbw.c0000755000176200001440000000331414342153463015542 0ustar liggesusers#include #include #include #include /* simultaneously calculate m different products of KDEs, 1 for each component, as in equation (8) of Benaglia et al for a fixed value of \ell. If r is the number of coordinates in block \ell, then each final value is the r-fold product of KDEs */ void KDErepeatedbw( int *nn, /* Sample size */ int *mm, /* Number of components */ int *rr, /* size of current block */ double *x, /* data: vector of length nn*rr */ double *hh, /* m-vector of bandwidths (compare to KDErepeated) */ double *z, /* nn*mm vector of normalized posteriors (or indicators in stochastic case), normalized by "column" */ double *f /* nxm matrix of KDE products */ ) { int n=*nn, i, ii; int mn = *mm*n, rn=*rr*n, jn, kn, kkn; double sum1, sum2, tmp, xik; double const2 = 0.39894228040143267794/((double)(*rr)); /* .3989...=1/(sqrt(2*pi)) */ double const1; for(jn=0; jn #include /* Compute the matrix of "posterior" probabilities in a finite mixture of univariate normal densities. The algorithm used is fairly safe from a numerical perspective; it avoids over- or under-flow as long as the values of sigma are not too large or small. */ void normpost( int *nn, /* sample size */ int *mm, /* number of components */ double *data, /* vector of observations */ double *mu, /* current vector of component means */ double *sigma, /* current vector of component stdevs */ double *lambda, /* current vector of mixing parameters */ double *res2, /* n by m matrix of squared residuals */ double *work, /* 3*m-vector of workspace, which will be broken into 3 parts */ double *post, /* n by m matrix of posterior probabilities */ double *loglik /* scalar loglikelihood value */ ) { int n=*nn, m=*mm, i, j, minj=0; double x, r, rowsum, min=0.0; double *LamSigRatio = work+m; /* Second 1/3 of workspace, for frequently used constants */ double *logLamSigRatio = work+2*m; /* Third 1/3 of workspace, for frequently used constants */ *loglik = -(double)n * 0.91893853320467274178; /* n/2 times log(2pi) */ for (j=0; j #include #define MAX(a,b) ((a) > (b) ? (a) : (b)) /* In the npMSL algorithm (formerly NEMS), it is necessary to store the values of each f_{jk} density on a univariate grid of points, since the E-step involves a convolution (which means that it no longer suffices to store f_{jk} only at the data points x_{ik}, as it did for the original npEM algorithm of Benaglia et al). In the M-step, we must set each f_{jk}(u_a) equal to the sum (over i) of p_{ij} * phi((u_a - x_{ik}) / h) / h, where phi is the std. normal density which gives the normal kernel with bandwidth h. Thus, the M-step involves four nested loops, one each for i, j, k, and a. In the E-step, we must set each p_{ij} equal to K * lambda_j * N(f_j)(x_i), where: -- K is a normalizing constant ensuring that sum_j p_{ij} = 1 for all i. -- N(f_j)(x_i) is the product prod_j N(f_jk)(x_{ik}) -- N(f_{jk})(x_{ik}) = exp{integral of (1/h)*phi((u-x_{ik})/h)*log(f_{jk}(u))du} -- that last integral is approximated by the sum (over a) of (normalizing constant)*exp((u_a-x_{ik})^2/h^2)*log(f_{jk}(u_a)) Current version: with underflow handling in the E-step and block structure, */ /* ********************************************************** Version allowing blocks of conditionaly iid coordinates: f is now a ngrid by m by B array of f_{j ell} values on the grid note: *BB is not used here, but remains in the parameter list for consistency with the npMSL_Estep_bw() version which needs it */ void npMSL_Estep( int *nngrid, /* size of grid */ int *nn, /* sample size */ int *mm, /* number of components */ int *rr, /* number of repeated measurements */ int *BB, /* total nb of blocks (not used in samebw version) */ int *blockid, /* r-vector (b_k) block to which belongs coord k */ double *hh, /* bandwidth */ double *data, /* n by r vector of observations */ double *grid, /* grid points */ double *f, /* ngrid by m by B array of density values on grid */ double *lambda, /* current vector of mixing parameters */ double *post, /* n by m matrix of posterior probabilities */ double *loglik, /* scalar value of penalized loglikelihood */ int *nb_udfl, /* nb of underflows log(0) cancelled */ int *nb_nan /* nb of nonzero K()*log(0) cancelled */ ) { int n=*nn, m=*mm, r=*rr, ngrid=*nngrid; int i, j, k, ell, a; double sum, conv, xik, *fjl, two_h_squared =2*(*hh)*(*hh); double Delta = (grid[2]-grid[1]) / *hh / sqrt(2*3.14159265358979); double t1, expminus500=exp(-500); double epsi=1e-323; /* smallest number; maybe machine-dependent ? */ double epsi2=1e-100; /* assumed small enough for cancelling log(0) */ *loglik=0.0; for (i=0; i epsi) { /* no underflow pb */ conv += t1 * log(fjl[a]); } else if (t1 < epsi2) { /* assume kernel cancels log(0) part */ *nb_udfl +=1; /* count underflow replaced by 0 */ } else *nb_nan +=1; /* kernel *may* be not small enough ! */ } conv *= Delta; /* Delta is the normalizing constant */ conv = exp(conv); /* conv now = Nf_{jb_k}(xik) */ post[i + n*j] *= conv; /* numerator = lambda_j*prod_k Nf_{jb_k}(xik) */ } sum += post[i + n*j]; } *loglik += log(sum); for(j=0; j epsi) { /* no underflow pb */ conv += t1 * log(fjl[a]); } else if (t1 < epsi2) { /* assume kernel cancels log(0) part */ *nb_udfl +=1; /* count underlow replaced by 0 */ } else *nb_nan +=1; /* kernel *may* be not small enough ! */ } conv *= Delta; /* Delta is the normalizing constant */ conv = exp(conv); /* conv now = Nf_{jb_k}(xik) */ post[i + n*j] *= conv; /* numerator = lambda_j*prod_k Nf_{jb_k}(xik) */ } sum += post[i + n*j]; } *loglik += log(sum); for(j=0; j1$ arbitrary distributions, which we will call {\em components} throughout this article. The density of each $\vec X_i$ may be written \begin{equation} \label{mvmixture} g_{\f}(\vec x_i) = \sum_{j=1}^m\lambda_j\phi_j(\vec x_i), \quad \vec x_i\in\bR^r, \end{equation} where $\f=(\vec\lambda, \vec \phi) = (\lambda_1, \ldots, \lambda_m, \phi_1, \ldots, \phi_m)$ denotes the parameter and the $\lambda_m$ are positive and sum to unity. We assume that the $\phi_j$ are drawn from some family $\cal F$ of multivariate density functions absolutely continuous with respect to, say, Lebesgue measure. The representation \eqref{mvmixture} is not identifiable if no restrictions are placed on $\cal F$, where by ``identifiable'' we mean that $g_{\f}$ has a {\em unique} representation of the form \eqref{mvmixture} and we do not consider that ``label-switching'' --- i.e., reordering the $m$ pairs $(\lambda_1, \phi_1), \ldots, (\lambda_m, \phi_m)$ --- produces a distinct representation. In the next sections we will sometimes have to distinguish between {\em parametric} and more general {\em nonparametric} situations. This distinction is related to the structure of the family $\CF$ of distributions to which the component densities $\phi_j$ in model \eqref{mvmixture} belong. We say that the mixture is {\em parametric} if $\CF$ is a parametric family, $\CF = \{\phi(\cdot|\vec\xi), \vec\xi\in\bR^d\}$, indexed by a ($d$-dimensional) Euclidean parameter $\vec\xi$. A parametric family often used is the univariate Gaussian family $\CF = \{\phi(\cdot|\mu,\sigma^2)=\mbox{density of }\CN(\mu,\sigma^2), (\mu,\sigma^2)\in\bR\times\bR^+_*\}$, in which case the model parameter reduces to $\f = (\vec \lambda, (\mu_1,\sigma^2_1),\ldots,(\mu_m,\sigma^2_m))$. For the multivariate case, a possible parametric model is the {\em conditionally i.i.d.\ normal model}, for which $\CF=\{\phi(\vec x_i) = \prod_{k=1}^r f(x_{ik}), \mbox{$f(t)$ density of $\CN(\mu,\sigma^2)$}\}$ (this model is included in \pkg{mixtools}; see Section~\ref{ss:nbcomp}). An example of a (multivariate) nonparametric situation is $\CF=\{\phi(\vec x_i) = \prod_{k=1}^r f(x_{ik}), \mbox{$f(t)$ a univariate density on $\bR$}\}$, in which case $\vec\f$ consists in a Euclidean part ($\vec\lb$) and a nonparametric part $(f_1,\ldots,f_m)$. As a simple example of a dataset to which mixture models may be applied, consider the sample depicted in Figure \ref{geyser}. In the Old Faithful dataset, measurements give time in minutes between eruptions of the Old Faithful geyser in Yellowstone National Park, USA. These data are included as part of the \pkg{datasets} package in \proglang{R} \citep{r2009}; type \code{help("faithful")} in \proglang{R} for more details. <>= library(mixtools) data(faithful) attach(faithful) @ \setkeys{Gin}{width=0.6\textwidth} \begin{figure}[h] \centering <>= hist(waiting, main="Time between Old Faithful eruptions", xlab="Minutes", ylab="", cex.main=1.5, cex.lab=1.5, cex.axis=1.4) @ \caption{The Old Faithful dataset is clearly suggestive of a two-component mixture of symmetric components.} \label{geyser} \end{figure} For the Old Faithful eruption data, a two-component mixture model is clearly a reasonable model based on the bimodality evident in the histogram. This example is analyzed by \citet{hunter2007ims}, who compare a standard normal-mixture method for fitting it with a novel semiparametric approach. Both approaches are included in \pkg{mixtools}; see Sections \ref{section:EMexample} and \ref{section:SPexample} of this article. In Section~\ref{section:EM} of the current article we review the well-known class of EM algorithms for finite mixture models, a common thread that runs throughout much of the rest of the article. The remaining sections discuss various categories of functions found in the \pkg{mixtools} package, from cutpoint methods that relax distributional assumptions for multivariate data by discretizing the data (Section~\ref{section:cut}), to semi- and non-parametric methods that eliminate distributional assumptions almost entirely depending on what the identifiability of the model allows (Section~\ref{section:np}), to methods that handle various mixtures of regressions (Section~\ref{section:reg}). Finally, Section \ref{section:misc} describes several miscellaneous features of the \pkg{mixtools} package. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{EM algorithms for finite mixtures} \label{section:EM} \subsection{Missing data setup} Much of the general methodology used in \pkg{mixtools} involves the representation of the mixture problem as a particular case of maximum likelihood estimation (MLE) when the observations can be viewed as incomplete data. This setup implies consideration of two sample spaces, the sample space of the (incomplete) observations, and a sample space of some ``complete'' observations, the characterization of which being that the estimation can be performed explicitly at this level. For instance, in parametric situations, the MLE based on the complete data may exist in closed form. Among the numerous reference papers and monographs on this subject are, e.g., the original EM algorithm paper by \citet{dempster1977mli} and the finite mixture model book by \citet{mclachlan2000fmm} and references therein. We now give a brief description of this setup as it applies to finite mixture models in general. The (observed) data consist of $n$ i.i.d. observations $\vec x = (\vec x_1,\ldots,\vec x_n)$ from a density $g_\f$ given by \eqref{mvmixture}. It is common to denote the density of the sample by $\Bg_\f$, the $n$-fold product of $g_\f$, so that we write simply $\Bx\sim \Bg_\f$. In the missing data setup, $\Bg_\f$ is called the incomplete-data density, and the associated log-likelihood is $L_{\Bx}(\f) = \sum_{i=1}^n \log g_\f(\vec x_i)$. The (parametric) ML estimation problem consists in finding $\hat\f_{\Bx} = \argmax_{\f\in\Phi} L_{\Bx}(\f)$, or at least finding a local maximum --- there are certain well-known cases in which a finite mixture model likelihood is unbounded \citep{mclachlan2000fmm}, but we ignore these technical details for now. Calculating $\hat\f_{\Bx}$ even for a parametric finite mixture model is known to be a difficult problem, and considering $\Bx$ as incomplete data resulting from non-observed complete data helps. The associated complete data is denoted by $\Bc = (\vec c_1,\ldots, \vec c_n)$, with density $\Bh_\f(\Bc)=\prod_{i=1}^n h_\f(\vec c_i)$ (there exists a many-to-one mapping from $\Bc$ to $\Bx$, representing the loss of information). In the model for complete data associated with model~\eqref{mvmixture}, each random vector $\vec C_i = (\vec X_i,\vec Z_i)$, where $\vec Z_i = (Z_{ij},j=1,\ldots m)$, and $Z_{ij}\in\{0,1\}$ is a Bernoulli random variable indicating that individual $i$ comes from component $j$. Since each individual comes from exactly one component, this implies $\sum_{j=1}^m Z_{ij}=1$, and $$ \Prob(Z_{ij} = 1) = \lambda_{j},\quad (\vec X_i|Z_{ij}=1) \sim \phi_j, \quad j=1,\ldots,m. $$ The complete-data density for one observation is thus $$ h_\f(\vec c_i) = h_\f(\vec x_i,\vec z_i) = \sum_{j=1}^m \I_{z_{ij}}\lb_j \phi_j (\vec x_i), $$ In the parametric situation, i.e.\ when $\CF$ is a parametric family, it is easy to check that the complete-data MLE $\hat\f_{\Bc}$ based on maximizing $\log \Bh_\f(\Bc)$ is easy to find, provided that this is the case for the family $\CF$. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{EM algorithms} \label{sec:EM} An EM algorithm iteratively maximizes, instead of the observed log-likelihood $L_{\Bx}(\f)$, the operator $$ Q(\f | \f^{(t)}) = \E \left[\log \Bh_\f(\BC)|\Bx,\f^{(t)} \right], $$ where $\f^{(t)}$ is the current value at iteration~$t$, and the expectation is with respect to the distribution $\Bk_\f(\Bc|\Bx)$ of $\Bc$ given $\Bx$, for the value $\f^{(t)}$ of the parameter. The iteration $\f^{(t)} \to \f^{(t+1)}$ is defined in the above general setup by \begin{enumerate} \item E-step: compute $Q(\f | \f^{(t)})$ \item M-step: set $\f^{(t+1)} = \argmax_{\f\in\Phi}Q(\f | \f^{(t)})$ \end{enumerate} For finite mixture models, the E-step does not depend on the structure of $\CF$, since the missing data part is only related to the $\Bz$'s: $$ \Bk_\f(\Bc|\Bx) = \prod_{i=1}^n k_\f(\vec z_i|\vec x_i). $$ The $\Bz$ are discrete, and their distribution is given via Bayes' theorem. The M-step itself can be split in two parts, the maximization related to $\vec\lb$, which does not depend on $\CF$, and the maximization related to $\vec \phi$, which has to be handled specifically (say, parametrically, semi- or non-parametrically) for each model. Hence the EM algorithms for the models handled by the \pkg{mixtools} package share the following common features: \begin{enumerate} \item{\bf E-step:\ } Calculate the ``posterior'' probabilities (conditional on the data and $\vec\theta^{(t)}$) of component inclusion, \begin{equation}\label{posteriors} \post_{ij}^{(t)} \, \defn \, \Prob_{\vec\theta^{(t)}}(Z_{ij}=1| \vec x_i) = \frac{\lambda_j^{(t)} \phi_{j}^{(t)}(\vec x_{i})} {\sum_{j'=1}^m\lambda_{j'}^{(t)} \phi_{j'}^{(t)}(\vec x_{i})} \end{equation} for all $i=1,\ldots, n$ and $j=1, \ldots, m$. Numerically, it can be dangerous to implement equation (\ref{posteriors}) exactly as written due to the possibility of the indeterminant form $0/0$ in cases where $\vec x_i$ is so far from any of the components that all $\phi_{j'}^{(t)}(\vec x_i)$ values result in a numerical underflow to zero. Thus, many of the routines in \pkg{mixtools} actually use the equivalent expression \begin{equation}\label{altposteriors} \post_{ij}^{(t)} = \left[ 1 + \sum_{j'\ne j} \frac{ \lambda_{j'}^{(t)} \phi_{j'}^{(t)}(\vec x_{i})} {\lambda_j^{(t)} \phi_{j}^{(t)}(\vec x_{i})} \right]^{-1} \end{equation} or some variant thereof. \item{\bf M-step for $\vec\lb$:\ } Set \begin{equation}\label{lambda} \lambda_j^{(t+1)} = \frac1n\sum_{i=1}^n \post_{ij}^{(t)} , \quad\mbox{for $j=1, \ldots, m$.} \end{equation} \end{enumerate} \subsection{An EM algorithm example} \label{section:EMexample} As an example, we consider the univariate normal mixture analysis of the Old Faithful waiting data depicted in Figure \ref{geyser}. This fully parametric situation corresponds to a mixture from the univariate Gaussian family described in Section~\ref{s:intro}, where the $j$th component density $\phi_j(x)$ in \eqref{mvmixture} is normal with mean $\mu_j$ and variance $\sigma_j^2$. This is a special case of the general mixture-of-normal model that is well-studied in the literature and for which other software, such as the \pkg{mclust} \citep{Fraley+Raftery:2009} package for \proglang{R}, may also be used for parameter estimation. The M-step for the parameters $(\mu_j,\sigma^2_j)$, $j=1,\ldots,m$ of this EM algorithm for such mixtures of univariate normals is straightforward, and can be found, e.g., in \citet{mclachlan2000fmm}. The function \code{normalmixEM} implements the algorithm in \pkg{mixtools}. Code for the Old Faithful example, using most of the default values (e.g., stopping criterion, maximum number of iterations), is simply <>= wait1 <- normalmixEM(waiting, lambda = .5, mu = c(55, 80), sigma = 5) @ The code above will fit a 2-component mixture (because \code{mu} is a vector of length two) in which the standard deviations are assumed equal (because \code{sigma} is a scalar instead of a vector). See \code{help("normalmixEM")} for details about specifying starting values for this EM algorithm. <>= plot(wait1, density=TRUE, cex.axis=1.4, cex.lab=1.4, cex.main=1.8, main2="Time between Old Faithful eruptions", xlab2="Minutes") @ \setkeys{Gin}{width=0.49\textwidth} \begin{figure}[!h] \centering <>= for(i in 1:2){ file=paste("geyserEM", i, ".pdf", sep="") pdf(file=file, paper="special", width=6, height=6) plot(wait1, whichplots=i, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") dev.off() cat("\\includegraphics{", file, "}\n", sep="") } @ \caption{The Old Faithful waiting data fitted with a parametric EM algorithm in \pkg{mixtools}. Left: the sequence of log-likelihood values; Right: the fitted Gaussian components.} \label{geyserEM} \end{figure} The \code{normalmixEM} function returns an object of class \code{"mixEM"}, and the \code{plot} method for these objects delivers the two plots given in Figure \ref{geyserEM}: the sequence $t\mapsto L_{\Bx}(\f^{(t)})$ of observed log-likelihood values and the histogram of the data with the $m$ ($m=2$ here) fitted Gaussian component densities of $\CN(\hat\mu_j,\hat\sigma^2_j)$, $j=1,\ldots,m$, each scaled by the corresponding $\hat\lambda_j$, superimposed. The estimator $\hat{\vec\theta}$ can be displayed by typing, e.g., <>= wait1[c("lambda", "mu", "sigma")] @ Alternatively, the same output may be obtained using the \code{summary} method: <>= summary(wait1) @ \section{Cutpoint methods} \label{section:cut} Traditionally, most literature on finite mixture models has assumed that the density functions $\phi_j(\vec x)$ of equation (\ref{mvmixture}) come from a known parametric family. However, some authors have recently considered the problem in which $\phi_j(\vec x)$ is unspecified except for some conditions necessary to ensure the identifiability of the parameters in the model. One such set of conditions is as follows: \citet{hettmansperger2000ani}; \citet{cruzmedina2004smm}; and \citet{elmore2004ecc} treat the case in which $\phi_j(\vec x)$ equals the product $f_j(x_i)\cdots f_j(x_r)$ for some univariate density function $f_j$. Thus, conditional on knowing that $\vec X$ comes from the $j$th mixture component, the coordinates of $\vec X$ are independent and identically distributed. For this reason, this case is called the conditionally i.i.d.\ model. The authors named above have developed an estimation method for the conditionally i.i.d.\ model. This method, the {\em cutpoint approach}, discretizes the continuous measurements by replacing each $r$-dimensional observation, say $\vec X_i= (x_{i1}, \ldots, x_{ir})$, by the $p$-dimensional multinomial vector $(n_1, \ldots, n_p)$, where $p\ge2$ is chosen by the experimenter along with a set of cutpoints $-\infty = c_0 < c_1 < \cdots < c_p=\infty$, so that for $a=1, \ldots, p$, \[ n_a = \sum_{k=1}^r I\{c_{a-1} < x_{ik} \le c_a\}. \] Note that the multinomial distribution is guaranteed by the conditional i.i.d.\ assumption, and the multinomial probability of the $a$th category is equal to $\theta_a \equiv P_{}(c_{a-1}>= data("Waterdata") cutpts <- 10.5*(-6:6) watermult <- makemultdata(Waterdata, cuts = cutpts) @ Once the multinomial data have been created, we may apply the \code{multmixEM} function to estimate the multinomial parameters via an EM algorithm. <>= set.seed(15) theta4 <- matrix(runif(56), ncol = 14) theta3 <- theta4[1:3,] mult3 <- multmixEM(watermult, lambda = rep(1, 3)/3, theta = theta3) mult4 <- multmixEM (watermult, lambda = rep (1, 4) / 4, theta = theta4) @ Finally, \code{compCDF} calculates and plots the estimated distribution functions of equation (\ref{ecdf}). Figure \ref{WDcutpoint} gives plots for both a 3-component and a 4-component solution; these plots are very similar to the corresponding plots in Figures 1 and 2 of \citet{elmore2004ecc}. <>= cdf3 <- compCDF(Waterdata, mult3$posterior, lwd=2, lab=c(7, 5, 7), xlab="Angle in degrees", ylab="Component CDFs", main="Three-Component Solution") cdf4 <- compCDF(Waterdata, mult4$posterior, lwd=2, lab=c(7, 5, 7), xlab="Angle in degrees", ylab="Component CDFs", main="Four-Component Solution") @ <>= pdf(file="WDcutpoint3comp.pdf", paper="special", width=8, height=8) cdf3 <- compCDF(Waterdata, mult3$posterior, lwd=3, xlab="Angle in degrees", lab=c(7, 5, 7), ylab="Component CDFs", main="Three-Component Solution", cex.axis=1.4, cex.lab=1.5, cex.main=1.5) ltext <- paste(round(mult3$lam*100, 1), "%", sep="") legend("bottomright", legend=ltext, pch=15:17, cex=1.5, pt.cex=1.35) y <- compCDF(Waterdata, mult3$posterior, x=cutpts, makeplot=F) for(i in 1:3) points(cutpts, y[i,], pch=14+i, cex=1.35) dev.off() pdf(file="WDcutpoint4comp.pdf", paper="special", width=8, height=8) cdf4 <- compCDF(Waterdata, mult4$posterior, lwd=3, xlab="Angle in degrees", lab=c(7, 5, 7), ylab="Component CDFs", main="Four-Component Solution", cex.axis=1.4, cex.lab=1.5, cex.main=1.5) ltext <- paste(round(mult4$lam*100,1), "%", sep="") legend("bottomright", legend=ltext, pch=15:18, cex=1.5, pt.cex=1.35) y <- compCDF(Waterdata, mult4$posterior, x=cutpts, makeplot=F) for(i in 1:4) points(cutpts, y[i,], pch=14+i, cex=1.35) dev.off() @ \begin{figure}[!h] \centering \includegraphics[width=0.49\textwidth]{WDcutpoint3comp} \includegraphics[width=0.49\textwidth]{WDcutpoint4comp} \caption{Empirical cumulative distribution function (CDF) estimates for the three- and four-component multinomial cutpoint models for the water-level data; compare Figures 1 and 2 of \citet{elmore2004ecc}. The 13 cutpoints used are indicated by the points in the plots, and the estimated mixing proportions for the various components are given by the legend. } \label{WDcutpoint} \end{figure} As with the output of \code{normalmixEM} in Section~\ref{section:EM}, it is possible to summarize the output of the \code{multmixEM} function using the \code{summary} method for \code{mixEM} objects: <>= summary(mult4) @ \section{Nonparametric and semiparametric methods} \label{section:np} In this section, we consider nonparametric multivariate finite mixture models. The first algorithm presented here was introduced by \citet{benaglia2009} as a generalization of the stochastic semiparametric EM algorithm of \citet{bordes2007sas}. Both algorithms are implemented in \pkg{mixtools}. \subsection{EM-like algorithms for mixtures of unspecified densities} \label{section:EMlike} Consider the mixture model described by equation \eqref{mvmixture}. If we assume that the coordinates of the $\vec X_i$ vector are {\em conditionally independent}, i.e. they are independent conditional on the subpopulation or component ($\phi_1$ through $\phi_m$) from which $\vec X_i$ is drawn, the density in \eqref{mvmixture} can be rewritten as: \begin{equation} \label{mvmixture2} g_{\vec\theta}(\vec x_i) = \sum_{j=1}^m\lambda_j\prod_{k=1}^rf_{jk}(x_{ik}), \end{equation} where the function $f(\cdot)$, with or without subscripts, will always denote a univariate density function. Here we do not assume that $f_{jk}(\cdot)$ comes from a family of densities that may be indexed by a finite-dimensional parameter vector, and we estimate these densities using nonparametric density techniques. That is why we say that this algorithm is a fully nonparametric approach. The density in equation \eqref{mvmixture2} allows for a different distribution for each component and each coordinate of $\vec X_i$. Notice that if the density $f_{jk}(\cdot)$ does not depend on $k$, we have the case in which the $\vec X_i$ are not only conditionally independent but identically distributed as well. These are the two extreme cases. In order to encompass both the conditionally i.i.d. case and the more general case \eqref{mvmixture2} simultaneously in one model, we allow that the coordinates of $\vec X_i$ are conditionally independent and there exist {\em blocks} of coordinates that are also identically distributed. If we let $b_k$ denote the block to which the $k$th coordinate belongs, where $1\le b_k\le B$ and $B$ is the total number of such blocks, then equation \eqref{mvmixture2} is replaced by \begin{equation}\label{rmgeneral} g_{\vec\theta} (\vec x_i) = \sum_{j=1}^m \lambda_j \prod_{k=1}^r f_{j{b_k}} (x_{ik}). \end{equation} The indices $i$, $j$, $k$, and $\ell$ will always denote a generic individual, component (subpopulation), coordinate (repeated measurement), and block, respectively. Therefore, we will always have $1\le i\le n$, $1\le j\le m$, $1\le k\le r$, and $1\le\ell\le B$. The EM algorithm to estimate model \eqref{rmgeneral} has the E-step and M-step described in Section~\ref{sec:EM}. In equation (\ref{posteriors}), we have $\phi_j^{(t)}(\vec x_i) = \prod_{k=1}^r f_{jb_k}^{(t)}(x_{ik})$, where $f_{j\ell}^{(t)}(\cdot)$ is obtained by a weighted nonparametric (kernel) density estimate, given by: \begin{enumerate} \addtocounter{enumi}{2} \item{\bf Nonparametric (Kernel) density estimation step:\ } For any real $u$, define for each component $j\in\{1, \ldots, m\}$ and each block $\ell\in\{1, \ldots, B\}$ \begin{equation} \label{densest} f_{j\ell}^{t+1}(u) = \frac {1}{nh_{j\ell} C_\ell\lambda_{j}^{t+1}} \sum_{k=1}^r \sum_{i=1}^n \post_{ij}^{(t)} I\{b_k=\ell\} K\left(\frac{u-x_{ik}}{h_{j\ell}}\right), \end{equation} where $K(\cdot)$ is a kernel density function, $h_{j\ell}$ is the bandwidth for the $j$th component and $\ell$th block density estimate, and $C_\ell$ is the number of coordinates in the $\ell$th block. \end{enumerate} The function \code{npEM} implements this algorithm in \pkg{mixtools}. This function has an argument \code{samebw} which, when set to \code{TRUE} (the default), takes $h_{j\ell} = h$, for all $1 \le j \le m$ and $1\le\ell\le B$, that is, the same bandwidth for all components and blocks, while \code{samebw = FALSE} allows a different bandwidth for each component and each block, as detailed in \citet{bch:festchrift2009}. This function will, if called using \code{stochastic = TRUE}, replace the deterministic density estimation step (\ref{densest}) by a {\em stochastic} density estimation step of the type proposed by \citet{bordes2007sas}: First, generate $\vec Z^{(t)}_{i} = (Z^{(t)}_{i1}, \ldots, Z^{(t)}_{im})$ as a multivariate random vector with a single trial and success probability vector $\vec p_i^{(t)} = (p_{i1}^{(t)}, \ldots, p_{1m}^{(t)})$, then in the M-step for $\lambda_{j}^{t+1}$ in equation~(\ref{lambda}), replace $p^{(t)}_{ij}$ by $Z^{(t)}_{ij}$ and let \[ f_{j\ell}^{t+1}(u) = \frac {1}{nh_{j\ell} C_\ell\lambda_{j}^{t+1}} \sum_{k=1}^r \sum_{i=1}^n Z_{ij}^{(t)} I\{b_k=\ell\} K\left(\frac{u-x_{ik}}{h_{j\ell}}\right). \] In other words, the stochastic versions of these algorithms re-assign each observation randomly at each iteration, according to the $p_{ij}^{(t)}$ values at that iteration, to one of the $m$ components, then the density estimate for each component is based only on those observations that have been assigned to it. Because the stochastic algorithms do not converge the way a deterministic algorithm often does, the output of \code{npEM} is slightly different when \code{stochastic = TRUE} than when \code{stochastic = FALSE}, the default. See the corresponding help file for details. \citet{benaglia2009} also discuss specific cases of model (\ref{rmgeneral}) in which some of the $f_{jb_k}(\cdot)$ densities are assumed to be the same except for a location and scale change. They refer to such cases as semiparametric since estimating each $f_{jb_k}(\cdot)$ involves estimating an unknown density as well as multiple location and scale parameters. For instance, equation (17) of \citet{benaglia2009} sets \begin{equation} \label{spEM} f_{j\ell}(x) = \frac{1}{\sigma_{j\ell}}f \left( \frac{x-\mu_{j\ell}}{\sigma_{j\ell}} \right), \end{equation} where $\ell=b_k$ for a generic $k$. The \pkg{mixtools} package implements an algorithm for fitting model (\ref{spEM}) in a function called \code{spEM}. Details on the use of this function may be obtained by typing \code{help("spEM")}. Implementation of this algorithm and of that of the \code{npEM} function requires updating the values of $f_{jb_k}(x_{ik})$ for all $i$, $j$, and $k$ for use in the E-step (\ref{posteriors}). To do this, the \code{spEM} algorithm keeps track of an $n\times m$ matrix, called $\Phi$ here, where \[ \Phi_{ij} \equiv \phi_j(\vec x_i) = \prod_{k=1}^r f_{jb_k}(x_{ik}). \] The density estimation step of equation (\ref{densest}) updates the $\Phi$ matrix for the $(t+1)$th iteration based on the most recent values of all of the parameters. For instance, in the case of model (\ref{spEM}), we obtain \begin{eqnarray*} \Phi_{ij}^{t+1} &=& \prod_{\ell=1}^B\prod_{k:b_k=\ell} \frac{1}{\sigma_{j\ell}^{t+1}} f^{t+1} \left( \frac{x-\mu_{j\ell}^{t+1}}{\sigma_{j\ell}^{t+1}} \right) \\ &=& \prod_{\ell=1}^B \prod_{k:b_k=\ell} \frac{1}{\sigma_{j\ell}^{t+1}} \sum_{i'=1}^n \frac{p_{ij}^{t+1}}{hrn\lambda_j^{t+1}} \sum_{k'=1}^r K\left[ \frac{\left(\frac{x_{ik}-\mu_{j\ell}^{t+1}}{\sigma_{j\ell}^{t+1}} \right) - (x_{i'k'} - \mu_{j\ell}^{t+1})} {h\sigma_{j\ell}^{t+1}} \right]. \end{eqnarray*} \subsection{A univariate symmetric, location-shifted semiparametric example} \label{section:SPexample} Both \citet{hunter2007ims} and \citet{bordes2006set} study a particular case of model ({\ref{mvmixture}) in which $x$ is univariate and \begin{equation} \label{spmodel} g_{\vec \theta}(x) = \sum_{j=1}^m\lambda_j \phi(x-\mu_j), \end{equation} where $\phi(\cdot)$ is a density that is assumed to be completely unspecified except that it is symmetric about zero. Because each component distribution has both a nonparametric part $\phi(\cdot)$ and a parametric part $\mu_j$, we refer to this model as semiparametric. Under the additional assumption that $\phi(\cdot)$ is absolutely continuous with respect to Lebesgue measure, \citet{bordes2007sas} propose a stochastic algorithm for estimating the model parameters, namely, $(\vec\lambda, \vec\mu, \phi)$. This algorithm is implemented by the \pkg{mixtools} function \code{spEMsymloc}. This function also implements a nonstochastic version of the algorithm, which is the default and which is a special case of the general algorithm described in Section~\ref{section:EMlike}. <>= pdf(file="spsymmfig1.pdf", paper="special", width=8, height=8) par(mar=0.1+c(5,4.2,4,1.8)) plot(wait1, which = 2, cex.axis = 1.4, cex.lab = 1.5, cex.main = 1.5, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") wait2 <- spEMsymloc(waiting, mu0 = c(55, 80)) plot(wait2, lty = 2, newplot = FALSE, addlegend = FALSE) dev.off() pdf(file="spsymmfig2.pdf", paper="special", width=8, height=8) par(mar=0.1+c(5,4.2,4,1.8)) wait2a <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 1) wait2b <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 6) plot(wait2a, lty = 1, addlegend = FALSE, cex.axis = 1.4, cex.lab = 1.5, cex.main = 1.5, title = "Time between Old Faithful eruptions", xlab = "Minutes") plot(wait2b, lty = 2, newplot = FALSE, addlegend = FALSE) dev.off() @ \begin{figure}[h] \centering \includegraphics[height=3in,width=3in]{spsymmfig1} \includegraphics[height=3in,width=3in]{spsymmfig2} \caption{The Old Faithful dataset, fit using different algorithms in \pkg{mixtools}. Left: the fitted Gaussian components (solid) and a semiparametric fit assuming model (\ref{spmodel}) with the default bandwidth of $4.0$ (dashed); Right: the same model (\ref{spmodel}) using bandwidths of $1.0$ (solid) and $6.0$ (dashed).} \label{spsymmfig} \end{figure} As noted in Figure \ref{geyser}, model (\ref{spmodel}) appears to be an appropriate model for the Old Faithful waiting times dataset. Here, we provide code that applies the \code{spEMsymloc} function to these data. First, we display the normal mixture solution of Figure \ref{geyserEM} with a semiparametric solution superimposed, in Figure \ref{spsymmfig}(a): <>= plot(wait1, which = 2, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") wait2 <- spEMsymloc(waiting, mu0 = c(55, 80)) plot(wait2, lty = 2, newplot = FALSE, addlegend = FALSE) @ Because the semiparametric version relies on a kernel density estimation step (\ref{densest}), it is necessary to select a bandwidth for this step. By default, \code{spEMsymloc} uses a fairly simplistic approach: It applies ``Silverman's rule of thumb'' \citep{silverman1986des} to the entire dataset using the \code{bw.nrd0} function in \proglang{R}. For the Old Faithful waiting time dataset, this bandwidth is about~$4$: <>= bw.nrd0(waiting) @ But the choice of bandwidth can make a big difference, as seen in Figure \ref{spsymmfig}(b). <>= wait2a <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 1) wait2b <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 6) plot(wait2a, lty = 1, addlegend = FALSE, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, xlab = "Minutes", title = "Time between Old Faithful eruptions") plot(wait2b, lty = 2, newplot = FALSE, addlegend = FALSE) @ We find that with a bandwidth near $2$, the semiparametric solution looks quite close to the normal mixture solution of Figure \ref{geyserEM}. Reducing the bandwidth further results in the ``bumpiness'' exhibited by the solid line in Figure \ref{spsymmfig}(b). On the other hand, with a bandwidth of 8, the semiparametric solution completely breaks down in the sense that algorithm tries to make each component look similar to the whole mixture distribution. We encourage the reader to experiment by changing the bandwidth in the above code. \subsection{A trivariate Gaussian example} \label{ss:trigauss} As a first simple, nonparametric example, we simulate a Gaussian trivariate mixture with independent repeated measures and a shift of location between the two components in each coordinate, i.e., $m=2$, $r=3$, and $b_k=k$, $k=1,2,3$. The individual densities $f_{jk}$ are the densities of $\CN(\mu_{jk},1)$, with component means $\vec\mu_1 = (0,0,0)$ and $\vec\mu_2=(3,4,5)$. This example was introduced by \citet{hall2005nim} then later reused by \citet{benaglia2009} for comparison purposes. Note that the parameters in this model are identifiable, since \citet{hall2003nec} showed that for two components ($m=2$), identifiability holds in model~\eqref{mvmixture} is under mild assumptions as long as $r\ge3$, even in the most general case in which $b_k=k$ for all $k$. A function \code{ise.npEM} has been included in \pkg{mixtools} for numerically computing the integrated squared error (ISE) relative to a user-specified true density for a selected estimated density $\hat f_{jk}$ from \code{npEM} output. Each density $\hat f_{jk}$ is computed using equation~(\ref{densest}) together with the posterior probabilities after convergence of the algorithm, i.e., the final values of the $\post_{ij}^t$ (when \code{stochastic = FALSE}). We illustrate the usage of \code{ise.npEM} in this example by running a Monte Carlo simulation for $S$ replications, then computing the square root of the mean integrated squared error (MISE) for each density, where \[ {\rm MISE} = \frac{1}{S}\sum_{s=1}^S \int \left(\hat f_{jk}^{(s)}(u)-f_{jk}(u)\right)^2\,du,\quad j=1,2 \mbox{ and } k=1,2,3. \] For this example, we first set up the model true parameters with $S=100$ replications of $n=300$ observations each: <>= m <- 2; r <- 3; n <- 300; S <- 100 lambda <- c(0.4, 0.6) mu <- matrix(c(0, 0, 0, 3, 4, 5), m, r, byrow = TRUE) sigma <- matrix(rep(1, 6), m, r, byrow = TRUE) @ Next, we set up ``arbitrary'' initial centers, a matrix for storing sums of integrated squared errors, and an integer storing the number of suspected instances of label switching that may occur during the replications: <>= centers <- matrix(c(0, 0, 0, 4, 4, 4), 2, 3, byrow = TRUE) ISE <- matrix(0, m, r, dimnames = list(Components = 1:m, Blocks = 1:r)) nblabsw <- 0 @ Finally, we run the Monte Carlo simulation, using the \code{samebw = FALSE} option since it is more appropriate for this location-shift model: <>= set.seed(1000) for (mc in 1:S) { x <- rmvnormmix(n, lambda, mu, sigma) a <- npEM(x, centers, verb = FALSE, samebw = FALSE) if (a$lambda[1] > a$lambda[2]) nblabsw <- nblabsw + 1 for (j in 1:m) { for (k in 1:r) { ISE[j, k] <- ISE[j, k] + ise.npEM(a, j, k, dnorm, lower = mu[j, k] - 5, upper = mu[j, k] + 5, plots = FALSE, mean = mu[j, k], sd = sigma[j, k])$value #$ } } } MISE <- ISE/S print(sqMISE <- sqrt(MISE)) @ We can examine the \code{npEM} output from the last replication above using <>= summary(a) @ We can also get plots of the estimated component densities for each block (recall that in this example, block $\ell$ consists only of coordinate $\ell$) using the \code{plot} function. The resulting plots are given in Figure~\ref{fig:gausstrivariate}. <>= plot(a) @ <>= pdf("gauss3rm.pdf", paper="special", width=10, height=5) par(mfrow=c(1,3), ask=F) plot(a) dev.off() @ \begin{figure}[h] \centering \includegraphics[width=.99\textwidth]{gauss3rm} \caption{Output of the \code{npEM} algorithm for the trivariate Gaussian model with independent repeated measures.} \label{fig:gausstrivariate} \end{figure} \subsection{A more general multivariate nonparametric example} \label{sec:generalmv} In this section, we fit a more difficult example, with non-multimodal mixture densities (in block \#2), heavy-tailed distributions, and different scales among the coordinates. The model is multivariate with $r=5$ repeated measures and $m=2$ components (hence identifiability holds; cf.\ \citet{hall2003nec} as cited in Section~\ref{ss:trigauss}). The $5$ repeated measures are grouped into $B=2$ blocks, with $b_1=b_2=b_3=1$ and $b_4=b_5=2$. Block $1$ corresponds to a mixture of two noncentral Student $t$ distributions, $t'(2,0)$ and $t'(10,8)$, where the first parameter is the number of degrees of freedom, and the second is the non-centrality. Block~2 corresponds to a mixture of Beta distributions, ${\cal B}(1,1)$ (which is actually the uniform distribution over $[0,1]$) and ${\cal B}(1,5)$. The first component weight is $\lambda_1 = 0.4$. The true mixtures are depicted in Figure~\ref{fig:true5rm}. <>= pdf("truepdf5rm_block1.pdf") par(mar=0.1+c(5,4.2,4,1.5)) x <- seq(-10, 25, len=250) plot(x, .4* dt(x, 2, 0) + .6 * dt(x, 10, 8), type="l", lwd=3, col=2, cex.axis=1.4, cex.lab=1.5, cex.main=1.5, main="Block 1", xlab="", ylab="Density") lines (x, .4*dt(x, 2, 0), lwd=4, lty=2) lines (x, .6*dt(x, 10, 8), lwd=4, lty=2) dev.off() pdf("truepdf5rm_block2.pdf") par(mar=0.1+c(5,4.2,4,1.5)) x <- seq(0, 1, len=250) plot(x, .4 + .6 * dbeta(x, 1, 5), type="l", lwd=3, col=2, cex.axis=1.4, cex.lab=1.5, cex.main=1.5, main="Block 2", xlab="", ylab="Density", ylim= c(0, 3.4)) lines (x, rep(.4, 250), lwd=4, lty=2) lines (x, .6*dbeta(x, 1, 5), lwd=4, lty=2) dev.off() @ \begin{figure}[h] \centering \includegraphics[height=2.5in,width=2.5in]{truepdf5rm_block1} \includegraphics[height=2.5in,width=2.5in]{truepdf5rm_block2} \caption{True densities for the mixture of Section~\ref{sec:generalmv}, with individual component densities (scaled by $\lambda_j$) in dotted lines and mixture densities in solid lines. The noncentral $t$ mixture of coordinates 1 through 3 is on the left, the beta mixture of coordinates 4 and 5 on the right.} \label{fig:true5rm} \end{figure} To fit this model in \pkg{mixtools}, we first set up the model parameters: <>= m <- 2; r <- 5 lambda <- c(0.4, 0.6) df <- c(2, 10); ncp <- c(0, 8) sh1 <- c(1, 1) ; sh2 <- c(1, 5) @ Then we generate a pseudo-random sample of size $n=300$ from this model: <>= n <- 300; z <- sample(m, n, rep = TRUE, prob = lambda) r1 <- 3; z2 <- rep(z, r1) x1 <- matrix(rt(n * r1, df[z2], ncp[z2]), n, r1) r2 <- 2; z2 <- rep(z, r2) x2 <- matrix(rbeta(n * r2, sh1[z2], sh2[z2]), n, r2) x <- cbind(x1, x2) @ For this example in which the coordinate densities are on different scales, it is obvious that the bandwidth in \code{npEM} should depend on the blocks and components. We set up the block structure and some initial centers, then run the algorithm with the option \code{samebw = FALSE}: <>= id <- c(rep(1, r1), rep(2, r2)) centers <- matrix(c(0, 0, 0, 1/2, 1/2, 4, 4, 4, 1/2, 1/2), m, r, byrow = TRUE) b <- npEM(x, centers, id, eps = 1e-8, verb = FALSE, samebw = FALSE) @ Figure~\ref{fig:npEM5rm} shows the resulting density estimates, which may be obtained using the plotting function included in \pkg{mixtools}: <>= plot(b, breaks = 15) @ % plot(b, breaks = 15, cex.main = 1.5, cex.lab = 1.5, cex.axis = 1.4, % cex.legend = 1.5) <>= pdf("npEM5rm.pdf", width=8, height=5) par(mfrow=c(1,2)) plot(b, breaks = 15) dev.off() @ \begin{figure}[h] \centering \includegraphics[width=.95\textwidth]{npEM5rm} \caption{Result of plotting \code{npEM} output for the example of Section~\ref{sec:generalmv}. Since $n=300$, the histogram on the left includes 900 observations and the one on the right includes 600.} \label{fig:npEM5rm} \end{figure} Finally, we can compute the ISE of the estimated density relative to the truth for each block and component. The corresponding output is depicted in Figure \ref{fig:ISEnpEM5rm}. <>= par(mfrow=c(2,2)) for (j in 1:2){ ise.npEM(b, j, 1, truepdf = dt, lower = ncp[j] - 10, upper = ncp[j] + 10, df = df[j], ncp = ncp[j]) ise.npEM(b, j, 2, truepdf = dbeta, lower = -0.5, upper = 1.5, shape1 = sh1[j], shape2 = sh2[j]) } @ <>= options(warn=-1) pdf("ISEnpEM5rm.pdf", width=8, height=8) par(mfrow = c(2, 2)) for (j in 1:2){ ise.npEM(b, j, 1, truepdf = dt, lower = ncp[j] - 10, upper = ncp[j] + 10, df = df[j], ncp = ncp[j]) ise.npEM(b, j, 2, truepdf = dbeta, lower = -0.5, upper = 1.5, shape1 = sh1[j], shape2 = sh2[j]) } dev.off() @ \begin{figure}[h] \centering \includegraphics[height=5in,width=6in]{ISEnpEM5rm} \caption{\code{ise.npEM} output for the 5-repeated measures example; the true densities are $f_{11}\equiv t'(2,0)$, $f_{21}\equiv t'(10,8)$, $f_{12}\equiv {\cal U}_{(0,1)}$, $f_{22}\equiv {\cal B}(1,5)$.} \label{fig:ISEnpEM5rm} \end{figure} \section{Mixtures of regressions} \label{section:reg} \subsection{Mixtures of linear regressions} Consider a mixture setting where we now assume $\textbf{X}_{i}$ is a vector of covariates observed with a response $Y_{i}$. The goal of mixtures of regressions is to describe the conditional distribution of $Y_{i}|\textbf{X}_{i}$. Mixtures of regressions have been extensively studied in the econometrics literature and were first introduced by \citet{quandt1972sr} as the \textit{switching regimes} (or \textit{switching regressions}) problem. A switching regimes system is often compared to \textit{structural change} in a system \citep{quandtram1978sr}. A structural change assumes the system depends deterministically on some observable variables, but switching regimes implies one is unaware of what causes the switch between regimes. In the case where it is assumed there are two heterogeneous classes, \citet{quandt1972sr} characterized the switching regimes problem ``by assuming that nature chooses between regimes with probabilities $\lambda$ and $1-\lambda$''. Suppose we have $n$ independent univariate observations, $y_{1},\ldots,y_{n}$, each with a corresponding vector of predictors, $\textbf{x}_{1},\ldots,\textbf{x}_{n}$, with $\textbf{x}_{i}=(x_{i,1},\ldots,x_{i,p})^\top$ for $i=1,\ldots,n$. We often set $x_{i,1}=1$ to allow for an intercept term. Let $\textbf{y}=(y_{1},\ldots,y_{n})^\top$ and let $\underline{\textbf{X}}$ be the $n\times p$ matrix consisting of the predictor vectors. Suppose further that each observation $(y_{i}, \vec x_i)$ belongs to one of $m$ classes. Conditional on membership in the $j$th component, the relationship between $y_{i}$ and $\textbf{x}_{i}$ is the normal regression model \begin{equation}\label{regmodel} y_{i}=\textbf{x}_{i}^\top\vec{\beta}_{j}+\epsilon_{i}, \end{equation} where $\epsilon_{i}\thicksim \CN(0,\sigma^{2}_{j})$ and $\vec{\beta}_{j}$ and $\sigma_{j}^{2}$ are the $p$-dimensional vector of regression coefficients and the error variance for component $j$, respectively. Accounting for the mixture structure, the conditional density of $y_{i}|\vec x_i$ is \begin{equation}\label{mor} g_{\vec\theta}(y_{i}|\textbf{x}_{i})=\sum_{j=1}^{m}\lambda_{j} \phi(y_{i} | \textbf{x}_{i}^\top\vec{\beta}_{j},\sigma^{2}_{j}), \end{equation} where $\phi(\cdot|\textbf{x}^\top\vec{\beta}_{j},\sigma^{2}_{j})$ is the normal density with mean $\textbf{x}^\top\vec\beta$ and variance $\sigma^2$. Notice that the model parameter for this setting is $\vec\theta=(\vec\lambda,(\vec{\beta}_{1},\sigma^2_{1}),\ldots,(\vec{\beta}_{m},\sigma^2_{m}))$. The mixture of regressions model (\ref{mor}) differs from the well-known mixture of multivariate normals model $(Y_{i},\textbf{X}_{i}^\top)^\top\thicksim \sum_{j=1}^{m}\lambda_{j}\CN_{p+1}(\vec{\mu}_{j},\Sigma_{j})$ because model (\ref{mor}) makes no assertion about the marginal distribution of $\textbf{X}_{i}$, whereas the mixture of multivariate normals specifies that $\textbf{X}_{i}$ itself has a mixture of multivariate normals distribution. <>= data("CO2data") attach(CO2data) pdf("gnpdata.pdf") par(mar=0.1+c(5,4.2,4,1.5)) plot(GNP, CO2, xlab="Gross National Product", ylab=expression(paste(CO[2]," per Capita")), cex.lab=1.5, cex.main=1.5, cex.axis=1.4, main="1996 GNP and Emissions Data") text(GNP, CO2, country, adj=c(.5,-.5)) dev.off() @ \begin{figure}[h] \centering \includegraphics[height=3in,width=3in]{gnpdata.pdf} \caption{1996 data on gross national product (GNP) per capita and estimated carbon dioxide ($\textrm{CO}_{2}$) emissions per capita. Note that ``CH'' stands for Switzerland, not China.} \label{gnpdata} \end{figure} As a simple example of a dataset to which a mixture of regressions models may be applied, consider the sample depicted in Figure \ref{gnpdata}. In this dataset, the measurements of carbon dioxide ($\textrm{CO}_{2}$) emissions are plotted versus the gross national product (GNP) for $n=28$ countries. These data are included \pkg{mixtools}; type \code{help("CO2data")} in \proglang{R} for more details. \citet{hurn} analyzed these data using a mixture of regressions from the Bayesian perspective, pointing out that ``there do seem to be several groups for which a linear model would be a reasonable approximation.'' They further point out that identification of such groups could clarify potential development paths of lower GNP countries. \subsection{EM algorithms for mixtures of regressions} A standard EM algorithm, as described in Section~\ref{section:EM}, may be used to find a local maximum of the likelihood surface. \citet{deveaux1989} describes EM algorithms for mixtures of regressions in more detail, including proposing a method for choosing a starting point in the parameter space. The E-step is the same as for any finite mixture model EM algorithm; i.e., the $p_{ij}^{(t)}$ values are updated according to equation (\ref{posteriors})---or, in reality, equation (\ref{altposteriors})---where each $\phi_j^{(t)}(\vec x_i)$ is replaced in the regression context by $\phi(y_i | \vec x_i^\top\vec\beta_j, \sigma_j^2)$: \begin{equation}\label{regposteriors} \post_{ij}^{(t)} = \left[ 1 + \sum_{j'\ne j} \frac{ \lambda_{j'}^{(t)} \phi(y_i | \vec x_i^\top\vec\beta_{j'}, \sigma_{j'}^2)}{\lambda_j^{(t)} \phi(y_i | \vec x_i^\top\vec\beta_j, \sigma_j^2)} \right]^{-1} \end{equation} The update to the $\lambda$ parameters in the M-step, equation (\ref{lambda}), is also the same. Letting $\textbf{W}_{j}^{(t)}=\textrm{diag}(\post_{1j}^{(t)},\ldots,\post_{nj}^{(t)})$, the additional M-step updates to the $\vec\beta$ and $\sigma$ parameters are given by \begin{eqnarray}\label{betaEM} \vec{\beta}_{j}^{(t+1)} &=& (\underline{\textbf{X}}^\top\textbf{W}_{j}^{(t)}\underline{\textbf{X}})^{-1}\underline{\textbf{X}}^\top \textbf{W}_{j}^{(t)}\textbf{y} \quad \mbox{and} \\ \label{sigma} \sigma_{j}^{2(t+1)} &=& \frac{\biggl\|\textbf{W}_{j}^{1/2(t)}(\textbf{y}-\underline{\textbf{X}}^\top\vec{\beta}_{j}^{(t+1)})\biggr\|^{2}}{\mbox{tr}(\textbf{W}_{j}^{(t)})}, \end{eqnarray} where $\|\textbf{A}\|^{2}=\textbf{A}^\top\textbf{A}$ and $\mbox{tr}(\textbf{A})$ means the trace of the matrix $\textbf{A}$. Notice that equation (\ref{betaEM}) is a weighted least squares (WLS) estimate of $\vec{\beta}_{j}$ and equation (\ref{sigma}) resembles the variance estimate used in WLS. Allowing each component to have its own error variance $\sigma_j^2$ results in the likelihood surface having no maximizer, since the likelihood may be driven to infinity if one component gives a regression surface passing through one or more points exactly and the variance for that component is allowed to go to zero. A similar phenomenon is well-known in the finite mixture-of-normals model where the component variances are allowed to be distinct \citep{mclachlan2000fmm}. However, in practice we observe this behavior infrequently, and the \pkg{mixtools} functions automatically force their EM algorithms to restart at randomly chosen parameter values when it occurs. A local maximum of the likelihood function, a consistent version of which is guaranteed to exist by the asymptotic theory as long as the model is correct and all $\lambda_j$ are positive, usually results without any restarts. The function \code{regmixEM} implements the EM algorithm for mixtures of regressions in \pkg{mixtools}. This function has arguments that control options such as adding an intercept term, \code{addintercept = TRUE}; forcing all $\vec\beta_j$ estimates to be the same, \code{arbmean = FALSE} (for instance, to model outlying observations as having a separate error variance from the non-outliers); and forcing all $\sigma_j^2$ estimates to be the same, \code{arbvar = FALSE}. For additional details, type \code{help("regmixEM")}. As an example, we fit a 2-component model to the GNP data shown in Figure \ref{gnpdata}. \citet{hurn} and \citet{youngphd} selected 2 components for this dataset using model selection criteria, Bayesian approaches to selecting the number of components, and a bootstrapping approach. The function \code{regmixEM} will be used for fitting a 2-component mixture of regressions by an EM algorithm: <>= data("CO2data") attach(CO2data) @ <>= CO2reg <- regmixEM(CO2, GNP, lambda = c(1, 3) / 4, beta = matrix(c(8, -1, 1, 1), 2, 2), sigma = c(2, 1)) @ We can then pull out the final observed log-likelihood as well as estimates for the 2-component fit, which include $\hat{\lambda}$, $\hat{\vec{\beta}}_{1}$, $\hat{\vec{\beta}}_{2}$, $\hat{\sigma}_{1}$, and $\hat{\sigma}_{2}$: <>= summary(CO2reg) @ The reader is encouraged to alter the starting values or let the internal algorithm generate random starting values. However, this fit seems appropriate and the solution is displayed in Figure \ref{co2EM} along with 99\% Working-Hotelling Confidence Bands, which are constructed automatically by the \code{plot} method in this case by assigning each point to its most probable component and then fitting two separate linear regressions: <>= plot(CO2reg, density = TRUE, alpha = 0.01, cex.main = 1.5, cex.lab = 1.5, cex.axis = 1.4) @ \setkeys{Gin}{width=0.49\textwidth} \begin{figure}[!h] \centering <>= for(i in 1:2){ file=paste("CO2reg", i, ".pdf", sep="") pdf(file=file, paper="special", width=6, height=6) plot(CO2reg, whichplots=i, alpha = 0.01, cex.main = 1.5, cex.lab = 1.5, cex.axis = 1.4) dev.off() cat("\\includegraphics{", file, "}\n", sep="") } @ \caption{The GNP data fitted with a 2-component parametric EM algorithm in \pkg{mixtools}. Left: the sequence of log-likelihood values, $L_{\Bx}(\f^{(t)})$; Right: the fitted regression lines with 99\% Working-Hotelling Confidence Bands.} \label{co2EM} \end{figure} \subsection{Predictor-dependent mixing proportions} \label{section:pdmp} Suppose that in model (\ref{mor}), we replace $\lambda_j$ by $\lambda_{j}(\textbf{x}_{i})$ and assume that the mixing proportions vary as a function of the predictors $\textbf{x}_{i}$. Allowing this type of flexibility in the model might be useful for a number of reasons. For instance, sometimes it is the proportions $\lambda_j$ that are of primary scientific interest, and in a regression setting it may be helpful to know whether these proportions appear to vary with the predictors. As another example, consider a \code{regmixEM} model using \code{arbmean = FALSE} in which the mixture structure only concerns the error variance: In this case, $\lambda_j(\vec x)$ would give some sense of the proportion of outliers in various regions of the predictor space. One may assume that $\lambda_{j}(\textbf{x})$ has a particular parametric form, such as a logistic function, which introduces new parameters requiring estimation. This is the idea of the \textit{hierarchical mixtures of experts} (HME) procedure \citep{jacobsall}, which is commonly used in neural networks and which is implemented, for example, in the \pkg{flexmix} package for \proglang{R} \citep{jss:Leisch:2004, Grun+Leisch:2008}. However, a parametric form of $\lambda_{j}(\textbf{x})$ may be too restrictive; in particular, the logistic function is monotone, which may not realistically capture the pattern of change of $\lambda_j$ as a function of $\vec x$. As an alternative, \citet{young2009mor} propose a nonparametric estimate of $\lambda_{j}(\textbf{x}_{i})$ that uses ideas from kernel density estimation. The intuition behind the approach of \citet{young2009mor} is as follows: The M-step estimate (\ref{lambda}) of $\lambda_j$ at each iteration of a finite mixture model EM algorithm is simply an average of the ``posterior'' probabilities $p_{ij}=\E(Z_{ij}|\mbox{data})$. As a substitute, the nonparametric approach uses local linear regression to approximate the $\lambda_j(\textbf{x})$ function. Considering the case of univariate $x$ for simplicity, we set $\lambda_j(x) = \hat\alpha_{0j}(x)$, where \begin{equation}\label{lambdax} (\hat\alpha_{0j}(x), \hat\alpha_{1j}(x))= \arg\min_{(\alpha_0, \alpha_1)} \sum_{i=1}^n K_h(x-x_i) \left[ p_{ij} - \alpha_0 - \alpha_1(x-x_i) \right]^2 \end{equation} and $K_h(\cdot)$ is a kernel density function with scale parameter (i.e., bandwidth) $h$. It is straightforward to generalize equation (\ref{lambdax}) to the case of vector-valued $\vec x$ by using a multivariate kernel function. \citet{young2009mor} give an iterative algorithm for estimating mixture of regression parameters that replaces the standard $\lambda_j$ updates (\ref{lambda}) by the kernel-weighted version (\ref{lambdax}). The algorithm is otherwise similar to a standard EM; thus, like the algorithm in Section~\ref{section:EMlike} of this article, the resulting algorithm is an EM-like algorithm. Because only the $\lambda_j$ parameters depend on $\vec x$ (and are thus ``locally estimated''), whereas the other parameters (the $\vec\beta_j$ and $\sigma_j$) can be considered to be globally estimated, \citet{young2009mor} call this algorithm an iterative global/local estimation (IGLE) algorithm. Naturally, it replaces the usual E-step (\ref{regposteriors}) by a modified version in which each $\lambda_j$ is replaced by $\lambda_j(x_i)$. The function \code{regmixEM.loc} implements the IGLE algorithm in \pkg{mixtools}. Like the \code{regmixEM} function, \code{regmixEM.loc} has the flexibility to include an intercept term by using \code{addintercept = TRUE}. Moreover, this function has the argument \code{kern.l} to specify the kernel used in the local estimation of the $\lambda_{j}(\textbf{x}_{i})$. Kernels the user may specify include \code{"Gaussian"}, \code{"Beta"}, \code{"Triangle"}, \code{"Cosinus"}, and \code{"Optcosinus"}. Further numeric arguments relating to the chosen kernel include \code{kernl.g} to specify the shape parameter for when \code{kern.l = "Beta"} and \code{kernl.h} to specify the bandwidth which controls the size of the window used in the local estimation of the mixing proportions. See the corresponding help file for additional details. For the GNP and emissions dataset, Figure \ref{co2EM} indicates that the assumption of constant weights for the component regressions across all values of the covariate space may not be appropriate. The countries with higher GNP values appear to have a greater probability of belonging to the first component (i.e., the red line in Figure \ref{co2EM}). We will therefore apply the IGLE algorithm to this dataset. We will use the triweight kernel in equation (\ref{lambdax}), which is given by setting $\gamma=3$ in \begin{equation}\label{beta} K_{h}(x)=\frac{1}{hB(1/2,\gamma+1)}\left(1-\frac{x^2}{h^2}\right)^{\gamma}_{+}, \end{equation} where $B(x,y)=\Gamma(x)\Gamma(y)/\Gamma(x+y)$ is the beta function. For the triweight, $B(1/2, 4)$ is exactly $32/35$. This kernel may be specified in \code{regmixEM.loc} with \code{kern.l = "Beta"} and \code{kernl.g = 3}. The bandwidth we selected was $h=20$, which we specify with \code{kernl.h = 20}. For this implementation of the IGLE algorithm, we set the parameter estimates and posterior probability estimates obtained from the mixture of regressions EM algorithm as starting values for $\hat{\vec{\beta}}_{1}$, $\hat{\vec{\beta}}_{2}$, $\hat{\sigma}_{1}$, $\hat{\sigma}_{2}$, and $\lambda(x_{i})$. <>= CO2igle <- regmixEM.loc(CO2, GNP, beta = CO2reg$beta, sigma = CO2reg$sigma, lambda = CO2reg$posterior, kern.l = "Beta", kernl.h = 20, kernl.g = 3) @ We can view the estimates for $\hat{\vec{\beta}}_{1}$, $\hat{\vec{\beta}}_{2}$, $\hat{\sigma}_{1}$, and $\hat{\sigma}_{2}$. Notice that the estimates are comparable to those obtained for the mixture of regressions EM output and the log-likelihood value is slightly higher. <>= summary(CO2igle) @ Next, we can plot the estimates of $\lambda(x_{i})$ from the IGLE algorithm. <>= plot(GNP, CO2igle$post[,1], xlab = "GNP", cex.axis = 1.4, cex.lab = 1.5, ylab = "Final posterior probabilities") lines(sort(GNP), CO2igle$lambda[order(GNP), 1], col=2) abline(h = CO2igle$lambda[1], lty = 2) @ <>= pdf("lamplot.pdf") plot(GNP, CO2igle$post[,1], xlab = "GNP", cex.axis = 1.4, cex.lab = 1.5, ylab = "Final posterior probabilities") lines(sort(GNP), CO2igle$lambda[order(GNP), 1], col=2, lwd=2) abline(h = CO2igle$lambda[1], lty = 2, lwd=2) dev.off() @ This plot is given in Figure \ref{lamplot}. Notice the curvature provided by the estimates from the IGLE fit. These fits indicate an upward trend in the posteriors. The predictor-dependent mixing proportions model provides a viable way to reveal this trend since the regular mixture of regressions fit simply provides the same estimate of $\lambda$ for all $x_{i}$. \begin{figure}[h] \centering \includegraphics[height=3in,width=3in]{lamplot.pdf} \caption{Posterior membership probabilities $p_{i1}$ for component one versus the predictor GNP along with estimates of $\lambda_1(x)$ from the IGLE algorithm (the solid red curve) and $\lambda_1$ from the mixture of linear regressions EM algorithm (the dashed black line).} \label{lamplot} \end{figure} \subsection{Parametric bootstrapping for standard errors} With likelihood methods for estimation in mixture models, it is possible to obtain standard error estimates by using the inverse of the observed information matrix when implementing a Newton-type method. However, this may be computationally burdensome. An alternative way to report standard errors in the likelihood setting is by implementing a parametric bootstrap. \citet{eftib} claim that the parametric bootstrap should provide similar standard error estimates to the traditional method involving the information matrix. In a mixture-of-regressions context, a parametric bootstrap scheme may be outlined as follows: \begin{enumerate} \item Use \code{regmixEM} to find a local maximizer $\hat{\vec\theta}$ of the likelihood. \item For each $\textbf{x}_{i}$, simulate a response value $y_{i}^{*}$ from the mixture density $g_{\hat{\vec\theta}}(\cdot|\textbf{x}_{i})$. \item Find a parameter estimate $\tilde{\vec{\theta}}$ for the bootstrap sample using \code{regmixEM}. \item Use some type of check to determine whether label-switching appears to have occurred, and if so, correct it. \item Repeat steps 2 through 4 $B$ times to simulate the bootstrap sampling distribution of $\hat{\vec\theta}$. \item Use the sample covariance matrix of the bootstrap sample as an approximation to the covariance matrix of $\hat{\vec\theta}$. \end{enumerate} Note that step 3, which is not part of a standard parametric bootstrap, can be especially important in a mixture setting. The \pkg{mixtools} package implements a parametric bootstrap algorithm in the \code{boot.se} function. We may apply it to the regression example of this section, which assumes the same estimate of $\lambda$ for all $x_{i}$, as follows: <>= set.seed(123) CO2boot <- boot.se(CO2reg, B = 100) @ This output consists of both the standard error estimates and the parameter estimates obtained at each bootstrap replicate. An examination of the slope and intercept parameter estimates of the 500 bootstrap replicates reveals that no label-switching is likely to have occurred. For instance, the intercept terms of component one range from 4 to 11, whereas the intercept terms of component two are all tightly clumped around 0: <>= rbind(range(CO2boot$beta[1,]), range(CO2boot$beta[2,])) @ We may examine the bootstrap standard error estimates by themselves as follows: <>= CO2boot[c("lambda.se", "beta.se", "sigma.se")] @ \section[Additional capabilities of mixtools]{Additional capabilities of \pkg{mixtools}} \label{section:misc} \subsection{Selecting the number of components} \label{ss:nbcomp} Determining the number of components $k$ is still a major contemporary issue in mixture modeling. Two commonly employed techniques are information criterion and parametric bootstrapping of the likelihood ratio test statistic values for testing \begin{eqnarray}\label{mixturetest} \nonumber H_{0}&:& k = k_{0} \\ H_{1}&:& k = k_{0}+1 \end{eqnarray} for some positive integer $k_{0}$ \citep{mclach}. The \pkg{mixtools} package has functions to employ each of these methods using EM output from various mixture models. The information criterion functions calculate An Information Criterion (AIC) of \citet{aic}, the Bayesian Information Criterion (BIC) of \citet{schw}, the Integrated Completed Likelihood (ICL) of \citet{biern}, and the consistent AIC (CAIC) of \citet{boz}. The functions for performing parametric bootstrapping of the likelihood ratio test statistics sequentially test $k=k_{0}$ versus $k=k_{0}+1$ for $k_0=1, 2, \ldots$, terminating after the bootstrapped $p$-value for one of these tests exceeds a specified significance level. Currently, \pkg{mixtools} has functions for calculating information criteria for mixtures of multinomials (\code{multmixmodel.sel}), mixtures of multivariate normals under the conditionally i.i.d.\ assumption (\code{repnormmixmodel.sel}), and mixtures of regressions (\code{regmixmodel.sel}). Output from various mixture model fits available in \pkg{mixtools} can also be passed to the function \code{boot.comp} for the parametric bootstrapping approach. The parameter estimates from these EM fits are used to simulate data from the null distribution for the test given in (\ref{mixturetest}). For example, the following application of the \code{multmixmodel.sel} function to the water-level multinomial data from Section~\ref{section:cut} indicates that either 3 or 4 components seems like the best option (no more than 4 are allowed here since there are only 8 multinomial trials per observation and the mixture of multinomials requires $2m \le r+1$ for identifiability): <>= <> set.seed(10) multmixmodel.sel(watermult, comps = 1:4, epsilon = 0.001) @ \citet{youngphd} gives more applications of these functions to real datasets. \subsection{Bayesian methods} Currently, there are only two \pkg{mixtools} functions relating to Bayesian methodology and they both pertain to analyzing mixtures of regressions as described in \citet{hurn}. The \code{regmixMH} function performs a Metropolis-Hastings algorithm for fitting a mixture of regressions model where a proper prior has been assumed. The sampler output from \code{regmixMH} can then be passed to \code{regcr} in order to construct credible regions of the regression lines. Type \code{help("regmixMH")} and \code{help("regcr")} for details and an illustrative example. \section*{Acknowledgments} This research is partially supported by NSF Award SES-0518772. DRH received additional funding from Le Studium, an agency of the Centre National de la Recherche Scientifique of France. \bibliography{mixtools} \end{document} mixtools/NEWS0000755000176200001440000001266514343306274012652 0ustar liggesusersChanges in mixtools 2.0.0 ============================ * 2022-12-05 * Updates included in this major release were due to funding received from the Chan Zuckerberg Initiative: Essential Open Source Software for Science (Grant No. 2020-255193). This has been added to both the DESCRIPTION file and the zzz.R file. * Updated all graphics functions to use plotly. These new functions are prefaced by "plotly_". All of the original plotting functions that used base R graphics are still included in order to maintain backwards compatibility. * Launched a GitHub repo for mixtools, which has been added to DESCRIPTION. Bug requests can be submitted through the repo. * Modified the NAMESPACE to import the necessary functions from the scales package as well as export all of the newly-created plotly graphics functions. * Modified the summary.mixEM() function to fix some output inconsistencies when analyzing results from mvnormalmixEM(). * Changed conditional tests for the class of certain objects to use the inherits() function. The affected functions are boot.comp(), boot.se(), gammamixEM(), and segremixEM(). * Generalized the regmixEM.loc() and lambda() functions to allow multiple predictors. The previous versions only accepted a single predictor even though the documentation mistakenly indicated multiple predictors. The revised functions use a product kernel in the calculation if inputting multiple predictors. Thanks to Julio Trecenti for pointing this out. * Updated links to URLs found in various .Rd files and the CITATION file. * Added Kedai Cheng (UNC - Asheville) as an author of the package. * Resolved issues noted on CRAN regarding escaped LaTeX specials in certain .Rd files. Changes in mixtools 1.2.0 ============================ * 2020-02-05 * Fixed compatibility issues with R 4.0.0. * Modified the NAMESPACE to only import three functions from the kernlab package: kpca(), pcv(), and Q(). * Modified gammamixEM() to reflect the developments in Young, Chen, Hewage, and Nilo-Poyanco (2019). This includes the addition of the argument mom.start to use a method-of-moments starting value strategy, as well as the addition of the fix.alpha argument for estimating a common shape parameter across the different components. * Added the mixturegram() function to construct mixturegrams for determining the number of components, which was introduced by Young, Ke, and Zeng (2018). * Modified the way the mixing proportions were randomly generated in the poisregmix.init() and logisregmix.init() functions. Previously, there was the possibility of generating too small of a mixing component, which could cause numerical instabilities. Thanks to Xiaoqiong Fang for identifying this issue. Changes in mixtools 1.1.0 ============================ * 2017-03-10 * Properly registered native routines for internal C code to conform with R-devel checks. * Fixed some inconsistencies with the S3 methods used. * Added tauequivnormalmixEM() to search for a local maximum of the likelihood surface for a univariate finite mixture of normals with possible equality constraints on the stdev parameters. * Added expRMM_EM() for fitting univariate finite mixtures-of-exponentials with right censoring. Some associated distribution functions for this calculation were also added. * Added weibullRMM_SEM(), which is a stochastic EM algorithm for estimating Reliability Mixture Models (RMM) with censoring. * Added spRMM_SEM(), which is a stochastic EM algorithm for estimating a semiparametric Scaling RMM with censoring. * Corrected an issue with loading WaterdataFull. * Removed dependency on 'boot' package and revised code in the appropriate functions. Thanks to Tim Hesterberg and Karl Millar of Google for this suggestion. * Updated some help files. Changes in mixtools 1.0.4 ============================ * 2016-01-11 * Added mvnpEM() and some related functions, which are multivariate blocks extension to the npEM() function. * Updated some help files. Changes in mixtools 1.0.3 ============================ * 2015-04-17 * Updated the maintainer's contact e-mail. * Added a new npMSL() version, with k-fold cross-validation. * Fixed some errors in the examples due to change in format to the Waterdata dataset. * Updated some references. Changes in mixtools 1.0.2 ============================ * 2014-05-13 * Fixed an indexing error in the boot.comp() function. * Updated some references. Changes in mixtools 1.0.1 ============================ * 2014-01-01 * Fixed a small bug to the boot.comp() function. * Added more complete version of Waterdata dataset, which includes all 579 children originally measured along with age and sex information Changes in mixtools 1.0.0 ============================ * 2013-10-05 * Started a NEWS file as of this version. New capabilities include: * A normalmixMMlc() function was added, for mixtures of univariate Normals with linear constraints on both the means and the variances parameters, requiring a MM-type algorithm. * A spEMsymlocN01() function was added, implementing a specific semiparametric EM-like algorithm for univariate mixture in False Discovery Rate (FDR) estimation, in which setup one component is known and set to the standard normal whereas the second component is semiparametric. Functions for plotting the results from this algorithm and for FDR estimation from its output have also been added. * Some documentation (Rd) files have been updated for examples, and some reference papers in EM-related Rd files have been updated. mixtools/R/0000755000176200001440000000000014343400152012325 5ustar liggesusersmixtools/R/multmixmodelsel.R0000755000176200001440000000350114342153463015707 0ustar liggesusersmultmixmodel.sel <- function (y, comps = NULL, ...) { if (class(y)[1]=="list" && !is.null(y$y)) { y <- y$y } n = dim(y)[1] p = dim(y)[2] m = min(apply(y, 1, sum)) # m = unique(apply(y, 1, sum)) # if (length(m) > 1) { # stop("Each row of y must have same total number of observations") # } max.allowed.comp = floor((m + 1)/2) if (is.null(comps)) comps = 1:max.allowed.comp if (max(comps) > max.allowed.comp) { stop(paste("No more than", max.allowed.comp, "components allowed", "with", m, "multinomial trials")) } aic = NULL bic = NULL caic = NULL icl = NULL ll = NULL theta = matrix(0, 0, p) lambda = NULL for (k in sort(comps)) { # cat("Testing", k, "components: ") # newrows = k - nrow(theta) tmp <- multmix.init(y, k = k) theta <- tmp$theta lambda <- tmp$lambda if (k!=1){ em = multmixEM(y, lambda = lambda, theta = theta, k = k, ...) loglik = em$loglik lambda = em$lambda theta = em$theta # cat(em$iter, "iterations.\n") } else loglik = sum(log(exp(apply(y,1,ldmult,theta=theta)))) aic = c(aic, loglik - (p * k - 1)) bic = c(bic, loglik - log(n) * (p * k - 1)/2) caic = c(caic, loglik - (log(n) + 1) * (p * k - 1)/2) if (k==1) { icl = c(icl, loglik - log(n) * (p * k - 1)/2) } else icl = c(icl, loglik - log(n) * (p * k - 1)/2 - sum(lambda * log(lambda))) ll = c(ll, loglik) } out = rbind(aic, bic, caic, icl, ll) # Winner = apply(out, 1, function(x) (1:length(x))[x == # max(x)]) win = apply(out, 1, which.max) rownames(out) = c("AIC", "BIC", "CAIC", "ICL", "Loglik") colnames(out) = sort(comps) Winner = as.numeric(colnames(out)[win]) cbind(out, Winner) } mixtools/R/bootcomp.R0000755000176200001440000007723314343147341014321 0ustar liggesusersboot.comp <- function (y, x = NULL, N = NULL, max.comp = 2, B = 100, sig = 0.05, arbmean = TRUE, arbvar = TRUE, mix.type = c("logisregmix", "multmix", "mvnormalmix", "normalmix", "poisregmix", "regmix", "regmix.mixed", "repnormmix"), hist = TRUE, ...) { mix.type <- match.arg(mix.type) k = max.comp p = 0 sigtest = 1 Q.star = list() i = 0 if (mix.type == "regmix") { Q0 = 0 Q1 = 0 obs.Q = 0 i = 1 while (sigtest == 1 && i <= k) { Q.star[[i]] = 0 if (i == 1) { w = 1 while (w == 1) { H0.fit = lm(y ~ x) beta = coef(H0.fit) Q0[i] = as.numeric(logLik(H0.fit)) H1.fit = try(regmixEM(y = y, x = x, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) w = 1 else w = 2 beta = coef(H0.fit) xbeta = cbind(1, x) %*% beta xy.sd = sqrt(sum(H0.fit$res^2)/(length(y) - 2)) j = 0 } } while (j < B) { j = j + 1 y.sim = rnorm(length(y), mean = xbeta, sd = xy.sd) xy.simout = lm(y.sim ~ x) em.out = try(regmixEM(y = y.sim, x = x, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out$loglik - as.numeric(logLik(xy.simout))) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } else { w = 1 while (w == 1) { H0.fit = try(regmixEM(y = y, x = x, k = i, arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) H1.fit = try(regmixEM(y = y, x = x, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H0.fit, "try-error", which = TRUE) || inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q0[i] = H0.fit$loglik if (arbmean == FALSE) { scale = H0.fit$scale beta = matrix(rep(H0.fit$beta, i), ncol = i) } else { scale = 1 } Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) w = 1 else w = 2 } beta.new = H0.fit$beta xbeta.new = cbind(1, x) %*% beta.new j = 0 } while (j < B) { j = j + 1 wt = rmultinom(length(y), size = 1, prob = H0.fit$lambda) if (arbmean == FALSE) { y.sim = sapply(1:length(y), function(i) rnorm(1, mean = xbeta.new, sd = ((scale * H0.fit$sigma)[wt[, i] == 1]))) } else { if (arbvar == FALSE) { y.sim = sapply(1:length(y), function(i) rnorm(1, mean = xbeta.new[i, (wt[, i] == 1)], sd = H0.fit$sigma)) } else { y.sim = sapply(1:length(y), function(i) rnorm(1, mean = xbeta.new[i, (wt[, i] == 1)], sd = H0.fit$sigma[wt[, i] == 1])) } } em.out.0 = try(regmixEM(y = y.sim, x = x, k = i, arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) em.out.1 = try(regmixEM(y = y.sim, x = x, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out.0, "try-error", which = TRUE) || inherits(em.out.1, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out.1$loglik - em.out.0$loglik) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } p[i] = mean(Q.star[[i]] >= obs.Q[i]) sigtest = (p[i] < sig) i = i + 1 } } if (mix.type == "repnormmix") { Q0 = 0 Q1 = 0 obs.Q = 0 i = 1 while (sigtest == 1 && i <= k) { Q.star[[i]] = 0 if (i == 1) { w = 1 while (w == 1) { dens = dnorm(y, mean = mean(y), sd = sd(y)) Q0[i] = sum(log(dens[dens > 0])) H1.fit = try(repnormmixEM(x = y, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } j = 0 } } while (j < B) { j = j + 1 y.sim = rmvnormmix(nrow(y), mu = rep(mean(y), ncol(y)), sigma = rep(sd(y), ncol(y))) dens.sim = dnorm(y.sim, mean = mean(y), sd = sd(y)) x.simout = sum(log(dens.sim[dens.sim > 0])) em.out = try(repnormmixEM(x = y.sim, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out$loglik - x.simout) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } else { w = 1 while (w == 1) { H0.fit = try(repnormmixEM(x = y, k = i, arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) H1.fit = try(repnormmixEM(x = y, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H0.fit, "try-error", which = TRUE) || inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q0[i] = H0.fit$loglik if (arbmean == FALSE) scale = H0.fit$scale else scale = 1 Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } } j = 0 } while (j < B) { j = j + 1 wt = rmultinom(length(y), size = 1, prob = H0.fit$lambda) if (arbmean == FALSE) { y.sim = sapply(1:ncol(y), function(i) rnorm(nrow(y), mean = H0.fit$mu, sd = ((scale * H0.fit$sigma)[wt[, i] == 1]))) } else { if (arbvar == FALSE) { y.sim = sapply(1:ncol(y), function(i) rnorm(nrow(y), mean = H0.fit$mu[wt[, i] == 1], sd = H0.fit$sigma)) } else { y.sim = sapply(1:ncol(y), function(i) rnorm(nrow(y), mean = H0.fit$mu[wt[, i] == 1], sd = H0.fit$sigma[wt[, i] == 1])) } } em.out.0 = try(repnormmixEM(x = y.sim, k = i, arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) em.out.1 = try(repnormmixEM(x = y.sim, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out.0, "try-error", which = TRUE) || inherits(em.out.1, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out.1$loglik - em.out.0$loglik) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } p[i] = mean(Q.star[[i]] >= obs.Q[i]) sigtest = (p[i] < sig) i = i + 1 } } if (mix.type == "regmix.mixed") { if (is.list(y)) { if (length(y) != length(x)) stop("Number of elements in lists for x and y must match!") } tt = sapply(1:length(x), function(i) x[[i]][, 1]) beta = t(sapply(1:length(y), function(i) lm(y[[i]] ~ x[[i]])$coef)) y = beta mix.type = "mvnormalmix" } if (mix.type == "mvnormalmix") { Q0 = 0 Q1 = 0 obs.Q = 0 i = 1 while (sigtest == 1 && i <= k) { Q.star[[i]] = 0 if (i == 1) { w = 1 while (w == 1) { y.mean = apply(y, 2, mean) y.cov = cov(y) dens = dmvnorm(y, mu = y.mean, sigma = y.cov) Q0[i] = sum(log(dens[dens > 0])) H1.fit = try(mvnormalmixEM(x = y, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) w = 1 else w = 2 j = 0 } } while (j < B) { j = j + 1 y.sim = rmvnorm(nrow(y), mu = apply(y, 2, mean), sigma = y.cov) dens.sim = dmvnorm(y.sim, mu = y.mean, sigma = y.cov) y.simout = sum(log(dens.sim[dens.sim > 0])) em.out = try(mvnormalmixEM(x = y.sim, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out$loglik - y.simout) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } else { w = 1 while (w == 1) { H0.fit = try(mvnormalmixEM(x = y, k = i, ...), silent = TRUE) H1.fit = try(mvnormalmixEM(x = y, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H0.fit, "try-error", which = TRUE) || inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q0[i] = H0.fit$loglik if (arbmean == FALSE) { H0.fit$mu = lapply(1:i, function(l) H0.fit$mu) } if (arbvar == FALSE) { H0.fit$sigma = lapply(1:i, function(l) H0.fit$sigma) } Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } } j <- 0 } while (j < B) { j = j + 1 wt = rmultinom(nrow(y), size = 1, prob = H0.fit$lambda) if (arbmean == FALSE) { y.sim = t(sapply(1:nrow(y), function(i) rmvnorm(1, mu = H0.fit$mu, sigma = H0.fit$sigma[wt[, i] == 1][[1]]))) } else { if (arbvar == FALSE) { y.sim = t(sapply(1:nrow(y), function(i) rmvnorm(1, mu = H0.fit$mu[wt[, i] == 1][[1]], sigma = H0.fit$sigma))) } else { y.sim = t(sapply(1:nrow(y), function(i) rmvnorm(1, mu = H0.fit$mu[wt[, i] == 1][[1]], sigma = H0.fit$sigma[wt[, i] == 1][[1]]))) } } em.out.0 = try(mvnormalmixEM(x = y.sim, k = i, arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) em.out.1 = try(mvnormalmixEM(x = y.sim, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out.0, "try-error", which = TRUE) || inherits(em.out.1, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out.1$loglik - em.out.0$loglik) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } p[i] = mean(Q.star[[i]] >= obs.Q[i]) sigtest = (p[i] < sig) i = i + 1 } } if (mix.type == "normalmix") { Q0 = 0 Q1 = 0 obs.Q = 0 i = 1 while (sigtest == 1 && i <= k) { Q.star[[i]] = 0 if (i == 1) { w = 1 while (w == 1) { dens = dnorm(y, mean = mean(y), sd = sd(y)) Q0[i] = sum(log(dens[dens > 0])) H1.fit = try(normalmixEM(x = y, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } j = 0 } } while (j < B) { j = j + 1 y.sim = rnorm(length(y), mean = mean(y), sd = sd(y)) dens.sim = dnorm(y.sim, mean = mean(y), sd = sd(y)) x.simout = sum(log(dens.sim[dens.sim > 0])) em.out = try(normalmixEM(x = y.sim, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out$loglik - x.simout) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } else { w = 1 while (w == 1) { H0.fit = try(normalmixEM(x = y, k = i, arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) H1.fit = try(normalmixEM(x = y, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(H0.fit, "try-error", which = TRUE) || inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q0[i] = H0.fit$loglik if (arbmean == FALSE) scale = H0.fit$scale else scale = 1 Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } } j = 0 } while (j < B) { j = j + 1 wt = rmultinom(length(y), size = 1, prob = H0.fit$lambda) if (arbmean == FALSE) { y.sim = sapply(1:length(y), function(i) rnorm(1, mean = H0.fit$mu, sd = ((scale * H0.fit$sigma)[wt[, i] == 1]))) } else { if (arbvar == FALSE) { y.sim = sapply(1:length(y), function(i) rnorm(1, mean = H0.fit$mu[(wt[, i] == 1)], sd = H0.fit$sigma)) } else { y.sim = sapply(1:length(y), function(i) rnorm(1, mean = H0.fit$mu[(wt[, i] == 1)], sd = H0.fit$sigma[wt[, i] == 1])) } } em.out.0 = try(normalmixEM(x = y.sim, k = i, arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) em.out.1 = try(normalmixEM(x = y.sim, k = (i + 1), arbmean = arbmean, arbvar = arbvar, ...), silent = TRUE) if (inherits(em.out.0, "try-error", which = TRUE) || inherits(em.out.1, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out.1$loglik - em.out.0$loglik) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } p[i] = mean(Q.star[[i]] >= obs.Q[i]) sigtest = (p[i] < sig) i = i + 1 } } if (mix.type == "multmix") { Q0 = 0 Q1 = 0 obs.Q = 0 i = 1 while (sigtest == 1 && i <= k) { Q.star[[i]] = 0 if (i == 1) { w = 1 while (w == 1) { m = apply(y, 1, sum) n.i = apply(y, 2, sum) theta = n.i/sum(n.i) Q0[i] = sum(log(exp(apply(y, 1, ldmult, theta = theta)))) H1.fit = try(multmixEM(y = y, k = (i + 1), ...), silent = TRUE) if (inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } j = 0 } } while (j < B) { j = j + 1 y.sim = matrix(0, ncol = ncol(y), nrow = nrow(y)) for (l in 1:length(m)) { y.sim[l, ] <- rmultinom(1, size = m[l], prob = theta) } theta.sim = apply(y.sim, 2, sum)/sum(apply(y.sim, 2, sum)) y.simout = sum(log(exp(apply(y.sim, 1, ldmult, theta = theta)))) em.out = try(multmixEM(y = y.sim, k = (i + 1), ...), silent = TRUE) if (inherits(em.out, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out$loglik - y.simout) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } else { w = 1 while (w == 1) { H0.fit = try(multmixEM(y = y, k = i, ...), silent = TRUE) H1.fit = try(multmixEM(y = y, k = (i + 1), ...), silent = TRUE) if (inherits(H0.fit, "try-error", which = TRUE) || inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { theta = H0.fit$theta Q0[i] = H0.fit$loglik Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } } j = 0 } while (j < B) { j = j + 1 wt = rmultinom(nrow(y), size = 1, prob = H0.fit$lambda) # y.sim = t(sapply(1:nrow(y), function(i) rmultinom(1, # size = n.i[i], prob = H0.fit$theta[(wt[, # i] == 1), ]))) new.y.sim = t(sapply(1:nrow(y), function(i) rmultinom(1, size = n.i, prob = H0.fit$theta[(wt[, i] == 1), ]))) # new.y.sim = 0 em.out.0 = try(multmixEM(y = new.y.sim, k = i, ...), silent = TRUE) em.out.1 = try(multmixEM(y = new.y.sim, k = (i + 1), ...), silent = TRUE) if (inherits(em.out.0, "try-error", which = TRUE) || inherits(em.out.1, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out.1$loglik - em.out.0$loglik) Q.star[[i]][j] if (Q.star[[i]][j] < 0) { j = j - 1 } } } } p[i] = mean(Q.star[[i]] >= obs.Q[i]) sigtest = (p[i] < sig) i = i + 1 } } if (mix.type == "logisregmix") { if (is.null(N)) stop("Number of trials must be specified!") Q0 = 0 Q1 = 0 obs.Q = 0 i = 1 while (sigtest == 1 && i <= k) { Q.star[[i]] = 0 if (i == 1) { w = 1 while (w == 1) { H0.fit = glm(cbind(y, N - y) ~ x, family = binomial()) Q0[i] = logLik(H0.fit) H1.fit = try(logisregmixEM(y = y, x = x, N = N, k = (i + 1), ...), silent = TRUE) if (inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } beta = coef(H0.fit) xbeta = cbind(1, x) %*% beta j = 0 } } while (j < B) { j = j + 1 y.sim = rbinom(length(y), size = N, prob = inv.logit(xbeta)) xy.simout = glm(cbind(y.sim, N - y.sim) ~ x, family = binomial()) em.out = try(logisregmixEM(y = y.sim, x = x, N = N, k = (i + 1), ...), silent = TRUE) if (inherits(em.out, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out$loglik - logLik(xy.simout)) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } else { w = 1 while (w == 1) { H0.fit = try(logisregmixEM(y = y, x = x, N = N, k = i, ...), silent = TRUE) H1.fit = try(logisregmixEM(y = y, x = x, N = N, k = (i + 1), ...), silent = TRUE) if (inherits(H0.fit, "try-error", which = TRUE) || inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q0[i] = H0.fit$loglik Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } beta = H0.fit$beta xbeta = cbind(1, x) %*% beta } j = 0 } while (j < B) { j = j + 1 wt = rmultinom(length(y), size = 1, prob = H0.fit$lambda) y.sim = sapply(1:length(y), function(i) rbinom(1, size = N[i], prob = inv.logit(xbeta)[, (wt[, i] == 1)])) em.out.0 = try(logisregmixEM(y = y.sim, x = x, N = N, k = i, ...), silent = TRUE) em.out.1 = try(logisregmixEM(y = y.sim, x = x, N = N, k = (i + 1), ...), silent = TRUE) if (inherits(em.out.0, "try-error", which = TRUE) || inherits(em.out.1, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out.1$loglik - em.out.0$loglik) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } p[i] = mean(Q.star[[i]] >= obs.Q[i]) sigtest = (p[i] < sig) i = i + 1 } } if (mix.type == "poisregmix") { Q0 = 0 Q1 = 0 obs.Q = 0 i = 1 while (sigtest == 1 && i <= k) { Q.star[[i]] = 0 if (i == 1) { w = 1 while (w == 1) { H0.fit = glm(y ~ x, family = poisson()) Q0[i] = logLik(H0.fit) H1.fit = try(poisregmixEM(y = y, x = x, k = (i + 1), ...), silent = TRUE) if (inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } beta = coef(H0.fit) xbeta = cbind(1, x) %*% beta j = 0 } } while (j < B) { j = j + 1 y.sim = rpois(length(y), lambda = exp(xbeta)) xy.simout = glm(y.sim ~ x, family = poisson()) em.out = try(poisregmixEM(y = y.sim, x = x, k = (i + 1), ...), silent = TRUE) if (inherits(em.out, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out$loglik - logLik(xy.simout)) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } else { w = 1 while (w == 1) { H0.fit = try(poisregmixEM(y = y, x = x, k = i, ...), silent = TRUE) H1.fit = try(poisregmixEM(y = y, x = x, k = (i + 1), ...), silent = TRUE) if (inherits(H0.fit, "try-error", which = TRUE) || inherits(H1.fit, "try-error", which = TRUE)) { w = 1 } else { Q0[i] = H0.fit$loglik Q1[i] = H1.fit$loglik obs.Q[i] = 2 * (Q1[i] - Q0[i]) if (obs.Q[i] < 0) { w = 1 } else { w = 2 } beta = H0.fit$beta xbeta = cbind(1, x) %*% beta } j = 0 } while (j < B) { j = j + 1 wt = rmultinom(length(y), size = 1, prob = H0.fit$lambda) y.sim = sapply(1:length(y), function(i) rpois(1, lambda = exp(xbeta)[, (wt[, i] == 1)])) em.out.0 = try(poisregmixEM(y = y.sim, x = x, k = i, ...), silent = TRUE) em.out.1 = try(poisregmixEM(y = y.sim, x = x, k = (i + 1), ...), silent = TRUE) if (inherits(em.out.0, "try-error", which = TRUE) || inherits(em.out.1, "try-error", which = TRUE)) { j = j - 1 } else { Q.star[[i]][j] = 2 * (em.out.1$loglik - em.out.0$loglik) if (Q.star[[i]][j] < 0) { j = j - 1 } } } } p[i] = mean(Q.star[[i]] >= obs.Q[i]) sigtest = (p[i] < sig) i = i + 1 } } if (hist) { if (length(p) == 2) { par(mfrow = c(1, 2)) for (i in 1:length(p)) { hist(Q.star[[i]], xlab = c("Bootstrap Likelihood", "Ratio Statistic"), main = paste(i, "versus", i + 1, "Components")) segments(obs.Q[i], 0, obs.Q[i], B, col = 2, lwd = 2) } } else { g = ceiling(sqrt(length(p))) par(mfrow = c(g, g)) for (i in 1:length(p)) { hist(Q.star[[i]], xlab = c("Bootstrap Likelihood", "Ratio Statistic"), main = paste(i, "versus", i + 1, "Components")) segments(obs.Q[i], 0, obs.Q[i], B, col = 2, lwd = 2) } } } if (p[length(p)] < sig) { cat("Decision: Select", length(p) + 1, "Component(s)", "\n") } else { cat("Decision: Select", length(p), "Component(s)", "\n") } list(p.values = p, log.lik = Q.star, obs.log.lik = obs.Q) }mixtools/R/plotly_seq.npEM.R0000644000176200001440000000720114343053456015514 0ustar liggesusersplotly_seq.npEM <- function(x, col = '#1f77b4' , width = 6, xlab = "Iteration" , xlab.size = 15 , xtick.size = 15, ylab.size = 15 , ytick.size = 15, title.size = 15 , title.x = 0.5 , title.y = 0.95){ r <- NCOL(x$data) n <- NROW(x$data) m <- length(x$lambdahat) iter <- NROW(x$lambda) nbcol <- 1 if (!is.null(x$symmetric) && x$symmetric){nbcol <- 2} # in all cases, plots the lambda's for (j in 1:m){ estim <- paste(round(x$lambdahat[j],3)) # tt <- substitute(expression(paste("sequence of ",lambda[j], # ", estimate ",widehat(lambda[j]),"=", estim, sep=""))) tt <- paste("Sequence of " ,'λ',"",j,"", " (Estimated ","λ","",j,"","=",estim, ")",sep="") # ylabel <- substitute(expression(paste(lambda[j],sep=""))) ylabel <- paste('λ',"",j,"",sep="") plot1 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(x$lambda[,j]) , by = 1), y = x$lambda[,j] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col), showlegend = FALSE)%>% add_trace(x = c(0 , iter), y = rep(x$lambdahat[j],2) , type = 'scatter' , mode = 'lines', line = list(width = width , color = 'red' , dash = "dash"), showlegend = FALSE)%>% plotly::layout( title = list(text = tt, x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = eval(ylabel), font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) print(plot1) } ## for symmetric location spEM case plots mu if (!is.null(x$symmetric) && x$symmetric){ for (j in 1:m){ estim <- paste(round(x$muhat[j],3)) # tt <- substitute(expression(paste("sequence of ",mu[j], # ", estimate ",widehat(mu[j]),"=",estim,sep=""))) tt <- paste("Sequence of " ,'μ',"",j,"", " (Estimated ","μ","",j,"","=",estim, ")",sep="") # ylabel <- substitute(expression(paste(mu[j],sep=""))) ylabel <- paste('μ',"",j,"",sep="") plot2 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(x$mu[,j]) , by = 1), y = x$mu[,j] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col), showlegend = FALSE)%>% add_trace(x = c(0 , iter), y = rep(x$muhat[j],2) , type = 'scatter' , mode = 'lines', line = list(width = width , color = 'red' , dash = "dash"), showlegend = FALSE)%>% plotly::layout( title = list(text = tt, x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = eval(ylabel), font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) print(plot2) } } }mixtools/R/ddirichlet.R0000755000176200001440000000053114342153463014576 0ustar liggesusersddirichlet <- function (x, alpha) { if (length(x) != length(alpha)) stop("Mismatch between dimensions of x and alpha in ddirichlet().\n") logD <- sum(lgamma(alpha)) - lgamma(sum(alpha)) s <- sum((alpha - 1) * log(x)) pd <- exp(sum(s) - logD) pd[any(x < 0 | x > 1)] <- 0 if(sum(x) != 1) pd <- 0 return(pd) }mixtools/R/tryflare.R0000755000176200001440000000646714342153463014331 0ustar liggesuserstry.flare <- function (y, x, lambda = NULL, beta = NULL, sigma = NULL, alpha = NULL, nu=1, epsilon = 1e-04, maxit = 10000, verb = FALSE, restart=50) { loglik <- function(res, sigma, lambda, alpha) { tmp <- lambda*dnorm(res,sd=sqrt(sigma)) + (1-lambda)*dexp(res,rate=alpha) sum(log(tmp)) } Q=function(res, sigma, lambda, alpha, z) { Q <- sum(z*log(lambda)) + sum((1-z)*log(1-lambda)) - log(2*pi*sigma)*sum(z)/2 - sum(z*res^2)/2/sigma + log(alpha)*sum(1-z) - alpha*sum((1-z)*res) Q } Z <- function(res, sigma, lambda, alpha) { z=rep(1, length(res)) z[res>0] = lambda / (lambda+(1-lambda)* sqrt(2*pi*sigma) * alpha * as.vector(exp(res[res>0]^2/2/sigma - alpha*res[res>0]))) z } x <- cbind(1, x) n <- length(y) p <- ncol(x) est <- flaremix.init(y=y, x=x, lambda=lambda, beta=beta, sigma=sigma, alpha=alpha) lambda <- est$lambda beta <- est$beta sigma <- est$sigma alpha <- est$alpha diff <- 1 iter <- 0 counts <- 0 ll.counts<-0 xbeta <- x %*% beta res <- y - xbeta dn <- dnorm(res,sd=sqrt(sigma)) de <- dexp(res,rate=alpha) obsloglik <- loglik(res, sigma, lambda, alpha) ll<-obsloglik Q1 <- -Inf all.Q <- NULL z=Z(res,sigma,lambda,alpha) while (sum(abs(diff) > epsilon)>0 && iter < maxit) { iter=iter+1 temp=(solve(-1/sigma*t(x) %*% sweep(x, 1, z, "*") + nu*t(x) %*% sweep(x, 1, (1-z)/(y-x%*%beta), "*"))%*%(1/sigma*(apply(sweep(x,1,z*(y-x%*%beta),"*"),2,sum)) +alpha*apply(sweep(x,1,1-z,"*"),2,sum))) m=1 while(m0) beta.new=beta else beta.new=beta.new xbeta.new <- x %*% beta.new res.new <- y-xbeta.new Q.beta <- Q(res.new,sigma,lambda,alpha,z) if(Q.beta < Q1) j=j+1 else j=101 } if(j==restart) stop(paste("Too many attempts at step-halving!","\n")) z.new=Z(res.new,sigma,lambda,alpha) lambda.new <- mean(z.new) sigma.new <- sum(z.new*(res.new^2))/sum(z.new) alpha.new <- sum(1-z.new[res.new>0])/sum((1-z.new[res.new>0])*res.new[res.new>0]) diff <- c(lambda.new,beta.new,sigma.new,alpha.new)-c(lambda,beta,sigma,alpha) z.new2=Z(res,sigma,lambda,alpha) # z.new2=z.new2/apply(z.new2,1,sum) Q.new <- Q(res.new,sigma.new,lambda.new,alpha.new,z.new2) q.diff=Q.new-Q1 if(q.diff<0) m=m+1 else m=101 } if(m==restart) stop(paste("Too many attempts at step-halving!","\n")) lambda <- lambda.new beta <- beta.new xbeta <- xbeta.new res <- res.new sigma <- sigma.new alpha <- alpha.new z<-z.new2 newobsloglik <- loglik(res.new, sigma.new, lambda.new, alpha.new) ll<-c(ll, newobsloglik) counts <- counts + (Q.newnewobsloglik) Q1 <- Q.new obsloglik <- newobsloglik if(verb==TRUE) cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n") } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } # par(mfrow=c(2,1)) # plot(all.Q,type="l") # plot(ll,type="l") cat("number of iterations=", iter, "\n") a=list(x=x,y=y,posterior=cbind(z,1-z),lambda=c(lambda,1-lambda),beta=beta,sigma=sigma,alpha=alpha,loglik=obsloglik,all.loglik=ll,ft="flaremixEM") class(a)="mixEM" a } mixtools/R/plotly_ise.npEM.R0000644000176200001440000000541514343042424015502 0ustar liggesusersplotly_ise.npEM <- function(npEMout, component=1, block=1, truepdf=dnorm, lower=-Inf, upper=Inf, plots = TRUE , col = NULL , width = 3, title = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "t" , xlab.size = 15 , xtick.size = 15, ylab = "" , ylab.size = 15 , ytick.size = 15, legend.text = "" , legend.text.size = 15 , legend.size = 15, ...){ coords <- npEMout$blockid == block bs <- sum(coords) # block size xx <- as.vector(npEMout$data[,coords]) # flatten data wts <- rep(npEMout$post[,component],bs) # duplicate weights if (is.matrix(npEMout$bandwidth)){ bw <- npEMout$bandwidth[block,component] } else {bw <- npEMout$bandwidth} integrand = function(u,...) { (wkde(xx,u,wts,bw) - truepdf(u,...))^2 } numint <- integrate(integrand,lower,upper, ...) if (is.null(col)){ col <- hue_pal()(2) } if (length(col) != 2){ print("Please specify 2 colors in 'col'.") } if (plots){ # plot of estimated and truepdf ise <- paste(round(numint$value,4)) temp=paste(component, block, sep="") if (is.null(title)){ title = substitute(expression(paste("Integrated Squared Error for ", f[temp]," = ",ise,sep=""))) } if (!is.finite(lower)) { lower <- min(xx) } if (!is.finite(upper)) { upper <- max(xx) } u <- seq(lower,upper, 0.01) fhat <- wkde(xx,u,wts,bw) ymax <- max(max(truepdf(u, ...)),max(fhat)) plot <- plot_ly()%>% add_trace(x=u , y=fhat , type = 'scatter' , mode = 'lines', line = list(width = (width/2) , color = col[2]), name = "Fitted", showlegend = TRUE)%>% add_trace(x=u , y=truepdf(u, ...) , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[1]), name = "True", showlegend = TRUE)%>% plotly::layout( legend = list(title=list(text=legend.text, font=list(size=legend.text.size)), font = list(size=legend.size)), title = list(text = eval(title), x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) } print(plot) numint }mixtools/R/depth.R0000755000176200001440000000243514342153463013574 0ustar liggesusers###################################################################### # the following depth function can compute the depth for # # multi points at one time # ###################################################################### #dyn.load("~fxuan/depth/spherical/sphericaldepth.so") depth <- function(pts,x,Cx=var(x)){ x=x%*%t(chol(solve(Cx))) pts=pts%*%t(chol(solve(Cx))) # y <- .Fortran("mudepth", # as.integer(nrow(x)), # as.integer(nrow(pts)), # as.integer(ncol(x)), # as.single(pts), # as.single(x), # as.integer(1:nrow(pts)), # as.single(1:nrow(pts)), # PACKAGE="mixtools") # Now rewritten in C: y <- .C(C_mudepth, as.integer(nrow(x)), as.integer(nrow(pts)), as.integer(ncol(x)), as.double(pts), as.double(x), integer(nrow(pts)), double(nrow(pts)), PACKAGE="mixtools") count <- y[[6]] n <- nrow(x) # depth <- sqrt(8)*(count-n*(n-1)/4)/sqrt((n*(n-1)))#this is to standardize the depth # depth <- (factorial(n)/(2*factorial(n-2)))^(-1)*count depth <- choose(n,2)^(-1)*count depth } mixtools/R/rnormmix.R0000755000176200001440000000050614342153463014340 0ustar liggesusers# Simulate from a normal mixture. New version simply calls rmvnormmix. # normmix.sim is here for backwards compatibility rnormmix <- normmix.sim <- function(n,lambda=1,mu=0,sigma=1) { if (NCOL(mu)>1 || NCOL(sigma)>1) stop ("Use the rmvnormmix function instead.") as.vector(rmvnormmix(n,lambda,mu,sigma)) } mixtools/R/plot.npEM.R0000755000176200001440000000406614342153463014306 0ustar liggesusersplot.spEM <- plot.npEM <- function(x, blocks = NULL, hist=TRUE, addlegend=TRUE, scale = TRUE, title=NULL, breaks="Sturges", ylim=NULL, dens.col, newplot=TRUE, pos.legend="topright", cex.legend=1, ...) { r <- NCOL(x$data) m <- NCOL(x$posteriors) blockid <- x$blockid if (is.null(blocks)) { if(!is.null(blockid)) { blocks <- 1:max(blockid) } else { blocks <- blockid <- 1:r } } ask <- par(ask=(length(unique(blocks))>1)) ylim.orig <- ylim out <- list(x=list(), y=list()) if (!newplot) { hist <- FALSE } for(i in 1:length(blocks)) { coords <- blockid == blocks[i] ylim <- ylim.orig if (is.null(title)) { if (r>1) { tt <- paste(which(coords), collapse=",") tt <- paste("Coordinate", ifelse(sum(coords)>1, "s ", " "), tt, sep="") } else { tt <- "Density Curves" } } else { tt <- rep(title,length(blocks))[i] } dx <- dy <- NULL for (j in 1:m) { d <- density(x, component=j, block=blocks[i], scale=scale) dx <- cbind(dx, d$x) dy <- cbind(dy, d$y) } xx <- as.vector(as.matrix(x$data)[,coords]) if (is.null(ylim)) { ylim=range(dy) if (hist) { ylim[2] <- max(ylim[2], hist(xx, breaks=breaks, plot=FALSE)$density) } } if (!hist && newplot) { pf <- plot # Use plot or hist as plotting fn the 1st time only, then lines } else { pf <- lines } if (hist) { hist(xx, breaks=breaks, prob=TRUE, ylim=ylim, main="", ...) } if (missing(dens.col)) dens.col <- 2:(m+1) dens.col <- rep(dens.col, length.out=m) for (j in 1:m) { pf(dx[,j],dy[,j], type="l", lwd=2, col=dens.col[j], ylim=ylim, ...) pf <- lines } if (addlegend) { legend(pos.legend, legend=round(x$lambdahat,3), fill=dens.col, cex=cex.legend) out$x[[i]]<-dx out$y[[i]]<-dy } if (newplot) { title(main=tt, ...) } } par(ask=ask) invisible(out) } mixtools/R/poisregmixEM.R0000755000176200001440000000641614342153463015103 0ustar liggesuserspoisregmixEM = function (y, x, lambda = NULL, beta = NULL, k = 2, addintercept = TRUE, epsilon = 1e-08, maxit = 10000, verb=FALSE) { if (addintercept) { x = cbind(1, x) } else x = as.matrix(x) n <- length(y) p <- ncol(x) tmp <- poisregmix.init(y=y, x=x, lambda=lambda, beta=beta, k=k) lambda <- tmp$lambda beta <- tmp$beta k <- tmp$k xbeta <- x %*% beta z <- matrix(0, n, k) diff <- 1 iter <- 0 comp <- t(t(dpois(y, exp(xbeta))) * lambda) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik restarts <- 0 while (diff > epsilon && iter < maxit) { j.star = apply(xbeta, 1, which.max) for (i in 1:n) { for (j in 1:k) { z[i, j] = lambda[j]/lambda[j.star[i]] * exp(y[i] * (xbeta[i, j] - xbeta[i, j.star[i]]) + exp(xbeta[i, j.star[i]]) - exp(xbeta[i, j])) } } z = z/apply(z, 1, sum) z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) if(sum(is.na(z))>0){ cat("Need new starting values due to underflow...","\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- poisregmix.init(y=y, x=x, k=k) lambda <- tmp$lambda beta <- tmp$beta k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta comp <- t(t(dpois(y, exp(xbeta))) * lambda) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik } else{ lambda <- apply(z, 2, mean) lm.out <- lapply(1:k, function(j) try(glm.fit(x, y, weights = z[, j], family = poisson()) ,silent=TRUE)) beta = sapply(lm.out,coef) xbeta <- x %*% beta comp <- t(t(dpois(y, exp(xbeta))) * lambda) compsum <- apply(comp, 1, sum) newobsloglik <- sum(log(compsum)) if(abs(newobsloglik)==Inf || is.na(newobsloglik) || newobsloglik < obsloglik){# || sum(z)!=n){ cat("Need new starting values due to singularity...","\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- poisregmix.init(y=y, x=x, k=k) lambda <- tmp$lambda beta <- tmp$beta k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta comp <- t(t(dpois(y, exp(xbeta))) * lambda) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik } else{ diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n") } } } } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") beta <- matrix(beta,ncol=k) rownames(beta) <- c(paste("beta", ".", 0:(p-1), sep = "")) colnames(beta) <- c(paste("comp", ".", 1:k, sep = "")) colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, y=y, lambda = lambda, beta = beta, loglik = obsloglik, posterior = z, all.loglik=ll, restarts=restarts, ft="poisregmixEM") class(a) = "mixEM" a } mixtools/R/regcr.R0000755000176200001440000000537314342153463013576 0ustar liggesusers# Produce credible region for regression lines based on # sample from posterior distribution of beta parameters. # It is assumed that beta, upon entry, is an nx2 matrix, # where the first column gives the intercepts and the # second column gives the slopes. # alpha is the proportion of beta to remove from the posterior. # Thus, 1-alpha is the level of the credible region. # # If nonparametric=TRUE, then the region is based on the convex # hull of the remaining beta after trimming, which is accomplished # using a data depth technique. # # If nonparametric=FALSE, then the region is based on the # asymptotic normal approximation. regcr=function (beta, x, em.beta=NULL, em.sigma=NULL, alpha = 0.05, nonparametric = FALSE, plot = FALSE, xyaxes = TRUE, ...) { if (nonparametric) { beta.old=beta if(is.null(em.sigma) && is.null(em.beta)){ beta=t(matsqrt(solve(cov(beta)))%*%(t(beta)-apply(beta,2,mean))) } else beta=1/sqrt(length(x))*t(em.sigma^(-1)*matsqrt(t(cbind(1,x))%*%cbind(1,x))%*%(t(beta.old)-em.beta)) d = depth(beta, beta) beta = beta.old[order(d), ] d = d[order(d)] n = length(d) trimbeta = beta[-(1:round(n * alpha)), ] h = unique(trimbeta[chull(trimbeta), ]) nh = nrow(h) m = which.max(h[, 2]) h = rbind(h[m:nh, ], h[((1:nh) < m), ], h[m, ]) bound = NULL for (i in 1:nh) { bound = rbind(bound, h[i, ]) bound = rbind(bound, cbind(seq(h[i, 1], h[i + 1, 1], len = 50), seq(h[i, 2], h[i + 1, 2], len = 50))) } beta=trimbeta } else { xbar = apply(beta, 2, mean) n = nrow(beta) cbeta = t(t(beta) - xbar) S = t(cbeta) %*% cbeta/(n - 1) eS = eigen(S) B = eS$vec %*% diag(sqrt(eS$val)) theta = seq(0, 2 * pi, len = 250) v = cbind(cos(theta), sin(theta)) * sqrt(qchisq(1 - alpha, 2)) h = t(B %*% t(v) + xbar) nh = nrow(h) m = which.max(h[, 2]) h = rbind(h[m:nh, ], h[((1:nh) < m), ], h[m, ]) bound = h } z <- length(x) * 5 u <- seq(min(x), max(x), length = z) lower <- c() upper <- c() v <- c() for (j in 1:z) { for (i in 1:nrow(beta)) { v[i] <- as.matrix(beta[, 1][i] + beta[, 2][i] * u[j]) } uv <- cbind(u[j], v) lower <- rbind(lower, uv[order(v), ][1, ]) upper <- rbind(upper, uv[order(v), ][nrow(beta), ]) } if (plot) { if (xyaxes) { lines(upper, ...) lines(lower, ...) } else { lines(bound, ...) } } invisible(list(boundary = bound, upper = upper, lower = lower)) } mixtools/R/ellipse.R0000755000176200001440000000067114342153463014125 0ustar liggesusersellipse <- function(mu, sigma, alpha=.05, npoints=250, newplot=FALSE, draw=TRUE, ...) { es <- eigen(sigma) e1 <- es$vec%*%diag(sqrt(es$val)) r1 <- sqrt(qchisq(1-alpha,2)) theta <- seq(0,2*pi,len=npoints) v1 <- cbind(r1*cos(theta),r1*sin(theta)) pts=t(mu-(e1%*%t(v1))) if (newplot && draw) { plot(pts, ...) } else if (!newplot && draw) { lines(pts, ...) } invisible(pts) } mixtools/R/regmixEMlambda.R0000755000176200001440000001032614342153463015344 0ustar liggesusersregmixEM.lambda = function (y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) { if (arbmean == FALSE && arbvar == FALSE) { stop(paste("Must change constraints on beta and/or sigma!", "\n")) } s = sigma if (addintercept) { x = cbind(1, x) } n <- length(y) p <- ncol(x) tmp <- regmix.lambda.init(y = y, x = x, lambda = lambda, beta = beta, s = s, k = k, addintercept = addintercept, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda beta <- tmp$beta s <- tmp$s k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta res2 <- (y - xbeta)^2 if (arbmean == FALSE) { res2 <- sapply(1:k, function(i) res2) } comp <- t(t(lambda)/sqrt(2 * pi * s^2)) * exp(-t(t(res2)/(2 * s^2))) obsloglik <- sum(log(apply(comp, 1, sum))) ll <- obsloglik while (diff > epsilon && iter < 1) { V=as.double(sweep(lambda, 2, s+rep(0,k), "/")) W=as.double(sweep(res2, 2, 2*(s+rep(0,k))^2, "/")) z <- matrix(.C(C_newz, as.integer(n), as.integer(k), V=V, W=W, newz=double(n*k), PACKAGE = "mixtools")$newz, ncol=k) z = z/apply(z,1,sum) if (addintercept) { lm.out <- lapply(1:k, function(i) lm(y ~ x[,-1], weights = z[, i])) } else lm.out <- lapply(1:k, function(i) lm(y ~ x - 1, weights = z[, i])) beta.new <- sapply(lm.out, coef) if (arbmean == FALSE) { beta.new <- apply(t(apply(z, 2, sum) * t(beta.new)), 1, sum)/n } xbeta.new <- x %*% beta.new res2 <- (y - xbeta.new)^2 if (arbmean == FALSE) { res2 <- sapply(1:k, function(i) res2) } if (arbvar) { s.new <- sqrt(sapply(1:k, function(i) sum(z[,i] * (res2[, i]))/sum(z[, i]))) } else s.new <- sqrt(sum(z * res2)/n) beta <- beta.new xbeta <- x %*% beta s <- s.new sing <- sum(s < 1e-08) comp <- lapply(1:k, function(i) lambda[,i] * dnorm(y, xbeta[, i * arbmean + (1 - arbmean)], s[i * arbvar + (1 - arbvar)])) comp <- sapply(comp, cbind) compsum <- apply(comp, 1, sum) newobsloglik <- sum(log(compsum)) if (newobsloglik < obsloglik || sing > 0 || abs(newobsloglik) == Inf || is.nan(newobsloglik)){# || sum(z) != n) { cat("Need new starting values due to singularity...", "\n") tmp <- regmix.lambda.init(y = y, x = x, k = k, addintercept = addintercept, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda beta <- tmp$beta s <- tmp$s k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta res2 <- (y - xbeta)^2 if (arbmean == FALSE) { res2 <- sapply(1:k, function(i) res2) } comp <- t(t(lambda)/sqrt(2 * pi * s^2)) * exp(-t(t(res2)/(2 * s^2))) obsloglik <- sum(log(apply(comp, 1, sum))) ll <- obsloglik } else { diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 } } scale.order = order(s) sigma.min = min(s) if (arbmean == FALSE) { z = z[, scale.order] names(beta) <- c(paste("beta", ".", 0:(p - 1), sep = "")) colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a = list(x = x, y = y, lambda = lambda[,scale.order], beta = beta, sigma = sigma.min, scale = s[scale.order]/sigma.min, loglik = obsloglik, posterior = z[, scale.order], all.loglik = ll, ft="regmixEM.lambda") class(a) = "mixEM" a } else { rownames(beta) <- c(paste("beta", ".", 0:(p - 1), sep = "")) colnames(beta) <- c(paste("comp", ".", 1:k, sep = "")) colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a = list(x = x, y = y, lambda = lambda, beta = beta, sigma = s, loglik = obsloglik, posterior = z, all.loglik = ll, ft="regmixEM.lambda") class(a) = "mixEM" a } } mixtools/R/plotly_npEM.R0000644000176200001440000001034514343050142014715 0ustar liggesusersplotly_spEM <- plotly_npEM <- function( x, blocks = NULL, hist=TRUE, addlegend=TRUE, scale = TRUE, title=NULL, breaks="Sturges", dens.col = NULL, newplot=TRUE, ylim = NULL , col.hist = "#1f77b4", width = 3, title.x = 0.5 , title.y = 0.95, title.size = 15, xlab = "X" , xlab.size = 15 , xtick.size = 15, ylab = "Density" , ylab.size = 15 , ytick.size = 15, legend.text = "Posteriors", legend.text.size = 15, legend.size = 15 ){ r <- NCOL(x$data) m <- NCOL(x$posteriors) if(is.null(dens.col)){ dens.col <- hue_pal()(m) } if (length(dens.col) > m){ print(paste("Please specify",m,"colors in 'dens.col'.")) } blockid <- x$blockid if (is.null(blocks)) { if(!is.null(blockid)) { blocks <- 1:max(blockid) } else { blocks <- blockid <- 1:r } } ylim.orig <- ylim out <- list(x=list(), y=list()) if (!newplot) { hist <- FALSE } ############################ plot.all <- plot_ly()%>% plotly::layout( legend = list(title=list(text=legend.text, font=list(size=legend.text.size)), font = list(size=legend.size)), title = list(text = "Densities for Different Posteriors", x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for(i in 1:length(blocks)){ coords <- blockid == blocks[i] ylim <- ylim.orig if (is.null(title)) { if (r>1) { tt <- paste(which(coords), collapse=",") tt <- paste("Coordinate", ifelse(sum(coords)>1, "s ", " "), tt, sep="") } else { tt <- "Density Curves" } } else { tt <- rep(title,length(blocks))[i] } dx <- dy <- NULL for (j in 1:m) { d <- density(x, component=j, block=blocks[i], scale=scale) dx <- cbind(dx, d$x) dy <- cbind(dy, d$y) } xx <- as.vector(as.matrix(x$data)[,coords]) if (is.null(ylim)) { ylim=range(dy) if (hist) { ylim[2] <- max(ylim[2], hist(xx, breaks=breaks, plot=FALSE)$density) } } if (newplot){ plot.new <- plot_ly()%>% plotly::layout( legend = list(title=list(text=legend.text, font=list(size=legend.text.size)), font = list(size=legend.size)), title = list(text = tt, x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (j in 1:m){ plot.new <- plot.new %>% add_trace(x=dx[,j] , y=dy[,j] , type = 'scatter' , mode = 'lines', line = list(width = width , color = dens.col[j]), name = paste("Posterior",j), showlegend = addlegend) } if (hist){ plot.new <- plot.new%>% add_trace(x=xx , type = 'histogram', histnorm = "probability density", name = 'Data' , showlegend = FALSE, marker = list(color = col.hist, line = list(color = col.hist)) )%>% plotly::layout(bargap = 0.01) } print(plot.new) } else { if (i > 1){addlegend <- FALSE} for (j in 1:m){ plot.all <- plot.all %>% add_trace(x=dx[,j] , y=dy[,j] , type = 'scatter' , mode = 'lines', line = list(width = width , color = dens.col[j]), name = paste("Posterior",j), showlegend = addlegend) } } } if (!newplot){print(plot.all)} }mixtools/R/plotly_spEMN01.R0000644000176200001440000000475114343053262015213 0ustar liggesusersplotly_spEMN01 <- function(x, bw=x$bandwidth, knownpdf=dnorm, add.plot=FALSE, width = 3 , col.dens = NULL, col.hist = '#1f77b4', title = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "t" , xlab.size = 15 , xtick.size = 15, ylab = "Density" , ylab.size = 15 , ytick.size = 15, legend.text = "Densities" , legend.text.size = 15 , legend.size = 15 ){ t <- seq(min(x$data), max(x$data), len=200) f1 <- x$lambdahat[1]*knownpdf(t) f2 <- x$lambdahat[2]*wkde(x$data-x$muhat, u=t-x$muhat, w=x$post[,2], bw=bw, sym=TRUE) f <- f1+f2 if(is.null(col.dens)){ col.dens <- hue_pal()(3) } if (length(col.dens) != 3){ print("Please sepcify 3 colors in 'col.dens'.") } if (is.null(title)){ title <- "" } plot <- plot_ly()%>% add_trace(x=t , y=f , type = 'scatter' , mode = 'lines', line = list(width = width , color = col.dens[1]), name = "f", showlegend = TRUE)%>% add_trace(x=t , y=f1 , type = 'scatter' , mode = 'lines', line = list(width = width , color = col.dens[2]), name = "f1", showlegend = TRUE)%>% add_trace(x=t , y=f2 , type = 'scatter' , mode = 'lines', line = list(width = width , color = col.dens[3]), name = "f2", showlegend = TRUE)%>% plotly::layout( legend = list(title=list(text=legend.text, font=list(size=legend.text.size)), font = list(size=legend.size)), title = list(text = title, x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) if (add.plot){ plot <- plot%>% add_trace(x=x$data , type = 'histogram', histnorm = "probability density", name = 'Data' , showlegend = FALSE, marker = list(color = col.hist, line = list(color = col.hist)) )%>% plotly::layout(bargap = 0.01) } print(plot) }mixtools/R/plot.mixEM.R0000644000176200001440000002142114342153463014455 0ustar liggesusersplot.mixEM <-function (x, whichplots = 1, loglik = 1 %in% whichplots, density = 2 %in% whichplots, xlab1="Iteration", ylab1="Log-Likelihood", main1="Observed Data Log-Likelihood", col1=1, lwd1=2, xlab2=NULL, ylab2=NULL, main2=NULL, col2=NULL, lwd2=2, alpha = 0.05, marginal = FALSE, ...) { def.par <- par(ask=(loglik + density > 1), "mar") # only ask and mar are changed mix.object <- x if (!inherits(mix.object, "mixEM")) stop("Use only with \"mixEM\" objects!") if (loglik) { plot(mix.object$all.loglik, xlab = xlab1, ylab = ylab1, main = main1, type="l", lwd=lwd1, col=col1, ...) } if (density) { if (mix.object$ft == "logisregmixEM") { if (ncol(mix.object$x) != 2) { stop("The predictors must have 2 columns!") } if (sum((mix.object$y == 1) + (mix.object$y == 0)) != length(mix.object$y)) { stop("The response must be binary!") } k = ncol(mix.object$beta) x = mix.object$x[, 2] if(is.null(main2)) { main2 <- "Most Probable Component Membership" } if(is.null(xlab2)) { xlab2 <- "Predictor" } if(is.null(ylab2)) { ylab2 <- "Response" } if(is.null(col2)) { col2 <- 2:(k+1) } plot(x, mix.object$y, main=main2, xlab=xlab2, ylab=ylab2, col = col2[apply(mix.object$posterior, 1, which.max)], ...) a = cbind(x, mix.object$y) a = a[order(a[, 1]), ] for (i in 1:k) { lines(a[, 1], plogis(mix.object$beta[1, i] + mix.object$beta[2, i] * a[, 1]), col = col2[i]) } } if (mix.object$ft == "normalmixEM") { k <- ncol(mix.object$posterior) x <- sort(mix.object$x) a <- hist(x, plot = FALSE) maxy <- max(max(a$density), .3989*mix.object$lambda/mix.object$sigma) if(is.null(main2)) { main2 <- "Density Curves" } if(is.null(xlab2)) { xlab2 <- "Data" } if(is.null(col2)) { col2 <- 2:(k+1) } hist(x, prob = TRUE, main = main2, xlab = xlab2, ylim = c(0,maxy), ...) if (length(mix.object$mu) == 1) { arbvar <- TRUE mix.object$sigma <- mix.object$scale * mix.object$sigma arbmean <- FALSE } if (length(mix.object$mu) == k && length(mix.object$sigma) == 1) { arbmean <- TRUE arbvar <- FALSE } if (length(mix.object$sigma) == k && length(mix.object$mu) == k) { arbmean <- TRUE arbvar <- TRUE } for (i in 1:k) { lines(x, mix.object$lambda[i] * dnorm(x, mean = mix.object$mu[i * arbmean + (1 - arbmean)], sd = mix.object$sigma[i * arbvar + (1 - arbvar)]), col = col2[i], lwd = lwd2) } } if (mix.object$ft == "repnormmixEM") { x <- as.vector(as.matrix(x)) k <- ncol(mix.object$posterior) x <- sort(mix.object$x) a <- hist(x, plot = FALSE) maxy <- max(max(a$density), .3989*mix.object$lambda/mix.object$sigma) if (is.null(main2)) { main2 <- "Density Curves" } if(is.null(xlab2)) { xlab2 <- "Data" } if(is.null(col2)) { col2 <- 2:(k+1) } hist(x, prob = TRUE, main = main2, xlab = xlab2, ylim = c(0, maxy), ...) if (length(mix.object$mu) == 1) { arbvar <- TRUE mix.object$sigma = mix.object$scale * mix.object$sigma arbmean <- FALSE } if (length(mix.object$mu) == k && length(mix.object$sigma) == 1) { arbmean <- TRUE arbvar <- FALSE } if (length(mix.object$sigma) == k && length(mix.object$mu) == k) { arbmean <- TRUE arbvar <- TRUE } for (i in 1:k) { lines(x, mix.object$lambda[i] * dnorm(x, mean = mix.object$mu[i * arbmean + (1 - arbmean)], sd = mix.object$sigma[i * arbvar + (1 - arbvar)]), col = col2[i], lwd = lwd2) } } if (mix.object$ft == "regmixEM.mixed") { x.1 = mix.object$x n = sum(sapply(x.1, nrow)) x.1.sum = sum(sapply(1:length(x.1), function(i) length(x.1[[i]][, 1]))) if (x.1.sum == n) { x = lapply(1:length(x.1), function(i) matrix(x.1[[i]][, -1], ncol = 1)) } else { x = x.1 } post.beta(x = x, y = mix.object$y, p.beta = mix.object$posterior.beta, p.z = mix.object$posterior.z) } if (mix.object$ft == "mvnormalmixEM") { x = mix.object$x if (ncol(x) != 2) { stop("The data must have 2 columns!") } post = apply(mix.object$posterior, 1, which.max) k <- ncol(mix.object$posterior) if (is.list(mix.object$sigma)) { sigma = mix.object$sigma } else { sigma = lapply(1:k, function(i) mix.object$sigma) } if (is.list(mix.object$mu)) { mu = mix.object$mu } else { mu = lapply(1:k, function(i) mix.object$mu) } if(is.null(xlab2)) { xlab2 <- "X.1" } if(is.null(ylab2)) { ylab2 <- "X.2" } if(is.null(col2)) { col2 <- 2:(k+1) } if (marginal == FALSE) { if (is.null(main2)) { main2 <- "Density Curves" } plot(x, col = col2[post], xlab = xlab2, ylab = ylab2, main = main2, ...) lapply(1:k, function(i) points(mu[[i]][1], mu[[i]][2], pch = 19)) for (i in 1:k) { for (j in 1:length(alpha)) { ellipse(mu = mu[[i]], sigma = sigma[[i]], alpha = alpha[j], col = col2[i]) } } } else { if (is.null(main2)) { main2 <- "" } # FIXME: What's the right main2 here? x <- mix.object$x[, 1] y <- mix.object$x[, 2] xhist <- hist(x, plot = FALSE) yhist <- hist(y, plot = FALSE) top <- max(c(xhist$counts, yhist$counts)) xrange <- range(x) yrange <- range(y) nf <- layout(matrix(c(2, 0, 1, 3), 2, 2, byrow = TRUE), c(4, 1), c(1, 4), TRUE) layout.show(nf) par(mar = c(3, 3, 1, 1)) plot(mix.object$x[, 1], mix.object$x[,2], col = col2[post], xlab = xlab2, ylab = ylab2, main = main2, ...) lapply(1:k, function(i) points(mu[[i]][1], mu[[i]][2], pch = 19)) for (i in 1:k) { for (j in 1:length(alpha)) { ellipse(mu = mu[[i]], sigma = sigma[[i]], alpha = alpha[j], col = (i + 1)) } } par(mar = c(0, 3, 1, 1)) barplot(xhist$counts, axes = FALSE, ylim = c(0, top), space = 0, ...) par(mar = c(3, 0, 1, 1)) barplot(yhist$counts, axes = FALSE, xlim = c(0, top), space = 0, horiz = TRUE, ...) } } if (mix.object$ft == "regmixEM") { if (ncol(mix.object$x) != 2) { stop("The predictors must have 2 columns!") } post <- apply(mix.object$posterior, 1, which.max) k <- ncol(mix.object$posterior) x <- mix.object$x[, 2] y <- mix.object$y n <- length(y) if(is.null(main2)) { main2 <- "Most Probable Component Membership" } if(is.null(xlab2)) { xlab2 <- "Predictor" } if(is.null(ylab2)) { ylab2 <- "Response" } if(is.null(col2)) { col2 <- 2:(k+1) } plot(x, y, main = main2, xlab=xlab2, ylab=ylab2, type="n", ...) a = cbind(mix.object$x[, 2], mix.object$y, post) for (i in 1:k) { xy = subset(cbind(a, mix.object$posterior[, i]), a[, 3] == i)[, -3] xy = matrix(xy, ncol=3) points(xy[, 1], xy[, 2], col = col2[i]) if (is.matrix(mix.object$beta) == FALSE) { abline(coef = mix.object$beta) beta = matrix(mix.object$beta, ncol = k, nrow = 2) } else { abline(coef = mix.object$beta[, i], col = col2[i]) beta = mix.object$beta } out = lm(y ~ x, weights = mix.object$posterior[,i]) fit = beta[1, i] + beta[2, i] * x out.aov = anova(out) MSE = out.aov$Mean[2] xy.f = cbind(x, y, fit) xy.sort = xy.f[order(xy.f[, 1]), ] x.new = seq(from=min(x),to=max(x),length.out=100) y.new = beta[1, i] + beta[2, i] * x.new s.h <- sqrt(MSE * (1/n + (x.new - mean(xy.sort[,1]))^2 / var(xy.sort[, 1])/(n - 1))) for (j in 1:length(alpha)) { W = sqrt(qf(1 - alpha[j], 2, n - 2)) upper = y.new + W * s.h lower = y.new - W * s.h lines(x.new, upper, col = (i + 1)) lines(x.new, lower, col = (i + 1)) } } } if (mix.object$ft == "expRMM_EM") {plotexpRMM(mix.object, ...)} # all default if (mix.object$ft == "weibullRMM_SEM") {plotweibullRMM(mix.object, ...)} # all default } par(def.par) # reset ask and mar to original values } mixtools/R/normalmixMMlc.R0000644000176200001440000001767114342153463015254 0ustar liggesusers################################################################### ## "EC-MM" algorithm ## to search for a local maximum of the likelihood surface for a ## univariate finite mixture of normals with possible ## linear constraints on the mean and variance parameters. ## ## (EC-MM is ECM in the sense of Meng and Rubin, ## Biometrika 1993, where the M step is replaced by a ## Conditional MM step) ## ## version allowing for linear constraints on the mean ## mu = M beta + C, where M is matrix(k,p) and C is vector() ## C-MM step required for the linear constraint on the Variances ## var.lincstr = matrix A (k,q) s.t. iv = A g, where "i"nverse "v"ar ## iv = k-vector of 1/v_j's, and g = q-vector of unknown parameters ## no fast option, & ECM-MM algorithm forced (no ECM option available) ## init values for gparam are *required* here for the MM algorithm ## # default value for A could be diag(k) so that iv=g normalmixMMlc <- function (x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, mean.constr = NULL, mean.lincstr = NULL, mean.constant = NULL, var.lincstr = NULL, gparam = NULL, epsilon = 1e-08, maxit = 1000, maxrestarts=20, verb = FALSE) { ECM <- TRUE # always required in this case A <- var.lincstr x <- as.vector(x); n <- length(x) tmp <- normalmix.init(x = x, lambda = lambda, mu = mu, s = sigma, k = k) # no arbmean & arbvar parameters lambda <- tmp$lambda; mu <- tmp$mu; sigma <- tmp$s; k <- tmp$k # arbvar <- tmp$arbvar; arbmean <- tmp$arbmean arbmean <- arbvar <- TRUE # forced for parse.constraints() warn <- options(warn=-1) # Turn off warnings (for parsing only) z <- parse.constraints(mean.constr, k=k, allsame=!arbmean) options(warn) # Reset warnings to original value meancat <- z$category; meanalpha <- z$alpha if (!is.null(mean.lincstr)) { # linear constraint on the means M <- mean.lincstr cat("linear constraint mu = M beta + C version\n") p <- dim(M)[2] # nb of columns = size of constr. mean parameter if (dim(M)[1] != k) stop("mean.lincstr and mu dimensions must agree") if (is.null(mean.constant)) C <- matrix(0,k,1) else C <- matrix(mean.constant,k,1) } notdone <- TRUE while(notdone) { # Initialize everything notdone <- FALSE tmp <- normalmix.init(x=x, lambda=lambda, mu=mu, s=sigma, k=k) lambda <- tmp$lambda; mu <- tmp$mu; k <- tmp$k; sigma <- tmp$s q <- dim(A)[2] # nb of inverse variance parameters (gamma) if(is.null(gparam)) g <- rexp(q) else g <- gparam iv <- A %*% g # inverse variances, as a one-column matrix v <- 1/iv # is it necessary to redefined sigma from g here ? sigma <- as.vector(sqrt(v)) diff <- epsilon+1 iter <- 0 postprobs <- matrix(nrow = n, ncol = k) restarts <- 0 mu <- rep(mu, k)[1:k] # is this useful? sigma <- rep(sigma,k)[1:k] # sigma still needed for post computation ## Initialization E-step here: z <- .C(C_normpost, as.integer(n), as.integer(k), as.double(x), as.double(mu), as.double(sigma), as.double(lambda), res2 = double(n*k), double(3*k), post = double(n*k), loglik = double(1), PACKAGE = "mixtools") postprobs <- matrix(z$post, nrow=n) res <- matrix(z$res2, nrow=n) # n,m matrix of squared residuals (x_i-mu_j)^2 ll <- obsloglik <- z$loglik ## EC-MM iterations while (diff > epsilon && iter < maxit) { # ECM loop, 1st M-step: condition on sigma, update lambda and mu : lambda <- colMeans(postprobs) # update for lambda # update for mu, depending on constraint type mu[meancat==0] <- meanalpha[meancat==0] if (max(meancat)>0 && is.null(mean.lincstr)) { # simple constraint for(i in 1:max(meancat)) { w <- which(meancat==i) if (length(w)==1) { mu[w] <- sum(postprobs[,w]*x) / (n*lambda[w]) } else { tmp <- t(postprobs[,w])*(meanalpha[w]/sigma[w]^2) mu[w] <- meanalpha[w] * sum(t(tmp)*x) / sum(tmp*meanalpha[w]) } } } if (!is.null(mean.lincstr)) { # linear constraint mu = M beta + C iv2 <- as.vector(iv) # A1_j = sum_i p_ij x_i/v_j A1 <- apply(postprobs*matrix(x,n,k),2,sum)*iv2 B <- diag(apply(postprobs,2,sum)*iv2) Stemp <- solve(t(M) %*% B %*% M) beta <- Stemp %*% t(M) %*% (A1 - B %*% C) mu <- as.vector(M %*% beta + C) # coerce to vector } # ECM E-step number one: z <- .C(C_normpost, as.integer(n), as.integer(k), as.double(x), as.double(mu), as.double(sigma), as.double(lambda), res2 = double(n*k), double(3*k), post = double(n*k), loglik = double(1), PACKAGE = "mixtools") postprobs <- matrix(z$post, nrow=n) res <- matrix(z$res2, nrow=n) #### ECM loop 2nd M-step: condition on mu, update lambda #### and sigma via the MM step lambda <- colMeans(postprobs) # Update variances with the MM algo on g, conditional on mu # note: code in too much steps/details for debugging # computing q-vector of denominators r0 <- postprobs*res # (i,j)th is p_{ij}*(x_i - mu_j)^2 r1 <- r0 %*% A # r1(n,q) matrix, (i,l) term =\sum_j p_{ij}A_{jl}(x_i - mu_j)^2 den <- colSums(r1) # q-vector of denominators for updating g # computing q-vector of numerators r3 <- matrix(v,nrow=k,ncol=q)*A # (k,q) matrix of v_j.A_{jl} r4 <- postprobs %*% r3 # (n,q) matrix of \sum_j p_{ij} A_{jl} v_j num <- colSums(r4) # # update of gamma parameters which gives iv, v and sigma g.new <- g*(num/den) iv <- A %*% g.new v <- 1/iv # needed for next computation of r3 sigma <- as.vector(sqrt(v)) # needed in next E-steps g <- g.new # iterates ## test for variance degeneration if(any(sigma < 1e-08)) { notdone <- TRUE cat("One of the variances is going to zero; ", "trying new starting values.\n") restarts <- restarts + 1 lambda <- mu <- sigma <- NULL # WHAT TO DO WITH g in this case? if(restarts>maxrestarts) { stop("Too many tries!") } break } # ECM E-step number two: z <- .C(C_normpost, as.integer(n), as.integer(k), as.double(x), as.double(mu), as.double(sigma), as.double(lambda), res2 = double(n*k), double(3*k), post = double(n*k), loglik = double(1), PACKAGE = "mixtools") postprobs <- matrix(z$post, nrow=n) res <- matrix(z$res2, nrow=n) newobsloglik <- z$loglik diff <- newobsloglik - obsloglik # does not increase that one? obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration", iter, ": log-lik diff =", round(diff,4), " log-lik =", obsloglik, "\n") } } } # summurizing and returning structure if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") if(arbmean == FALSE){ scale.order = order(sigma) sigma.min = min(sigma) postprobs = postprobs[,scale.order] colnames(postprobs) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, lambda = lambda[scale.order], mu = mu, sigma = sigma.min, scale = sigma[scale.order]/sigma.min, loglik = obsloglik, posterior = postprobs, all.loglik=ll, restarts=restarts, gamma = g, ft="normalmixMMlc") } else { colnames(postprobs) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, lambda = lambda, mu = mu, sigma = sigma, loglik = obsloglik, posterior = postprobs, all.loglik=ll, restarts=restarts, beta = beta, gamma = g, ft="normalmixMMlc") } class(a) = "mixEM" a } mixtools/R/zzz.R0000755000176200001440000000073714342153463013330 0ustar liggesusers.onAttach <- function(lib, pkg){ info <- packageDescription("mixtools") packageStartupMessage( paste('mixtools package, version ', info$Version, ', Released ', info$Date, '\n', 'This package is based upon work supported by the National Science ', 'Foundation under Grant No. SES-0518772 and ', 'the Chan Zuckerberg Initiative: Essential Open Source Software for ', 'Science (Grant No. 2020-255193).\n', sep="") ) } mixtools/R/hmeEM.R0000755000176200001440000001164214342153463013463 0ustar liggesusershmeEM <- function (y, x, lambda=NULL, beta = NULL, sigma = NULL, w = NULL, k = 2, addintercept = TRUE, epsilon = 1e-08, maxit = 10000, verb=FALSE) { NR <- function (w, x, z) { A = (inv.logit(x %*% w)/(1 + exp(x %*% w)))^-1 B = z[,1]-inv.logit(x %*% w) C = matrix(c(sum(B),sum(x[,2]*B)),2,1) D = matrix(nrow=2,ncol=nrow(x)) D = solve(matrix(c(sum(A),sum(A * x[,2]),sum(A * x[,2]),sum(A * x[,2]^2)),nrow=2,ncol=2)) E = w + apply(D %*% C, 1, sum) list(w.new = E) } if (k != 2) cat("This algorithm currently only works for a 2-component mixture-of-experts model!") s=sigma if (addintercept) { x = cbind(1, x) } n <- length(y) p <- ncol(x) if (is.null(w)) { w = rep(0,p*(k-1)) } tmp <- regmix.init(y = y, x = x, beta = beta, s = s, k = k, addintercept = addintercept) beta = tmp$beta s = tmp$s k = tmp$k if(is.null(lambda)) lambda = inv.logit(x %*% w) diff <- 1 iter <- 0 nlogroot2pi = n * log(sqrt(2 * pi)) xbeta <- x %*% beta tmp <- t(-1/2/s[2]^2 * t(y - xbeta[, -1])^2) + 1/2/s[1]^2 * (y - xbeta[, 1])^2 tmp2 <- (1-lambda)/s[2] * s[1]/lambda tmp3 <- log(1 + (tmp2 * exp(tmp))) obsloglik <- sum(log(lambda)) - nlogroot2pi - n * log(s[1]) - 1/2/s[1]^2 * sum((y - xbeta[, 1])^2) + sum(tmp3) ll <- obsloglik z = matrix(nrow = n, ncol = k) restarts <- 0 while (diff > epsilon & iter < maxit) { lambda.mat <- cbind(lambda,1-lambda) res <- (y - xbeta)^2 for (i in 1:n) { for (j in 1:k) { z.denom = c() for (h in 1:k) { z.denom = c(z.denom, (lambda.mat[i,h]/lambda.mat[i,j]) * (s[j]/s[h]) * exp(-0.5 * ((1/s[h]^2) * res[i, h] - (1/s[j]^2) * res[i, j]))) } z[i, j] = 1/sum(z.denom) } } # z[, k] = 1 - apply(as.matrix(z[, (1:(k - 1))]), 1, sum) z = z/apply(z,1,sum) if (addintercept) { lm.out <- lapply(1:k, function(i) lm(y ~ x[, -1], weights = z[, i])) } else lm.out <- lapply(1:k, function(i) lm(y ~ x - 1, weights = z[, i])) beta.new <- sapply(lm.out, coef) w.diff=10 while(sum(abs(w.diff))>(p*.001)){ w.temp <- NR(w,x,z)$w.new w.diff <- w-w.temp w <- w.temp } w.new <- w lambda.new <- inv.logit(x %*% w.new) xbeta.new <- x %*% beta.new res <- (y - xbeta.new)^2 s.new <- sqrt(sapply(1:k, function(i) sum(z[,i] * (res[, i]))/sum(z[, i]))) sing <- sum(s.new < 1e-08) lambda <- lambda.new beta <- beta.new s <- s.new w <- w.new xbeta <- xbeta.new tmp <- t(-1/2/s[2]^2 * t(y - xbeta[, -1])^2) + 1/2/s[1]^2 * (y - xbeta[, 1])^2 tmp2 <- (1-lambda)/s[2] * s[1]/lambda tmp3 <- log(1 + (tmp2 * exp(tmp))) newobsloglik <- sum(log(lambda)) - nlogroot2pi - n * log(s[1]) - 1/2/s[1]^2 * sum((y - xbeta[, 1])^2) + sum(tmp3) if (sing > 0 || is.na(newobsloglik) || newobsloglik < obsloglik || abs(newobsloglik) == Inf){# || sum(z) != n) { cat("Need new starting values due to singularity...", "\n") restarts <- restarts + 1 if (restarts > 15) stop("Too many tries!") tmp <- regmix.init(y = y, x = x, k = k, addintercept = addintercept) beta = tmp$beta s = tmp$s k = tmp$k w = rep(0,p*(k-1)) lambda = inv.logit(x %*% w) diff <- 1 iter <- 0 xbeta <- x %*% beta tmp <- t(-1/2/s[2]^2 * t(y - xbeta[, -1])^2) + 1/2/s[1]^2 * (y - xbeta[, 1])^2 tmp2 <- (1-lambda)/s[2] * s[1]/lambda tmp3 <- log(1 + (tmp2 * exp(tmp))) obsloglik <- sum(log(lambda)) - nlogroot2pi - n * log(s[1]) - 1/2/s[1]^2 * sum((y - xbeta[, 1])^2) + sum(tmp3) ll <- obsloglik } else{ diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n")} } } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") rownames(beta) <- c(paste("beta", ".", 0:(p - 1), sep = "")) colnames(beta) <- c(paste("comp", ".", 1:k, sep = "")) colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a = list(x = x, y = y, w=w, lambda = cbind(lambda,1-lambda), beta = beta, sigma = s, loglik = obsloglik, posterior = z, all.loglik = ll, restarts = restarts, ft = "regmixEM") class(a) = "mixEM" a } mixtools/R/parse.constraints.R0000755000176200001440000000242514342153463016147 0ustar liggesusersparse.constraints <- function(constr, k=2, allsame=FALSE) { if (!is.null(constr)) { alpha <- category <- rep(NA, k) u <- sum(is.na(constr)) # Number of unconstrained means category[is.na(constr)] <- 1:u numcon <- as.numeric(constr) # All non-numbers become NA here. category[!is.na(numcon)] <- 0 # These means will remain fixed constants alpha[!is.na(numcon)] <- numcon[!is.na(numcon)] w <- which(is.na(numcon) & !is.na(constr)) # w indexes only character constraints if (length(w)>0) { # Process all the character (equality) constraints constr <- as.character(constr) alpha[w] <- constr[w] nc <- nchar(constr)[w] # nc: number of characters (in each constraint) ss <- substr(constr[w], nc, nc) # extract final character category[w] <- u + match(ss, unique(ss)) # make categories for final characters alpha[w] <- substr(alpha[w], 1, nc-1) # Now extract number before final character alpha[w][alpha[w]=="-"] <- "-1" alpha[w][alpha[w]==""] <- "1" } alpha <- as.numeric(alpha) # Entire alpha vector should be numeric or NA now. } else { alpha <- rep(1,k) if(allsame) category <- alpha else category <- 1:k } list(category=category, alpha=alpha) } mixtools/R/plotly_spRMM.R0000644000176200001440000000750514343052521015063 0ustar liggesusersplotly_spRMM <- function(sem, tmax = NULL, width = 3 , col = '#1f77b4', cex = 3, title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab.size = 15 , xtick.size=15 , ylab.size = 15 , ytick.size=15){ t <- sem$t ym <- max(sem$all.scaling) plot1 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(sem$all.scaling) , by = 1), y = sem$all.scaling , type = 'scatter' , mode = 'lines', line = list(width = width , color = col), showlegend = FALSE)%>% plotly::layout( title = list(text = "Scaling", x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = "Iteration", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "", font = list(size = ylab.size)), tickfont = list(size = ytick.size), range = c(0,ym) ) ) plot2 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(sem$all.lambda[,1]) , by = 1), y = sem$all.lambda[,1] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col), showlegend = FALSE)%>% plotly::layout( title = list(text = "Weight of Component 1", x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = "Iteration", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "", font = list(size = ylab.size)), tickfont = list(size = ytick.size), range = c(0,1) ) ) if (is.null(tmax)){tmax <- max(sem$scaling*t) + 2} u <- seq(0, tmax, len=200) fhat <- sem$s.hat(sem$t.hat)*sem$hazard.hat ffinal <- sem$survival(sem$final.t)*sem$hazard plot3 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(sem$survival) , by = 1), y = sem$survival , type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col), showlegend = FALSE)%>% plotly::layout( title = list(text = "Survival Function Estimate", x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = "Time", font = list(size = xlab.size)), tickfont = list(size = xtick.size), range = c(0,tmax) ), yaxis = list(title = list(text = "", font = list(size = ylab.size)), tickfont = list(size = ytick.size), range = c(0,1) ) ) plot4 <- plot_ly()%>% add_trace(x = sem$final.t, y = ffinal , type = 'scatter' , mode = 'lines', line = list(width = width , color = col), showlegend = FALSE)%>% plotly::layout( title = list(text = "Density Estimate", x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = "Time", font = list(size = xlab.size)), tickfont = list(size = xtick.size), range = c(0,tmax) ), yaxis = list(title = list(text = "Density", font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) print(plot1) print(plot2) print(plot3) print(plot4) }mixtools/R/density.spEM.R0000755000176200001440000000351114342153463015006 0ustar liggesusers# Method for "density" generic: Takes an spEM object and returns # a corresponding KDE for the appropriate component and block, evaluated # at the given set of points. # Does not use the FFT like the density.default function does; still # quite fast, but not optimized for speed density.spEM <- function (x, u = NULL, component=1, block = 1, scale = FALSE, ...) { m <- NCOL(x$posteriors) r <- NCOL(x$data) n <- NROW(x$data) if (is.null(blockid <- x$blockid)) { coords <- 1 u2 <- rep(1, r) } else { u2 <- match(x$blockid, unique(x$blockid)) # convert blockid to integers 1, 2, ... coords <- blockid == block if (!any(coords)) stop("Illegal value of block argument") } stackedx <- x$data[rep(1:n,m),] cs <- colSums(x$posteriors) z.tmp <- sweep(x$posteriors, 2, cs, "/") z.tmp[, cs==0] <- 1/NROW(z.tmp) # Just in case wts <- rep(as.vector(z.tmp),r) mu <- matrix(x$muhat, nrow=m) sigma <- matrix(x$sigmahat, nrow=m) scaledx <- as.vector((stackedx - mu[rep(1:m, each=n), u2])/ sigma[rep(1:m, each=n), u2]) bw <- x$bandwidth if (is.null(u)) { xx <- as.vector(as.matrix(x$data)[, coords]) u = seq(min(xx) - 4 * bw, max(xx) + 4 * bw, len = 250) } # This part isn't used for now: if (!is.null(x$symmetric) && x$symmetric) { d <- wkde(x=scaledx, u=(u-mu[component, block])/sigma[component, block], w=wts, bw=bw, sym=TRUE) / sigma[component, block] } else { d <- wkde(x=scaledx, u=(u-mu[component, block])/sigma[component, block], w=wts, bw=bw) / sigma[component, block] } if (scale) d <- d * x$lambdahat[component] structure(list(x = u, y = d, bw = bw, n = n, call = match.call(), data.name = deparse(substitute(x)), has.na = FALSE), class = "density") } mixtools/R/poisregmixinit.R0000755000176200001440000000206014342153463015534 0ustar liggesuserspoisregmix.init <- function(y, x, lambda = NULL, beta = NULL, k = 2){ x <- as.matrix(x) n <- length(y) if (is.null(lambda)) { cond = TRUE while(cond){ lambda = runif(k) lambda = lambda/sum(lambda) if(min(lambda)<0.05) cond=TRUE else cond=FALSE } } else k = length(lambda) p <- ncol(x) w = cbind(y, x) w = w[order(w[, 1]), ] w.bin = list() for (j in 1:k) { w.bin[[j]] <- w[max(1, floor((j - 1) * n/k)):ceiling(j * n/k), ] } if (is.null(beta)) { beta.hyp = matrix(sapply(1:k, function(j) glm.fit(w.bin[[j]][, 2:(p + 1)], w.bin[[j]][, 1], family = poisson())$coeff), ncol = k) sd.hyp = apply(beta.hyp, 1, sd) beta = matrix(0, p, k) for (j in 1:k) { beta[, j] = rnorm(p, mean = as.vector(beta.hyp[, j]), sd = sd.hyp) } } else k = ncol(beta) list(lambda = lambda, beta = beta, k = k) } mixtools/R/regmixMH.R0000755000176200001440000000675014342153463014214 0ustar liggesusersregmixMH=function (y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, addintercept = TRUE, mu = NULL, sig = NULL, lam.hyp = NULL, sampsize = 1000, omega = 0.01, thin = 1) { if (addintercept) { x = cbind(1, x) } XTX <- solve(t(x)%*%x) n <- length(y) p <- ncol(x) if (is.null(s)) { s = sqrt(1/rexp(k)) } else k = length(s) if (is.null(beta)) { beta = matrix(rnorm(p * k), p, k) } else k = ncol(beta) if (is.null(lambda)) { lambda = runif(k) lambda = lambda/sum(lambda) } else k = length(lambda) if (is.null(mu)) { mu = 0 * beta } if (is.null(sig)) { sig = rep(5 * sqrt(var(y)),k) } sig.beta = t(matrix(rep(sig,p),ncol=p)) * sqrt(matrix(rep(diag(XTX),k),ncol=k)) if(is.null(lam.hyp)) lam.hyp = rep(1,k) L.theta <- matrix(nrow = n, ncol = k) pi.beta <- matrix(nrow = p, ncol = k) pi.sigma <- c() pi.lambda <- c() new.L.theta <- matrix(nrow = length(y), ncol = k) new.pi.beta <- matrix(nrow = p, ncol = k) new.pi.sigma <- c() new.pi.lambda <- c() accepts = 0 theta <- matrix(c(beta, s, lambda), nrow = 1) thetalist <- matrix(theta, sampsize, ncol(theta), byrow=TRUE) for (i in 2:sampsize) { log.pi.beta <- dnorm(beta, mu, sig.beta, log=TRUE) log.pi.sigma <- dexp(s, 1/sig, log=TRUE) log.pi.lambda <- sum((lam.hyp-1)*log(lambda)) - lgamma(lam.hyp) + lgamma(sum(lam.hyp)) # Dirichlet log-density # log.pi.lambda <- log(ddirichlet(lambda, lam.hyp)) L.theta <- dnorm(y - x %*% beta, 0, matrix(s, n, k, byrow = TRUE) ) %*% matrix(lambda, k, 1) log.Lik.theta <- sum(log(L.theta)) log.prior <- sum(log.pi.beta) + sum(log.pi.sigma) + sum(log.pi.lambda) log.f.theta <- log.Lik.theta + log.prior new.beta <- beta + omega * matrix(rcauchy(k * p), p, k) new.sigma <- log(s) + omega * rcauchy(k) new.sigma <- exp(new.sigma) new.lambda <- lambda.pert(lambda, omega*rcauchy(k)) log.new.pi.beta <- dnorm(new.beta, mu, sig.beta, log=TRUE) log.new.pi.sigma <- dexp(new.sigma, 1/sig, log=TRUE) log.new.pi.lambda <- sum((lam.hyp-1)*log(new.lambda)) - lgamma(lam.hyp) + lgamma(sum(lam.hyp)) # Dirichlet log-density # log.new.pi.lambda <- log(ddirichlet(new.lambda, lam.hyp)) new.L.theta <- dnorm(y - x %*% new.beta, 0, matrix(new.sigma, n, k, byrow = TRUE)) %*% matrix(new.lambda, k, 1) log.new.Lik.theta <- sum(log(new.L.theta)) log.new.prior <- sum(log.new.pi.beta) + sum(log.new.pi.sigma) + sum(log.new.pi.lambda) log.new.f.theta <- log.new.Lik.theta + log.new.prior new.theta <- c(new.beta, new.sigma, new.lambda) a <- log.new.f.theta - log.f.theta r <- log(runif(1)) if (a > r & !is.na(a)) { theta <- new.theta beta <- new.beta s <- new.sigma lambda <- new.lambda accepts = accepts + 1 } if (i%%thin == 0) thetalist[i,] = theta } cat(paste("Acceptance rate: ", 100 * accepts/sampsize, "%\n", sep = "")) colnames(thetalist) <- c(paste("beta", rep(0:(p - 1), k), ".", rep(1:k, rep(p, k)), sep = ""), paste("s.", 1:k, sep = ""), paste("lambda.", 1:k, sep = "")) invisible(thetalist) a=list(x=x, y=y, theta=thetalist, components=k) class(a)="mixMCMC" a } mixtools/R/perm.R0000755000176200001440000000034314342153463013427 0ustar liggesusersperm <- function (n, r, v = 1:n) { if (r == 1) matrix(v, n, 1) else if (n == 1) matrix(v, 1, r) else { X <- NULL for (i in 1:n) X <- rbind(X, cbind(v[i], perm(n - 1, r - 1, v[-i]))) X } } mixtools/R/wkde.R0000755000176200001440000000045214342153463013417 0ustar liggesuserswkde <- function(x, u=x, w=rep(1, length(x)), bw=bw.nrd0(as.vector(x)), sym=FALSE) { if (sym) { return((wkde(x, u, w, bw) + wkde(x, -u, w, bw))/2) } Km <- exp(outer(x/bw, u/bw, function(a,b) -(a-b)^2/2)) normw <- matrix(w/sum(w), nrow=1) as.vector(normw %*% Km) / (bw * sqrt(2*pi)) } mixtools/R/kernC.R0000755000176200001440000000010514342153463013522 0ustar liggesuserskern.C <- function (x, xi, h) { (1+cos(pi*(xi-x)/h))/(2*h) } mixtools/R/regmixEMlambdainit.R0000755000176200001440000000341114342153463016225 0ustar liggesusersregmix.lambda.init = function (y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar = TRUE) { x <- as.matrix(x) n <- length(y) p <- ncol(x) if (addintercept) { x = x[, -1] } else x = x w = cbind(y, x) w = w[order(w[, 1]), ] w.bin = list() for (j in 1:k) { w.bin[[j]] <- w[max(1, floor((j - 1) * n/k)):ceiling(j * n/k), ] } if (addintercept) { lm.out <- lapply(1:k, function(i) lm(w.bin[[i]][, 1] ~ w.bin[[i]][, 2:p])) } else lm.out <- lapply(1:k, function(i) lm(w.bin[[i]][, 1] ~ w.bin[[i]][, 2:(p + 1)] - 1)) if (is.null(s)) { s.hyp = lapply(lm.out, anova) s.hyp = as.vector(sqrt(sapply(1:k, function(i) s.hyp[[i]]$Mean[length(s.hyp[[i]]$Mean)]))) if (arbvar) { s = 1/rexp(k, rate = s.hyp) } else { s.hyp = mean(s.hyp) s = 1/rexp(1, rate = s.hyp) } } if (is.null(s) == FALSE && arbvar == TRUE) { k = length(s) } if (is.null(beta)) { beta.hyp = matrix(sapply(lm.out, coef), ncol = k) beta = matrix(0, nrow = p, ncol = k) for (j in 1:k) { beta[, j] = rnorm(p, mean = as.vector(beta.hyp[, j]), sd = s[arbvar * j + (1 - arbvar)]) } if (arbmean == FALSE) { beta = apply(beta, 1, mean) } } if (is.null(beta) == FALSE && arbmean == TRUE) { k = ncol(beta) } if (is.null(lambda)) { lam = runif(k) lam = lam/sum(lam) for(i in 1:n) {lambda <- rbind(lambda,lam)} } else k = ncol(lambda) list(lambda = lambda, beta = beta, s = s, k = k) }mixtools/R/plotly_weibullRMM.R0000644000176200001440000001072114343052727016106 0ustar liggesusersplotly_weibullRMM <- function(a, title=NULL, rowstyle=TRUE, subtitle=NULL, width = 3 , col = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "Iterations" , xlab.size = 15 , xtick.size = 15, ylab = "Estimates" , ylab.size = 15 , ytick.size = 15, legend.size = 15){ n <- length(a$x) m <- dim(a$all.lambda)[2] if (is.null(col)){ col <- hue_pal()(m) } if (length(col) != m){ print("Please specify",m,"colors in 'col'.") } pcc <- round(100*(1-mean(a$d)),2) if (is.null(subtitle)) { subtitle <- paste("n=",n,", ", pcc, "% censored", sep="")} if (is.null(title)) { tt1 <- "Shape parameters"; tt2 <- "Scale parameters" tt3 <- "Weight parameters" } else tt1 <- tt2 <- tt3 <- title plot1 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(a$all.shape[,1]) , by = 1), y = a$all.shape[,1] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[1]), name = "Shape 1",showlegend = TRUE)%>% plotly::layout( legend = list(font = list(size=legend.size)), title = list(text = paste(tt1 , "\n(", subtitle,")"), x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (j in 2:m){ plot1 <- plot1%>% add_trace(x = seq(from = 1 , to = length(a$all.shape[,j]) , by = 1), y = a$all.shape[,j] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[j]), name = paste("Shape",j),showlegend = TRUE) } plot2 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(a$all.scale[,1]) , by = 1), y = a$all.scale[,1] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[1]), name = "Scale 1",showlegend = TRUE)%>% plotly::layout( legend = list(font = list(size=legend.size)), title = list(text = paste(tt2 , "\n(", subtitle,")"), x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (j in 2:m){ plot2 <- plot2%>% add_trace(x = seq(from = 1 , to = length(a$all.scale[,j]) , by = 1), y = a$all.scale[,j] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[j]), name = paste("Scale",j),showlegend = TRUE) } plot3 <- plot_ly()%>% add_trace(x = seq(from = 1 , to = length(a$all.lambda[,1]) , by = 1), y = a$all.lambda[,1] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[1]), name = paste('λ',"",1,"" , sep=""),showlegend = TRUE)%>% plotly::layout( legend = list(font = list(size=legend.size)), title = list(text = paste(tt3 , "\n(", subtitle,")"), x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (j in 2:m){ plot3 <- plot3%>% add_trace(x = seq(from = 1 , to = length(a$all.lambda[,j]) , by = 1), y = a$all.lambda[,j] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[j]), name = paste('λ',"",j,"" , sep=""),showlegend = TRUE) } print(plot1) print(plot2) print(plot3) }mixtools/R/spEMsymloc.R0000644000176200001440000000564414342153463014565 0ustar liggesusers## EM-like algorithm for a nonparametric univariate mixture model with ## symmetric components from a location family spEMsymloc <- function(x, mu0, bw = bw.nrd0(x), h=bw, eps = 1e-8, maxiter=100, stochastic = FALSE, verbose = FALSE){ bw <- h # h is alternative bandwidth argument, for backward compatibility n <- length(x) if (length(mu0)>1) m <- length(mu0) # mu0=centers else m <- mu0 # when mu0=number of clusters z.hat <- matrix(0, nrow=n, ncol=m) fkernel <- matrix(0, nrow=n, ncol=m) tt0 <- proc.time() lambda <- rep(1/m, m) kmeans <- kmeans(x, mu0) for(j in 1:m) { z.hat[kmeans$cluster==j, j] <- 1 } iter <- 0 if (stochastic) { sumpost <- matrix(0, n, m) } finished <- FALSE lambda <- mu <- matrix(0,maxiter,m) while (!finished) { #while (max(abs(change)) > eps & iter < maxiter) { iter <- iter + 1 t0 <- proc.time() ## M-Step lambda[iter,] <- colMeans(z.hat) mu[iter,] <- apply(sweep(z.hat, 1, x, "*"), 2, mean)/lambda[iter,] ## density estimation step if(stochastic){ z <- t(apply(z.hat, 1, function(prob) rmultinom(1, 1, prob))) ans <- .C(C_KDEsymloc, n=as.integer(n), m=as.integer(m), mu=as.double(mu[iter,]), x=as.double(x), bw=as.double(bw), z=as.double(z), f = double(n*m), PACKAGE="mixtools") } else { ans <- .C(C_KDEsymloc, n=as.integer(n), m=as.integer(m), mu=as.double(mu[iter,]), x=as.double(x), bw=as.double(bw), z=as.double(z.hat), f = double(n*m), PACKAGE="mixtools") } fkernel <- matrix(ans$f, ncol=m) lambda.f <- sweep(fkernel, 2, lambda[iter,], "*") ## E-step (for next iteration) z.hat <- lambda.f/rowSums(lambda.f) finished <- iter >= maxiter if (stochastic) { sumpost <- sumpost + z.hat } else if (iter>1) { # This convergence criterion is too simplistic: change <- c(lambda[iter,] - lambda[iter-1,], mu[iter,]-mu[iter-1,]) finished <- finished | (max(abs(change)) < eps) } if (verbose) { t1 <- proc.time() cat("iteration ", iter, " lambda ", round(lambda[iter,], 4), " mu ", round(mu[iter,], 4)) cat(" time", (t1 - t0)[3], "\n") } } if (verbose) { tt1 <- proc.time() cat("lambda ", round(lambda[iter,], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } if(stochastic) { return(structure(list(data=x, posteriors=sumpost/iter, lambda=lambda, bandwidth=bw, lambdahat=colMeans(lambda), mu = mu, muhat = colMeans(mu), symmetric=TRUE), class="npEM")) } else { return(structure(list(data=x, posteriors=z.hat, lambda=lambda[1:iter,], bandwidth=bw, lambdahat=lambda[iter,], mu = mu[1:iter,], muhat = mu[iter,], symmetric=TRUE), class="npEM")) } } mixtools/R/flaremixinit.R0000755000176200001440000000111714342153463015157 0ustar liggesusersflaremix.init <- function(y, x, lambda=NULL, beta=NULL, sigma=NULL, alpha=NULL){ n<-length(y) if(is.null(lambda)){ lambda=runif(2) lambda=lambda/sum(lambda) } lm.out=lm(y~x[,2]) if(is.null(beta)){ beta=lm.out$coef beta[1]=beta[1]+mean(sort(lm.out$residuals)[(n-10):n]) beta[2]=rnorm(1,mean=beta[2],sd=abs(beta[2]/10)) } if(is.null(sigma)){ sigma=rexp(1,rate=sqrt(1/anova(lm.out)$Mean[2])) } if(is.null(alpha)){ a=1/sum(lm.out$res[lm.out$res>0]) alpha=abs(rnorm(1,a)) } list(lambda=lambda[1], beta=matrix(beta,ncol=1), sigma=sigma, alpha=alpha) } mixtools/R/segregmixEM.R0000755000176200001440000002763714343155175014722 0ustar liggesuserssegregmixEM=function (y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, seg.Z, psi, psi.locs = NULL, delta = NULL, epsilon = 1e-08, maxit = 10000, verb = FALSE, max.restarts=15) { if (sum(x[,1]==1)==nrow(x)) x=x[,-1] x=data.frame(x) col.names.x <- colnames(x) xnam <- colnames(x) fmla <- as.formula(paste("y ~ ", paste(xnam, collapse= "+"))) if(!is.null(psi.locs)){ psi.counts=apply(psi,1,sum) for(i in 1:k){ if(psi.counts[i]>0){ TEMP <- (is.list(psi.locs[[i]]))&(length(psi.locs[[i]])==sum(psi[i,]>0)) } else{ TEMP <- is.null(psi.locs[[i]]) } if(TEMP==FALSE) stop(paste("You must specify a correct changepoint structure!", "\n")) } } if (!is.null(delta)) { cat("Estimation performed assuming the changepoints are known.", "\n") if (is.null(psi.locs)) { stop(paste("You must specify the changepoints for this setting!", "\n")) } } if ((length(seg.Z) != k) | !inherits(seg.Z, "list", which = TRUE)) { stop(paste("You must specify a list of length k for the segmented relationships!", "\n")) } if (!identical(all.equal(dim(psi),c(k,ncol(x))),TRUE)) { stop(paste("You must specify a matrix with the correct dimension for psi!", "\n")) } if (((length(psi.locs) != k) | !inherits(psi.locs, "list", which = TRUE)) & !is.null(psi.locs)) { stop(paste("You must specify a list of length k for the number of changepoints per predictor in each component!", "\n")) } tot.cp <- apply(psi,1,sum) tmp.ind=1 tmp <- try(suppressWarnings(segregmix.init(y=y, x=x, lambda = lambda, beta = beta, s = sigma, k = k, seg.Z=seg.Z, psi=psi, psi.locs = psi.locs)),silent=TRUE) if(inherits(tmp, "try-error", which = TRUE)){ cat("Generating new initial values.", "\n") while(tmp.ind<=10){ tmp <- try(suppressWarnings(segregmix.init(y=y, x=x, lambda = NULL, beta = NULL, s = NULL, k = k, seg.Z=seg.Z, psi=psi, psi.locs = NULL)),silent=TRUE) tmp.ind <- tmp.ind+1 if(tmp.ind==11) stop(paste("Had to reinitialize algorithm too many times. Reconsider specified model.", "\n")) if(!inherits(tmp, "try-error", which = TRUE)) tmp.ind=20 } } x.old=x x = cbind(1, x) data.x=cbind(y,x) lambda <- tmp$lambda beta <- tmp$beta s <- tmp$s k <- tmp$k psi.locs <- tmp$psi.locs sing <- 0 perms=perm(k,k) perm.ind=nrow(perms) if (is.null(delta)) delta <- lapply(1:k,function(i) NULL) n <- length(y) diff <- 1 iter <- 0 X.aug <- lapply(1:k, function(i) cbind(1,aug.x(x[,-1],unlist(psi.locs[[i]]),psi[i,],delta=delta[[i]]))) X.aug.old <- X.aug psi.locs.old <- psi.locs xbeta <- lapply(1:k, function(i) X.aug[[i]] %*% matrix(beta[[i]],ncol=1)) res <- sapply(1:k, function(i) as.numeric((y - xbeta[[i]])^2)) comp <- t((lambda/sqrt(2 * pi * s^2)) * t(exp(-t(t(res)/(2 * s^2))))) obsloglik <- sum(log(apply(comp, 1, sum))) ll <- obsloglik z = matrix(nrow = n, ncol = k) restarts <- 0 while (diff > epsilon && iter < maxit) { null.beta=0 lambda.old <- lambda beta.old <- beta s.old <- s for (i in 1:n) { for (j in 1:k) { z.denom = c() for (h in 1:k) { z.denom = c(z.denom, (lambda[h]/lambda[j]) * (s[j]/s[h]) * exp(-0.5 * ((1/s[h]^2) * res[i, h] - (1/s[j]^2) * res[i, j]))) } z[i, j] = 1/sum(z.denom) } } z = z/apply(z, 1, sum) z[,k] = 1-apply(as.matrix(z[,-k]),1,sum) z<-round(z,15) z.old <- z lambda.new <- apply(z, 2, mean) if (sum(lambda.new < 1e-08) > 0 || is.na(sum(lambda.new))) { sing <- 1 } else { lm.out <- vector("list",k) psi.temp=psi.locs psi.ind=lapply(1:k,function(i) which(psi[i,]!=0)) for(i in 1:k){ if(is.null(seg.Z[[i]]) | (sum(1-sapply(delta,is.null))>0)){ temp.seg <- lm(fmla,data=data.x,weights=z[,i]) } else temp.seg <- try(suppressWarnings(segmented(lm(fmla,data=data.x,weights=z[,i]),seg.Z=seg.Z[[i]],psi=psi.temp[[i]])),silent=TRUE) if(inherits(temp.seg, "try-error", which = TRUE)){ seq = 1 temp.names = names(psi.locs.old[[i]]) while(seq < 20){ psi.temp2 <- vector("list",length(psi.temp[[i]])) for(ii in 1:length(psi.temp[[i]])){ x.range <- range(data.x[,which(names(data.x)==temp.names[ii])]) psi.temp2[[ii]] <- psi.temp[[i]][[ii]]+sample(c(-1,1),length(psi.temp[[i]][[ii]]),replace=TRUE)*runif(length(psi.temp[[i]][[ii]]),0,diff(x.range)/10) if((any(psi.temp2[[ii]]<=x.range[1]))|(any(psi.temp2[[ii]]>=x.range[2]))) psi.temp2[[ii]]=psi.temp[[i]][[ii]] psi.temp2[[ii]]=sort(psi.temp2[[ii]]) } names(psi.temp2)=temp.names temp.seg <- try(suppressWarnings(segmented(lm(fmla,data=data.x,weights=z[,i]),seg.Z=seg.Z[[i]],psi=psi.temp2[[i]],control=seg.control(it.max=1))),silent=TRUE) if(!inherits(temp.seg, "try-error", which = TRUE)){ seq = seq+1 } else seq=40 } if(seq!=40){ temp.seg <- try(suppressWarnings(segmented(lm(fmla,data=data.x,weights=z[,i]),seg.Z=seg.Z[[i]],psi=psi.temp[[i]],control=seg.control(it.max=1))),silent=TRUE) } } lm.out[[i]]=temp.seg } lambda <- lambda.new if(sum(sapply(lm.out, inherits, "try-error", which=TRUE))>0){ newobsloglik=-Inf } else{ if(sum(1-sapply(delta,is.null))>0){ psi.new <- psi.locs.old } else { psi.new <- psi.locs for(i in 1:k){ if(inherits(lm.out, "segmented", which = TRUE)){ temp.names=names(psi.locs[[i]]) temp.cumsum=cumsum(sapply(psi.locs[[i]],length)) TC.ind = length(temp.cumsum) seg.temp = lm.out[[i]]$psi[,2] psi.new[[i]] = lapply(1:length(psi.locs[[i]]), function(j) as.numeric(lm.out[[i]]$psi[,2])) psi.new[[i]] = vector("list",TC.ind) psi.new[[i]][[1]]=sort(seg.temp[1:temp.cumsum[1]]) if(TC.ind>1) for(j in 2:TC.ind) psi.new[[i]][[j]] = sort(seg.temp[(temp.cumsum[j-1]+1):temp.cumsum[j]]) names(psi.new[[i]])=temp.names } } } X.aug.new <- lapply(1:k, function(i) cbind(1,aug.x(x[,-1],unlist(psi.new[[i]]),psi[i,],delta[[i]]))) lm.out2=lapply(1:perm.ind, function(j) lapply(1:k, function(i) lm(y~X.aug.new[[i]][,-1],weights=z[,perms[j,i]]))) beta.new <- lapply(1:perm.ind, function(j) lapply(lm.out2[[j]],coef)) null.perms <- sapply(1:perm.ind,function(i) all(!is.na(lapply(beta.new,unlist)[[i]]))) null.beta=0 if(sum(null.perms)>0){ xbeta.new <- lapply(1:perm.ind, function(j) lapply(1:k, function(i) X.aug.new[[i]] %*% matrix(beta.new[[j]][[i]],ncol=1))) res <- lapply(1:perm.ind, function(j) sapply(1:k, function(i) (y - xbeta.new[[j]][[i]])^2)) s.new <- lapply(1:perm.ind, function(j) sqrt(sapply(1:k, function(i) sum(z[,perms[j,i]] * (res[[j]][, i]))/sum(z[,perms[j,i]])))) comp <- lapply(1:perm.ind, function(j) lapply(1:k, function(i) lambda.new[i] * dnorm(y, xbeta.new[[j]][[i]], s.new[[j]][i]))) comp <- lapply(1:perm.ind, function(j) sapply(comp[[j]], cbind)) compsum <- lapply(1:perm.ind, function(j) apply(comp[[j]], 1, sum)) newobsloglik <- sapply(1:perm.ind, function(j) sum(log(compsum[[j]]))) newobsloglik[c(1-null.perms)]=-Inf IND <- which.max(newobsloglik) z = z[,perms[IND,]] lambda.new <- apply(z, 2, mean) lambda <- lambda.new beta <- beta.new[[IND]] xbeta <- xbeta.new[[IND]] res <- res[[IND]] X.aug <- X.aug.old s <- s.new[[IND]] psi.locs <- psi.new sing <- sum(s < 1e-08) newobsloglik <- newobsloglik[IND] } else{ newobsloglik=Inf null.beta=1 } } if((newobsloglik0){ xbeta.new <- lapply(1:perm.ind, function(j) lapply(1:k, function(i) X.aug.old[[i]] %*% matrix(beta.new[[j]][[i]],ncol=1))) res <- lapply(1:perm.ind, function(j) sapply(1:k, function(i) (y - xbeta.new[[j]][[i]])^2)) s.new <- lapply(1:perm.ind, function(j) sqrt(sapply(1:k, function(i) sum(z[,perms[j,i]] * (res[[j]][, i]))/sum(z[,perms[j,i]])))) comp <- lapply(1:perm.ind, function(j) lapply(1:k, function(i) lambda.new[i] * dnorm(y, xbeta.new[[j]][[i]], s.new[[j]][i]))) comp <- lapply(1:perm.ind, function(j) sapply(comp[[j]], cbind)) compsum <- lapply(1:perm.ind, function(j) apply(comp[[j]], 1, sum)) newobsloglik <- sapply(1:perm.ind, function(j) sum(log(compsum[[j]]))) newobsloglik[c(1-null.perms)]=-Inf IND <- which.max(newobsloglik) z = z[,perms[IND,]] lambda.new <- apply(z, 2, mean) lambda <- lambda.new beta <- beta.new[[IND]] xbeta <- xbeta.new[[IND]] res <- res[[IND]] X.aug <- X.aug.old s <- s.new[[IND]] psi.locs <- psi.locs.old sing <- sum(s < 1e-08) newobsloglik <- newobsloglik[IND] } else{ newobsloglik=Inf sing=1 } } if(newobsloglik 0 || is.na(newobsloglik) || abs(newobsloglik) == Inf) { cat("Need new starting values due to singularity...", "\n") restarts <- restarts + 1 if (restarts > max.restarts) stop("Too many tries!") tmp.ind=1 while(tmp.ind==1){ if(sum(1-sapply(delta,is.null))>0) psi.temp=psi.locs tmp <- try(suppressWarnings(segregmix.init(y=y, x=x.old, lambda = NULL, beta = NULL, s = NULL, k = k, seg.Z=seg.Z, psi=psi, psi.locs = NULL)),silent=TRUE) if(!inherits(tmp, "try-error", which = TRUE)) tmp.ind=2 } lambda <- tmp$lambda beta <- tmp$beta s <- tmp$s k <- tmp$k psi.locs <- tmp$psi.locs n <- length(y) diff <- 1 iter <- 0 X.aug <- lapply(1:k, function(i) cbind(1,aug.x(x[,-1],unlist(psi.locs[[i]]),psi[i,],delta[[i]]))) xbeta <- lapply(1:k, function(i) X.aug[[i]] %*% matrix(beta[[i]],ncol=1)) res <- sapply(1:k, function(i) as.numeric((y - xbeta[[i]])^2)) comp <- t((lambda/sqrt(2 * pi * s^2)) * t(exp(-t(t(res)/(2 * s^2))))) obsloglik <- sum(log(apply(comp, 1, sum))) ll <- obsloglik } else { diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) X.aug.old <- X.aug psi.locs.old <- psi.locs iter <- iter + 1 if (verb) { cat("iteration =", iter, "diff =", diff, "log-likelihood =", obsloglik, "\n") } } } if (iter == maxit) { warning("Maximum number of iterations reached.", call. = FALSE) } if (iter == 1) { cat("Converged in 1 iteration. Consider rerunning with different starting values or smaller stopping criterion.", "\n") } cat("number of iterations=", iter, "\n") names(delta) <- c(paste("comp", ".", 1:k, sep = "")) names(seg.Z) <- c(paste("comp", ".", 1:k, sep = "")) names(psi.locs) <- c(paste("comp", ".", 1:k, sep = "")) names(beta) <- c(paste("comp", ".", 1:k, sep = "")) for(i in 1:k){ names(beta[[i]])[1]="(Intercept)" names(beta[[i]])[2:ncol(x)]=colnames(x)[-1] if(!is.null(psi.locs[[i]])){ for(j in 1:ncol(psi)){ if(psi[i,j]>0 & j==1){ names(beta[[i]])[(ncol(x)+1):(ncol(x)+cumsum(psi[i,])[j])]=c(paste(colnames(x)[j+1], ".", 1:psi[i,j], sep = "")) } else if(psi[i,j]>0) names(beta[[i]])[(ncol(x)+cumsum(psi[i,])[j-1]+1):(ncol(x)+cumsum(psi[i,])[j])]=c(paste(colnames(x)[j+1], ".", 1:psi[i,j], sep = "")) } } } colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a = list(x = x, y = y, lambda = lambda, beta = beta, sigma = s, seg.Z = seg.Z, psi.locs = psi.locs, delta = delta, loglik = obsloglik, posterior = z, all.loglik = ll, restarts = restarts, ft = "segregmixEM") class(a) = "mixEM" a }mixtools/R/expReliabilityMixEM.R0000644000176200001440000001231214342153463016346 0ustar liggesusers# code for Reliability Mixture Models (RMM) with Censored data # D. Chauveau # ref: Bordes L. and Chauveau D. Computational Statistics (2016) # Simulate from an exponential mixture. # lambda = vector of component probabilities # rate = vector of component rates rexpmix <- function(n,lambda=1,rate=1) { m <- length(lambda) # nb of components z <- sample(m, n, replace = TRUE, prob = lambda) # component indicator rexp(n, rate = rate[z]) } # pdf of exponential mixture dexpmixt <- function(t,lam,rate){ m <- length(lam) f <- 0 for (j in 1:m) f <- f + lam[j]*dexp(t,rate=rate[j]) f } ############################################## ## EM algorithm for Reliability Mixture Models (RMM) with Censoring ## Parametric model, for ## univariate finite mixture of exponentials with right censoring # x = lifetime data, censored by random c if d is not NULL, in which case # x= min(x,c) and d = I(x <= c) # complete data may be (t,d,z) or (x,z), see option complete expRMM_EM <- function (x, d=NULL, lambda = NULL, rate = NULL, k = 2, complete="tdz", epsilon = 1e-08, maxit = 1000, verb = FALSE) { # warn <- options(warn=-1) # Turn off warnings # x <- as.vector(x) n <- length(x) if (!is.null(lambda)) k=length(lambda) if (!is.null(rate)) k=length(rate) # either should be define !!! if (is.null(d)) d <- rep(1,n) # simple EM for noncensored case xx <- matrix(x, nrow=n, ncol=k) # x repeated k times, used in E-steps dd <- matrix(d, nrow=n, ncol=k) # idem for d # init function call to do later, in case lambda = rate = NULL if (is.null(lambda)) lambda <- rep(1/k,k) if (is.null(rate)) rate <- rep(1,k) # to do : init.rate(k) # handle the 2 complete data models if (complete=="tdz") comptdz=TRUE else comptdz=FALSE # sequences for storing along iterations lambda_seq <- rate_seq <- matrix(0, nrow = maxit, ncol = k) lambda_seq[1,] <- lambda rate_seq[1,] <- rate loglik_seq <- NULL oldloglik <- -Inf # notdone <- TRUE # while(notdone) { # Initialize everything notdone <- FALSE dll <- epsilon+1 iter <- 1 post <- matrix(nrow = n, ncol = k) restarts <- 0 while (dll > epsilon && iter < maxit) { # EM iterations ### E-step ### rr <- matrix(rate, n, k, byrow=T) ll <- matrix(lambda, n, k, byrow=T) # handling censored & non-censored cases post <- ((ll*dexp(xx,rr))^dd)*((ll*(1-pexp(xx,rr)))^(1-dd)) rs <- rowSums(post) loglik <- sum(log(rs)) # loglik without the constant term # post normalized per row post <- sweep(post, 1, rs, "/") # posteriors p_{ij}^t 's ### M-step ### lambda <- colMeans(post) lambda_seq[iter+1, ] <- lambda if (comptdz) rate <- colSums(post*dd)/colSums(post*xx) # complete=(t,d,z) # rate <- colSums(post*d)/colSums(post*x) # gives same answer # cf automatic recycling if (!comptdz) { # complete data = (x,z) mean_xi <- matrix(1/rate, n, k, byrow=T) rate <- colSums(post)/colSums(post*(xx + (1-dd)*mean_xi)) # rate <- colSums(post)/colSums(post*(x + (1-d)*mean_xi)) # same answer } rate_seq[iter+1, ] <- rate dll <- loglik - oldloglik # = Inf for iter=0 1st time oldloglik <- loglik loglik_seq <- c(loglik_seq, loglik) if (verb) { cat("iteration", iter, " log-lik diff =", dll, " log-lik =", loglik, "\n") } iter <- iter + 1 } # end of EM loops over iterations if (iter == maxit) cat("WARNING! NOT CONVERGENT!", "\n") cat("number of iterations =", iter - 1, "\n") colnames(post) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, d=d, lambda = lambda, rate = rate, loglik = loglik, posterior = post, all.loglik=loglik_seq, all.lambda = lambda_seq[1:iter,], all.rate = rate_seq[1:iter,], # restarts=restarts, ft="expRMM_EM") class(a) = "mixEM" a } ################################################## # plot EM sequences from expRMM_EM: # color by components, one plot per parameter type # commented-out abline() usages are for true values for rate and lambda if available plotexpRMM <- function(a, title=NULL, rowstyle=TRUE, subtitle=NULL, ...) { n <- length(a$x); m <- dim(a$all.lambda)[2] pcc <- round(100*(1-mean(a$d)),2) sizes <- paste("n=",n,", ", pcc, "% censored", sep="") if (is.null(subtitle)) { subtitle <- paste("n=",n,", ", pcc, "% censored", sep="")} if (is.null(title)) { tt1 <- "Rate parameters" tt2 <- "Weight parameters" } else tt1 <- tt2 <- title lwdset <- 2 if (rowstyle) par(mfrow=c(1,2)) else par(mfrow=c(2,1)) plot(a$all.rate[,1], type="l", ylim=c(0,max(a$all.rate)), xlab="iterations", ylab="estimates", main=tt1, ...) title(sub=subtitle,cex.sub = 0.75) lgd <- expression(xi[1]); lcol <- 1 for (j in 2:m) { lines(a$all.rate[,j], col=j, ...) # abline(rate[j],0,col=j,lty=3) lgd <- c(lgd,substitute(xi[j])); lcol <- c(lcol,j) } legend("topright",lgd,col=lcol,lty=1,...) plot(a$all.lambda[,1], type="l", ylim=c(0,1), xlab="iterations", ylab="estimates", main=tt2, ...) title(sub=subtitle,cex.sub = 0.75) lgd <- expression(lambda[1]); lcol <- 1 if (m>2) { for (j in 2:m) { lines(a$all.lambda[,j], col=j, ...) lgd <- c(lgd,substitute(lambda[j])) lcol <- c(lcol,j) } } legend("topright",lgd,col=lcol,lty=1,...) } mixtools/R/testequality.R0000755000176200001440000000405414342153463015224 0ustar liggesuserstest.equality <- function(y, x = NULL, arbmean=TRUE, arbvar=FALSE, mu=NULL, sigma=NULL, beta=NULL, lambda=NULL,...){ if(arbmean==arbvar) stop("Change either 'arbmean' or 'arbvar'!") if(arbmean==FALSE){ w=1 while(w==1){ if(is.null(x)){ H0=normalmixEM(x=y,arbmean=FALSE,arbvar=TRUE, mu=mu, sigma=sigma, lambda=lambda,...) k=length(H0$lambda) # H1=normalmixEM(x=y,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,mu=rep(H0$mu,k)*(1:k),sigma=(H0$scale*H0$sigma),...) H1=normalmixEM(x=y,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,mu=NULL,sigma=(H0$scale*H0$sigma),...) D=2*(H1$loglik-H0$loglik) df=k-1 alpha=1-pchisq(D,df=df) } else{ H0=regmixEM(y=y,x=x,arbmean=FALSE,arbvar=TRUE,beta=beta, sigma=sigma, lambda=lambda,...) k=length(H0$lambda) # H1=regmixEM(y=y,x=x,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,beta=matrix(rep(H0$beta,k),k)*(1:k),sigma=(H0$scale*H0$sigma),...) H1=regmixEM(y=y,x=x,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,beta=NULL,sigma=(H0$scale*H0$sigma),...) p=nrow(H1$beta) D=2*(H1$loglik-H0$loglik) df=p*(k-1) alpha=1-pchisq(D,df=df) } if(D<0){ w=1 mu=NULL sigma=NULL lambda=NULL } else w=2 } } if(arbvar==FALSE){ w=1 while(w==1){ if(is.null(x)){ H0=normalmixEM(x=y,arbmean=TRUE,arbvar=FALSE,mu=mu, sigma=sigma, lambda=lambda,...) k=length(H0$lambda) # H1=normalmixEM(x=y,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,mu=H0$mu,sigma=rep(H0$sigma,k),...) H1=normalmixEM(x=y,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,mu=H0$mu,sigma=NULL,...) D=2*(H1$loglik-H0$loglik) df=k-1 alpha=1-pchisq(D,df=df) } else{ H0=regmixEM(y=y,x=x,arbmean=TRUE,arbvar=FALSE,beta=beta, sigma=sigma, lambda=lambda,...) k=length(H0$lambda) # H1=regmixEM(y=y,x=x,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,beta=H0$beta,sigma=rep(H0$sigma,k),...) H1=regmixEM(y=y,x=x,arbmean=TRUE,arbvar=TRUE,lambda=H0$lambda,beta=H0$beta,sigma=NULL,...) D=2*(H1$loglik-H0$loglik) df=k-1 alpha=1-pchisq(D,df=df) } if(D<0){ w=1 mu=NULL sigma=NULL lambda=NULL } else w=2 } } a=list(chi.sq=D, df=df, p.value=alpha) a }mixtools/R/plotseq.npEM.R0000755000176200001440000000306114342153463015011 0ustar liggesusers# plots SEQuence from npEM object # function for plotting the scalar parameters sequences along iterations # if object x comes from npEM, just the x$lambda sequence # if object x comes from spEM, both x$lambda and x$mu sequences plotseq <- function(x, ...) UseMethod("plotseq") plotseq.npEM <- function(x, ...) { # ask <- par(ask=TRUE) r <- NCOL(x$data) n <- NROW(x$data) m <- length(x$lambdahat) iter <- NROW(x$lambda) xlabel <- paste("iterations") nbcol <- 1 if (!is.null(x$symmetric) && x$symmetric) nbcol <- 2 par(mfcol=c(m, nbcol)) # in all cases, plots the lambda's for (j in 1:m) { estim <- paste(round(x$lambdahat[j],3)) tt <- substitute(expression(paste("sequence of ",lambda[j], ", estimate ",widehat(lambda[j]),"=", estim, sep=""))) ylabel <- substitute(expression(paste(lambda[j],sep=""))) plot(x$lambda[,j], type="l", main=eval(tt), xlab=xlabel, ylab=eval(ylabel), ...) lines(c(0,iter),rep(x$lambdahat[j],2),col=2,lty=2) } ## for symmetric location spEM case plots mu if (!is.null(x$symmetric) && x$symmetric) { for (j in 1:m) { estim <- paste(round(x$muhat[j],3)) tt <- substitute(expression(paste("sequence of ",mu[j], ", estimate ",widehat(mu[j]),"=",estim,sep=""))) ylabel <- substitute(expression(paste(mu[j],sep=""))) plot(x$mu[,j], type="l", main=eval(tt), ylab=eval(ylabel), xlab=xlabel, ...) lines(c(0,iter),rep(x$muhat[j],2),col=2,lty=2) } # legend("topright", legend=round(x$muhat,3), fill=2:(m+1)) } # structure (list (call=match.call())) } mixtools/R/plotly_FDR.R0000644000176200001440000000647414342641745014517 0ustar liggesusersplotly_FDR <- function(post1, post2=NULL, lg1="FDR 1", lg2=NULL, compH0=1, alpha=0.1, complete.data =NULL, pctfdr=0.3, col = NULL, width = 3 , title = NULL , title.size = 15 , title.x = 0.5 , title.y = 0.95, xlab = "Index" , xlab.size = 15 , xtick.size = 15, ylab = "Probability" , ylab.size = 15 , ytick.size = 15, legend.text = "" , legend.text.size = 15 , legend.size = 15 ){ hline <- function(y = 0, color = '#1f77b4') { list( type = "line", y0 = y, y1 = y, xref = "paper", x0 = 0, x1 = 1, line = list(color = '#1f77b4', dash = "dash", width = 1) ) } if(is.null(col)){ col <- hue_pal()(3) } if(length(col) != 3){ print("Please specify 3 colors in 'col'.") } n <- dim(post1)[1] cs1 <- cumsum(post1[,compH0]) # local FDR(p_i)'s fdr1 <- cs1/(1:n) # FDR(p_i)'s if (is.null(title)) title <- paste("FDR estimate(s), n=",n) if (!is.null(post2)) { cs2 <- cumsum(post2[,compH0]) # local FDR(p_i)'s fdr2 <- cs2/(1:n) if (is.null(lg2)) {lg2 <- "FDR 2"} } i1 <- sum(fdr1 pctfdr # cat("index",i1) plot <- plot_ly()%>% add_trace(x=seq(from = 1 , to = i1 , by = 1) , y=fdr1[1:i1] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[1]), name = lg1, showlegend = TRUE)%>% plotly::layout( legend = list(title=list(text=legend.text, font=list(size=legend.text.size)), font = list(size=legend.size)), title = list(text = title, x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ), shapes = list(type = "line", y0 = alpha, y1 = alpha, xref = "paper", x0 = 0, x1 = 1, line = list(color = '#1f77b4', dash = "dash", width = 1) ) ) if (!is.null(post2)){ plot <- plot%>% add_trace(x=seq(from = 1 , to = i1 , by = 1) , y=fdr2[1:i1] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[2]), name = lg2, showlegend = TRUE) } if (!is.null(complete.data)){ V <- cumsum(complete.data[,1]==1) # cumulative nb of items under H0 trueFDR <- V/(1:n) plot <- plot%>% add_trace(x=seq(from = 1 , to = i1 , by = 1) , y=trueFDR[1:i1] , type = 'scatter' , mode = 'lines', line = list(width = width , color = col[3] , dash = "dash"), name = "True FDR", showlegend = TRUE) } print(plot) } mixtools/R/compcdf.R0000755000176200001440000000176414342153463014107 0ustar liggesuserscompCDF <- function(data, weights, x=seq(min(data, na.rm=TRUE), max(data, na.rm=TRUE), len=250), comp=1:NCOL(weights), makeplot=TRUE, ...) { if (NROW(weights) != NROW(data)) { stop("data and weights arguments must have same number of rows") } # First, normalize the weights so the sum of each column is 1/NCOL(data) weights <- t(t(weights) / (NCOL(data) * colSums(weights))) # Next, give a binomial count for each row of the data and for each x f <- function(row, cutpt) colSums(outer(row, cutpt, "<="), na.rm = TRUE) bc <- apply(data, 1, f, x) # bc is a length(x) by n matrix; each column should be multiplied by # the appropriate weight(s) and then the rows summed to give the # unnormalized cdf estimates. This is just a matrix product. cdfs <- bc %*% weights[,comp,drop=FALSE] if(makeplot) { plot(range(x), 0:1, type="n", ...) for (i in 1:length(comp)) { lines(x, cdfs[,comp[i]], lty=i, ...) } } t(cdfs) } mixtools/R/rmvnormmix.R0000755000176200001440000000074014342153463014703 0ustar liggesusers# Note: normmixrm.sim is here for backwards compatibility rmvnormmix <- normmixrm.sim <- function(n,lambda=1,mu=0,sigma=1) { m <- length(lambda) # nb of components mu <- matrix(mu, nrow=m) sigma <- matrix(sigma, nrow=m) if ((r <- NCOL(mu)) != NCOL(sigma)) { stop("mu and sigma must have the same number of columns", call.=FALSE) } z <- sample(m,n,replace=TRUE,prob=lambda) # component matrix(rnorm(n*r,mean=as.vector(mu[z,]),sd=as.vector(sigma[z,])),n,r) } mixtools/R/spEM.R0000644000176200001440000001151514342153463013330 0ustar liggesusers## EM-like algorithm for a location-scale mixture model with ## independent repeated measures -- some ID, some not -- ## where each block has its own location and scale but otherwise ## all blocks (within a component or globally, depending) have the same ## shape. ## Correction: For now, this algorithm only implements model (17) in ## Benaglia et al -- in other words, each component and block has exactly ## the same shape and they differ only by location and scale. spEM <- function(x, mu0, blockid = 1:ncol(x), bw=bw.nrd0(as.vector(as.matrix(x))), constbw = TRUE, h=bw, eps=1e-8, maxiter=500, stochastic = FALSE, verb = TRUE){ bw <- h # h is alternative bandwidth argument, for backward compatibility x <- as.matrix(x) n <- nrow(x) # number of subjects r <- ncol(x) # number of measurements in each subject u <- match(blockid, unique(blockid)) # convert blockid to integers 1, 2, ... if (is.matrix(mu0)) m <- dim(mu0)[1] # mu0=centers else m <- mu0 # mu0=number of clusters z.hat <- matrix(0, nrow = n, ncol = m) tt0 <- proc.time() # for total time ## Initial Values if(m == 1) z.hat <- matrix(1, nrow = n, ncol = m) else{ kmeans <- kmeans(x, mu0) for(j in 1:m) z.hat[kmeans$cluster==j, j] <- 1 } iter <- 0 if (stochastic) { sumpost <- matrix(0, n, m) } finished <- FALSE lambda <- matrix(0, nrow = maxiter, ncol = m) mu <- sigma <- array(0, dim=c(maxiter, m, max(u))) stackedx <- x[rep(1:n,m),] loglik <- NULL while (!finished) { iter <- iter + 1 bw.old <- bw t0 <- proc.time() ## Note: Enter loop assuming E-step is done -- i.e., z.hat is in place ## M-Step lambda[iter, ] <- colMeans(z.hat) if (stochastic) { z <- t(apply(z.hat, 1, function(prob) rmultinom(1, 1, prob))) cs <- colSums(z) z.tmp <- sweep(z, 2, cs, "/") z.tmp[, cs==0] <- 1/NROW(z.tmp) # Just in case } else { cs <- colSums(z.hat) z.tmp <- sweep(z.hat, 2, cs, "/") z.tmp[, cs==0] <- 1/NROW(z.tmp) # Just in case } h <- bw ## More M-step (means and std devs are location / scale params) for (k in 1:max(u)) { # k is the block number r2 <- sum(u == k) x2 <- x[, u==k] # Subset of data belonging to kth block (n x r2 matrix) mu[iter, , k] <- as.vector(rowMeans(t(z.tmp) %*% x2)) for (j in 1:m) sigma[iter, j, k] <- sqrt(sum(z.tmp[,j] * (x2-mu[iter, j, k])^2)/r2) } ## density estimation step if (!constbw) { wts <- rep(as.vector(z.tmp),r) scaledx <- as.vector((stackedx - mu[iter, rep(1:m, each=n), u])/ sigma[iter, rep(1:m, each=n), u]) h <- bw <- 0.9 / (n*r)^(1/5) * min(1, wiqr<-wIQR(wt=wts, x=scaledx)/1.34) } ans <- .C(C_KDElocscale, n = as.integer(n), m = as.integer(m), r = as.integer(r), blockid=as.integer(u), mu = as.double(mu[iter, , ]), sigma = as.double(sigma[iter, , ]), x = as.double(x), bw = as.double(h), z = as.double(z.tmp), f = double(n*m), PACKAGE="mixtools") lambda.f <- sweep(matrix(ans$f, ncol=m), 2, lambda[iter, ], "*") ## E-step (for next iteration) z.hat <- lambda.f/rowSums(lambda.f) loglik <- c(loglik,sum(log(rowSums(lambda.f)))) # log-likelihood finished <- iter >= maxiter if (stochastic) { sumpost <- sumpost + z.hat } else if (iter > 1) { # This convergence criterion may be too simplistic: maxchange <- max(abs(lambda[iter,] - lambda[iter-1,])) if (!constbw) maxchange <- max(maxchange, max(abs(bw.old - bw))) finished <- finished | (maxchange < eps) } if (verb) { t1 <- proc.time() cat("iteration", iter, " lambda ", round(lambda[iter, ], 4)) cat(" time", (t1 - t0)[3], "\n") } } if (verb) { tt1 <- proc.time() cat("lambda ", round(lambda[iter, ], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } if (stochastic) { return(structure(list(data = x, posteriors = sumpost/iter, lambda = lambda, bandwidth = bw, blockid = u, lambdahat = colMeans(lambda), mu = mu, muhat = colMeans(mu), sigma = sigma, sigmahat = colMeans(sigma), loglik = loglik), class="spEM")) } else { return(structure(list(data = x, posteriors = z.hat, lambda = lambda[1:iter,], bandwidth = bw, blockid = u, lambdahat = lambda[iter,], mu = mu[1:iter, , ], muhat = mu[iter, , ], sigma = sigma[1:iter, , ], sigmahat = sigma[iter, , ], loglik = loglik), class="spEM")) } } mixtools/R/print.npEM.R0000755000176200001440000000077014342153463014462 0ustar liggesusersprint.npEM <- function(x, ...) { n <- NROW(x$data) r <- NCOL(x$data) m <- length(x$lambdahat) cat(paste("Observations:", n, "\n")) cat(paste("Coordinates per observation:", r, "\n")) cat(paste("Mixture components:", m, "\n")) if (r>1) { B <- max(x$blockid) cat(paste("Blocks (of conditionally iid coordinates):", B, "\n\n")) } dp = match(c("data","posteriors", "lambda", "mu"), names(x), nomatch=0) print.default(structure(x[-dp], class=class(x)), ...) invisible(x) } mixtools/R/tauequivnormalmixEM.R0000644000176200001440000000341614342153463016501 0ustar liggesusers## Use an ECM algorithm (in the sense of Meng and Rubin, Biometrika 1993) ## to search for a local maximum of the likelihood surface for a ## univariate finite mixture of normals with possible equality ## constraints on the stdev parameters. ## It is assumed here that there are three components and the three normal means ## are equal to alpha, alpha-delta, and alpha+delta for unknown parameters ## alpha and delta. ## In other words, this function implements the specific model described in ## Thomas et al (2009), Extensions of Reliability Theory. ## It is a modified version of normalmixEM. tauequivnormalmixEM <- function (x, lambda = NULL, mu = NULL, sigma = NULL, k = 3, mean.constr = NULL, sd.constr = NULL, gparam = NULL, epsilon = 1e-08, maxit = 10000, maxrestarts=20, verb = FALSE, fast=FALSE, ECM = TRUE, arbmean = TRUE, arbvar = TRUE) { M <- A <- NULL if (is.null(mean.constr)) { # In this case, we will be fitting a 3-component mixture model with means # constrained to be alpha, alpha-delta, and alpha+delta for # parameters alpha and delta. k <- 3 if (length(mu) != 3) mu <- NULL if (length(sigma) != 3) sigma <- NULL M <- matrix(c(1, 1, 1, 0, -1, 1), 3, 2) # We will also constain the reciprocals of the variances to be # gamma_1+gamma_2, gamma_1, and gamma_1 for positive # parameters gamma_1 and gamma_2. A <- matrix(c(1, 1, 1, 1, 0, 0), 3, 2) } normalmixMMlc(x, lambda = lambda, mu = mu, sigma = sigma, k = k, mean.constr = mean.constr, mean.lincstr = M, var.lincstr = A, gparam = gparam, epsilon = epsilon, maxit = maxit, maxrestarts = maxrestarts, verb = verb) } mixtools/R/multmixEM.R0000755000176200001440000000643614342153463014416 0ustar liggesusersmultmixEM <- function (y, lambda = NULL, theta = NULL, k = 2, maxit = 10000, epsilon = 1e-08, verb = FALSE) { if (class(y)[1]=="list" && !is.null(y$y)) { y <- y$y } n <- nrow(y) p <- ncol(y) m <- colSums(y) r <- rowSums(y) # These need not all be the same tmp <- multmix.init(y=y, lambda=lambda, theta=theta, k=k) lambda <- tmp$lambda theta <- tmp$theta k <- tmp$k restarts<-0 mustrestart <- FALSE llconstant <- sum(lgamma(r+1)) - sum(lgamma(y+1)) while (restarts < 50) { ll <- NULL iter <- 0 diff <- epsilon+1 # to ensure entering main EM loop # Normalize rows of theta matrix theta <- theta/rowSums(theta) theta <- pmax(theta, 1e-100) # ensure no zeros # preparatory E-step prior to entering main EM loop loglamcd <- log(lambda) + log(theta) %*% t(y) # kxn matrix of log(lambda * component densities) z <- .C(C_multinompost, as.integer(n), as.integer(k), as.double(loglamcd), post=double(n*k), loglik=as.double(llconstant), PACKAGE = "mixtools") post <- matrix(z$post, ncol=k) newll <- z$loglik tmp.post <- (post==0) if(any(apply(tmp.post,2,sum)==n)){ diff <- epsilon mustrestart <- TRUE } while ((iter < maxit) && diff > epsilon) { # main EM loop iter <- iter + 1 oldll <- newll ll <- c(ll, oldll) # M-step: First update theta values (proportional to sum of posteriors * data) theta <- t(post) %*% y theta <- theta/rowSums(theta) theta <- pmax(theta, 1e-100) # ensure no zeros # M-step: Update the lambdas as usual for a finite mixture lambda <- colMeans(post) # E-step: prepare to find posteriors using C function loglamcd <- log(lambda) + log(theta) %*% t(y) # kxn matrix of log(lambda * component densities) # E-step: Call C function to return nxk matrix of posteriors along with loglikelihood z <- .C(C_multinompost, as.integer(n), as.integer(k), as.double(loglamcd), post=double(n*k), loglik=as.double(llconstant), PACKAGE = "mixtools") post <- matrix(z$post, ncol=k) newll <- z$loglik diff <- newll - oldll if (diff<0 || is.na(newll) || is.infinite(newll) || is.nan(newll)) { mustrestart <- TRUE break } if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", ll[iter], "lambda", lambda, "\n") } } if (mustrestart) { cat("Restarting due to numerical problem.\n") mustrestart <- FALSE restarts <- restarts + 1 tmp <- multmix.init(y=y, k=k) lambda <- tmp$lambda theta <- tmp$theta k <- tmp$k } else { if (iter == maxit) { cat("Warning: Not convergent after", maxit, "iterations\n") } theta[,p] <- 1-apply(as.matrix(theta[,1:(p-1)]),1,sum) colnames(theta) <- c(paste("theta", ".", 1:p, sep = "")) rownames(theta) <- c(paste("comp", ".", 1:k, sep = "")) colnames(post) <- c(paste("comp", ".", 1:k, sep = "")) cat("number of iterations=", iter, "\n") out <-list(y=y, lambda = lambda, theta = theta, loglik = ll[length(ll)], posterior = post, all.loglik=ll, restarts=restarts, ft="multmixEM") class(out) <- "mixEM" return(out) } } stop("Too many restarts!") } mixtools/R/mixturegram.R0000644000176200001440000001247314342153463015034 0ustar liggesusersmixturegram <- function(data, pmbs, method=c("pca","kpca","lda"), all.n=FALSE, id.con=NULL, score=1, iter.max=50, nstart=25, ...){ col.blind=rep(c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#7FFF00","#7D26CD"),100) method <- match.arg(method) k=length(pmbs)+1 if (is.null(id.con)) id.con=lapply(pmbs,function(x) data%*%x/apply(x,2,sum)) ###regular pca if(method=="pca"){ x.star=c(list(data), lapply(1:(k-1), function(i) cbind(data,pmbs[[i]][,order(id.con[[i]])]))) Data=lapply(x.star,scale) if(score>(ncol(Data[[1]])+1)) warning(paste("The largest value that can be specified for 'score' is ",ncol(Data[[1]])+1,", which is what will be used for the mixturegram.",sep="")) score<-min(score,ncol(x.star[[2]])) if(score==1){ PCA=lapply(Data,function(x) x%*%princomp(x)$loadings[,score]) } else{ PCA <- vector("list",k) PCA[[1]]=Data[[1]]%*%princomp(Data[[1]])$loadings[,1] PCA[2:k]=lapply(1:(k-1),function(i) Data[[(i+1)]]%*%princomp(Data[[(i+1)]])$loadings[,score]) } K=lapply(2:k,function(i) kmeans(PCA[[i]],i,iter.max=iter.max,nstart=nstart)) lim=ceiling(max(abs(unlist(PCA)))) plot(1:k,rep(1e1000,k),ylim=c(-lim,lim),col='white',xlab='k',ylab='PC Scores',xaxt="n", ...) rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col = colors()[356]) axis(1,at=1:k,labels=1:k) abline(v=1:k,col="gray80") mix.method <- PCA }else{ ###kernel pca if(method=="kpca"){ x.star=c(list(data), lapply(1:(k-1), function(i) cbind(data,pmbs[[i]][,order(id.con[[i]])]))) Data=lapply(x.star,scale) if(score>(ncol(Data[[1]])+1)) warning(paste("The largest value that can be specified for 'score' is ",ncol(Data[[1]])+1,", which is what will be used for the mixturegram.",sep="")) score<-min(score,ncol(x.star[[2]])) if(score==1){ kPCA=lapply(Data,function(x) cbind(pcv(kpca(x))[,1])) } else{ kPCA <- vector("list",k) kPCA[[1]]=cbind(pcv(kpca(Data[[1]]))[,1]) kPCA[2:k]=lapply(1:(k-1),function(i) cbind(pcv(kpca(Data[[i+1]]))[,score])) } K=lapply(2:k,function(i) kmeans(kPCA[[i]],i,iter.max=iter.max,nstart=nstart)) lim=max(abs(unlist(kPCA)))+0.1 plot(1:k,rep(1e1000,k),ylim=c(-lim,lim),col='white',xlab='k',ylab='Kernel PC Scores',xaxt="n", ...) rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col = colors()[356]) axis(1,at=1:k,labels=1:k) abline(v=1:k,col="gray80") mix.method <- kPCA }else{ if(method=="lda"){ class=lapply(pmbs, function(post) apply(post,1,which.max)) ldcdata = c(list(as.matrix(data) %*% ldc(data, rep(1,nrow(as.matrix(data))),score=score)), lapply(class, function(class) as.matrix(data) %*% ldc(data, class,score=score))) K=lapply(2:k,function(i) kmeans(ldcdata[[i]],i,iter.max=iter.max,nstart=nstart)) lim=ceiling(max(abs(unlist(ldcdata)))) plot(1:k,rep(1e1000,k),ylim=c(-lim,lim),col='white',xlab='k',ylab='LDC Scores',xaxt="n", ...) rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col = colors()[356]) axis(1,at=1:k,labels=1:k) abline(v=1:k,col="gray80") mix.method <- ldcdata } } } Kcol=function(x){ temp=unlist(sapply(1:length(x$size),function(i) rep(rank(x$center)[i],x$size[i]))) index=unlist(sapply(1:length(x$size),function(i) which(x$cluster==i))) K.col=replace(x$cluster,index,temp) } all.K.col=lapply(1:(k-1), function(i) Kcol(K[[i]])) K.col=all.K.col[[k-1]] n=length(K.col) K.centers=c(0, lapply(1:(k-1), function(i) sort(c(K[[i]]$centers)))) if(all.n){ sapply(1:(k-1),function(i) segments(i,mix.method[[i]],(i+1),mix.method[[i+1]],col=col.blind[K.col])) points(1,mean(mix.method[[1]]),pch=21,cex=1.2,bg=colors()[553],col=1) sapply(2:k,function(i) points(rep(i,i),sort(c(K[[i-1]]$centers)),pch=21,cex=1.2,bg=colors()[553],col=1)) } else{ ride.medians=sapply(1:k, function(i) unlist(by(c(mix.method[[i]]),col.blind[K.col],median))) prop.mad=sapply(1:k, function(i) unlist(by(c(mix.method[[i]]),col.blind[K.col],mad))) L1=ride.medians-prop.mad U1=ride.medians+prop.mad L2=ride.medians-2*prop.mad U2=ride.medians+2*prop.mad L3=ride.medians-3*prop.mad U3=ride.medians+3*prop.mad srt.colors=rownames(ride.medians) srt.colors1=adjustcolor(srt.colors, alpha.f = 0.7) srt.colors2=adjustcolor(srt.colors, alpha.f = 0.4) srt.colors3=adjustcolor(srt.colors, alpha.f = 0.2) invisible(sapply(1:k, function(i) polygon(c(1:k,k:1),c(L3[i,],rev(U3[i,])),col=srt.colors3[i], border=FALSE) )) invisible(sapply(1:k, function(i) polygon(c(1:k,k:1),c(L2[i,],rev(U2[i,])),col=srt.colors2[i], border=FALSE) )) invisible(sapply(1:k, function(i) polygon(c(1:k,k:1),c(L1[i,],rev(U1[i,])),col=srt.colors1[i], border=FALSE) )) invisible(sapply(1:(k-1),function(i) segments(rep(i,k),ride.medians[,i],rep((i+1),k),ride.medians[,(i+1)],col=srt.colors) )) points(1,mean(mix.method[[1]]),pch=21,cex=1.2,bg=colors()[553],col=1) invisible(sapply(2:k,function(i) points(rep(i,i),sort(c(K[[i-1]]$centers)),pch=21,cex=1.2,bg=colors()[553],col=1))) } props=c(1,sapply(1:length(K), function(i) K[[i]][[5]]/sum(unlist(K[[i]][5:6])))) print(list(stopping=props)) } mixtools/R/regmixEMloc.R0000755000176200001440000000566614343276574014726 0ustar liggesusersregmixEM.loc=function (y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, addintercept = TRUE, kern.l = c("Gaussian", "Beta", "Triangle", "Cosinus", "Optcosinus"), epsilon = 1e-08, maxit = 10000, kernl.g = 0, kernl.h = 1, verb = FALSE) { diff <- 1 iter <- 0 x.1 <- cbind(1, x) n <- length(y) kern.l <- match.arg(kern.l) out.EM <- regmixEM.lambda(y, x, lambda = lambda, beta = beta, sigma = sigma, k = k, epsilon = epsilon, maxit = maxit) ll = out.EM$loglik restarts <- 0 while (diff > epsilon && iter < maxit) { old.l.x = out.EM$lambda old.loglik = out.EM$loglik l.x = matrix(nrow = n, ncol = k) for (i in 1:k) { # l.x[, i] <- c((cbind(rep(1,n),0)*t(apply(matrix(x, ncol = 1), 1, lambda, # z = out.EM$post[, i], xi = x, kernel = kern.l, # g = kernl.g, h = kernl.h)))[,1]) l.x[,i] <- t(apply(as.matrix(x), 1, lambda, z = out.EM$post[, i], xi = as.matrix(x), kernel = kern.l, g = kernl.g, h = kernl.h))[,1] l.x[,i] <- pmin(pmax(l.x[,i],0),1) # l.x[,i]=apply(cbind(l.x[,i]),1,max,0) # l.x[,i]=apply(cbind(l.x[,i]),1,min,1) } l.x <- l.x/matrix(rep(apply(l.x,1,sum),k),ncol = k) # l.x <- cbind(l.x, 1 - apply(l.x, 1, sum)) out.EM.loc <- regmixEM.lambda(y, x, beta = out.EM$beta, sigma = out.EM$sigma, lambda = l.x, k = k) loglik.loc <- out.EM.loc$loglik out.EM.old <- regmixEM.lambda(y, x, beta = out.EM$beta, sigma = out.EM$sigma, lambda = old.l.x, k = k) loglik.old <- out.EM.old$loglik if (loglik.loc > old.loglik) { out.EM <- out.EM.loc } else out.EM <- out.EM.old loglik.chosen <- out.EM$loglik ll <- c(ll, loglik.chosen) diff <- loglik.chosen - old.loglik if (diff < 0) { cat("Generating new starting values...", "\n") out.EM <- regmixEM.lambda(y, x, lambda = lambda, beta = beta, sigma = sigma, k = k, epsilon = epsilon, maxit = maxit) restarts <- restarts + 1 if (restarts > 15) stop("Too many tries!") iter <- 0 diff <- 1 } else { iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", loglik.chosen, "\n") } } } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of overall iterations=", iter, "\n") a = list(x = x, y = y, lambda.x = out.EM$lambda, beta = out.EM$beta, sigma = out.EM$sigma, loglik = loglik.chosen, posterior = out.EM$post, all.loglik = ll, restarts = restarts, ft = "regmixEM.loc") class(a) = "mixEM" a } mixtools/R/regmixmodelsel.R0000755000176200001440000001146114342153463015507 0ustar liggesusersregmixmodel.sel = function (x, y, w=NULL, k = 2, type = c("fixed", "random", "mixed"), ...) { aic <- NULL bic <- NULL caic <- NULL icl <- NULL type <- match.arg(type) AIC <- function(emout, p) { emout$loglik - (p - 1) } BIC <- function(emout, p, n) { emout$loglik - log(n) * (p - 1)/2 } CAIC <- function(emout, p, n) { emout$loglik - (log(n) + 1) * (p - 1)/2 } ICL <- function(emout, p, n) { BIC(emout, p, n) - sum(emout$lambda * log(emout$lambda)) } if (type == "fixed") { p <- function(emout) {length(emout$beta) + length(emout$sigma) + (length(emout$scale)-1)*is.null(emout$scale) +length(emout$lambda)} n <- length(y) for (i in 1:k) { if (i == 1) { a <- glm(y ~ x) beta <- matrix(a$coef, ncol = 1) loglik <- log(prod(dnorm(y, mean = beta[1, ] + as.matrix(x) %*% beta[2:nrow(beta), ], sd = sd(a$res)))) emout <- list(beta = beta, sigma = sd(a$res), lambda = 1, loglik = loglik) } else emout <- regmixEM(y, x, k = i, ...) P = p(emout) aic[i] <- AIC(emout, p=P) bic[i] <- BIC(emout, p=P, n=n) caic[i] <- CAIC(emout, p=P, n=n) icl[i] <- ICL(emout, p=P, n=n) } } else if (type == "random") { p <- function(emout) { if(is.list(emout$R)){ m<-nrow(emout$R[[1]]) v<-length(emout$R) } else { m<-nrow(emout$R) v<-1} length(emout$mu) +(v*m*(m+1)/2)+ length(emout$sigma)+ length(emout$lambda)} n <- sum(sapply(y,length)) for (j in 1:k) { if (j == 1) { a <- lapply(1:length(y), function(i) glm(y[[i]] ~ x[[i]])) aa <- sapply(1:length(a), function(i) as.vector(a[[i]]$res)) b <- sapply(1:length(a), function(i) as.matrix(a[[i]]$coef)) mu <- apply(b, 1, mean) R <- cov(t(b)) a.res <- NULL for (i in 1:length(aa)) { a.res <- c(a.res, aa[[i]]) } sd.a <- sd(a.res) loglik <- sapply(1:length(y), function(i) dmvnorm(as.vector(y[[i]]), b[1, i] + as.matrix(x[[i]]) %*% b[2:nrow(b), i], sd.a^2 * diag(length(y[[i]])))) loglik <- log(prod(loglik)) emout <- list(mu = mu, R = R, sigma = sd.a, lambda = 1, loglik = loglik) } else emout <- regmixEM.mixed(y, x, k = j, ...) P = p(emout) aic[j] <- AIC(emout, p=P) bic[j] <- BIC(emout, p=P, n=n) caic[j] <- CAIC(emout, p=P, n=n) icl[j] <- ICL(emout, p=P, n=n) } } else if (type == "mixed") { p <- function(emout) { if(is.list(emout$R)){ m<-nrow(emout$R[[1]]) v<-length(emout$R) } else { m<-nrow(emout$R) v<-1} length(emout$alpha)+ length(emout$mu) +(v*m*(m+1)/2)+ length(emout$sigma)+ length(emout$lambda)} n <- sum(sapply(y,length)) for (i in 1:k) { if (i == 1) { a <- lapply(1:length(y), function(i) glm(y[[i]] ~ x[[i]] + w[[i]])) aa <- sapply(1:length(a), function(i) as.vector(a[[i]]$res)) alpha <- sapply(1:length(a), function(i) matrix(a[[i]]$coef[(ncol(x[[i]]) + 2):(ncol(x[[i]]) + 1 + ncol(w[[i]]))])) alpha <- apply(as.matrix(alpha), 1, mean) b <- sapply(1:length(a), function(i) matrix(a[[i]]$coef[1:(ncol(x[[i]]) + 1)])) mu <- apply(b, 1, mean) R <- cov(t(b)) a.res <- NULL for (i in 1:length(aa)) { a.res <- c(a.res, aa[[i]]) } sd.a <- sd(a.res) loglik <- sapply(1:length(y), function(i) dmvnorm(as.vector(y[[i]]), b[1, i] + as.matrix(x[[i]]) %*% b[2:nrow(b), i], sd.a^2 * diag(length(y[[i]])))) loglik <- log(prod(loglik)) emout <- list(mu = mu, R = R, alpha = alpha, sigma = sd.a, lambda = 1, loglik = loglik) } else emout <- regmixEM.mixed(y, x, k = i, ...) P = p(emout) aic[i] <- AIC(emout, p=P) bic[i] <- BIC(emout, p=P, n=n) caic[i] <- CAIC(emout, p=P, n=n) icl[i] <- ICL(emout, p=P, n=n) } } out = rbind(aic, bic, caic, icl) Winner = apply(out, 1, function(x) (1:length(x))[x == max(x)]) colnames(out) = 1:k rownames(out) = c("AIC", "BIC", "CAIC", "ICL") cbind(out, Winner) }mixtools/R/repnormmixEM.R0000755000176200001440000001176614342153463015121 0ustar liggesusersrepnormmixEM = function (x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) { if(arbmean == FALSE && arbvar == FALSE){ stop(paste("Must change constraints on mu and/or sigma!","\n")) } s = sigma n <- ncol(x) m <- nrow(x) tmp <- repnormmix.init(x = x, lambda = lambda, mu = mu, s = s, k = k, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda mu <- tmp$mu s <- tmp$s s.2 <- s^2 k <- tmp$k diff <- 1 iter <- 0 res <- lapply(1:k, function(i) (x - mu[i * arbmean + (1 - arbmean)])^2) comp <- lapply(1:k, function(i) lambda[i] * (2 * pi * s.2[i * arbvar + (1 - arbvar)])^(-m/2) * exp(-0.5 * apply(res[[i]], 2, sum)/s.2[i * arbvar + (1 - arbvar)])) obsloglik <- sum(log(apply(sapply(comp, rbind), 1, sum))) ll <- obsloglik restarts <- 0 while (diff > epsilon & iter < maxit) { xmu <- lapply(1:k, function(i) apply(res[[i]], 2, sum)) z = matrix(nrow = n, ncol = k) for (i in 1:n) { for (j in 1:k) { z.denom = c() for (h in 1:k) { z.denom = c(z.denom, lambda[h]/lambda[j] * (s[j * arbvar + (1 - arbvar)]/s[h * arbvar + (1 - arbvar)])^m * exp(-0.5 * ((1/s[h * arbvar + (1 - arbvar)]^2) * xmu[[h]][i] - (1/s[j * arbvar + (1 - arbvar)]^2) * xmu[[j]][i]))) } z[i, j] = 1/sum(z.denom) } } z = z/apply(z,1,sum) # z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) lambda.new <- apply(z, 2, mean) if (sum(lambda.new < 1e-08)>0 || is.na(sum(lambda.new))) { sing <- 1 } else { if(arbmean){ mu.new <- sapply(1:k, function(i) sum(t(z[, i] * t(x))))/(m * apply(z, 2, sum)) } else { mu.new <- sum(sapply(1:k, function(i) sum(t(z[, i] * t(x)))))/(m * n) } res <- lapply(1:k, function(i) (x - mu.new[i * arbmean + (1 - arbmean)])^2) if (arbvar) { s.new <- sqrt(sapply(1:k, function(i) sum(t(z[, i] * t(res[[i]]))))/(m * apply(z, 2, sum))) } else s.new <- sqrt(sum(sapply(1:k, function(i) sum(t(z[, i] * t(res[[i]])))))/(m * n)) lambda <- lambda.new mu <- mu.new s <- s.new s.2 <- s^2 sing <- sum(is.nan(z)) comp <- lapply(1:k, function(i) lambda[i] * (2 * pi * s.2[i * arbvar + (1 - arbvar)])^(-m/2) * exp(-0.5 * apply(res[[i]], 2, sum)/s.2[i * arbvar + (1 - arbvar)])) newobsloglik <- sum(log(apply(sapply(comp, rbind), 1, sum))) } if (sing > 0 || is.na(newobsloglik) || abs(newobsloglik) == Inf ){#|| sum(z) != n) { cat("Need new starting values due to singularity...", "\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- repnormmix.init(x = x, k = k, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda mu <- tmp$mu s <- tmp$s s.2 <- s^2 k <- tmp$k diff <- 1 iter <- 0 res <- lapply(1:k, function(i) (x - mu[i * arbmean + (1 - arbmean)])^2) comp <- lapply(1:k, function(i) lambda[i] * (2 * pi * s.2[i * arbvar + (1 - arbvar)])^(-m/2) * exp(-0.5 * apply(res[[i]], 2, sum)/s.2[i * arbvar + (1 - arbvar)])) obsloglik <- sum(log(apply(sapply(comp, rbind), 1, sum))) ll <- obsloglik } else { diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n") } } } scale.order = order(s) sigma.min = min(s) if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") if(arbmean == FALSE){ z = z[,scale.order] colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=as.data.frame(x), lambda = lambda[scale.order], mu = mu, sigma = sigma.min, scale = s[scale.order]/sigma.min, loglik = obsloglik, posterior = z[,scale.order], all.loglik=ll, restarts = restarts, ft="repnormmixEM") class(a) = "mixEM" a } else { colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=as.data.frame(x), lambda = lambda, mu = mu, sigma = s, loglik = obsloglik, posterior = z, all.loglik=ll, restarts = restarts, ft="repnormmixEM") class(a) = "mixEM" a } } mixtools/R/plotMCMC.R0000755000176200001440000000232214342153463014101 0ustar liggesusersplot.mixMCMC <- function(x, trace.plots = TRUE, summary.plots = FALSE, burnin = 2000, ...){ mix.object <- x if (!inherits(mix.object, "mixMCMC")) stop("Use only with \"mixMCMC\" objects!") if(trace.plots==TRUE){ k<-mix.object$components theta<-mix.object$theta p.k=ncol(theta) p=p.k/k name.theta<-colnames(theta) par(mfrow=c(p,k)) for(i in 1:p){ for(j in 1:k){ plot(theta[,(i-1)*k+j],type="l",ylab=name.theta[(i-1)*k+j]) } } } #regmixMH if(is.matrix(mix.object$x) == TRUE && is.null(mix.object$y) == FALSE && summary.plots == TRUE){ y<-mix.object$y n<-length(y) x<-mix.object$x p<-ncol(x) k<-mix.object$components theta<-mix.object$theta if(p!=2 || sum(x[,1])!=n){ stop(paste("This only works for simple linear regression!","\n")) } par(mfrow=c(1,1)) plot(x[,2],y,main="Credible Regions",xlab="Predictor",ylab="Response") #plot(theta[-c(1:burnin),seq(1,2*k-1,by=2)],theta[-c(1:burnin),seq(2,2*k,by=2)],col=0) for(i in 1:k){ #points(theta[-c(1:burnin),2*i-1],theta[-c(1:burnin),2*i],col=(i+1)) regcr(beta=cbind(theta[-c(1:burnin),2*i-1],theta[-c(1:burnin),2*i]),col=(i+1), x=x[,2], plot=TRUE,...) } } } mixtools/R/kernT.R0000755000176200001440000000007614342153463013552 0ustar liggesuserskern.T <- function (x, xi, h) { (1-abs((xi-x)/h))/h } mixtools/R/summary.npEM.R0000755000176200001440000000325414342153463015023 0ustar liggesuserssummary.npEM <- function(object, ...) { normpost <- sweep(object$post, 2, sums <- colSums(object$post), "/") n <- NROW(object$data) r <- NCOL(object$data) m <- length(object$lambdahat) B <- 1 if (r>1) B <- max(object$blockid) lambda <- sums/n means <- variances <- NULL for(i in 1:B) { if (r>1) { coords <- object$blockid == i xx <- as.vector(object$data[,coords]) } else { coords <- 1 xx <- as.vector(object$data) } sc <- sum(coords) M <- V <- NULL for (j in 1:m) { wts <- rep(normpost[,j]/sc, sc) M <- c(M, tmp <- sum(xx*wts)) V <- c(V, sum((xx-tmp)^2 *wts)) # cat(M," ") } means <- rbind(means, M) variances <- rbind(variances, V) } rownames(means) <- rownames(variances) <- paste("block", 1:B) colnames(means) <- colnames(variances) <- paste("component", 1:m) ans <- list(n=n, m=m, r=r, B=B, blockid=object$blockid, means = means, variances=variances) class(ans) <- "summary.npEM" ans } print.summary.npEM <- function(x, digits=3, ...) { if (x$r>1) cat (paste(x$n,"observations,",x$r,"coordinates,", x$m,"components, and",x$B,"blocks.\n\n")) else cat(paste(x$n,"univariate observations, and", x$m,"components.\n\n")) cat ("Means (and std. deviations) for each component:\n") for(i in 1:x$B) { coords <- 1 if (x$r>1) { coords <- x$blockid == i cat(paste(" Block #",i,": Coordinate", sep="")) cat(ifelse(sum(coords)>1, "s ", " ")) cat(which(coords)) cat("\n ") } cat(paste(signif(x$means[i,],digits), " (", signif(sqrt(x$variances[i,]),digits), ") ", sep="")) cat("\n") } } mixtools/R/dmvnorm.R0000755000176200001440000000177514342153463014160 0ustar liggesusers# Alternative version of dmvnorm to eliminate dependence of mixtools # on additional package 'mvtnorm' # Written (hopefully) to be more efficient than mvtnorm version, which uses both # a call to "eigen" and a call to "mahalanobis", by using only a single # call to the more efficient "qr" (read "Note" under ?qr) # Note: These functions assume that each ROW of y is a separate position vector. # i.e., y is assumed to be nxd, where d=dimension dmvnorm <- function(y, mu=NULL, sigma=NULL) { exp(logdmvnorm(y, mu=mu, sigma=sigma)) } logdmvnorm <- function(y, mu=NULL, sigma=NULL) { if (is.vector(y)) y <- matrix(y, nrow=1) d <- ncol(y) if (!is.null(mu)) y <- sweep(y, 2, mu, '-') if (is.null(sigma)) sigma <- diag(d) k <- d * 1.8378770664093454836 # that constant is log(2*pi) a <- qr(sigma) logdet <- sum(log(abs(diag(a$qr)))) if(nrow(y)==1) mahaldist <- as.vector(y %*% qr.solve(a,t(y))) else mahaldist <- rowSums((y %*% qr.solve(a)) * y) -0.5*(mahaldist + logdet + k) } mixtools/R/npEM.R0000644000176200001440000001265514342153463013331 0ustar liggesusers## EM-like algorithm for a nonparametric mixture model with ## independent repeated measures - some ID, some not npEMindrep <- # npEMindrep is an alias (only for backward compatibility) npEM <- function(x, mu0, blockid = 1:ncol(x), bw=bw.nrd0(as.vector(as.matrix(x))), samebw = TRUE, h=bw, eps=1e-8, maxiter=500, stochastic = FALSE, verb = TRUE){ bw <- h # h is alternative bandwidth argument, for backward compatibility x <- as.matrix(x) n <- nrow(x) # number of subjects r <- ncol(x) # number of measurements in each subject u <- match(blockid, unique(blockid)) if (is.matrix(mu0)) m <- dim(mu0)[1] # mu0=centers else m <- mu0 # mu0=number of clusters if(!samebw && !is.matrix(bw)) { bw <- matrix(bw, nrow=max(u), ncol=m) } z.hat <- matrix(0, nrow = n, ncol = m) tt0 <- proc.time() # for total time ## Initial Values if(m == 1) z.hat <- matrix(1, nrow = n, ncol = m) else{ kmeans <- kmeans(x, mu0) for(j in 1:m) z.hat[kmeans$cluster==j, j] <- 1 } iter <- 0 if (stochastic) { sumpost <- matrix(0, n, m) } finished <- FALSE lambda <- matrix(0, nrow = maxiter, ncol = m) loglik <- NULL orderx <- xx <- list() for(k in 1:max(u)) { xx[[k]] <- as.vector(x[, u==k]) if (!samebw) { orderx[[k]] = order(xx[[k]]) # only needed for IQR calculation for bw } } ### Cfunction <- ifelse(samebw, "KDErepeated", "KDErepeatedbw") while (!finished) { iter <- iter + 1 bw.old <- bw t0 <- proc.time() ## Note: Enter loop assuming E-step is done -- i.e., z.hat in place ## M-Step lambda[iter, ] <- colMeans(z.hat) ## density estimation step if (stochastic) { z <- t(apply(z.hat, 1, function(prob) rmultinom(1, 1, prob))) cs <- colSums(z) z.tmp <- sweep(z, 2, cs, "/") z.tmp[, cs==0] <- 1/NROW(z.tmp) # Just in case } else { cs <- colSums(z.hat) z.tmp <- sweep(z.hat, 2, cs, "/") z.tmp[, cs==0] <- 1/NROW(z.tmp) # Just in case } fkernel <- matrix(1, n, m) h <- bw # This is for samebw == TRUE for (k in 1:max(u)) { r2 <- sum(u == k) # block size if (!samebw) { wts <- apply(z.tmp, 2, function(z) rep(z/r2, r2)) variances <- colSums(wts * outer(xx[[k]], colSums(wts * xx[[k]]), '-')^2) iqr <- apply(as.matrix(wts[orderx[[k]],]), 2, wIQR, xx[[k]][orderx[[k]]], already.sorted=TRUE, already.normalized=TRUE) h <- bw[k, ] <- 0.9 * pmin(sqrt(variances), iqr/1.34) * pmax(1,r2*n*lambda[iter, ])^(-1/5) # Note: Doesn't allow "sample size" < 1. # browser() } if(samebw){ ans <- .C(C_KDErepeated, n = as.integer(n), m = as.integer(m), r = as.integer(r2), x = as.double(x[,u==k]), h = as.double(h), z = as.double(z.tmp), f = double(n*m), PACKAGE="mixtools") } else{ ans <- .C(C_KDErepeatedbw, n = as.integer(n), m = as.integer(m), r = as.integer(r2), x = as.double(x[,u==k]), h = as.double(h), z = as.double(z.tmp), f = double(n*m), PACKAGE="mixtools") } fkernel <- fkernel * matrix(ans$f, ncol = m) } lambda.f <- sweep(fkernel, 2, lambda[iter, ], "*") ## E-step (for next iteration) z.hat <- lambda.f/rowSums(lambda.f) loglik <- c(loglik,sum(log(rowSums(lambda.f)))) # log-likelihood finished <- iter >= maxiter if (stochastic) { sumpost <- sumpost + z.hat } else if (iter > 1) { # This convergence criterion may be too simplistic: maxchange <- max(abs(lambda[iter,] - lambda[iter-1,])) if (!samebw) maxchange <- max(maxchange, max(abs(bw.old - bw))) finished <- finished | (maxchange < eps) } if (verb) { t1 <- proc.time() cat("iteration", iter, " lambda ", round(lambda[iter, ], 4)) cat(" time", (t1 - t0)[3], "\n") } } if (!samebw) { rownames(bw) <- paste("block", 1:max(u)) colnames(bw) <- paste("component", 1:m) } if (verb) { tt1 <- proc.time() cat("lambda ", round(lambda[iter, ], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } if (stochastic) { return(structure(list(data = x, posteriors = sumpost/iter, lambda = lambda, bandwidth = bw, blockid = u, lambdahat = colMeans(lambda), loglik = loglik), class="npEM")) } else { return(structure(list(data = x, posteriors = z.hat, lambda = lambda[1:iter,], bandwidth = bw, blockid = u, lambdahat = lambda[iter,], loglik = loglik), class="npEM")) } } # Not sure whether the following function is really necessary: npEMindrepbw <- function (x, mu0, blockid = 1:ncol(x), bw = bw.nrd0(as.vector(as.matrix(x))), eps = 1e-08, maxiter = 500, stochastic = FALSE, verb = TRUE){ npEM(x=x, mu0=mu0, blockid=blockid, bw=bw, samebw=FALSE, eps=eps, maxiter=maxiter, stochastic=stochastic, verb=verb) } mixtools/R/plotly_mixMCMC.R0000644000176200001440000001204214343041265015315 0ustar liggesusersplotly_mixMCMC <- function( x , trace.plot = TRUE , summary.plot = FALSE , burnin = 2000, credit.region = 0.95, col.cr = NULL, cex.trace = 3 , width.trace = 3 , cex.summary = 3 , width.summary = 1, title.trace = "", title.trace.x = 0.5 , title.trace.y = 0.95, title.trace.size = 15, xlab.trace = "Index" , xlab.trace.size = 15, xtick.trace.size = 15, ylab.trace = NULL , ylab.trace.size = 15, ytick.trace.size = 15, title.summary = "Credible Regions", title.summary.x = 0.5 , title.summary.y = 0.95, title.summary.size = 15, xlab.summary = "Predictor" , xlab.summary.size = 15, xtick.summary.size = 15, ylab.summary = "Response" , ylab.summary.size = 15, ytick.summary.size = 15 ){ mix.object <- x if (!inherits(mix.object, "mixMCMC")){ stop("Use only with \"mixMCMC\" objects!") } if (trace.plot){ k<-mix.object$components theta<-mix.object$theta p.k=ncol(theta) p=p.k/k name.theta<-colnames(theta) for (i in 1:dim(theta)[2]){ if (is.null(ylab.trace)){ ylab.trace <- name.theta[i] } plot.trace <- plot_ly()%>% add_trace(x=seq(from = 1 , to = dim(theta)[1] , by=1) , y=theta[,i] , type = 'scatter' , mode = 'lines+markers', marker = list(size = cex.trace), line = list(width = width.trace), showlegend = FALSE) %>% plotly::layout( title = list(text = title.trace, x = title.trace.x, y = title.trace.y, font = list(size=title.trace.size)), xaxis = list(title = list(text = xlab.trace, font = list(size = xlab.trace.size)), tickfont = list(size = xtick.trace.size)), yaxis = list(title = list(text = ylab.trace, font = list(size = ylab.trace.size)), tickfont = list(size = ytick.trace.size)) ) print(plot.trace) } } if(is.matrix(mix.object$x) == TRUE && is.null(mix.object$y) == FALSE && summary.plot == TRUE){ y<-mix.object$y n<-length(y) x<-mix.object$x p<-ncol(x) k<-mix.object$components theta<-mix.object$theta if(p!=2 || sum(x[,1])!=n){ stop(paste("This only works for simple linear regression!","\n")) } plot.summary <- plot_ly()%>% add_trace(x=x[,2] , y=y , type = 'scatter' , mode = 'markers', marker = list(size = cex.summary), showlegend = FALSE) %>% plotly::layout( title = list(text = paste(credit.region*100, "% " , title.summary ,sep = ""), x = title.summary.x, y = title.summary.y, font = list(size=title.summary.size)), xaxis = list(title = list(text = xlab.summary, font = list(size = xlab.summary.size)), tickfont = list(size = xtick.summary.size) ), yaxis = list(title = list(text = ylab.summary, font = list(size = ylab.summary.size)), tickfont = list(size = ytick.summary.size) ) ) if(is.null(col.cr)){ col.cr <- hue_pal()(k) } if (length(col.cr) != k){ print(paste("Please specify",k,"colors in 'col.cr'.")) } for (i in 1:k){ beta.summary <- cbind(theta[-c(1:burnin),2*i-1],theta[-c(1:burnin),2*i]) xbar = apply(beta.summary, 2, mean) n = nrow(beta.summary) cbeta = t(t(beta.summary) - xbar) S = t(cbeta) %*% cbeta/(n - 1) eS = eigen(S) B = eS$vec %*% diag(sqrt(eS$val)) theta.summary = seq(0, 2 * pi, len = 250) alpha = 1-credit.region v = cbind(cos(theta.summary), sin(theta.summary)) * sqrt(qchisq(1 - alpha,2)) h = t(B %*% t(v) + xbar) nh = nrow(h) m = which.max(h[, 2]) h = rbind(h[m:nh, ], h[((1:nh) < m), ], h[m, ]) bound = h x.summary <- x[,2] z <- length(x.summary) * 5 u <- seq(min(x.summary), max(x.summary), length = z) lower <- c() upper <- c() v <- c() for (q in 1:z) { for (l in 1:nrow(beta.summary)) { v[l] <- as.matrix(beta.summary[, 1][l] + beta.summary[, 2][l] * u[q]) } uv <- cbind(u[q], v) lower <- rbind(lower, uv[order(v), ][1, ]) upper <- rbind(upper, uv[order(v), ][nrow(beta.summary), ]) } plot.summary <- plot.summary%>% add_trace(x=lower[,1] , y=lower[,2] , type = 'scatter' , mode = 'lines', line = list(width = width.summary , color = col.cr[i]), name = paste("Lower Bound for Component",i), showlegend = FALSE)%>% add_trace(x=upper[,1] , y=upper[,2] , type = 'scatter' , mode = 'lines', line = list(width = width.summary , color = col.cr[i]), name = paste("Upper Bound for Component",i), showlegend = FALSE) } print(plot.summary) } }mixtools/R/gammamixEM.R0000755000176200001440000002037614343151770014516 0ustar liggesusersgammamixEM <- function(x, lambda = NULL, alpha = NULL, beta = NULL, k = 2, mom.start = TRUE, fix.alpha = FALSE, epsilon = 1e-08, maxit = 1000, maxrestarts = 20, verb = FALSE){ if(!is.null(alpha) & is.numeric(fix.alpha)) stop(paste("Both alpha and fix.alpha cannot be numeric!", "\n")) if(!is.null(lambda)|!is.null(beta)) k <- max(length(lambda),length(beta)) x <- as.vector(x) y <- x^(1/3) n <- length(x) if(is.logical(fix.alpha)&(fix.alpha==FALSE)){ cond <- 1 } else if(is.logical(fix.alpha)&(fix.alpha==TRUE)){ cond <- 2 } else cond <- 3 fn.alpha <- function(alpha,beta,z,x) log(beta)+sum(z*log(x))/sum(z)-digamma(alpha) fn.alpha.2 <- function(alpha,beta,z,x) (log(beta)+sum(z*log(x))/sum(z)-digamma(alpha))^2 fn.beta <- function(z,x,alpha) sum(z)/sum(z*x)*alpha fn.alpha2 <- function(alpha,beta,z,x) sum(z%*%cbind(log(beta)))/length(x)+sum(t(z)%*%cbind(log(x)))/length(x)-digamma(alpha) fn.alpha2.2 <- function(alpha,beta,z,x) (sum(z%*%cbind(log(beta)))/length(x)+sum(t(z)%*%cbind(log(x)))/length(x)-digamma(alpha))^2 if(mom.start){ out <- try(normalmixEM(y,k=k,maxit=5000,epsilon=1e-5,maxrestarts=10),silent=TRUE) if(inherits(out, "try-error", which = TRUE)){ tmp <- gammamix.init(x = x, lambda = lambda, alpha = alpha, beta = beta, k = k) } else{ z <- out$posterior wt.mean <- sapply(1:k,function(i) weighted.mean(x,w=z[,i])) wt.var <- sapply(1:k,function(i) sum(z[,i] * (x - wt.mean[i])^2)/((n-1)*sum(z[,i])/n)) shape.mom <- wt.mean^2/wt.var scale.mom <- wt.var/wt.mean shape.mle <- try(sapply(1:k, function(i) uniroot(fn.alpha,interval=c(0.000001,1000000),beta=1/scale.mom[i],z=z[,i],x=x)$root),silent=TRUE) if(inherits(shape.mle, "try-error", which = TRUE)) shape.mle <- sapply(1:k, function(i) nlminb(shape.mom[i],fn.alpha.2,lower=0,beta=1/scale.mom[i],z=z[,i],x=x)$par) scale.mle <- sapply(1:k, function(i) 1/fn.beta(z=z[,i],x=x,alpha=shape.mle[i])) lambda.mle <- apply(z,2,mean) tmp <- list(lambda=lambda.mle,alpha=scale.mle,beta=shape.mle) } } else tmp <- gammamix.init(x = x, lambda = lambda, alpha = alpha, beta = beta, k = k) lambda.mle <- tmp$lambda scale.mle <- tmp$beta if(cond==2){ shape.mle <- rep(mean(tmp$alpha),k) } else if(cond==1){ shape.mle <- tmp$alpha } else shape.mle <- rep(fix.alpha,k) dens <- function(x, lambda, alpha, beta) { k <- length(lambda) temp = sapply(1:k, function(j) dgamma(x, shape = alpha[j], scale = beta[j])) temp = t(lambda * t(temp)) temp } iter <- 0 mr <- 0 diff <- epsilon + 1 dens1 <- dens(x=x, lambda=lambda.mle, alpha=shape.mle, beta=scale.mle) old.obs.ll <- sum(log(apply(dens1, 1, sum))) ll <- old.obs.ll if(cond==1){ while (diff > epsilon && iter < maxit) { old.shape.mle <- shape.mle old.scale.mle <- scale.mle old.lambda.mle <- lambda.mle z <- dens1/apply(dens1, 1, sum) #M-step shape.mle <- try(sapply(1:k, function(i) uniroot(fn.alpha,interval=c(0.000001,10000),beta=1/old.scale.mle[i],z=z[,i],x=x)$root),silent=TRUE) if(inherits(shape.mle, "try-error", which = TRUE)) shape.mle <- sapply(1:k, function(i) nlminb(old.shape.mle[i],fn.alpha.2,lower=0,beta=1/scale.mle[i],z=z[,i],x=x)$par) scale.mle <- sapply(1:k, function(i) 1/fn.beta(z=z[,i],x=x,alpha=shape.mle[i])) lambda.mle <- apply(z,2,mean) dens1 <- dens(x=x, lambda=lambda.mle, alpha=shape.mle, beta=scale.mle) new.obs.ll <- sum(log(apply(dens1, 1, sum))) diff <- new.obs.ll - old.obs.ll old.obs.ll <- new.obs.ll ll <- c(ll, old.obs.ll) iter = iter + 1 if (verb) { cat("iteration =", iter, " log-lik diff =", diff, " log-lik =", new.obs.ll, "\n") } if(is.na(diff)){ cat("Note: Choosing new starting values.", "\n") if (mr == maxrestarts) stop(paste("Try different number of components?", "\n")) mr <- mr + 1 tmp <- gammamix.init(x = x, lambda = lambda, alpha = alpha, beta = beta, k = k) lambda.mle <- tmp$lambda if(cond==2){ shape.mle <- rep(mean(tmp$alpha),k) } else if(cond==1){ shape.mle <- tmp$alpha } else shape.mle <- rep(fix.alpha,k) scale.mle <- tmp$beta iter <- 0 diff <- epsilon + 1 dens1 <- dens(x=x, lambda=lambda.mle, alpha=shape.mle, beta=scale.mle) old.obs.ll <- sum(log(apply(dens1, 1, sum))) ll <- old.obs.ll } } } else if(cond==2){ while (diff > epsilon && iter < maxit) { old.shape.mle <- shape.mle old.scale.mle <- scale.mle old.lambda.mle <- lambda.mle z <- dens1/apply(dens1, 1, sum) #M-step shape.mle <- try(rep(uniroot(fn.alpha2,interval=c(0.000001,10000),beta=1/old.scale.mle,z=z,x=x)$root,k),silent=TRUE) if(inherits(shape.mle, "try-error", which = TRUE)) shape.mle <- rep(nlminb(old.shape.mle[1],fn.alpha2,lower=0,beta=1/old.scale.mle,z=z,x=x)$par,k) scale.mle <- sapply(1:k, function(i) 1/fn.beta(z=z[,i],x=x,alpha=shape.mle[1])) lambda.mle <- apply(z,2,mean) dens1 <- dens(x=x, lambda=lambda.mle, alpha=shape.mle, beta=scale.mle) new.obs.ll <- sum(log(apply(dens1, 1, sum))) diff <- new.obs.ll - old.obs.ll old.obs.ll <- new.obs.ll ll <- c(ll, old.obs.ll) iter = iter + 1 if (verb) { cat("iteration =", iter, " log-lik diff =", diff, " log-lik =", new.obs.ll, "\n") } if(is.na(diff)){ cat("Note: Choosing new starting values.", "\n") if (mr == maxrestarts) stop(paste("Try different number of components?", "\n")) mr <- mr + 1 tmp <- gammamix.init(x = x, lambda = lambda, alpha = alpha, beta = beta, k = k) lambda.mle <- tmp$lambda if(cond==2){ shape.mle <- rep(mean(tmp$alpha),k) } else if(cond==1){ shape.mle <- tmp$alpha } else shape.mle <- rep(fix.alpha,k) scale.mle <- tmp$beta iter <- 0 diff <- epsilon + 1 dens1 <- dens(x=x, lambda=lambda.mle, alpha=shape.mle, beta=scale.mle) old.obs.ll <- sum(log(apply(dens1, 1, sum))) ll <- old.obs.ll } } } else{ while (diff > epsilon && iter < maxit) { old.scale.mle <- scale.mle old.lambda.mle <- lambda.mle z <- dens1/apply(dens1, 1, sum) #M-step scale.mle <- sapply(1:k, function(i) 1/fn.beta(z=z[,i],x=x,alpha=shape.mle[1])) lambda.mle <- apply(z,2,mean) dens1 <- dens(x=x, lambda=lambda.mle, alpha=shape.mle, beta=scale.mle) new.obs.ll <- sum(log(apply(dens1, 1, sum))) diff <- new.obs.ll - old.obs.ll old.obs.ll <- new.obs.ll ll <- c(ll, old.obs.ll) iter = iter + 1 if (verb) { cat("iteration =", iter, " log-lik diff =", diff, " log-lik =", new.obs.ll, "\n") } if(is.na(diff)){ cat("Note: Choosing new starting values.", "\n") if (mr == maxrestarts) stop(paste("Try different number of components or different value for the fixed shape parameter?", "\n")) mr <- mr + 1 tmp <- gammamix.init(x = x, lambda = lambda, alpha = alpha, beta = beta, k = k) lambda.mle <- tmp$lambda if(cond==2){ shape.mle <- rep(mean(tmp$alpha),k) } else if(cond==1){ shape.mle <- tmp$alpha } else shape.mle <- rep(fix.alpha,k) scale.mle <- tmp$beta iter <- 0 diff <- epsilon + 1 dens1 <- dens(x=x, lambda=lambda.mle, alpha=shape.mle, beta=scale.mle) old.obs.ll <- sum(log(apply(dens1, 1, sum))) ll <- old.obs.ll } } } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") theta = rbind(shape.mle, scale.mle) rownames(theta) = c("alpha", "beta") colnames(theta) = c(paste("comp", ".", 1:k, sep = "")) a = list(x = x, lambda = lambda.mle, gamma.pars = theta, loglik = new.obs.ll, posterior = z, all.loglik = ll, ft = "gammamixEM") class(a) = "mixEM" a } mixtools/R/plotly_mixEM.R0000644000176200001440000003533514343047511015111 0ustar liggesusersplotly_mixEM <-function (x, loglik = TRUE, density = FALSE, xlab1="Iteration", xlab1.size=15 , xtick1.size=15, ylab1="Log-Likelihood", ylab1.size=15 , ytick1.size=15, title1="Observed Data Log-Likelihood", title1.size=15, title1.x = 0.5,title1.y=0.95, col1="#1f77b4", lwd1=3, cex1=6, xlab2=NULL, xlab2.size=15 , xtick2.size=15, ylab2=NULL, ylab2.size=15 , ytick2.size=15, title2=NULL, title2.size=15, title2.x = 0.5,title2.y=0.95, col.hist = "#1f77b4", col2=NULL, lwd2=3, cex2=6, alpha = 0.05, marginal = FALSE){ def.par <- par(ask=(loglik + density > 1), "mar") # only ask and mar are changed mix.object <- x if (!inherits(mix.object, "mixEM")) stop("Use only with \"mixEM\" objects!") ### iteration plot ### if (loglik) { plot.loglik <- plot_ly()%>% add_trace(x= seq(from=1 , to=length(mix.object$all.loglik) , by=1), y= mix.object$all.loglik , type = 'scatter' , mode = 'lines+markers', marker = list(color = col1 , size = cex1), line = list(color = col1 , width = lwd1), name = "Log-Likelihood" , showlegend = FALSE)%>% plotly::layout( title = list(text = title1, x = title1.x, y = title1.y, font = list(size=title1.size) ), xaxis = list(title = list(text = xlab1, font = list(size = xlab1.size)), tickfont = list(size = xtick1.size) ), yaxis = list(title = list(text = ylab1, font = list(size = ylab1.size)), tickfont = list(size = ytick1.size) ) ) print(plot.loglik) } ### density plot ### if (density){ if (mix.object$ft == "logisregmixEM") { if (ncol(mix.object$x) != 2) { stop("The predictors must have 2 columns!") } if (sum((mix.object$y == 1) + (mix.object$y == 0)) != length(mix.object$y)) { stop("The response must be binary!") } k = ncol(mix.object$beta) x = mix.object$x[, 2] if(is.null(title2)) { title2 <- "Most Probable Component Membership" } if(is.null(xlab2)) { xlab2 <- "Predictor" } if(is.null(ylab2)) { ylab2 <- "Response" } if (is.null(col2)){ col2 <- hue_pal()(k) } if (length(col2) != k){ print(paste("Please specify" , k , "colors in 'col2'.")) } plot.density <- plot_ly()%>% add_trace(x=x , y=mix.object$y, type = 'scatter' , mode = 'markers', marker = list(color = col2[apply(mix.object$posterior,1, which.max)] , size = cex2), name = "Data" , showlegend = FALSE)%>% plotly::layout( title = list(text = title2, x = title2.x, y = title2.y, font = list(size=title2.size) ), xaxis = list(title = list(text = xlab2, font = list(size = xlab2.size)), tickfont = list(size = xtick2.size) ), yaxis = list(title = list(text = ylab2, font = list(size = ylab2.size)), tickfont = list(size = ytick2.size) ) ) a = cbind(x, mix.object$y) a = a[order(a[, 1]), ] for (i in 1:k) { plot.density <- add_trace(plot.density, x=a[,1] , y=plogis(mix.object$beta[1, i]+mix.object$beta[2,i] * a[,1]), type = 'scatter' , mode = 'lines', line = list(width = lwd2 , color = col2[i]), name = paste("Component" , i) , showlegend = FALSE) } } if (mix.object$ft == "normalmixEM") { k <- ncol(mix.object$posterior) x <- sort(mix.object$x) a <- hist(x, plot = FALSE) maxy <- max(max(a$density), 0.3989*mix.object$lambda/mix.object$sigma) if(is.null(title2)) { title2 <- "Density Curves" } if(is.null(xlab2)) { xlab2 <- "Data" } if (is.null(col2)){ col2 <- hue_pal()(k) } if (length(col2) != k){ print(paste("Please specify" , k , "colors in 'col2'.")) } plot.density <- plot_ly()%>% add_trace(x=x , type = 'histogram', histnorm = "probability density", name = 'Data' , showlegend = FALSE, marker = list(color = col.hist, line = list(color = col.hist)) )%>% plotly::layout( title = list(text = title2, x = title2.x, y = title2.y, font = list(size=title2.size) ), xaxis = list(title = list(text = xlab2, font = list(size = xlab2.size)), tickfont = list(size = xtick2.size) ), yaxis = list(title = list(text = ylab2, font = list(size = ylab2.size)), tickfont = list(size = ytick2.size), range = c(0 , maxy) ), bargap = 0.01 ) if (length(mix.object$mu) == 1) { arbvar <- TRUE mix.object$sigma <- mix.object$scale * mix.object$sigma arbmean <- FALSE } if (length(mix.object$mu) == k && length(mix.object$sigma) == 1) { arbmean <- TRUE arbvar <- FALSE } if (length(mix.object$sigma) == k && length(mix.object$mu) == k) { arbmean <- TRUE arbvar <- TRUE } for (i in 1:k) { plot.density <- add_trace(plot.density, x=x , y=mix.object$lambda[i] * dnorm(x, mean = mix.object$mu[i * arbmean + (1 - arbmean)], sd = mix.object$sigma[i * arbvar + (1 - arbvar)]), type = 'scatter' , mode = 'lines', line = list(width = lwd2 , color = col2[i]), name = paste("Component" , i) , showlegend = FALSE) } } if (mix.object$ft == "repnormmixEM") { x <- as.vector(as.matrix(mix.object$x)) k <- ncol(mix.object$posterior) x.sort <- sort(x) a <- hist(x.sort, plot = FALSE) maxy <- max(max(a$density), .3989*mix.object$lambda/mix.object$sigma) if (is.null(title2)) { title2 <- "Density Curves" } if(is.null(xlab2)) { xlab2 <- "Data" } if (is.null(col2)){ col2 <- hue_pal()(k) } if (length(col2) != k){ print(paste("Please specify" , k , "colors in 'col2'.")) } plot.density <- plot_ly()%>% add_trace(x=x , type = 'histogram', histnorm = "probability density", name = 'Data' , showlegend = FALSE, marker = list(color = col.hist, line = list(color = col.hist)) )%>% plotly::layout( title = list(text = title2, x = title2.x, y = title2.y, font = list(size=title2.size) ), xaxis = list(title = list(text = xlab2, font = list(size = xlab2.size)), tickfont = list(size = xtick2.size) ), yaxis = list(title = list(text = ylab2, font = list(size = ylab2.size)), tickfont = list(size = ytick2.size), range = c(0 , maxy) ), bargap = 0.01 ) if (length(mix.object$mu) == 1) { arbvar <- TRUE mix.object$sigma = mix.object$scale * mix.object$sigma arbmean <- FALSE } if (length(mix.object$mu) == k && length(mix.object$sigma) == 1) { arbmean <- TRUE arbvar <- FALSE } if (length(mix.object$sigma) == k && length(mix.object$mu) == k) { arbmean <- TRUE arbvar <- TRUE } for (i in 1:k) { plot.density <- add_trace(plot.density, x=x.sort , y=mix.object$lambda[i] * dnorm(x.sort, mean = mix.object$mu[i * arbmean + (1 - arbmean)], sd = mix.object$sigma[i * arbvar + (1 - arbvar)]), type = 'scatter' , mode = 'lines', line = list(width = lwd2 , color = col2[i]), name = paste("Component" , i) , showlegend = FALSE) } } if (mix.object$ft == "regmixEM.mixed") { if (is.null(col2)){ col2 <- hue_pal()(ncol(x$posterior.z)) } if (length(col2) != ncol(x$posterior.z)){ print(paste("Please specify", ncol(x$posterior.z) ,"color in 'col2'.")) } x.1 = mix.object$x n = sum(sapply(x.1, nrow)) x.1.sum = sum(sapply(1:length(x.1), function(i) length(x.1[[i]][,1]))) if (x.1.sum == n) { x = lapply(1:length(x.1), function(i) matrix(x.1[[i]][,-1], ncol = 1)) }else { x = x.1 } plot.density <- plotly_post.beta(x = x, y = mix.object$y, p.beta = mix.object$posterior.beta, p.z = mix.object$posterior.z , cex = cex2,lwd=lwd2, title.size = title2.size, xlab.size = xlab2.size , xtick.size = xtick2.size, ylab.size = ylab2.size , ytick.size = ytick2.size, col.comp = col2) } if (mix.object$ft == "mvnormalmixEM") { x = mix.object$x if (ncol(x) != 2) { stop("The data must have 2 columns!") } post = apply(mix.object$posterior, 1, which.max) k <- ncol(mix.object$posterior) if (is.null(col2)){ col2 <- hue_pal()(k) } if (length(col2) != k){ print(paste("Please specify" ,k," colors in 'col2'.")) } if (is.list(mix.object$sigma)) { sigma = mix.object$sigma } else { sigma = lapply(1:k, function(i) mix.object$sigma) } if (is.list(mix.object$mu)) { mu = mix.object$mu } else { mu = lapply(1:k, function(i) mix.object$mu) } if(is.null(xlab2)) { xlab2 <- "X.1" } if(is.null(ylab2)) { ylab2 <- "X.2" } if (!marginal) { if (is.null(title2)) { title2 <- "Density Curves" } } if (marginal) { title2 <- "" } plot.main <- plot_ly()%>% add_trace(x=mix.object$x[,1] , y=mix.object$x[,2], type = 'scatter' , mode = 'markers', marker = list(color = col2[post] , size = cex2), name = "Data" , showlegend = FALSE)%>% plotly::layout( title = list(text = title2, x = title2.x, y = title2.y, font = list(size=title2.size) ), xaxis = list(title = list(text = xlab2, font = list(size = xlab2.size)), tickfont = list(size = xtick2.size) ), yaxis = list(title = list(text = ylab2, font = list(size = ylab2.size)), tickfont = list(size = ytick2.size) ) ) for (i in 1:k){ plot.main <- add_markers(plot.main, x = mu[[i]][1], y = mu[[i]][2], marker = list(color = "black" , size = cex2+3), name = paste("Center" , i) , showlegend = FALSE) } es.multi <- lapply(sigma, eigen) e1.multi <- lapply(es.multi, function(x){x$vectors%*%diag(sqrt(x$values))}) r1.multi <- sapply(alpha, function(x){sqrt(qchisq(1-x,2))}) theta <- seq(0,2*pi,len=300) v1.multi <- lapply(r1.multi , function(x){cbind(x*cos(theta),x*sin(theta))}) pts.multi <- rep(list(NA),length(sigma)) for (i in 1:length(sigma)){ pts.multi[[i]] <- rep(list(NA) , length(alpha)) for (j in 1:length(alpha)){ pts.multi[[i]][[j]] <- t(mu[[i]]-e1.multi[[i]]%*%t(v1.multi[[j]])) } } for (i in 1:k) { for (j in 1:length(alpha)) { plot.main <- add_trace( plot.main, x=pts.multi[[i]][[j]][,1] , y=pts.multi[[i]][[j]][,2] , type = 'scatter' , mode = 'lines', line = list(color = col2[i] , width = lwd2), name = paste((1-alpha[j])*100,'% Ellipse'),showlegend = FALSE) } } if (!marginal){ plot.density <- plot.main } if (marginal){ x.marginal <- plot_ly()%>% add_trace(x=mix.object$x[, 1], type = 'histogram', name = "Dist X", showlegend = FALSE, marker = list(color = col.hist, line = list(color = col.hist)) )%>% plotly::layout( bargap = 0.01 ) y.marginal <- plot_ly()%>% add_trace(y=mix.object$x[, 2], type = 'histogram', name = "Dist X", showlegend = FALSE, marker = list(color = col.hist, line = list(color = col.hist)) )%>% plotly::layout( bargap = 0.01 ) plot.density <- subplot( x.marginal, plotly_empty(type = 'scatter' , mode = "markers"), plot.main, y.marginal, nrows = 2, heights = c(.2, .8), widths = c(.8,.2), margin = 0, shareX = TRUE, shareY = TRUE) %>% plotly::layout(showlegend = FALSE) } } print(plot.density) # if (mix.object$ft == "expRMM_EM") {plotexpRMM(mix.object, ...)} # all default # if (mix.object$ft == "weibullRMM_SEM") {plotweibullRMM(mix.object, ...)} # all default if (mix.object$ft == "expRMM_EM") {plotly_expRMM(mix.object)} # all default if (mix.object$ft == "weibullRMM_SEM") {plotly_weibullRMM(mix.object)} # all default } par(def.par) # reset ask and mar to original values }mixtools/R/multmixinit.R0000755000176200001440000000063714342153463015055 0ustar liggesusersmultmix.init <- function(y, lambda = NULL, theta = NULL, k = 2){ n <- nrow(y) p <- ncol(y) if (is.null(theta)) { theta = matrix(runif(p * k), k, p) theta = theta/apply(theta, 1, sum) } else k = nrow(theta) if (is.null(lambda)) { lambda = runif(k) lambda = lambda/sum(lambda) } else k = length(lambda) list(lambda=lambda, theta=theta, k=k) }mixtools/R/testmixedequality.R0000755000176200001440000000520314342153463016250 0ustar liggesuserstest.equality.mixed=function (y, x = NULL, w = NULL, arb.R = TRUE, arb.sigma = FALSE, lambda = NULL, mu = NULL, sigma = NULL, R = NULL, alpha = NULL, ...) { if (arb.R == arb.sigma) stop("Change either 'arb.R' or 'arb.sigma'!") v = 1 while (v == 1) { if (arb.R) { H0 = regmixEM.mixed(y = y, x = x, w = w, arb.R = TRUE, arb.sigma = FALSE, lambda = lambda, sigma = sigma, mu = mu, R = R, alpha = alpha, ...) p = nrow(H0$posterior.beta[[1]]) k = length(H0$lambda) if (is.null(w)) alpha = NULL else alpha = H0$alpha # n.i=sapply(y,length) # N=length(y) # tmp=apply(H1$posterior.z*n.i,2,sum) # common.sig=sum(tmp/N*H1$sigma) # H1 = regmixEM.mixed(y = y, x = x, w = w, arb.R = TRUE, # arb.sigma = TRUE, lambda = H0$lambda, sigma = rep(H0$sigma,k), # mu = H0$mu, R = H0$R, alpha = alpha, ...) H1 = regmixEM.mixed(y = y, x = x, w = w, arb.R = TRUE, arb.sigma = TRUE, lambda = H0$lambda, sigma = NULL, mu = H0$mu, R = H0$R, alpha = alpha, ...) D = 2 * (H1$loglik - H0$loglik) df = k - 1 alpha = 1 - pchisq(D, df = df) } else { H0 = regmixEM.mixed(y = y, x = x, w = w, arb.R = FALSE, arb.sigma = TRUE, lambda = lambda, sigma = sigma, mu = mu, R = R, alpha = alpha, ...) p = nrow(H0$posterior.beta[[1]]) k = length(H0$lambda) if (is.null(w)) alpha = NULL else alpha = H0$alpha # N=length(y) # tmp=(apply(H1$posterior.z,2,sum))/N # common.R=matrix(0,ncol=p,nrow=p) # for(i in 1:length(H1$lambda)){ # common.R=common.R+tmp[i]*H1$R[[i]] # } # H1 = regmixEM.mixed(y = y, x = x, w = w, arb.R = TRUE, # arb.sigma = TRUE, lambda = H0$lambda, sigma = H0$sigma, # mu = H0$mu, R = lapply(1:k,function(i) H0$R), alpha = alpha, ...) H1 = regmixEM.mixed(y = y, x = x, w = w, arb.R = TRUE, arb.sigma = TRUE, lambda = H0$lambda, sigma = H0$sigma, mu = H0$mu, R = NULL, alpha = alpha, ...) D = 2 * (H1$loglik - H0$loglik) df = p * (p + 1) * (k - 1)/2 alpha = 1 - pchisq(D, df = df) } if (D < 0) { v = 1 lambda=NULL sigma=NULL mu=NULL R=NULL alpha=NULL} else v = 2 } a = list(chi.sq = D, df = df, p.value = alpha) a } mixtools/R/plotly_ellipse.R0000644000176200001440000000527414343036567015537 0ustar liggesusersplotly_ellipse <- function(mu, sigma, alpha=.05, npoints=250, draw=TRUE, cex = 3, col = "#1f77b4", lwd = 3, title = "", title.x = 0.5, title.y = 0.95, title.size = 15, xlab = "X", xlab.size = 15, xtick.size = 15, ylab = "Y", ylab.size = 15, ytick.size = 15 ) { es <- eigen(sigma) e1 <- es$vec%*%diag(sqrt(es$val)) r1 <- sqrt(qchisq(1-alpha,2)) theta <- seq(0,2*pi,len=npoints) v1 <- cbind(r1*cos(theta),r1*sin(theta)) pts=t(mu-(e1%*%t(v1))) updatemenus <- list( list( x = 1.2, y = 1, visible = TRUE, font = list(size=12), active = 0, type= 'dropdown', buttons = list( list( label = "Show Markers", method = "update", args = list(list(visible = c(TRUE, FALSE , FALSE)))), list( label = "Show Lines", method = "update", args = list(list(visible = c(FALSE , TRUE , FALSE)))), list( label = "Show Lines+Markers", method = "update", args = list(list(visible = c(FALSE , FALSE , TRUE))))) ) ) plot <- plot_ly() %>% add_markers(x=pts[,1] , y=pts[,2] , type = 'scatter' , mode = 'markers' , marker = list(color = col , size = cex) , name = 'Data' , showlegend = FALSE) %>% add_trace(x=pts[,1] , y=pts[,2] , type = 'scatter' , mode = 'lines', line = list(color = col , width = lwd), name = "Data" , showlegend = FALSE) %>% add_trace(x=pts[,1] , y=pts[,2] , type = 'scatter' , mode = 'lines+markers', marker = list(color = col , size = cex), line = list(color = col , width = lwd), name = "Data" , showlegend = FALSE) %>% plotly::layout( updatemenus = updatemenus, title = list(text = title, x = title.x, y = title.y, font = list(size=title.size) ), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) print(plot) invisible(pts) } mixtools/R/normalmixEM2comp.R0000755000176200001440000000331314342153463015655 0ustar liggesusers# fast function for two-component univariate normal mixture normalmixEM2comp <- function(x, lambda, mu, sigsqrd, eps=1e-8, maxit=1000, verb=FALSE) { arbvar <- (length(sigsqrd)==2) mu1 <- mu[1]; mu2 <- mu[2] sigsqrd1 <- sigsqrd[1]; sigsqrd2 <- sigsqrd[arbvar+1] mx <- mean(x) const <- length(x) * 0.918938533204673 # i.e., times log(2*pi)/2 dl <- 1 + eps iter<-0 ll <- rep(0, maxit+1) a1<-(x-mu1)^2; b1<-(lambda/sqrt(sigsqrd1))*exp(-a1/2/sigsqrd1) a2<-(x-mu2)^2; b2<-((1-lambda)/sqrt(sigsqrd2))*exp(-a2/2/sigsqrd2) l <- sum(log(b1+b2)) while (dl>eps && iter= 0)) { xe.v1 <- diag(sqrt(xe.v)) } xvalue <- cbind(xe$vectors) xvalue.1 <- solve(xvalue) out <- xvalue %*% xe.v1 %*% xvalue.1 out } mixtools/R/rmvnorm.R0000755000176200001440000000155614342153463014173 0ustar liggesusers# Alternative version of rmvnorm to eliminate dependence of mixtools # on additional package 'mvtnorm' # Uses eigen decomposition assuming symmetric==TRUE. Don't know how efficient # this might be relative to other approaches, but some suggest this is among # the most efficient methods to find a matrix square root. rmvnorm <- function(n, mu=NULL, sigma=NULL) { if (is.null(mu)) { if (is.null(sigma)) { return(rnorm(n)) } else { mu = rep(0, nrow(sigma)) } } else if (is.null(sigma)) { sigma=diag(length(mu)) } lmu <- length(mu) if (lmu != nrow(sigma) || lmu != ncol(sigma)) stop("length of mu must equal nrow and ncol of sigma") e <- eigen(sigma, symmetric=TRUE) if (any(e$val<0)) stop("Numerically negative definite covariance matrix") t(mu + e$vec %*% (t(e$vec) * sqrt(e$val)) %*% matrix(rnorm(n*lmu), lmu, n)) } mixtools/R/density.npEM.R0000755000176200001440000000266214342153463015007 0ustar liggesusers# Method for "density" generic: Takes an npEM object and returns # a corresponding KDE for the appropriate component and block, evaluated # at the given set of points. # Does not use the FFT like the density.default function does; still # quite fast, but not optimized for speed density.npEM <- function (x, u = NULL, component = 1, block = 1, scale = FALSE, ...) { if (is.null(blockid <- x$blockid)) { coords <- 1 } else { coords <- blockid == block if (!any(coords)) stop("Illegal value of block argument") } m <- NCOL(x$post) xx <- as.vector(as.matrix(x$data)[, coords]) if(is.matrix(x$bandwidth)) bw <- x$bandwidth[block, component] else bw <- x$bandwidth if (is.null(u)) { u = seq(min(xx) - 4 * bw, max(xx) + 4 * bw, len = 250) } if (component > m || component < 1) stop("Illegal value of component argument") if (!is.null(x$symmetric) && x$symmetric) { n <- length(xx) d <- wkde(x = rep(xx, m) - rep(x$muhat, each = n), u = u - x$muhat[component], w = as.vector(x$post), bw = bw, sym = TRUE) } else { n <- NROW(x$data) wts <- rep(x$post[, component], sum(coords)) d <- wkde(xx, u = u, w = wts, bw = bw) } if (scale) d <- d * x$lambdahat[component] structure(list(x = u, y = d, bw = bw, n = n, call = match.call(), data.name = deparse(substitute(x)), has.na = FALSE), class = "density") } mixtools/R/normalmixEM.R0000755000176200001440000001362714342153463014725 0ustar liggesusers## Use an ECM algorithm (in the sense of Meng and Rubin, Biometrika 1993) ## to search for a local maximum of the likelihood surface for a ## univariate finite mixture of normals with possible equality ## constraints on the mean and stdev parameters. normalmixEM <- function (x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, mean.constr = NULL, sd.constr = NULL, epsilon = 1e-08, maxit = 1000, maxrestarts=20, verb = FALSE, fast=FALSE, ECM = FALSE, arbmean = TRUE, arbvar = TRUE) { warn <- options(warn=-1) # Turn off warnings x <- as.vector(x) tmp <- normalmix.init(x = x, lambda = lambda, mu = mu, s = sigma, k = k, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda mu <- tmp$mu sigma <- tmp$s k <- tmp$k arbvar <- tmp$arbvar arbmean <- tmp$arbmean if (fast==TRUE && k==2 && arbmean==TRUE) { a <- normalmixEM2comp (x, lambda=lambda[1], mu=mu, sigsqrd=sigma^2, eps=epsilon, maxit=maxit, verb=verb) } else { z <- parse.constraints(mean.constr, k=k, allsame=!arbmean) meancat <- z$category; meanalpha <- z$alpha z <- parse.constraints(sd.constr, k=k, allsame=!arbvar) sdcat <- z$category; sdalpha <- z$alpha ECM <- ECM || any(meancat != 1:k) || any(sdcat != 1) n <- length(x) notdone <- TRUE restarts <- 0 while(notdone) { # Initialize everything notdone <- FALSE tmp <- normalmix.init(x = x, lambda = lambda, mu = mu, s = sigma, k = k, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda mu <- tmp$mu k <- tmp$k sigma <- tmp$s var <- sigma^2 diff <- epsilon+1 iter <- 0 postprobs <- matrix(nrow = n, ncol = k) mu <- rep(mu, k)[1:k] sigma <- rep(sigma,k)[1:k] # Initialization E-step here: z <- .C(C_normpost, as.integer(n), as.integer(k), as.double(x), as.double(mu), as.double(sigma), as.double(lambda), res2 = double(n*k), double(3*k), post = double(n*k), loglik = double(1), PACKAGE = "mixtools") postprobs <- matrix(z$post, nrow=n) res <- matrix(z$res2, nrow=n) ll <- obsloglik <- z$loglik while (diff > epsilon && iter < maxit) { # ECM loop, 1st M-step: condition on sigma, update lambda and mu lambda <- colMeans(postprobs) mu[meancat==0] <- meanalpha[meancat==0] if (max(meancat)>0) { for(i in 1:max(meancat)) { w <- which(meancat==i) if (length(w)==1) { mu[w] <- sum(postprobs[,w]*x) / (n*lambda[w]) } else { tmp <- t(postprobs[,w])*(meanalpha[w]/sigma[w]^2) mu[w] <- meanalpha[w] * sum(t(tmp)*x) / sum(tmp*meanalpha[w]) } } } if (ECM) { # If ECM==FALSE, then this is a true EM algorithm and # so we omit the E-step between the mu and sigma updates # E-step number one: z <- .C(C_normpost, as.integer(n), as.integer(k), as.double(x), as.double(mu), as.double(sigma), as.double(lambda), res2 = double(n*k), double(3*k), post = double(n*k), loglik = double(1), PACKAGE = "mixtools") postprobs <- matrix(z$post, nrow=n) res <- matrix(z$res2, nrow=n) # ECM loop, 2nd M-step: condition on mu, update lambda and sigma lambda <- colMeans(postprobs) # Redundant if ECM==FALSE } sigma[sdcat==0] <- sdalpha[sdcat==0] if (max(sdcat)>0) { for(i in 1:max(sdcat)) { w <- which(sdcat==i) if (length(w)==1) { sigma[w] <- sqrt(sum(postprobs[,w]*res[,w]) / (n*lambda[w])) } else { tmp <- t(postprobs[,w]) / sdalpha[w] sigma[w] <- sdalpha[w] * sqrt(sum(t(tmp) * res[,w])/ (n * sum(lambda[w]))) } } if(any(sigma < 1e-08)) { notdone <- TRUE cat("One of the variances is going to zero; ", "trying new starting values.\n") restarts <- restarts + 1 lambda <- mu <- sigma <- NULL if(restarts>maxrestarts) { stop("Too many tries!") } break } } # E-step number two: z <- .C(C_normpost, as.integer(n), as.integer(k), as.double(x), as.double(mu), as.double(sigma), as.double(lambda), res2 = double(n*k), double(3*k), post = double(n*k), loglik = double(1), PACKAGE = "mixtools") postprobs <- matrix(z$post, nrow=n) res <- matrix(z$res2, nrow=n) newobsloglik <- z$loglik diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration =", iter, " log-lik diff =", diff, " log-lik =", obsloglik, "\n") print(rbind(lambda, mu, sigma)) } } } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") if(arbmean == FALSE){ scale.order = order(sigma) sigma.min = min(sigma) postprobs = postprobs[,scale.order] colnames(postprobs) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, lambda = lambda[scale.order], mu = mu, sigma = sigma.min, scale = sigma[scale.order]/sigma.min, loglik = obsloglik, posterior = postprobs, all.loglik=ll, restarts=restarts, ft="normalmixEM") } else { colnames(postprobs) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, lambda = lambda, mu = mu, sigma = sigma, loglik = obsloglik, posterior = postprobs, all.loglik=ll, restarts=restarts, ft="normalmixEM") } } class(a) = "mixEM" options(warn) # Reset warnings to original value a } mixtools/R/plotly_post.beta.R0000644000176200001440000001565414343051443015772 0ustar liggesusersplotly_post.beta <- function(y, x, p.beta, p.z, cex = 6,lwd=1, title.size = 15, xlab.size = 15 , xtick.size = 15, ylab.size = 15 , ytick.size = 15, col.data = "#1f77b4", col.comp = NULL){ N = length(y) k = ncol(p.z) g = apply(p.z, 1, function(i) (1:length(i))[i == max(i)]) if(is.null(col.comp)){ col.comp <- hue_pal()(k) } if (length(col.comp) != k){ print(paste("Please specify" , k , "colors in 'col.comp'.")) } abline.fun <- function(x , intercept , slope){ y <- slope * x + intercept return(y) } min.int=min(sapply(1:N, function(i) min(p.beta[[i]][1,]))) max.int=max(sapply(1:N, function(i) max(p.beta[[i]][1,]))) min.slp=min(sapply(1:N, function(i) min(p.beta[[i]][2,]))) max.slp=max(sapply(1:N, function(i) max(p.beta[[i]][2,]))) # All posterior regression lines. fig1 <- plot_ly()%>% plotly::layout( xaxis = list(title = list(text = "x-values", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "y-values", font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (i in 1:length(x)){ fig1 <- add_trace(fig1, x=as.vector(x[[i]]) , y=as.vector(y[[i]]), type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.data), name = paste("Comp" , i) , showlegend = FALSE) } for (j in 1:k){ for (l in 1:length(p.beta)){ fig1 <- add_trace(fig1, x=c(min(unlist(x)) , max(unlist(x))) , y=c(abline.fun(x=min(unlist(x)) , intercept = p.beta[[l]][1,j] , slope = p.beta[[l]][2,j]), abline.fun(x=max(unlist(x)) , intercept = p.beta[[l]][1,j] , slope = p.beta[[l]][2,j])), type = 'scatter' , mode = 'lines', line = list(width = lwd , color = col.comp[j]), name = paste("Fit" , j) , showlegend = FALSE) } } #Posterior regression lines chosen according to the membership probabilities. fig2 <- plot_ly()%>% plotly::layout( xaxis = list(title = list(text = "x-values", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "y-values", font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (i in 1:length(x)){ fig2 <- add_trace(fig2, x=as.vector(x[[i]]) , y=as.vector(y[[i]]), type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.data), name = paste("Comp" , i) , showlegend = FALSE) } for (l in 1:length(p.beta)){ fig2 <- add_trace(fig2, x=c(min(unlist(x)) , max(unlist(x))) , y=c(abline.fun(x=min(unlist(x)) , intercept = p.beta[[l]][1,g[l]] , slope = p.beta[[l]][2,g[l]]), abline.fun(x=max(unlist(x)) , intercept = p.beta[[l]][1,g[l]] , slope = p.beta[[l]][2,g[l]])), type = 'scatter' , mode = 'lines', line = list(width = lwd , color = col.comp[g[l]]), name = paste("Fit" , j) , showlegend = FALSE) } #All posterior beta values. fig3 <- plot_ly()%>% plotly::layout( xaxis = list(title = list(text = "Posterior Intercepts", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "Posterior Slopes", font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (j in 1:k){ for (l in 1:length(p.beta)){ fig3 <- add_trace(fig3, x=p.beta[[l]][1,j], y=p.beta[[l]][2,j], type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.comp[j]), name = paste("Comp" , j) , showlegend = FALSE) } } #Posterior beta values chosen according to the membership probabilities. fig4 <- plot_ly()%>% plotly::layout( xaxis = list(title = list(text = "Posterior Intercepts", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "Posterior Slopes", font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (l in 1:length(p.beta)){ fig4 <- add_trace(fig4, x=p.beta[[l]][1,g[l]] , y=p.beta[[l]][2,g[l]], type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.comp[g[l]]), name = paste("Comp" , l) , showlegend = FALSE) } fig <- subplot(fig1, fig2, fig3 , fig4 , nrows = 2, titleX = TRUE , titleY = TRUE, margin = c(0.03,0.03,0.15,0.15)) %>% plotly::layout(annotations = list( list( x = 0.225, y = 1.0, font = list(size = title.size), text = "Data and Posterior Regression Lines", xref = "paper", yref = "paper", xanchor = "center", yanchor = "bottom", showarrow = FALSE ), list( x = 0.775, y = 1.0, font = list(size = title.size), text = "Data and Most Probable Posterior Regression Lines", xref = "paper", yref = "paper", xanchor = "center", yanchor = "bottom", showarrow = FALSE ), list( x = 0.225, y = 0.375, font = list(size = title.size), text = "All Posterior Regression Coefficients", xref = "paper", yref = "paper", xanchor = "center", yanchor = "bottom", showarrow = FALSE ), list( x = 0.775, y = 0.375, font = list(size = title.size), text = "Most Probable Posterior Regression Coefficients", xref = "paper", yref = "paper", xanchor = "center", yanchor = "bottom", showarrow = FALSE ) ) ) print(fig) }mixtools/R/wquantile.R0000755000176200001440000000066014342153463014477 0ustar liggesuserswquantile <- function(wt=rep(1,length(x)), x, probs, already.sorted=FALSE, already.normalized=FALSE) { if(!already.sorted) { wt <- wt[o<-order(x)] x <- x[o] } if(!already.normalized) { wt <- wt/sum(wt) } x[findInterval(probs,cumsum(wt))] } wIQR <- function(wt=rep(1,length(x)), x, already.sorted=FALSE, already.normalized=FALSE) { diff(wquantile(wt, x, c(.25,.75), already.sorted, already.normalized)) } mixtools/R/regmixEMmixed.R0000755000176200001440000003735314342153463015243 0ustar liggesusersregmixEM.mixed = function (y, x, w = NULL, sigma = NULL, arb.sigma = TRUE, alpha = NULL, lambda = NULL, mu = NULL, rho=NULL, R = NULL, arb.R = TRUE, k = 2, ar.1 = FALSE, addintercept.fixed = FALSE, addintercept.random = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) { Omega.def <- function(rho,n){ Omega.1stcol <- NULL for(i in 1:n){ Omega.1stcol <- c(Omega.1stcol,rho^(i-1)) } A=Omega.1stcol for(i in 1:(n-1)){ A=cbind(A,c(rep(0,i),Omega.1stcol[1:(n-i)])) } B=A+t(A) diag(B)=rep(1,n) B=B/(1-rho^2) B } rho.max<-function(rho,z,sigma,y,x,w,alpha,beta,V.beta){ n.i <- length(y) Omega.ij <- Omega.def(rho=rho,n=n.i) -.5*z*(log(det(Omega.ij))+(1/sigma)*(t(y- as.vector(w %*% alpha)-x%*%beta))%*%solve(Omega.ij)%*%(y- as.vector(w %*% alpha)-x%*%beta)+sum(diag(solve(Omega.ij) %*% x %*% V.beta %*% t(x) ))) } `%L*%` = function(x, y) lapply(1:length(x), function(z) { t(x[[z]]) %*% y[[z]] }) N <- length(y) n <- sapply(y, length) if (addintercept.random) { x.1 = lapply(1:N, function(i) cbind(1, x[[i]])) x = x.1 } if (is.null(w)) { w = as.list(rep(0, N)) mixed=FALSE } else mixed=TRUE p <- ncol(x[[1]]) if (mixed == TRUE) { if (addintercept.fixed) { w.1 = lapply(1:N, function(i) cbind(1, w[[i]])) w = w.1 } tww = w %L*% w tww.inv = 0 for (i in 1:N) { tww.inv = tww.inv + tww[[i]] } tww.inv = solve(tww.inv) twx = w %L*% x twy = w %L*% y q <- ncol(w[[1]]) } tmp <- regmix.mixed.init(y = y, x = x, w = w, sigma = sigma, arb.sigma = arb.sigma, alpha = alpha, lambda = lambda, mu = mu, R = R, arb.R = arb.R, k = k, mixed = mixed, addintercept.fixed = addintercept.fixed, addintercept.random = addintercept.random) alpha <- tmp$alpha lambda <- tmp$lambda mu <- tmp$mu R <- tmp$R sigma <- tmp$sigma s.2 <- sigma^2 if(ar.1==TRUE & is.null(rho)==TRUE){ rho=matrix(runif(N*k,-1,1),nrow=N,ncol=k) } txx = x %L*% x diff <- 1 iter <- 0 obsloglik=-Inf ll <- NULL restarts <- 0 if(ar.1) Omega.k <- lapply(1:N, function(i) lapply(1:k, function(j) Omega.def(rho=rho[i,j],n=n[i]))) else Omega.k <- lapply(1:N, function(i) lapply(1:k, function(j) diag(1, n[i]))) while (diff > epsilon && iter < maxit) { txOx<-lapply(1:N, function(i) lapply(1:k, function(j) t(x[[i]]) %*% solve(Omega.k[[i]][[j]]) %*% x[[i]])) if (arb.R) { V.beta = list() for (i in 1:N) { V.beta[[i]] = list() V.beta[[i]] = lapply(1:k, function(j) { solve(txOx[[i]][[j]]/s.2[j * arb.sigma + (1 - arb.sigma)] + solve(R[[j]])) }) } beta = list() for (i in 1:N) { beta[[i]] = matrix(nrow = p, ncol = k) for (j in 1:k) { beta[[i]][, j] = V.beta[[i]][[j]] %*% (t(x[[i]])/s.2[j * arb.sigma + (1 - arb.sigma)]) %*% solve(Omega.k[[i]][[j]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, j]) + mu[, j] } } z = matrix(nrow = N, ncol = k) for (i in 1:N) { for (j in 1:k) { z.denom = c() for (m in 1:k) { z.denom = c(z.denom, lambda[m]/lambda[j] * (det(x[[i]] %*% R[[j]] %*% t(x[[i]]) + s.2[j * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[j]])/det(x[[i]] %*% R[[m]] %*% t(x[[i]]) + s.2[m * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[m]]))^(0.5) * exp(-0.5 * (t(y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, m]) %*% solve(x[[i]] %*% R[[m]] %*% t(x[[i]]) + s.2[m * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[m]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, m]) - t(y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, j]) %*% solve(x[[i]] %*% R[[j]] %*% t(x[[i]]) + s.2[j * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[j]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, j])))) } z[i, j] = 1/sum(z.denom) } } # z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) z = z/apply(z,1,sum) sing <- sum(is.na(z)) sum.z = apply(z, 2, sum) lambda.new <- sum.z/N if (sum(lambda.new < 1e-08)>0 || is.na(sum(lambda.new))) { sing <- 1 } else { mu.new <- matrix(nrow = p, ncol = k) for (j in 1:k) { mu.2 <- matrix(sapply(1:N, function(i) { beta[[i]][, j] }), ncol = N) mu.new[, j] <- apply(t(apply(t(mu.2), 2, "*", matrix(z[, j], nrow = 1))), 1, sum) } mu.new = t(apply(t(mu.new), 2, "/", matrix(sum.z, nrow = 1))) if (mixed == TRUE) { a.vec <- c() A.mat <- 0 for (i in 1:N) { for (j in 1:k) { A.mat = A.mat + (z[i, j]/s.2[j * arb.sigma + (1 - arb.sigma)])*tww[[i]] a.vec = cbind(a.vec, (z[i, j]/s.2[j * arb.sigma + (1 - arb.sigma)]) * (twy[[i]] - twx[[i]] %*% beta[[i]][, j])) # a.vec = cbind(a.vec, z[i, j] * (twy[[i]] - # twx[[i]] %*% beta[[i]][, j])) } } # alpha.new <- tww.inv %*% apply(a.vec, 1, sum) alpha.new <- solve(A.mat) %*% apply(a.vec, 1, sum) alpha = alpha.new } s.tr <- matrix(nrow = N, ncol = k) z.n <- matrix(nrow = N, ncol = k) for (i in 1:N) { for (j in 1:k) { s.tr[i, j] = sum(diag(z[i, j] * (solve(Omega.k[[i]][[j]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% beta[[i]][, j]) %*% t(y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% beta[[i]][, j]) + x[[i]] %*% V.beta[[i]][[j]] %*% t(x[[i]])))) z.n[i, j] = z[i, j] * n[i] } } if (arb.sigma) { s.2.new <- apply(s.tr, 2, sum)/apply(z.n, 2, sum) } else s.2.new <- sum(s.tr)/sum(n) R.new = list() for (j in 1:k) { r.2 <- 0 for (i in 1:N) { r <- z[i, j] * (V.beta[[i]][[j]] + t(t(beta[[i]][, j] - mu.new[, j])) %*% (beta[[i]][, j] - mu.new[, j])) r.2 <- r.2 + r } R.new[[j]] = r.2/sum(z[, j]) } lambda = lambda.new mu = mu.new s.2 = s.2.new R = R.new L = matrix(nrow = N, ncol = k) L = t(sapply(1:N, function(i) { sapply(1:k, function(j) { dmvnorm(as.vector(y[[i]]), as.vector(x[[i]] %*% mu[, j] + as.vector(w[[i]] %*% alpha)), x[[i]] %*% R[[j]] %*% t(x[[i]]) + s.2[j * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[j]]) }) })) L.n = t(apply(t(L), 2, "*", matrix(lambda, nrow = 1))) newobsloglik = sum(log(apply(L.n, 1, sum))) } } else { R.inv = solve(R) V.beta = list() for (i in 1:N) { V.beta[[i]] = list() V.beta[[i]] = lapply(1:k, function(j) { solve(txOx[[i]][[j]]/s.2[j * arb.sigma + (1 - arb.sigma)] + R.inv) }) } beta = list() for (i in 1:N) { beta[[i]] = matrix(nrow = p, ncol = k) for (j in 1:k) { beta[[i]][, j] = V.beta[[i]][[j]] %*% (t(x[[i]])/s.2[j * arb.sigma + (1 - arb.sigma)]) %*% solve(Omega.k[[i]][[j]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, j]) + mu[, j] } } z = matrix(nrow = N, ncol = k) for (i in 1:N) { for (j in 1:k) { z.denom = c() for (m in 1:k) { z.denom = c(z.denom, lambda[m]/lambda[j] * (det(x[[i]] %*% R %*% t(x[[i]]) + s.2[j * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[j]])/det(x[[i]] %*% R %*% t(x[[i]]) + s.2[m * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[m]]))^(0.5) * exp(-0.5 * (t(y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, m]) %*% solve(x[[i]] %*% R %*% t(x[[i]]) + s.2[m * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[m]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, m]) - t(y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, j]) %*% solve(x[[i]] %*% R %*% t(x[[i]]) + s.2[j * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[j]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% mu[, j])))) } z[i, j] = 1/sum(z.denom) } } # z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) z = z/apply(z,1,sum) sing <- sum(is.nan(z)) sum.z = apply(z, 2, sum) lambda.new <- sum.z/N if (sum(lambda.new < 1e-08)>0 || is.na(sum(lambda.new))) { sing <- 1 } else { mu.new <- matrix(nrow = p, ncol = k) for (j in 1:k) { mu.2 <- matrix(sapply(1:N, function(i) { beta[[i]][, j] }), ncol = N) mu.new[, j] <- apply(t(apply(t(mu.2), 2, "*", matrix(z[, j], nrow = 1))), 1, sum) } mu.new = t(apply(t(mu.new), 2, "/", matrix(sum.z, nrow = 1))) if (mixed == TRUE) { a.vec <- c() A.mat <- 0 for (i in 1:N) { for (j in 1:k) { A.mat = A.mat + (z[i, j]/s.2[j * arb.sigma + (1 - arb.sigma)])*tww[[i]] a.vec = cbind(a.vec, (z[i, j]/s.2[j * arb.sigma + (1 - arb.sigma)]) * (twy[[i]] - twx[[i]] %*% beta[[i]][, j])) # a.vec = cbind(a.vec, z[i, j] * (twy[[i]] - # twx[[i]] %*% beta[[i]][, j])) } } # alpha.new <- tww.inv %*% apply(a.vec, 1, sum) alpha.new <- solve(A.mat) %*% apply(a.vec, 1, sum) alpha = alpha.new } s.tr <- matrix(nrow = N, ncol = k) z.n <- matrix(nrow = N, ncol = k) for (i in 1:N) { for (j in 1:k) { s.tr[i, j] = sum(diag(z[i, j] * (solve(Omega.k[[i]][[j]]) %*% (y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% beta[[i]][, j]) %*% t(y[[i]] - as.vector(w[[i]] %*% alpha) - x[[i]] %*% beta[[i]][, j]) + x[[i]] %*% V.beta[[i]][[j]] %*% t(x[[i]])))) z.n[i, j] = z[i, j] * n[i] } } if (arb.sigma) { s.2.new <- apply(s.tr, 2, sum)/apply(z.n, 2, sum) } else s.2.new <- sum(s.tr)/sum(n) r.3 <- 0 for (j in 1:k) { r.2 <- 0 for (i in 1:N) { r <- z[i, j] * (V.beta[[i]][[j]] + t(t(beta[[i]][, j] - mu.new[, j])) %*% (beta[[i]][, j] - mu.new[, j])) r.2 <- r.2 + r } r.3 <- r.3 + r.2 } R.new = r.3/N lambda = lambda.new mu = mu.new s.2 = s.2.new R = R.new if(ar.1){ rho.new<-matrix(0,nrow=N,ncol=k) for(i in 1:N){ for(j in 1:k){ rho.new[i,j] <- optimize(rho.max,interval=c(-1,1),maximum=TRUE,tol=.Machine$double.eps,z=z[i,j],sigma=s.2[j * arb.sigma + (1 - arb.sigma)],y=y[[i]],x=x[[i]],w=w[[i]],alpha=alpha,beta=beta[[i]][,j],V.beta=V.beta[[i]][[j]])$max } } rho = rho.new Omega.k <- lapply(1:N, function(i) lapply(1:k, function(j) Omega.def(rho=rho[i,j],n=n[i] ))) } L = matrix(nrow = N, ncol = k) L = t(sapply(1:N, function(i) { sapply(1:k, function(j) { dmvnorm(as.vector(y[[i]]), as.vector(x[[i]] %*% mu[, j] + as.vector(w[[i]] %*% alpha)), x[[i]] %*% R %*% t(x[[i]]) + s.2[j * arb.sigma + (1 - arb.sigma)] * Omega.k[[i]][[j]]) }) })) L.n = t(apply(t(L), 2, "*", matrix(lambda, nrow = 1))) newobsloglik = sum(log(apply(L.n, 1, sum))) } } if (sing > 0 || is.na(newobsloglik) || abs(newobsloglik) == Inf || newobsloglik < obsloglik) {# || sum(z) != N cat("Need new starting values due to singularity...", "\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- regmix.mixed.init(y = y, x = x, w = w, arb.sigma = arb.sigma, arb.R = arb.R, k = k, mixed = mixed, addintercept.fixed = addintercept.fixed, addintercept.random = addintercept.random) alpha <- tmp$alpha lambda <- tmp$lambda mu <- tmp$mu R <- tmp$R sigma <- tmp$sigma s.2 <- sigma^2 diff <- 1 iter <- 0 obsloglik=-Inf ll <- NULL } else { diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n") } } } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, y=y, w=w, lambda = lambda, mu = mu, R = R, sigma = sqrt(s.2), alpha = alpha, loglik = obsloglik, posterior.z = z, posterior.beta = beta, all.loglik = ll, restarts=restarts, ft="regmixEM.mixed") class(a) = "mixEM" a } mixtools/R/gammamixinit.R0000755000176200001440000000151614342153463015153 0ustar liggesusersgammamix.init <- function (x, lambda = NULL, alpha = NULL, beta = NULL, k = 2) { n <- length(x) if (is.null(lambda)) { cond = TRUE while(cond){ lambda = runif(k) lambda = lambda/sum(lambda) if(min(lambda)<0.05) cond=TRUE else cond=FALSE } } else k = length(lambda) if (k == 1) { x.bar = mean(x) x2.bar = mean(x^2) } else { x.sort = sort(x) ind = floor(n * cumsum(lambda)) x.part = list() x.part[[1]] = x.sort[1:(ind[1] + 1)] for (j in 2:k) { x.part[[j]] = x.sort[ind[j - 1]:ind[j]] } x.bar = sapply(x.part, mean) x2.bar = sapply(lapply(x.part, "^", 2), mean) } if (is.null(alpha)) { alpha = x.bar^2/(x2.bar - x.bar^2) } if (is.null(beta)) { beta = (x2.bar - x.bar^2)/x.bar } list(lambda = lambda, alpha = alpha, beta = beta, k = k) } mixtools/R/kernB.R0000755000176200001440000000012514342153463013523 0ustar liggesuserskern.B <- function (x, xi, h, g = 0) { ((1-((xi-x)/h)^2)^g)/beta(.5,g+1)/h } mixtools/R/lambdapert.R0000755000176200001440000000021514342153463014575 0ustar liggesuserslambda.pert <- function (lambda, pert) { temp = logit(lambda) + pert temp2 = inv.logit(temp) new.lambda = temp2/sum(temp2) new.lambda } mixtools/R/mvnpEM.R0000644000176200001440000002533214342153463013670 0ustar liggesusers### multivariate npEM with multivariate conditionnally independent blocks ### functions for mvnpEM with mvwkde code all in C ###################################################################### ## mvnpEM final (late 2015) version calling C codes for mvwkde's ## both for same and adaptive bandwidths ## adding a default bandwidth matrix passed as an argument ## bwdefault: a r-vector of fixed bandwidths per coordinates ## default to Silverman's rule per coordinates, only when samebw=TRUE ## bw returns the standard deviation of the kernel density ## init= for initialization option (June 2015) ###################################################################### mvnpEM <- function (x, mu0, blockid = 1:ncol(x), samebw = TRUE, bwdefault = apply(x,2,bw.nrd0), init=NULL, eps=1e-8, maxiter = 500, verb = TRUE){ x = as.matrix(x) n = nrow(x); r = ncol(x) bk = blockid #b_k=l indicate the kth coordinate belongs to lth block. B = max(bk) # total number of blocks # ! Caution if blocks are numbered not consecutively, use unique? loglik = NULL tt0 <- proc.time() # for total time # coordinate of X in lth block (block of dl-variate densities) # dl[l] = number of coordinates in l-th block # xx[[j]] = (n,dl[l]) -matrix of block l observations dl=c(); for (l in 1:B){dl[l] = sum(bk==l)} xx = list() for (l in 1:B){ xx[[l]] = as.matrix(x[,bk==l]) # coordinate of X in lth block } if (is.matrix(mu0)) m <- dim(mu0)[1] # mu0 = initial means else m <- mu0 # when mu0 = number of components ## NB initial means used only if kmeans used for init ## z.hat are posterior zij's, initialized using kmeans if (is.null(init)){ z.hat <- matrix(0, nrow = n, ncol = m) if (m == 1) z.hat <- matrix(1, nrow = n, ncol = m) # ?? m can never be 1 else{ kmeans <- kmeans(x, mu0) for(j in 1:m) z.hat[kmeans$cluster==j, j] <- 1} } if (! is.null(init)) {z.hat <- init} # ToDo: check consistency dim (n,m) lambda = matrix(0, maxiter, m) # storing lambda's along iterations finished = FALSE bw=matrix(0,m,r) # only used for adaptbw version if (samebw){ # bw computed once for all iterations and mvwkde calls # bw <- apply(x,2,bw.nrd0) # bw <- bwdefault^2*diag(r) # diagonal bw matrix appropriate for mvwkde bw <- bwdefault*diag(r) # diagonal bw matrix, not variances, appropriate for mvwkde } ## loop iter = 0 #start point while (!finished){ iter = iter + 1 #step "iter + 1" # t0 = proc.time() ################################################################# ## M-step for the Euclidean parameter lambda[iter,] = colMeans(z.hat) #\lambda_j^(t+1) = 1/n* \sum_i^n (p_ij)^t ################################################################# ## Weighted Kernel Density function step # wts[,j] = normalized weights for component j cs <- colSums(z.hat) # or use n*lambda[iter,] to avoid re summing over n ? wts <- sweep(z.hat, 2, cs, "/") wts [, cs==0] <- 1/NROW(wts) if (samebw){ # default samebw=TRUE lambda.f <- matrix(NA,n,m) # lambda.f[i,j] = lambda_j f_j(x_i) fkernel <- matrix(1,n,m) # Faster new version: no loop in j, all is done in C block per block for (l in 1:B) { d = dl[l] tmp=as.matrix(bw[bk==l,bk==l]) # updated here, not sqrt anymore h=as.vector(diag(tmp)); ans <- .C(C_mvwkde_samebw, n = as.integer(n),d = as.integer(d), m = as.integer(m), h = as.double(h), x=as.double(xx[[l]]), u=as.double(xx[[l]]), z=as.double(wts), f=double(n*m)) fl = matrix(ans$f,n,m) # f_jl estimate fkernel <- fkernel*fl # product over blocks } lambda.f <- sweep(fkernel, 2, lambda[iter, ], "*") } # end of samebw case # Adaptive bandwidth case - NOT YET BEST C VERSION (for all j simultaneously ?) if (!samebw) { for (k in 1:r) { # compute adaptive bw h_jk^t # use o <- order(x[,k]) to re-use it twice var <- colSums(wts*outer(x[,k], colSums(wts*x[,k]),'-')^2) iqr <- apply(as.matrix(wts[order(x[,k]),]),2,wIQR, x[,k][order(x[,k])], already.sorted=TRUE, already.normalized=TRUE) bw[,k] <- 0.9*pmin(sqrt(var), iqr/1.34)*pmax(1,n*lambda[iter, ])^(-1/5) } lambda.f <- matrix(NA,n,m) # lambda.f[i,j] = lambda_j f_j(x_i) fkernel <- matrix(1,n,m) #for (j in 1:m){ #lda.f = lambda[iter, j] for (l in 1:B){ d = dl[l]; H = as.matrix(bw[, bk==l]); ans <- .C(C_mvwkde_adaptbw, n = as.integer(n),d = as.integer(d), m = as.integer(m), H = as.double(H), x=as.double(xx[[l]]), u=as.double(xx[[l]]), z=as.double(wts), f=double(n*m)) fl = matrix(ans$f,n,m)# f_jl estimate fkernel <- fkernel*fl # product over blocks } lambda.f <- sweep(fkernel, 2, lambda[iter, ], "*") #} }# end of adaptive case ################################################################ ## E-step (for next iteration) z.hat = lambda.f/rowSums(lambda.f) #p_ij^t, Z_ij^t, update z.hat loglik <- c(loglik,sum(log(rowSums(lambda.f)))) # log-likelihood ## End finished = iter >= maxiter if (iter>1) {maxchange = max(abs(lambda[iter,] - lambda[iter-1,])) finished = finished | (maxchange < eps) } if (verb) { # t1 <- proc.time() cat("iteration", iter, ": lambda ", round(lambda[iter, ], 4),"\n") # cat(" time", (t1 - t0)[3], "\n") } }# End while ##### Output if (verb) { tt1 <- proc.time() # total time ending cat("# iter", iter) cat(", lambda ", round(lambda[iter, ], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } # final bandwidth output depending on samebw switch if (samebw) bw <- diag(bw) return(structure(list(data = x, posteriors = z.hat, lambda = lambda[1:iter,], blockid = bk, samebw=samebw, bandwidth = bw, lambdahat = lambda[iter,], loglik = loglik), class = "mvnpEM")) } # End function. ####################################################### # plot marginal (univariate) wkde's from mvnpEM output # a plot.mvnpEM method for mvnpEM class # lambda, mu, v: true parameters, for gaussian true models only # ... passed to hist first level plotting plot.mvnpEM <- function(x, truenorm=FALSE, lambda=NULL, mu=NULL, v=NULL, lgdcex =1, ...) { mix.object <- x if (!inherits(mix.object, "mvnpEM")) a <- x x <- a$data; r <- ncol(x); m <- ncol(a$posteriors) rr <- sqrt(r); frr <- floor(rr) if (frr == rr) par(mfrow=c(rr,rr)) else { if (frr*(frr+1) >= r) par(mfrow=c(frr, frr+1)) else par(mfrow=c(frr+1, frr+1))} # if ((r %% 2) == 0) par(mfrow=c(floor(r/2), floor(r/2))) else { # par(mfrow=c(floor(r/2)+1, floor(r/2)+1))} for (k in 1:r) { # for each coord (whatever its block) xx <- x[,k] uk <- seq(min(xx),max(xx),len=100) tt <- paste("block", a$blockid[k],", coord",k) hist(xx, col=8, freq=F, xlab="", main=tt, ...) for (j in 1:m) { wj <- a$post[,j] # weights for component j if (a$samebw) bw <- a$bandwidth[k] else { bw <- a$bandwidth[j,k]} f <- wkde(xx, u=uk, w=wj, bw=bw, sym=F) lines(uk, a$lambdahat[j]*f, col=j) # add true Gaussian marginal if requested/known if (truenorm) { lines(uk,lambda[j]*dnorm(uk,mean=mu[j,k], sd=sqrt(v[j,k,k])), lty=2,lwd=2, col=j)} } if (a$samebw) subt <- paste("same bw:",round(a$bandwidth[k],3)) else { subt <- "adapt bw: " for (j in 1:m) subt <- paste(subt, round(a$bandwidth[j,k],3)) } title(sub=subt) } lgd <- NULL for (j in 1:m) lgd <- c(lgd, paste("comp",j)) legend("topright", lgd, col=1:m, lty=1, cex=lgdcex) } ########################################################### print.mvnpEM <- function(x,...) { n <- NROW(x$data) r <- NCOL(x$data) m <- length(x$lambdahat) cat(paste("Observations:", n, "\n")) cat(paste("Coordinates per observation:", r, "\n")) cat(paste("Mixture components:", m, "\n")) if (r > 1) { B <- max(x$blockid) cat(paste("Blocks (of conditionally iid coordinates):",B, "\n\n")) } dp = match(c("data", "posteriors", "lambda", "mu"), names(x), nomatch = 0) print.default(structure(x[-dp], class = class(x)), ...) invisible(x) } print.summary.mvnpEM <-function (x, digits = 3, ...) { if (x$r > 1) cat(paste(x$n, "observations,", x$r, "coordinates,", x$m, "components, and", x$B, "blocks.\n\n")) else cat(paste(x$n, "univariate observations, and", x$m, "components.\n\n")) cat("Means (and std. deviations) for each component:\n") for (l in 1:x$B) { coords <- 1 if (x$r > 1) { coords <- x$blockid == l cat(paste(" Block #", l, ": Coordinate", sep = "")) cat(ifelse(sum(coords) > 1, "s ", " ")) cat(which(coords)) cat("\n") } if (sum(coords)==1) { for (j in 1:x$m){ cat(paste(" Component", j,": ")) cat(paste(signif(x$means[j,coords], digits), " (", signif(x$variances[[j]][coords,coords],digits), ") ", sep = "")) } cat("\n") } else { for (j in 1:x$m){ cat(paste(" Component", j,": ")) cat(paste(signif(x$means[j,coords ], digits), sep = "")) cat("\n") print(signif(x$variances[[j]][coords,coords], digits)) cat("\n") }} } } summary.mvnpEM <- function(object,...) { n <- NROW(object$data);n r <- NCOL(object$data);r m <- length(object$lambdahat);m B <- max(object$blockid);B mu <- matrix(0, m, r);mu v <- array(0,c(m,r,r));v[1,,];v[2,,] normpost <- sweep(object$post, 2, sums <- colSums(object$post),"/") for (l in 1:B){ coords <- object$blockid == l;coords sc <- sum(coords);sc xx <- as.matrix(object$data[, coords]);xx var<- list();mean<-list() for (j in 1:m){ wts <- normpost[, j] M<-mu[j,coords] <- colSums(wts*as.matrix(xx)) if (sc==1) v[j,coords,coords]<- colSums(wts*outer(as.matrix(xx), colSums(wts*as.matrix(xx)),'-')^2) else{ for (t1 in 1:sc){ for (t2 in 1:sc){ v[j,coords,coords][t1,t2] <- v[j,coords,coords][t2,t1] <- colSums(wts*outer(as.matrix(xx[,t1]), colSums(wts*as.matrix(xx[,t1])),'-') *outer(as.matrix(xx[,t2]), colSums(wts*as.matrix(xx[,t2])),'-'))} } } var[[j]] = v[j,,] } } rownames(mu) <- paste("component",1:m) colnames(mu) <- paste("coordinate", 1:r) names(var) <- paste("component",1:m) ans <- list(n = n, m = m, r = r, B = B, blockid = object$blockid, means = mu, variances = var) class(ans)<-"summary.mvnpEM" ans } mixtools/R/plotly_mixturegram.R0000644000176200001440000002017614343046315016434 0ustar liggesusersplotly_mixturegram <- function( data, pmbs, method=c("pca","kpca","lda"), all.n=FALSE, id.con=NULL, score=1, iter.max=50, nstart=25, xlab = "K" , xlab.size = 15 , xtick.size = 15, ylab = NULL , ylab.size = 15 , ytick.size = 15, cex = 12 , col.dot = "red" , width = 1 , title = "Mixturegram" , title.size = 15 , title.x = 0.5 , title.y = 0.95 ){ vline <- function(x = 0, color = '#1f77b4') { list( type = "line", y0 = 0, y1 = 1, yref = "paper", x0 = x, x1 = x, line = list(color = '#1f77b4', dash = "dash", width = 1) ) } col.blind=rep(c("#000000", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#7FFF00","#7D26CD"),100) method <- match.arg(method) if(is.null(ylab)){ if (method == "pca"){ylab <- "PC Scores"} else if (method == "kpca"){ylab <- "Kernel PC Scores"} else if (method == "lda"){ylab <- "LDC Scores"} } k=length(pmbs)+1 if (is.null(id.con)) {id.con=lapply(pmbs,function(x) data%*%x/apply(x,2,sum))} ### Find ylim: lim ### ### Regular PCA ### if(method=="pca"){ x.star=c(list(data), lapply(1:(k-1), function(i) cbind(data,pmbs[[i]][,order(id.con[[i]])]))) Data=lapply(x.star,scale) if(score>(ncol(Data[[1]])+1)) { warning(paste("The largest value that can be specified for 'score' is ", ncol(Data[[1]])+1, ", which is what will be used for the mixturegram.",sep="")) } score<-min(score,ncol(x.star[[2]])) if(score==1){ PCA=lapply(Data,function(x) x%*%princomp(x)$loadings[,score]) } else{ PCA <- vector("list",k) PCA[[1]]=Data[[1]]%*%princomp(Data[[1]])$loadings[,1] PCA[2:k]=lapply(1:(k-1),function(i) Data[[(i+1)]]%*%princomp(Data[[(i+1)]])$loadings[,score]) } K=lapply(2:k,function(i) kmeans(PCA[[i]],i,iter.max=iter.max,nstart=nstart)) lim=ceiling(max(abs(unlist(PCA)))) mix.method <- PCA }else{ ### Kernel PCA ### if(method=="kpca"){ x.star=c(list(data), lapply(1:(k-1), function(i) cbind(data,pmbs[[i]][,order(id.con[[i]])]))) Data=lapply(x.star,scale) if(score>(ncol(Data[[1]])+1)) warning(paste("The largest value that can be specified for 'score' is ",ncol(Data[[1]])+1,", which is what will be used for the mixturegram.",sep="")) score<-min(score,ncol(x.star[[2]])) if(score==1){ kPCA=lapply(Data,function(x) cbind(pcv(kpca(x))[,1])) } else{ kPCA <- vector("list",k) kPCA[[1]]=cbind(pcv(kpca(Data[[1]]))[,1]) kPCA[2:k]=lapply(1:(k-1),function(i) cbind(pcv(kpca(Data[[i+1]]))[,score])) } K=lapply(2:k,function(i) kmeans(kPCA[[i]],i,iter.max=iter.max,nstart=nstart)) lim=max(abs(unlist(kPCA)))+0.1 mix.method <- kPCA } else if(method=="lda"){ class=lapply(pmbs, function(post) apply(post,1,which.max)) ldcdata = c(list(as.matrix(data) %*% ldc(data, rep(1,nrow(as.matrix(data))),score=score)), lapply(class, function(class) as.matrix(data) %*% ldc(data, class,score=score))) K=lapply(2:k,function(i) kmeans(ldcdata[[i]],i,iter.max=iter.max,nstart=nstart)) lim=ceiling(max(abs(unlist(ldcdata)))) mix.method <- ldcdata } } plot <- plot_ly()%>% plotly::layout( title = list(text = title, x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size), range = c(0.25,k+0.25), dtick = 1, tick0 = 1, tickmode = "linear" ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size), range = c(-lim, lim) ), shapes = lapply(1:k , function(i){vline(i)}) ) Kcol=function(x){ temp=unlist(sapply(1:length(x$size),function(i) rep(rank(x$center)[i],x$size[i]))) index=unlist(sapply(1:length(x$size),function(i) which(x$cluster==i))) K.col=replace(x$cluster,index,temp) } all.K.col=lapply(1:(k-1), function(i) Kcol(K[[i]])) K.col=all.K.col[[k-1]] n=length(K.col) K.centers=c(0, lapply(1:(k-1), function(i) sort(c(K[[i]]$centers)))) if (all.n){ for (i in 1:(k-1)){ for (j in 1:length(mix.method[[i]])){ plot <- plot%>% add_trace(x=c(i , i+1) , y=c(mix.method[[i]][j] , mix.method[[i+1]][j]) , type = 'scatter' , mode = 'lines', line = list(width = width , color = col.blind[K.col][j]), name = paste("Method" , i),showlegend = FALSE) } } for (q in 2:k){ plot <- plot%>% add_trace(x=rep(q,q), y=sort(c(K[[q-1]]$centers)) , type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.dot), name = paste("Cluster" , q), showlegend = FALSE) } plot <- plot%>% add_trace(x=1, y=mean(mix.method[[1]]) , type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.dot), name = "Cluster 1",showlegend = FALSE) } else{ ride.medians=sapply(1:k, function(i) unlist(by(c(mix.method[[i]]),col.blind[K.col],median))) prop.mad=sapply(1:k, function(i) unlist(by(c(mix.method[[i]]),col.blind[K.col],mad))) L1=ride.medians-prop.mad U1=ride.medians+prop.mad L2=ride.medians-2*prop.mad U2=ride.medians+2*prop.mad L3=ride.medians-3*prop.mad U3=ride.medians+3*prop.mad srt.colors=rownames(ride.medians) srt.colors1=adjustcolor(srt.colors, alpha.f = 0.7) srt.colors2=adjustcolor(srt.colors, alpha.f = 0.4) srt.colors3=adjustcolor(srt.colors, alpha.f = 0.2) for (l in 1:k){ plot <- plot%>% add_trace( x = c(1:k,k:1), y = c(L3[l,],rev(U3[l,])), type = 'scatter', mode = "lines", fill = 'tozeroy', ## fill type fillcolor = srt.colors3[l], hoveron = 'points+fills', line = list( color = srt.colors3[l] ), text = "Points + Fills", hoverinfo = 'text', showlegend = FALSE )%>% add_trace( x = c(1:k,k:1), y = c(L2[l,],rev(U2[l,])), type = 'scatter', mode = "lines", fill = 'tozeroy', ## fill type fillcolor = srt.colors2[l], hoveron = 'points+fills', line = list( color = srt.colors2[l] ), text = "Points + Fills", hoverinfo = 'text', showlegend = FALSE )%>% add_trace( x = c(1:k,k:1), y = c(L1[l,],rev(U1[l,])), type = 'scatter', mode = "lines", fill = 'tozeroy', ## fill type fillcolor = srt.colors1[l], hoveron = 'points+fills', line = list( color = srt.colors1[l] ), text = "Points + Fills", hoverinfo = 'text', showlegend = FALSE ) } # for (h in 1:(k-1)){ # plot <- plot%>% # add_trace(x=c(rep(h,k),rep((h+1),k)) , # y=c(ride.medians[,h] , ride.medians[,(h+1)]) , type = 'scatter' , mode = 'lines', # line = list(width = width , color = srt.colors), # showlegend = FALSE) # } for (j in 2:k){ plot <- plot%>% add_trace(x=rep(j,j), y=sort(c(K[[j-1]]$centers)) , type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.dot), name = paste("Cluster" , j),showlegend = FALSE) } plot <- plot%>% add_trace(x=1, y=mean(mix.method[[1]]) , type = 'scatter' , mode = 'markers', marker = list(size = cex , color = col.dot), name = "Cluster 1",showlegend = FALSE) } print(plot) props=c(1,sapply(1:length(K), function(i) K[[i]][[5]]/sum(unlist(K[[i]][5:6])))) print(list(stopping=props)) } mixtools/R/normalmixinit.R0000755000176200001440000000315414342153463015361 0ustar liggesusersnormalmix.init <- function (x, lambda = NULL, mu = NULL, s = NULL, k = 2, arbmean = TRUE, arbvar = TRUE){ if (!is.null(s)) { arbvar <- (length(s) > 1) if (arbvar) k <- length(s) } if (!is.null(mu)) { arbmean <- (length(mu) > 1) if (arbmean) { k <- length(mu) if (!is.null(s) && length(s) > 1 && k != length(s)) { stop("mu and sigma are each of length >1 but not of the same length.") } } } if (!arbmean && !arbvar) { stop("arbmean and arbvar cannot both be FALSE") } n = length(x) x = sort(x) x.bin = list() for (j in 1:k) { x.bin[[j]] <- x[max(1, floor((j - 1) * n/k)):ceiling(j * n/k)] } if (is.null(s)) { s.hyp = as.vector(sapply(x.bin, sd)) if (any(s.hyp == 0)) s.hyp[which(s.hyp == 0)] = runif(sum(s.hyp == 0), 0, sd(x)) if (arbvar) { s = 1/rexp(k, rate = s.hyp) } else { s = 1/rexp(1, rate = mean(s.hyp)) } } if (is.null(mu)) { mu.hyp <- as.vector(sapply(x.bin, mean)) if (arbmean) { mu = rnorm(k, mean = mu.hyp, sd = s) } else { mu = rnorm(1, mean = mean(mu.hyp), sd = mean(s)) } } if (is.null(lambda)) { cond = TRUE while(cond){ lambda = runif(k) lambda = lambda/sum(lambda) if(min(lambda)<0.05) cond=TRUE else cond=FALSE } } else { lambda <- rep(lambda, length.out = k) lambda <- lambda/sum(lambda) } list(lambda = lambda, mu = mu, s = s, k = k, arbvar = arbvar, arbmean = arbmean) } mixtools/R/logisregmixEM.R0000755000176200001440000000772014342153463015245 0ustar liggesuserslogisregmixEM=function (y, x, N = NULL, lambda = NULL, beta = NULL, k = 2, addintercept = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) { if (addintercept) { x = cbind(1, x) } else x = as.matrix(x) n <- length(y) p <- ncol(x) if (is.null(N)) { N = rep(1, n) } tmp <- logisregmix.init(y = y, x = x, N = N, lambda = lambda, beta = beta, k = k) lambda <- tmp$lambda beta <- tmp$beta k <- tmp$k xbeta <- x %*% beta z <- matrix(0, n, k) diff <- 1 iter <- 0 comp <- t(t(dbinom(y, size = N, prob = inv.logit(xbeta))) * lambda) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik restarts <- 0 while (diff > epsilon && iter < maxit) { j.star = apply(xbeta, 1, which.max) for (i in 1:n) { for (j in 1:k) { z[i, j] = lambda[j]/lambda[j.star[i]] * (inv.logit(xbeta[i, j])/inv.logit(xbeta[i, j.star[i]]))^y[i] * ((1 - inv.logit(xbeta[i, j]))/(1 - inv.logit(xbeta[i, j.star[i]])))^(N[i] - y[i]) } } z = z/apply(z, 1, sum) z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) if (sum(is.na(z)) > 0) { cat("Need new starting values due to underflow...", "\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- logisregmix.init(y = y, x = x, N = N, k = k) lambda <- tmp$lambda beta <- tmp$beta k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta comp <- t(t(dbinom(y, size = N, prob = inv.logit(xbeta))) * lambda) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik } else { lambda <- apply(z, 2, mean) lm.out = lapply(1:k, function(j) try(glm.fit(x, cbind(y, N - y), weights = z[, j], family = binomial()), silent = TRUE)) beta = sapply(lm.out, coef) xbeta <- x %*% beta comp <- t(t(dbinom(y, size = N, prob = inv.logit(xbeta))) * lambda) compsum <- apply(comp, 1, sum) newobsloglik <- sum(log(compsum)) if (abs(newobsloglik) == Inf || is.na(newobsloglik) || newobsloglik < obsloglik){# || sum(z) != n) { cat("Need new starting values due to singularity...", "\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- logisregmix.init(y = y, x = x, N = N, k = k) lambda <- tmp$lambda beta <- tmp$beta k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta comp <- t(t(dbinom(y, size = N, prob = inv.logit(xbeta))) * lambda) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik } else { diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n") } } } } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } beta <- matrix(beta,ncol=k) rownames(beta) <- c(paste("beta", ".", 0:(p - 1), sep = "")) colnames(beta) <- c(paste("comp", ".", 1:k, sep = "")) colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) cat("number of iterations=", iter, "\n") a = list(x = x, y = y, lambda = lambda, beta = beta, loglik = obsloglik, posterior = z, all.loglik = ll, restarts=restarts, ft = "logisregmixEM") class(a) = "mixEM" a } mixtools/R/ise.npEM.R0000755000176200001440000000260014342153463014100 0ustar liggesusersise.npEM <- function(npEMout, component=1, block=1, truepdf, lower=-Inf, upper=Inf, plots = TRUE, ...){ # returns the Integrated Squared Error # between f_{comp,block} as estimated by npEM, # and truepdf #true2 <- function(u) truepdf(u, ...) coords <- npEMout$blockid == block bs <- sum(coords) # block size xx <- as.vector(npEMout$data[,coords]) # flatten data wts <- rep(npEMout$post[,component],bs) # duplicate weights if (is.matrix(npEMout$bandwidth)){ bw <- npEMout$bandwidth[block,component] } else bw <- npEMout$bandwidth integrand = function(u,...) { (wkde(xx,u,wts,bw) - truepdf(u,...))^2 } numint <- integrate(integrand,lower,upper, ...) if (plots) { # plot of estimated and truepdf ise <- paste(round(numint$value,4)) temp=paste(component, block, sep="") title = substitute(expression(paste("Integrated Squared Error for ", f[temp]," = ",ise,sep=""))) if (!is.finite(lower)) { lower <- min(xx) } if (!is.finite(upper)) { upper <- max(xx) } u <- seq(lower,upper, 0.01) fhat <- wkde(xx,u,wts,bw) ymax <- max(max(truepdf(u, ...)),max(fhat)) plot(u,fhat,type="l",ylim=c(0,ymax), main=eval(title),ylab="") legend("topleft",legend=c("true","fitted"),col=c(2,1),lty=c(1,1),lwd=c(2,1)) lines(u,truepdf(u, ...),lwd=2,col=2) } numint } mixtools/R/postbeta.R0000755000176200001440000000347614342153463014317 0ustar liggesuserspost.beta <- function(y, x, p.beta, p.z) { N = length(y) k = ncol(p.z) g = apply(p.z, 1, function(i) (1:length(i))[i == max(i)]) min.int=min(sapply(1:N, function(i) min(p.beta[[i]][1,]))) max.int=max(sapply(1:N, function(i) max(p.beta[[i]][1,]))) min.slp=min(sapply(1:N, function(i) min(p.beta[[i]][2,]))) max.slp=max(sapply(1:N, function(i) max(p.beta[[i]][2,]))) par(mfrow=c(2,2)) #All posterior regression lines. plot(c(min(sapply(x,min)),max(sapply(x,max))),c(min(sapply(y,min)),max(sapply(y,max))),type="n",xlab="x-values",ylab="y-values",main="Data and Posterior Regression Lines") sapply(1:length(x),function(i) points(x[[i]], y[[i]])) for(j in 1:k){ sapply(1:length(p.beta), function(i) abline(coef=p.beta[[i]][,j], col=(j+1))) } #Posterior regression lines chosen according to the membership probabilities. plot(c(min(sapply(x,min)),max(sapply(x,max))),c(min(sapply(y,min)),max(sapply(y,max))),type="n",xlab="x-values",ylab="y-values",main="Data and Most Probable Posterior Regression Lines") sapply(1:length(x),function(i) points(x[[i]], y[[i]])) sapply(1:length(p.beta), function(i) abline(coef=p.beta[[i]][,g[i]], col=(g[i]+1))) #All posterior beta values. plot(c(min.int,max.int),c(min.slp,max.slp),type="n",xlab="Posterior Intercepts",ylab="Posterior Slopes",main="All Posterior Regression Coefficients") for(j in 1:k){ sapply(1:length(p.beta), function(i) points(t(p.beta[[i]][,j]), col=(j+1))) } #Posterior beta values chosen according to the membership probabilities. min.max=c(min(sapply(p.beta,min)),max(sapply(p.beta,max))) plot(c(min.int,max.int),c(min.slp,max.slp),type="n",xlab="Posterior Intercepts",ylab="Posterior Slopes",main="Most Probable Posterior Regression Coefficients") sapply(1:length(p.beta), function(i) points(t(p.beta[[i]][,g[i]]), col=(g[i]+1))) } mixtools/R/regmix.init.R0000755000176200001440000000406714342153463014730 0ustar liggesusersregmix.init<-function (y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar = TRUE) { x <- as.matrix(x) n <- length(y) p <- ncol(x) if (addintercept) { x = x[, -1] } else x = x if (is.null(lambda)) { lambda = runif(k) lambda = lambda/sum(lambda) } else k = length(lambda) A = round(lambda * n) while(min(A)<4){ lambda = runif(k) lambda = lambda/sum(lambda) A = round(lambda * n) } A[k] = n - sum(A[1:(k - 1)]) B = c(0, cumsum(A)) w = cbind(y, x) w = w[order(w[, 1]), ] w.bin = list() for (j in 1:k) { w.bin[[j]] <- w[(B[j] + 1):B[j + 1], ] } if (addintercept) { lm.out <- lapply(1:k, function(i) lm(w.bin[[i]][, 1] ~ w.bin[[i]][, 2:p])) } else lm.out <- lapply(1:k, function(i) lm(w.bin[[i]][, 1] ~ w.bin[[i]][, 2:(p + 1)] - 1)) s.hyp = lapply(lm.out, anova) s.hyp = as.vector(sqrt(sapply(1:k, function(i) s.hyp[[i]]$Mean[length(s.hyp[[i]]$Mean)]))) s.hyp[(s.hyp<=0)|(is.na(s.hyp)==1)]=1 if (is.null(s)) { if (arbvar) { s = 1/rexp(k, rate = s.hyp) } else { s.hyp = mean(s.hyp) s = 1/rexp(1, rate = s.hyp) } } if (is.null(s) == FALSE && arbvar == TRUE) { k = length(s) } if (is.null(beta)) { x.x <- solve(t(x)%*%x) beta.hyp = matrix(sapply(lm.out, coef), ncol = k) beta = matrix(0, nrow = p, ncol = k) for (j in 1:k) { beta[, j] = rnorm(p, mean = as.vector(beta.hyp[, # j]), sd = (s[arbvar * j + (1 - arbvar)]*sqrt(diag(x.x))) ) j]), sd = (s.hyp[arbvar * j + (1 - arbvar)]*sqrt(diag(x.x))) ) } if (arbmean == FALSE) { beta = apply(beta, 1, mean) } } if (is.null(beta) == FALSE && arbmean == TRUE) { k = ncol(beta) } list(lambda = lambda, beta = beta, s = s, k = k) }mixtools/R/kernO.R0000755000176200001440000000010714342153463013540 0ustar liggesuserskern.O <- function (x, xi, h) { (pi/4)*cos(.5*pi*(xi-x)/h)/h } mixtools/R/ldc.R0000644000176200001440000000175414342153463013232 0ustar liggesusersldc <- function(data,class,score){ data = as.matrix(data) K = length(unique(class)) # The number of classes (expect the classes to be labeled 1, 2, 3, ..., K-1, K N = dim(data)[1] # The number of samples p = dim(data)[2] # The number of features # Compute the class dependent probabilities and class dependent centroids: Pi = c(table(class))/N M = aggregate(data,list(class),mean)[,-1] # Compute W: W = cov(data) # Compute M* = M W^{-1/2} using the eigen-decomposition of W : e = eigen(W) V = e$vectors W_Minus_One_Half = V %*% diag( 1/sqrt(e$values),nrow=p ) %*% t(V) MStar = as.matrix(M) %*% W_Minus_One_Half # Compute B* the covariance matrix of M* and its eigen-decomposition: if(p>1 & length(Pi)>1){ BStar = cov(MStar) e = eigen(BStar) VStar = e$vectors # 1st linear discriminant coordinate ldc1 = W_Minus_One_Half %*% VStar[,score] } else if(p==1){ ldc1 = c(W_Minus_One_Half) } else ldc1 = W_Minus_One_Half[,score] return(ldc1) } mixtools/R/augx.R0000755000176200001440000000110114342153463013421 0ustar liggesusersaug.x <- function(X,cp.locs,cp,delta = NULL){ X=as.matrix(X) if(is.null(delta)) delta=cp.locs if(length(cp.locs)!=length(delta) | length(cp.locs)!=sum(cp)){ stop(paste("You must specify a correct changepoint structure!", "\n")) } if(sum(cp)==0){ X } else{ new.x=NULL sum.cp=cumsum(cp) for(i in 1:length(cp)){ X.i=matrix(X[,i],ncol=max(1,cp[i]),nrow=length(X[,1])) if(cp[i]!=0){ CPs=cp.locs[(max(1,sum.cp[i-1]+1)):sum.cp[i]] SPs=delta[(max(1,sum.cp[i-1]+1)):sum.cp[i]] new.x=cbind(new.x,t(t(X.i)-SPs)*t(t(X.i)>CPs)) } } cbind(X,new.x) } } mixtools/R/repnormmixmodelsel.R0000755000176200001440000000274314342153463016417 0ustar liggesusersrepnormmixmodel.sel <- function (x, k = 2, ...) { aic <- NULL bic <- NULL caic <- NULL icl <- NULL AIC <- function(emout) { emout$loglik - (length(emout$mu) + length(emout$stdev) + length(emout$lambda) - 1) } BIC <- function(emout) { emout$loglik - log(nrow(x)) * (length(emout$mu) + length(emout$stdev) + length(emout$lambda) - 1)/2 } CAIC <- function(emout) { emout$loglik - (log(nrow(x)) + 1) * (length(emout$mu) + length(emout$stdev) + length(emout$lambda) - 1)/2 } ICL <- function(emout) { BIC(emout) - sum(emout$lambda * log(emout$lambda)) } for (i in 1:k) { if (i == 1) { avx <- as.vector(x) mu <- mean(avx) s <- sd(avx) loglik <- sum(dnorm(avx, mean=mu, sd=s, log=TRUE)) emout <- list(mu=mu, stdev=s, lambda=1, loglik=loglik) } else emout <- repnormmixEM(x, k = i, ...) aic[i] <- AIC(emout) bic[i] <- BIC(emout) caic[i] <- CAIC(emout) icl[i] <- ICL(emout) } out = rbind(aic, bic, caic, icl) Winner = apply(out, 1, function(x) (1:length(x))[x == max(x)]) rownames(out) = c("AIC", "BIC", "CAIC", "ICL") colnames(out) = 1:k cbind(out, Winner) } mixtools/R/regmixEM.R0000755000176200001440000001432714342153463014210 0ustar liggesusersregmixEM = function (y, x, lambda = NULL, beta = NULL, sigma = NULL, k = 2, addintercept = TRUE, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) { if(arbmean == FALSE && arbvar == FALSE){ stop(paste("Must change constraints on beta and/or sigma!","\n")) } s = sigma if (addintercept) { x = cbind(1, x) } n <- length(y) p <- ncol(x) tmp <- regmix.init(y = y, x = x, lambda = lambda, beta = beta, s = s, k = k, addintercept = addintercept, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda beta <- tmp$beta s <- tmp$s k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta res <- (y - xbeta)^2 if(arbmean == FALSE){ res <- sapply(1:k,function(i) res) } # comp <- lapply(1:k, function(i) lambda[i] * dnorm(y, xbeta[,i * arbmean + (1 - arbmean)], # s[i * arbvar + (1 - arbvar)])) # comp <- sapply(comp, cbind) # compsum <- apply(comp, 1, sum) # obsloglik <- sum(log(compsum)) comp <- t((lambda/sqrt(2 * pi * s^2)) * t(exp(-t(t(res)/(2 * s^2))))) obsloglik <- sum(log(apply(comp, 1, sum))) ll <- obsloglik z = matrix(nrow = n, ncol = k) restarts <- 0 while (diff > epsilon && iter < maxit) { for (i in 1:n) { for (j in 1:k) { z.denom = c() for (h in 1:k) { z.denom = c(z.denom, (lambda[h]/lambda[j]) * (s[j * arbvar + (1 - arbvar)]/s[h * arbvar + (1 - arbvar)]) * exp(-0.5 * ((1/s[h * arbvar + (1 - arbvar)]^2) * res[i, h] - (1/s[j * arbvar + (1 - arbvar)]^2) * res[i, j]))) } z[i, j] = 1/sum(z.denom) } } # z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) z = z/apply(z,1,sum) lambda.new <- apply(z, 2, mean) if (sum(lambda.new < 1e-08)>0 || is.na(sum(lambda.new))) { sing <- 1 } else { if (arbmean == FALSE) { if (addintercept) { beta.new <- lm(y~x[,-1],weights=apply(t(t(z)/(s^2)),1,sum))$coef } else beta.new <- lm(y~x-1,weights=apply(t(t(z)/(s^2)),1,sum))$coef # beta.new <- sapply(lm.out, coef) # beta.new1 <- apply(t(apply(z,2,sum)*t(beta.new)),1,sum)/n # beta.new2 <- lm(y~x[,-1],weights=apply(t(t(z)/(s^2)),1,sum))$coef # beta.new<-as.vector(solve(t(x) %*% sweep(x, 1, t(t(z)/(s^2)), "*")) %*% apply(t(t(z)/(s^2))*y*x,2,sum) ) } else { if (addintercept) { lm.out <- lapply(1:k, function(i) lm(y ~ x[, -1], weights = z[, i])) } else lm.out <- lapply(1:k, function(i) lm(y ~ x - 1, weights = z[, i])) beta.new <- sapply(lm.out, coef) } xbeta.new <- x %*% beta.new res <- (y - xbeta.new)^2 if(arbmean == FALSE){ res <- sapply(1:k,function(i) res) } if (arbvar) { s.new <- sqrt(sapply(1:k, function(i) sum(z[, i] * (res[, i]))/sum(z[, i]))) } else s.new <- sqrt(sum(z * res)/n) lambda <- lambda.new beta <- beta.new xbeta <- x%*%beta s <- s.new sing <- sum(s < 1e-08) comp <- lapply(1:k, function(i) lambda[i] * dnorm(y, xbeta[,i * arbmean + (1 - arbmean)], s[i * arbvar + (1 - arbvar)])) comp <- sapply(comp, cbind) compsum <- apply(comp, 1, sum) newobsloglik <- sum(log(compsum)) # comp <- t((lambda/sqrt(2 * pi * s^2)) * t(exp(-t(t(res)/(2 * # s^2))))) # newobsloglik <- sum(log(apply(comp, 1, sum))) } if (sing > 0 || is.na(newobsloglik) || newobsloglik < obsloglik || abs(newobsloglik) == Inf){# || sum(z) != n) { cat("Need new starting values due to singularity...", "\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- regmix.init(y = y, x = x, k = k, addintercept = addintercept, arbmean = arbmean, arbvar = arbvar) lambda <- tmp$lambda beta <- tmp$beta s <- tmp$s k <- tmp$k diff <- 1 iter <- 0 xbeta <- x %*% beta res <- (y - xbeta)^2 if(arbmean == FALSE){ res <- sapply(1:k,function(i) res) } # comp <- lapply(1:k, function(i) lambda[i] * dnorm(y, xbeta[,i * arbmean + (1 - arbmean)], # s[i * arbvar + (1 - arbvar)])) # comp <- sapply(comp, cbind) # compsum <- apply(comp, 1, sum) # obsloglik <- sum(log(compsum)) comp <- t((lambda/sqrt(2 * pi * s^2)) * t(exp(-t(t(res)/(2 * s^2))))) obsloglik <- sum(log(apply(comp, 1, sum))) ll <- obsloglik } else { diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n") } } } scale.order = order(s) sigma.min = min(s) if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } cat("number of iterations=", iter, "\n") if(arbmean == FALSE){ z=z[,scale.order] names(beta) <- c(paste("beta", ".", 0:(p-1), sep = "")) colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, y=y, lambda = lambda[scale.order], beta = beta, sigma = sigma.min, scale = s[scale.order]/sigma.min, loglik = obsloglik, posterior = z[,scale.order], all.loglik=ll, restarts = restarts, ft="regmixEM") class(a) = "mixEM" a } else { rownames(beta) <- c(paste("beta", ".", 0:(p-1), sep = "")) colnames(beta) <- c(paste("comp", ".", 1:k, sep = "")) colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, y=y, lambda = lambda, beta = beta, sigma = s, loglik = obsloglik, posterior = z, all.loglik=ll, restarts = restarts, ft="regmixEM") class(a) = "mixEM" a } }mixtools/R/flaremixEM.R0000755000176200001440000000101514342153463014512 0ustar liggesusersflaremixEM<-function(y, x, lambda = NULL, beta = NULL, sigma = NULL, alpha = NULL, nu=NULL, epsilon = 1e-04, maxit = 10000, verb = FALSE, restart=50){ j=1 while(j<=length(nu)){ temp=try(try.flare(y=y, x=x, lambda = lambda, beta = beta, sigma = sigma, alpha = alpha, nu=nu[j], epsilon = epsilon, maxit = maxit, verb = verb, restart=restart),silent=TRUE) if(any(class(temp)=="try-error")) j=j+1 else j=2^100 } if(j==(length(nu)+1)) stop(paste("Too many attempts. Select a different barrier constant.","\n")) temp } mixtools/R/segregmixinit.R0000755000176200001440000000606214342153463015346 0ustar liggesuserssegregmix.init <- function (y, x, lambda = NULL, beta = NULL, s = NULL, k = 2, seg.Z, psi, psi.locs = NULL) { n <- length(y) p <- ncol(x) psi.counts <- apply(psi>0,1,sum) if(is.null(lambda)|is.null(beta)|is.null(s)|is.null(psi.locs)){ if (is.null(psi.locs)) { psi.locs = vector("list",k) psi.locs = lapply(1:k, function(i) if(psi.counts[i]>0) vector("list",psi.counts[i]) else NULL) for(i in 1:k){ if(!is.null(psi.locs[[i]])){ temp.locs <- which(psi[i,]>0) temp.labs=NULL for(j in 1:length(temp.locs)){ psi.locs[[i]][[j]]=sort(runif(psi[i,temp.locs[j]],as.numeric(quantile(x[,temp.locs[j]],.05)),as.numeric(quantile(x[,temp.locs[j]],.95)))) temp.labs=c(temp.labs,colnames(x)[temp.locs[j]]) } names(psi.locs[[i]])=temp.labs } } } else k = length(psi.locs) xnam <- colnames(x) fmla <- as.formula(paste("y ~ ", paste(xnam, collapse= "+"))) TEMP.lm <- lm(fmla,data=x) EM.out <- regmixEM(TEMP.lm$res,TEMP.lm$fit,k=k,epsilon=1e-2) posts = apply(EM.out$post,1,which.max) if (is.null(lambda)) { lambda = EM.out$lambda if(length(unique(posts))!=k) posts=rep(1:k,n)[1:n] } else k = length(lambda) A = round(lambda * n) while (min(A) <= 4) { lambda = runif(k) lambda = lambda/sum(lambda) A = round(lambda * n) } w = cbind(y, x) w.bin = list() for (j in 1:k) { w.bin[[j]] <- w[posts==j, ] } all.w.bin=vector("list",gamma(k+1)) all.inds=perm(k,k) all.X.aug=all.w.bin all.lm.out=all.w.bin avg.res=NULL for(j in 1:length(all.w.bin)){ all.w.bin[[j]]=w.bin[all.inds[j,]] X.aug <- lapply(1:k, function(i) cbind(1,aug.x(w.bin[[all.inds[j,i]]][,-1],unlist(psi.locs[[i]]),psi[i,],delta=NULL))) sapply(X.aug,dim) lm.out <- lapply(1:k, function(i) lm(w.bin[[all.inds[j,i]]][, 1] ~ X.aug[[i]][,-1])) all.X.aug[[j]]=X.aug all.lm.out[[j]]=lm.out avg.res=c(avg.res,mean(as.vector(unlist(lapply(1:k,function(t) lm.out[[t]]$res)))^2)) } IND=which.min(avg.res) w.bin=all.w.bin[[IND]] X.aug=all.X.aug[[IND]] lm.out=all.lm.out[[IND]] s.hyp = lapply(lm.out, anova) s.hyp = as.vector(sqrt(sapply(1:k, function(i) tail(s.hyp[[i]]$Mean,1)))) s.hyp[(s.hyp <= 0) | (is.na(s.hyp) == 1)] = 1 if (is.null(s)) { s = 1/rexp(k, rate = s.hyp) } else k = length(s) if (is.null(beta)) { x.x <- lapply(1:k,function(i) try(solve(t(X.aug[[i]]) %*% X.aug[[i]]),silent=TRUE)) test <- sum(sapply(1:k, function(i) class(x.x[[i]])[1]=="try-error")) if(test>0) stop("Lapack Routine Error") beta.hyp = lapply(lm.out,coef) # matrix(sapply(lm.out, coef), ncol = k) beta = vector("list",k) for (j in 1:k) { beta[[j]] = rnorm(length(beta.hyp[[j]]),mean=as.vector(beta.hyp[[j]]), sd = (s.hyp[j] * sqrt(diag(x.x[[j]])))) } } else k = length(beta) } else{ for(i in 1:k){ if(!is.null(psi.locs[[i]])){ temp.locs <- which(psi[i,]>0) temp.labs=NULL for(j in 1:length(temp.locs)){ temp.labs=c(temp.labs,colnames(x)[temp.locs[j]]) } names(psi.locs[[i]])=temp.labs } } } list(lambda = lambda, beta = beta, s = s, k = k, psi.locs = psi.locs) } mixtools/R/spRMMSEM.R0000644000176200001440000003447614342153463014042 0ustar liggesusers########################################################### # semi-parametric Reliability Mixture Models with Censored data # for 2 components # D. Chauveau # ref: Bordes L. and Chauveau D. Computational Statistics (2016) ########################################################### # Simulate from a lognormal scale mixture # like model (3) in compstat paper # lambda = vector of component probabilities # xi = scaling parameter rlnormscalemix <- function(n, lambda=1, meanlog=1, sdlog=1, scale=0.1) { m <- length(lambda) # nb of components z <- sample(m, n, replace = TRUE, prob = lambda) # component indicator x <- rlnorm(n, meanlog, sdlog) x[z==2] <- x[z==2]/scale x } ############################################## # Kaplan-Meier survival estimate # vectorized version ONLY on ** already ordered data ** # cpd = (n,2) matrix where # cpd[,1] = t = ORDERED censored life data = min(x,c) # cpd[,2] = d = censoring indicator, 1=observed 0=censored # returned value = a step function object allowing to evaluate S() # at any point, needed by SEM for computing S(xi*t_i)'s KMod <- function(cpd, already.ordered=TRUE){ # order stat of t and d ordered accordingly if (already.ordered) { n <- dim(cpd)[1] s <- cumprod(1 - cpd[,2]/(n - (1:n) +1)) stepfun(cpd[,1], c(1,s))} # starts with 1 for t<=t(1) } ############################################## ## KM estimate integration # s = a stepfun object as returned by KMod() # returned value = int_0^max(t_i) S(u)du KMintegrate <- function(s) { ks <- knots(s) n <- length(ks) # number of knots=data points ks2 <- c(0,ks[1:(n-1)]) # shifted right hs <- c(1,s(ks)[1:(n-1)]) # heights of survival sum((ks-ks2)*hs) } ################################################ ### HAZARD RATE SMOOTH KERNEL ESTIMATES ### ################################################ # WKDE with Triangular Kernel and global bandwidth, vectorized # returns vector of K_h(t_i-u_j), j=1,...,length(u) # t = vector of data # u = vector of points at which K(u) is computed # w = weights defaults to 1/n, not forced to be normalized # bw=bandwidth, can be a n-vector or a scalar # nb: this is not specific for hazard rate, just a wkde # NB: triang_wkde is the default wkde called by HRkde() for hazard rate triang_wkde <- function(t, u=t, w=rep(1/length(t),length(t)), bw=rep(bw.nrd0(t),length(t))) { n <- length(t); p <- length(u) xx <- outer(t, u, function(a,b) a-b) # K[i,j] = (t_i-u_j) xx <- abs(xx) # not necessarily for all kernels, separated from outer h <- matrix(bw,n,p) # bw repeated over p columns # works also if a scalar bw is passed! xx <- xx/h # now xx is |t_i-u_j|/h_i K <- (xx <= 1)*(1-xx)/bw # K((t-u)/h)/h mw <- matrix(w, nrow=1) # weights for matrix product as.vector(mw %*% K) } ## Hazard Rate kernel density estimate based on *ordered* censored data # weighted kernel density estimate passed as function argument, # defaults to symmetric triangle kernel # cpd = (n,2) matrix where # cpd[,1] = t = ORDERED censored life data = min(x,c) # cpd[,2] = d = censoring indicator, 1=observed 0=censored # u = vector of points at which alpha() is evaluated, # defaults to t itself # bw = bandwidth *vector* for the kernel density estimate # kernelft = kernel definition # return value = alpha(.) evaluated at u_j's # NB: ordered data are necessary from weights definitions # (n-i+1) items at risk etc HRkde <- function(cpd, u = cpd[,1], kernelft = triang_wkde, bw = rep(bw.nrd0(as.vector(cpd[,1])), length(cpd[,1]))){ # gaussian case (not recommended) # if (kernelft==gaussian) HRkdeGauss(cpd,u,bw) else { n <- length(cpd[,1]) aw <- cpd[,2]/(n - (1:n) +1) # weights d(i)/(n-i+1) kernelft(cpd[,1], u, w=aw, bw=bw) # old, non vectorized version (deprecated) # nu <- length(u) # hr <- rep(0,nu) # for (k in 1:nu) { # K <- kernelft(cpd[,1], u[k], bw) # hr[k] <- sum(K*aw) # } # } # hr } ################################################################# ################################################################# ## Stochastic EM algorithm for semiparametric Scaling ## Reliability Mixture Models (RMM) with Censoring, 2 components # t = lifetime data, censored by random c if d is not NULL, in which case # t = min(x,c) and d = I(x <= c) # rate = scaling parameter # centers = initial centers for initial call to kmeans # averaged = TRUE if averaging performed at each iteration (cf Nielsen 2000) # NB: averaging can be done in (at least) 2 ways; # here the current theta for E & M steps is the average over the sequence, # but the theta^next not averaged is stored on the sequence # batchsize = number of last iterations to use for "averaging" unscaled samples # for computing "average" final KM and HR estimates # alpha() and S() # kernelft = kernel used in HRkde for hazard rate nonparametric estimate # # NB: since the sequence of parameters is a stoch. process, the # stopping criterion is usually not satisfied until maxit spRMM_SEM <- function (t, d = NULL, lambda = NULL, scaling = NULL, centers = 2, kernelft = triang_wkde, bw = rep(bw.nrd0(t),length(t)), averaged = TRUE, epsilon = 1e-08, maxit = 100, batchsize = 1, verb = FALSE) { k = 2 # fixed number of components for this model identifiability n <- length(t) if (is.null(d)) { d <- rep(1,n) # but better use specific algo for noncensored data cat("warning: undefined censoring indicator d replaced by 1's") cat(" i.e. all data are assumed observed") cat(" better use instead a specific St-EM algorithm for uncensored data") } ##### Initializations ##### # init function call to do later, in case lambda = scaling = NULL if (is.null(lambda)) lambda <- rep(1/k,k) # not USED for init!? if (is.null(scaling)) scaling <- 1/2 # ToDo better init using centers fro kmeans! # sequences for storing along iterations lambda_seq <- matrix(0, nrow = maxit, ncol = k) lambda_seq[1,] <- lambda scaling_seq <- rep(0,maxit) scaling_seq[1] <- scaling sumNaNs <- 0 # for total nb of NaN's in iterations while computing post # dll <- epsilon+1 # not applicable for SEM versions, always run maxit post <- z <- sumpost <- posthat <- matrix(0, nrow = n, ncol = k) qt=round(maxit/10); pc <- 0 # for printing of % of iteration done if (qt == 0) qt <- 1 # initialization for batch storing if (batchsize > maxit) batchsize <- maxit batch_t <- NULL # for storing batchsize last unscaled samples batch_d <- NULL # and associated event indicators # kmeans method for initial posterior and z matrix kmeans <- kmeans(t, centers=centers) for(j in 1:k) { z[kmeans$cluster==j, j] <- 1 } # init values for Survival s() and hazard rate a() # strategy: use a M-step with z from kmeans result zt <- z*t # recycling t m times => zt[i,] holds zt[,2] <- scaling*zt[,2] # t if comp 1 and xi*t if comp 2 newt <- rowSums(zt) # redressed "unscaled" sample newo <- order(newt) new.od <- cbind(newt,d)[newo,] # ordered data with associated d s <- KMod(new.od) # stepfun object, can be evaluated by s(t) # note: <=> to use KMsurvfit(newt,d) which calls survival package functions a1 <- HRkde(new.od, t, kernelft, bw=bw) # evaluated at the original t's a2 <- HRkde(new.od, scaling*t, kernelft, bw=bw) # and at scaling*t's ####### SEM iterations ####### iter <- 1 # while (dll > epsilon && iter < maxit) { # EM-only version while (iter < maxit) { ### E-step post[,1] <- ((lambda[1]*a1*s(t))^(d))*((lambda[1]*s(t))^(1-d)) post[,2] <- (lambda[2]*scaling*a2*s(scaling*t))^d # observed post[,2] <- post[,2]*(lambda[2]*s(scaling*t))^(1-d) # censored # print(post) rs <- rowSums(post) # post normalized per row post <- sweep(post, 1, rs, "/") # posteriors p_{ij}^t 's # check and solve NaN's: may cause theoretical pbs!? snans <- sum(is.na(post)) if (snans > 0) { post[is.na(post[,1]),] <- 1/k # NaN's replaced by uniform weights sumNaNs <- sumNaNs + snans if (verb) cat(snans, "NaN's in post: ") } sumpost <- sumpost + post ### S-step # ~ matrix of component indicators simu checked OK z <- t(apply(post, 1, function(prob) rmultinom(1, 1, prob))) # cbind(post,z) # checking simulation zt <- z*t # each row of z is 0,1 hence zt holds {0,t} nsets <- colSums(z) # subsets per component sizes ### M-step for scalar parameters newlambda <- nsets/n # or colMeans(post) if EM strategy preferred! lambda_seq[iter+1, ] <- newlambda # update of the scaling (xi) parameter needs building of KM estimates # from each subsample, and integration of both # ToDo: use parallel on 2 cores to perform each subsample task! tsub1 <- t[z[,1]==1]; tsub2 <- t[z[,2]==1] # t subsamples dsub1 <- d[z[,1]==1]; dsub2 <- d[z[,2]==1] # d subsamples o1 <- order(tsub1); od1 <- cbind(tsub1,dsub1)[o1,] o2 <- order(tsub2); od2 <- cbind(tsub2,dsub2)[o2,] km1 <- KMod(od1); km2 <- KMod(od2) newscaling <- KMintegrate(km1)/KMintegrate(km2) scaling_seq[iter+1] <- newscaling # stored for final plotting if (averaged) { scaling <- mean(scaling_seq[1:(iter+1)]) lambda <- colMeans(lambda_seq[1:(iter+1),]) } else { # averaged=FALSE case, just use last update scaling <- newscaling lambda <- newlambda } ### M-step for nonparametric alpha() and s(): # unscaling the sample and order it, # keeping the associated d censoring indicator zt[,2] <- scaling*zt[,2] # unscale t's from component 2 newt <- rowSums(zt) # "unscaled" sample (sum 0 and t_i or scale*t_i ) newo <- order(newt) new.od <- cbind(newt,d)[newo,] # with associated (unchanged) d s <- KMod(new.od) # stepfun object, can be evaluated by s(t) a1 <- HRkde(new.od, t, kernelft, bw=bw) # evaluated at the original t's a2 <- HRkde(new.od, scaling*t, kernelft, bw=bw) # and at scaling*t's ### batch storage: collecting unscaled samples if (iter >= (maxit - batchsize)) { batch_t <- c(batch_t, newt) batch_d <- c(batch_d, d) cat("-- adding unscaled sample at iteration",iter,"\n") } # change <- c(lambda_seq[iter,] - lambda_seq[iter-1,], # scaling_seq[iter]- scaling_seq[iter-1]) # dll <- max(abs(change)) if (verb) { cat("iteration", iter, ": sizes=", nsets," ") cat("lambda_1=",lambda[1], "scaling=",scaling, "\n") } # printing % done b=round(iter/qt); r=iter-b*qt if (r==0) {pc <- pc+10; cat(pc,"% done\n")} iter <- iter + 1 } ###### end of SEM loops over iterations ###### colnames(post) <- colnames(posthat) <- c(paste("comp", ".", 1:k, sep = "")) lambdahat <- colMeans(lambda_seq[1:iter,]) scalinghat <- mean(scaling_seq[1:iter]) posthat <- sumpost/(iter-1) # average posteriors hazard <- HRkde(new.od, kernelft=kernelft, bw=bw) # at final unscaled sample # Would it be better to return the final unscaled sample?? cat(iter, "iterations: lambda=",lambdahat,", scaling=",scalinghat,"\n") if (sumNaNs > 0) cat("warning: ", sumNaNs,"NaN's occured in posterior computations") ###### FINISHING ###### # ToDo: average over batch set of last unscaled samples # compute average estimates via a S+M-step using posthat etc loglik <- sum(log(rs)) # "sort of" loglik with nonparam densities estimated # mimmics the parametric case, just like npEM does z <- t(apply(posthat, 1, function(prob) rmultinom(1, 1, prob))) zt <- z*t zt[,2] <- scalinghat*zt[,2] avgt <- rowSums(zt) # unscaled sample avgo <- order(avgt) avg.od <- cbind(avgt,d)[avgo,] # with associated d shat <- KMod(avg.od) # stepfun object ahat <- HRkde(avg.od, kernelft=kernelft, bw=bw) # eval at the unscaled ordered avgt a=list(t=t, d=d, lambda=lambdahat, scaling=scalinghat, posterior=post, # final posterior probabilities all.lambda=lambda_seq[1:iter,], # sequence of lambda's all.scaling=scaling_seq[1:iter], # sequence of scale loglik=loglik, # analog to parametric loglik, like npEM meanpost=posthat, # posterior proba averaged over iterations survival=s, # Kaplan-Meier last iter estimate (stepfun object) hazard=hazard, # hazard rate final estimate evaluated at final.t final.t=new.od[,1], # last unscaled sample s.hat=shat, # Kaplan-Meier average estimate t.hat= avg.od[,1], # ordered unscaled sample based on meanpost USEFUL?? avg.od=avg.od, # t.hat with associated d (for computing ahat outside) hazard.hat=ahat, # hazard rate average estimate on t.hat batch.t=batch_t, # batch sample t (not ordered) batch.d=batch_d, # associated event indicators just rep(d,batchsize) sumNaNs = sumNaNs, # total nb of NaN's in iterations while computing post ft="spRMM_SEM") class(a) = "spRMM" return(a) } ############################################## ## plot function for spRMM object : remove lognormal true pdf! # sem = spRMM_SEM object # other are true parameters, if available, for plotting references # ToDo: plot true f and S only if true param availables # pass the true pdf (like dlnorm) as well plotspRMM <- function(sem, tmax = NULL){ t <- sem$t ym <- max(sem$all.scaling) par(mfrow=c(2,2)) plot(sem$all.scaling, type="l", ylim=c(0, ym), xlab="iterations", main="scaling", ylab="") plot(sem$all.lambda[,1], ylim=c(0,1), type="l", xlab="iterations", main="weight of component 1",ylab="") # plots of Kaplan-Meier estimates # finding max time for plots if (is.null(tmax)){tmax <- max(sem$scaling*t) + 2} u <- seq(0, tmax, len=200) plot(sem$survival, xlim=c(0,tmax), ylim=c(0,1), pch=20, verticals=F, do.points=F, xlab="time", main="Survival function estimate") # plot(sem$s.hat, pch=20, verticals=F, do.points=F, col=2, add = TRUE) # pdf estimates fhat <- sem$s.hat(sem$t.hat)*sem$hazard.hat ffinal <- sem$survival(sem$final.t)*sem$hazard plot(sem$final.t, ffinal, type="l", col=1, xlim=c(0,tmax), xlab="time", ylab="density", main="Density estimate") } ## S3 method of summary for class "spRMM" summary.spRMM <- function(object, digits = 6, ...) { sem <- object if (sem$ft != "spRMM_SEM") stop("Unknown object of type ", sem$ft) cat("summary of", sem$ft, "object:\n") o <- matrix(NA, nrow = 2, ncol = 2) o[1,] <- sem$lambda o[2,2] <- sem$scaling colnames(o) <- paste("comp",1:2) rownames(o) <- c("lambda", "scaling") print(o, digits = digits, ...) cat("(pseudo) loglik at estimate: ", sem$loglik, "\n") pcc <- round(100*(1-mean(sem$d)), 2) cat(pcc, "% of the data right censored\n") } mixtools/R/npMSL.R0000644000176200001440000005136114342153463013460 0ustar liggesusers# original version, with weighted Silverman bandwidth unique option # has been improved (mid 2014) by a k-fold CV option # the original version is kept as "npMSL_old" in this file ################################################################ ################################################################ ## nonparametric algorithm for Smoothed Likelihood Maximization ## implementing block structure ## and Silverman adaptive bandwidth ## 2014 additions: loglik stores all the sequence, ## post argument for passing an init matrix of posterior ## bwiter argument for the duration of the adaptive bw stage ## can be set to 0 for keeping an initial bw matrix when samebw=FALSE ################################################################ ################################################################ npMSL_old <- function(x, mu0, blockid = 1:ncol(x), bw=bw.nrd0(as.vector(as.matrix(x))), samebw = TRUE, h=bw, eps=1e-8, maxiter=500, bwiter = maxiter, ngrid=200, post=NULL, verb = TRUE){ bw <- h # h is alternative bandwidth argument, for backward compatibility x <- as.matrix(x) n <- nrow(x) # number of subjects r <- ncol(x) # number of measurements in each subject u <- match(blockid, unique(blockid)) B <- max(u) # nb of blocks BlS <- rep(0,B) # block sizes = C_ell in JCGS paper for (ell in 1:B) { BlS[ell] <- sum(u == ell)} if (is.matrix(mu0)) # mu0=centers m <- dim(mu0)[1] else m <- mu0 # mu0=number of clusters if(!samebw && !is.matrix(bw)) { # create initial bandwidth matrix cat("create initial bandwidth matrix\n") bw <- matrix(bw, nrow=max(u), ncol=m) } z.hat <- matrix(0, nrow = n, ncol = m) tt0 <- proc.time() # for total time ## Initial Values if(m == 1) z.hat <- matrix(1, nrow = n, ncol = m) else if(is.null(post)) { kmeans <- kmeans(x, mu0) for(j in 1:m) z.hat[kmeans$cluster==j, j] <- 1 } else { z.hat <- post ## Currently no error-checking is done here } iter <- 0 finished <- FALSE lambda <- matrix(0, nrow = maxiter, ncol = m) loglik <- NULL; loglikseq <- rep(NA,maxiter) total_udfl <- 0; total_nan <- 0 # eventual NaN and underflow in C code tmp <- 1:n # is this needed? xtra <- (max(x)-min(x))/10 grid <- seq(min(x)-xtra, max(x)+xtra, length=ngrid) # f stored on a ngrid by m by B array # f_{g,j,ell} = f_{j ell}(u_g) # f <- array(1/m/diff(grid[1:2]), c(ngrid, m, B)) # this f was not normalized for being uniform over grid Delta <- diff(grid[1:2]) f <- array(1/((ngrid-1)*Delta), c(ngrid, m, B)) oldloglik <- -Inf orderx <- xx <- list() # preparation for adaptive bandwidth for(k in 1:B) { xx[[k]] <- as.vector(x[, u==k]) if (!samebw) { orderx[[k]] = order(xx[[k]]) # only needed for IQR calculation for bw } } ## CftEstep <- ifelse(samebw, "npMSL_Estep", "npMSL_Estep_bw") #Called directly below # CftEstep <- "npMSL_Estep_bw" # temporary, for testing only the M-step ## CftMstep <- ifelse(samebw, "npMSL_Mstep", "npMSL_Mstep_bw") #Called directly below while (!finished) { # Algorithm main iteration loop iter <- iter + 1 bw.old <- bw # is this needed? t0 <- proc.time() nb_udfl=0; # nb underflows, K()*log(0) ~0 cancelled in nems_Estep.c nb_nan=0; # nb nonzero K()*log(0) cancelled in nems_Estep.c ## Note: Enter loop assuming E-step is done -- i.e., z.hat in place ## M-Step lambda[iter, ] <- colMeans(z.hat) ## density estimation in M-step: WKDE-step cs <- colSums(z.hat) z.tmp <- sweep(z.hat, 2, cs, "/") z.tmp[, cs==0] <- 1/NROW(z.tmp) # Just in case ## adaptive bandwidth update IF in adaptive bw stage if (!samebw && iter <= bwiter) { for (ell in 1:B) { r2 <- BlS[ell] # block size = nb of coordinates wts <- apply(z.tmp, 2, function(z) rep(z/r2, r2)) variances <- colSums(wts*outer(xx[[ell]], colSums(wts*xx[[ell]]),'-')^2) iqr <- apply(as.matrix(wts[orderx[[ell]],]), 2, wIQR, xx[[ell]][orderx[[ell]]], already.sorted=TRUE, already.normalized=TRUE) h <- bw[ell, ] <- 0.9 * pmin(sqrt(variances), iqr/1.34) * pmax(1,r2*n*lambda[iter, ])^(-1/5) # Note: Doesn't allow "sample size" < 1. # browser() } } # end of bw adaptive stage if(samebw){ z <- .C(C_npMSL_Mstep, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(BlS), as.integer(u), as.double(bw), as.double(x), as.double(grid), new.f=as.double(f), as.double(lambda[iter,]), as.double(z.hat), PACKAGE = "mixtools") } else{ z <- .C(C_npMSL_Mstep_bw, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(BlS), as.integer(u), as.double(bw), as.double(x), as.double(grid), new.f=as.double(f), as.double(lambda[iter,]), as.double(z.hat), PACKAGE = "mixtools") } # z=.C(CftMstep, as.integer(ngrid), as.integer(n), # as.integer(m), as.integer(r), # as.integer(B), as.integer(BlS), as.integer(u), # as.double(bw), as.double(x), as.double(grid), # new.f=as.double(f), # as.double(lambda[iter,]), # as.double(z.hat)) f <- array(z$new.f, c(ngrid, m, B)) # check sum(f == 0) # print(apply(f,2:3,sum) * Delta) # print(max(abs(f-f2))) # browser() ## E-step (for next iteration) if(samebw){ z <- .C(C_npMSL_Estep, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(u), as.double(bw), as.double(x), as.double(grid), f=as.double(f), as.double(lambda[iter,]), post=as.double(z.hat), loglik = double(1), nb_udfl = as.integer(nb_udfl), nb_nan = as.integer(nb_nan), PACKAGE = "mixtools") } else{ z <- .C(C_npMSL_Estep_bw, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(u), as.double(bw), as.double(x), as.double(grid), f=as.double(f), as.double(lambda[iter,]), post=as.double(z.hat), loglik = double(1), nb_udfl = as.integer(nb_udfl), nb_nan = as.integer(nb_nan), PACKAGE = "mixtools") } # z=.C(CftEstep, as.integer(ngrid), as.integer(n), # as.integer(m), as.integer(r), # as.integer(B), as.integer(u), # as.double(bw), # as.double(x), as.double(grid), f=as.double(f), # as.double(lambda[iter,]), post=as.double(z.hat), # loglik = double(1), # nb_udfl = as.integer(nb_udfl), nb_nan = as.integer(nb_nan)) nb_udfl = z$nb_udfl; nb_nan = z$nb_nan; total_udfl <- total_udfl + nb_udfl total_nan <- total_nan + nb_nan z.hat <- matrix(z$post, n, m) if (sum(is.nan(z.hat)) > 0) cat("Error!! NaN in z.hat") # obsolete ? loglik <- loglikseq[iter] <- z$loglik loglikchange <- loglik - oldloglik oldloglik <- loglik finished <- iter >= maxiter if (iter>1 && max(abs(lambda[iter, ] - lambda[iter-1, ])) < eps) finished <- TRUE if (verb) { t1 <- proc.time() cat("iteration", iter, ": lambda ", round(lambda[iter, ], 4)) cat(" obj function", round(loglik, 4)) cat(" (change", round(loglikchange,4), ")") cat(" time", (t1 - t0)[3]) if ((nb_udfl > 0) || (nb_nan >0)) cat("\n ") if (nb_udfl > 0) cat("average underflows=", round(nb_udfl/(n*m*r),3)," ") if (nb_nan >0) cat("average NaNs=", round(nb_nan/(n*m*r),3)) # Note: these average mean nb of nan over ngrid convolution cat("\n") } } # f <- array(z$f, c(ngrid, m, r)) # obsolete in block version if (!samebw) { rownames(bw) <- paste("block", 1:max(u)) colnames(bw) <- paste("component", 1:m) } if (verb) { tt1 <- proc.time() cat("lambda ", round(lambda[iter, ], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } return(structure(list(data = x, posteriors = z.hat, lambda = lambda[1:iter,], bandwidth = bw, blockid = u, lambdahat = lambda[iter,], f=f, grid = grid, loglik = loglikseq[1:iter], meanUdfl = total_udfl/(n*m*r*iter),# average underflow meanNaN = total_nan/(n*m*r*iter)), # average NaN's class="npEM")) # define a "npMSL" class ? } ## updated late 2014 version ##################################################################### ##################################################################### ## nonparametric algorithm for Smoothed Likelihood Maximization ## implementing block structure ## 2014 latests additions: ## option for Silverman & weighted k-fold CV adaptive bandwidth: ## parameter bwmethod = "S" for Silverman's rule (the default), ## "CV" for Cross-Validation ## loglik now stores all the sequence ## post argument for passing an init matrix of posterior ## bwiter argument for the duration of the adaptive bw stage ## can be set to 0 for keeping an initial bw matrix when samebw=FALSE ###################################################################### ###################################################################### ## preliminary function for computing the weighted version of ## k-fold Cross-Validation # Splitting 1:n in nbsets subsets and return indices # n = total sample size # setsize = size of sets # nseq = explicit 1st and last indices splitsample <- function(n, nbsets=2) { k <- floor(n/nbsets) klast <- n - (nbsets-1)*k setsize <- c(rep(k, nbsets-1), klast) # n per set if (sum(setsize) != n) {cat("warning")} ni <- c(1,cumsum(setsize)+1) # indices for splitting nseq <- matrix(NA, nrow=nbsets, ncol=2) for (j in 1:nbsets) { nseq[j,1] <- ni[j] # 1st index for jth set nseq[j,2] <- ni[j+1]-1 # last index for jth set } a = list(setsize=setsize, nseq=nseq) return(a) } ## computes CV(h) in k-fold CV case # h = bandwidth (first argument for optimizing) # x = sample of data, vector # nbsets = number of folds # w = weights # lower, upper = numerical integration limits, data-driven defaults kfoldCV <- function(h, x, nbsets=2, w = rep(1, length(x)), lower=mean(x)-5*sd(x), upper=mean(x)+5*sd(x)) { n <- length(x) fold <- splitsample(n, nbsets) sumf <- 0 for (k in 1:nbsets) { Sk <- fold$nseq[k,1]:fold$nseq[k,2] # indices of set k learnset <- x[-Sk] # obs not in set k, from which f_h is "learned" evalset <- x[Sk] fk <- wkde(x = learnset, u = evalset, w = w[-Sk], bw = h) sumf <- sumf + sum(fk) } integrand <- function(u,...) {wkde(x, u, bw=h)^2} # computing ||f_h||^2 fh2 <- integrate(integrand, lower=lower, upper=upper)$value return(fh2 - 2*sumf/n) } ## Weighted bw selection by k-fold CV #### ## min search done by call to optimize # x = vector of data # w = weights, defaults to 1, unnormalized wbw.kCV <- function(x, nbfold=5, w = rep(1, length(x)), hmin=0.1*hmax, hmax=NULL) { n <- length(x) if (is.null(hmax)) hmax <- 1.144 * sqrt(var(x))*n^(-1/5) # default hmax as in bw.ucv # computing lower and upper integration limits for ||fh||^2 wm <- weighted.mean(x, w) lowerf <- wm - 5*sd(x); upperf <- wm + 5*sd(x) # maybe use a weighted.sd version as well? fucv <- function(h) kfoldCV(h, x, nbsets=nbfold, w=w, lower=lowerf, upper=upperf) hopt <- optimize(fucv, lower = hmin, upper = hmax)$minimum return(hopt) } ##################################################################### ##################################################################### ## nonparametric algorithm for Smoothed Likelihood Maximization ## implementing block structure ## 2014 latests additions: ## option for Silverman & weighted k-fold CV adaptive bandwidth: ## parameter bwmethod = "S" for Silverman's rule (the default), ## "CV" for Cross-Validation ## loglik now stores all the sequence ## post argument for passing an init matrix of posterior ## bwiter argument for the duration of the adaptive bw stage ## nbfold parameter passed to wbw.kCV, for leave-[n/nbfold]-out CV ## can be set to 0 for keeping an initial bw matrix when samebw=FALSE ###################################################################### ###################################################################### # ToDo: add a nbfold parameter passed to wbw.kCV npMSL <- function(x, mu0, blockid = 1:ncol(x), bw=bw.nrd0(as.vector(as.matrix(x))), samebw = TRUE, bwmethod = "S", h=bw, eps=1e-8, maxiter=500, bwiter = maxiter, nbfold = NULL, ngrid=200, post=NULL, verb = TRUE){ bw <- h # h is alternative bandwidth argument, for backward compatibility x <- as.matrix(x) n <- nrow(x) # number of subjects r <- ncol(x) # number of measurements in each subject u <- match(blockid, unique(blockid)) B <- max(u) # nb of blocks BlS <- rep(0,B) # block sizes = C_ell in JCGS paper for (ell in 1:B) { BlS[ell] <- sum(u == ell)} if (is.matrix(mu0)) # mu0=centers m <- dim(mu0)[1] else m <- mu0 # mu0 = number of clusters if(!samebw && !is.matrix(bw)) { # create initial bandwidth matrix h_lj bw <- matrix(bw, nrow=max(u), ncol=m)} z.hat <- matrix(0, nrow = n, ncol = m) tt0 <- proc.time() # for total time ## Initial Values if(m == 1) z.hat <- matrix(1, nrow = n, ncol = m) else if(is.null(post)) { kmeans <- kmeans(x, mu0) for(j in 1:m) z.hat[kmeans$cluster==j, j] <- 1 } else { z.hat <- post ## Currently no error-checking is done here } if (is.null(nbfold) && bwmethod == "CV") {nbfold <- 5} # default value for nbfold-CV iter <- 0 finished <- FALSE lambda <- matrix(0, nrow = maxiter, ncol = m) loglik <- NULL loglikseq <- rep(NA,maxiter) total_udfl <- 0; total_nan <- 0 # eventual NaN and underflow in C code tmp <- 1:n xtra <- (max(x)-min(x))/10 grid <- seq(min(x)-xtra, max(x)+xtra, length=ngrid) # f stored on a ngrid by m by B array # f_{g,j,ell} = f_{j ell}(u_g) # f <- array(1/m/diff(grid[1:2]), c(ngrid, m, B)) # this f was not normalized for being uniform over grid Delta <- diff(grid[1:2]) f <- array(1/((ngrid-1)*Delta), c(ngrid, m, B)) oldloglik <- -Inf orderx <- xx <- list() # preparation for Silverman adaptive bandwidth for(k in 1:B) { xx[[k]] <- as.vector(x[, u==k]) # data pooled from kth block if (!samebw && bwmethod == "S") { orderx[[k]] = order(xx[[k]]) # only needed for IQR calculation for bw } } ## CftEstep <- ifelse(samebw, "npMSL_Estep", "npMSL_Estep_bw") #Called directly below. # CftEstep <- "npMSL_Estep_bw" # temporary, for testing only the M-step ## CftMstep <- ifelse(samebw, "npMSL_Mstep", "npMSL_Mstep_bw") #Called directly below. while (!finished) { iter <- iter + 1 bw.old <- bw # is this needed? t0 <- proc.time() nb_udfl=0; # nb of underflows log(0) cancelled in nems_Estep.c nb_nan=0; # nb of nonzero K()*log(0) cancelled in nems_Estep.c ## Note: Enter loop assuming E-step is done i.e., z.hat in place ## M-Step lambda[iter, ] <- colMeans(z.hat) ## density estimation in M-step: WKDE-step cs <- colSums(z.hat) z.tmp <- sweep(z.hat, 2, cs, "/") z.tmp[, cs==0] <- 1/NROW(z.tmp) # Just in case ## adaptive bandwidth update - depends on bwmethod and adptbw stage duration in this version if (!samebw && iter <= bwiter) { # adaptive Silverman's rule if (bwmethod == "S") { for (ell in 1:B) { # for each block r2 <- BlS[ell] # block size = nb of coordinates wts <- apply(z.tmp, 2, function(z) rep(z/r2, r2)) variances <- colSums(wts*outer(xx[[ell]], colSums(wts*xx[[ell]]),'-')^2) iqr <- apply(as.matrix(wts[orderx[[ell]],]), 2, wIQR, xx[[ell]][orderx[[ell]]], already.sorted=TRUE, already.normalized=TRUE) h <- bw[ell, ] <- 0.9 * pmin(sqrt(variances), iqr/1.34) * pmax(1,r2*n*lambda[iter, ])^(-1/5) # Note: Doesn't allow "sample size" < 1. } } # adaptive nbfold CV computation, nbfold=5 by default if (bwmethod == "CV") { # k-fold CV for (ell in 1:B) { # for each block r2 <- BlS[ell] # block size = nb of coordinates wts <- apply(z.tmp, 2, function(z) rep(z, r2)) # replicate weights for (j in 1:m) bw[ell,j] <- wbw.kCV(xx[[ell]], nbfold = nbfold, w = wts[,j]) } } # end of CV version } # end of bw adaptive stage if(samebw){ z <- .C(C_npMSL_Mstep, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(BlS), as.integer(u), as.double(bw), as.double(x), as.double(grid), new.f=as.double(f), as.double(lambda[iter,]), as.double(z.hat), PACKAGE = "mixtools") } else{ z <- .C(C_npMSL_Mstep_bw, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(BlS), as.integer(u), as.double(bw), as.double(x), as.double(grid), new.f=as.double(f), as.double(lambda[iter,]), as.double(z.hat), PACKAGE = "mixtools") } # z=.C(CftMstep, as.integer(ngrid), as.integer(n), # as.integer(m), as.integer(r), # as.integer(B), as.integer(BlS), as.integer(u), # as.double(bw), as.double(x), as.double(grid), # new.f=as.double(f), # as.double(lambda[iter,]), # as.double(z.hat)) f <- array(z$new.f, c(ngrid, m, B)) # check sum(f == 0) # print(apply(f,2:3,sum) * Delta) # print(max(abs(f-f2))) # browser() ## E-step (for next iteration) if(samebw){ z <- .C(C_npMSL_Estep, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(u), as.double(bw), as.double(x), as.double(grid), f=as.double(f), as.double(lambda[iter,]), post=as.double(z.hat), loglik = double(1), nb_udfl = as.integer(nb_udfl), nb_nan = as.integer(nb_nan), PACKAGE = "mixtools") } else{ z <- .C(C_npMSL_Estep_bw, as.integer(ngrid), as.integer(n), as.integer(m), as.integer(r), as.integer(B), as.integer(u), as.double(bw), as.double(x), as.double(grid), f=as.double(f), as.double(lambda[iter,]), post=as.double(z.hat), loglik = double(1), nb_udfl = as.integer(nb_udfl), nb_nan = as.integer(nb_nan), PACKAGE = "mixtools") } # z=.C(CftEstep, as.integer(ngrid), as.integer(n), # as.integer(m), as.integer(r), # as.integer(B), as.integer(u), # as.double(bw), # as.double(x), as.double(grid), f=as.double(f), # as.double(lambda[iter,]), post=as.double(z.hat), # loglik = double(1), # nb_udfl = as.integer(nb_udfl), nb_nan = as.integer(nb_nan)) nb_udfl = z$nb_udfl; nb_nan = z$nb_nan; total_udfl <- total_udfl + nb_udfl total_nan <- total_nan + nb_nan z.hat <- matrix(z$post, n, m) if (sum(is.nan(z.hat)) > 0) cat("Error!! NaN in z.hat") # obsolete ? loglik <- loglikseq[iter] <- z$loglik loglikchange <- loglik - oldloglik oldloglik <- loglik finished <- iter >= maxiter if (iter>1 && max(abs(lambda[iter, ] - lambda[iter-1, ])) < eps) finished <- TRUE if (verb) { t1 <- proc.time() cat("iteration", iter, ": lambda ", round(lambda[iter, ], 4)) cat(" obj change", round(loglikchange,4)) cat(" time", (t1 - t0)[3]) if ((nb_udfl > 0) || (nb_nan >0)) cat("\n ") if (nb_udfl > 0) cat("average underflows=", round(nb_udfl/(n*m*r),3)," ") if (nb_nan >0) cat("average NaNs=", round(nb_nan/(n*m*r),3)) # Note: average nb of nan over ngrid convolution cat("\n") } } # f <- array(z$f, c(ngrid, m, r)) # obsolete in block version if (!samebw) { rownames(bw) <- paste("block", 1:max(u)) colnames(bw) <- paste("component", 1:m) } if (verb) { tt1 <- proc.time() cat("lambda ", round(lambda[iter, ], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } return(structure(list(data = x, posteriors = z.hat, lambda = lambda[1:iter,], bandwidth = bw, blockid = u, lambdahat = lambda[iter,], f=f, grid = grid, loglik = loglikseq[1:iter], meanUdfl = total_udfl/(n*m*r*iter),# average underflow meanNaN = total_nan/(n*m*r*iter)), # average NaN's class="npEM")) # should we define a "npMSL" class ? } mixtools/R/lambda.R0000755000176200001440000000222614343276430013707 0ustar liggesuserslambda <- function (z, x, xi, h = NULL, kernel = c("Gaussian", "Beta", "Triangle", "Cosinus", "Optcosinus"), g = 0) { if (is.null(h)) { cat("WARNING! BANDWIDTH MUST BE SPECIFIED!", "\n") } n <- nrow(xi) p <- ncol(xi) if(length(h)==1) h <- rep(h,p) if(length(h)!=p) { stop("Check the length of the bandwidth h.") } else{ h <- matrix(rep(h,each=n),nrow=n) } x <- matrix(rep(x,each=n),nrow=n) X.mat=cbind(1,(xi-x)) kernel <- match.arg(kernel) inwindow <- (abs((xi - x)/h) <= 1) if (kernel == "Gaussian") { W=(kern.G(x, xi, h) * inwindow) } else if (kernel == "Beta") { W=(kern.B(x, xi, h, g) * inwindow) } else if (kernel == "Triangle") { W=(kern.T(x, xi, h) * inwindow) } else if (kernel == "Cosinus") { W=(kern.C(x, xi, h) * inwindow) } else if (kernel == "Optcosinus") { W=(kern.O(x, xi, h) * inwindow) } W = diag(apply(matrix(W,ncol=ncol(X.mat)-1),1,prod)) A=try(solve(t(X.mat)%*%(W%*%X.mat)), silent=TRUE) if(inherits(A, "try-error", which = TRUE)) { A=ginv(t(X.mat)%*%(W%*%X.mat)) } beta.x=A%*%t(X.mat)%*%(W%*%cbind(z)) beta.x }mixtools/R/logisregmixinit.R0000755000176200001440000000207114342153463015701 0ustar liggesuserslogisregmix.init <- function(y, x, N, lambda = NULL, beta = NULL, k = 2){ x <- as.matrix(x) n <- length(y) if (is.null(lambda)) { cond = TRUE while(cond){ lambda = runif(k) lambda = lambda/sum(lambda) if(min(lambda)<0.05) cond=TRUE else cond=FALSE } } else k = length(lambda) p <- ncol(x) w = cbind(y, N, x) w = w[order(w[, 1]), ] w.bin = list() for (j in 1:k) { w.bin[[j]] <- w[max(1, floor((j - 1) * n/k)):ceiling(j * n/k), ] } if (is.null(beta)) { beta.hyp = matrix(sapply(1:k, function(j) glm.fit(w.bin[[j]][, 3:(p + 2)], w.bin[[j]][, 1:2], family = binomial())$coef), ncol = k) sd.hyp = apply(beta.hyp, 1, sd) beta = matrix(0, p, k) for (j in 1:k) { beta[, j] = rnorm(p, mean = as.vector(beta.hyp[, j]), sd = sd.hyp) } } else k = ncol(beta) list(lambda = lambda, beta = beta, k = k) } mixtools/R/repnormmixinit.R0000755000176200001440000000212014342153463015543 0ustar liggesusersrepnormmix.init = function (x, lambda = NULL, mu = NULL, s = NULL, k = 2, arbmean = TRUE, arbvar = TRUE) { n <- ncol(x) m <- nrow(x) y <- apply(x, 2, mean) x <- x[, order(y)] x.bin = list() for (j in 1:k) { x.bin[[j]] <- x[, max(1, floor((j - 1) * n/k)):ceiling(j * n/k)] } if (is.null(s)) { s.hyp = sapply(lapply(x.bin, as.vector), sd) if (arbvar) { s = 1/rexp(k, rate = s.hyp) } else { s.hyp = mean(s.hyp) s = 1/rexp(1, rate = s.hyp) } } if (is.null(s) == FALSE && arbvar == TRUE) { k = length(s) } if (is.null(mu)) { mu.hyp <- sapply(lapply(x.bin, as.vector), mean) mu = rnorm(k, mean = mu.hyp, sd = s) if(arbmean==FALSE){ mu = mean(mu) } } if (is.null(mu)==FALSE && arbmean==TRUE){ k = length(mu) } if (is.null(lambda)) { lambda = runif(k) lambda = lambda/sum(lambda) } else k = length(lambda) list(lambda = lambda, mu = mu, s = s, k = k) }mixtools/R/plotly_expRMM.R0000644000176200001440000000757314343041730015242 0ustar liggesusersplotly_expRMM <- function(a , title = NULL , rowstyle = TRUE , subtitle=NULL, width = 2 , cex = 2 , col.comp = NULL, legend.text = NULL, legend.text.size = 15, legend.size = 15, title.x = 0.5, title.y = 0.95, title.size = 15, xlab.size = 15, xtick.size = 15, ylab.size = 15, ytick.size = 15 ){ n <- length(a$x) m <- dim(a$all.lambda)[2] if (is.null(col.comp)){ col.comp <- hue_pal()(m) } if (length(col.comp) != m){ print(paste("Please specify",m,"colors in 'col.comp'.")) } pcc <- round(100*(1-mean(a$d)),2) sizes <- paste("n=",n,", ", pcc, "% censored", sep="") if (is.null(subtitle)) { subtitle <- paste("n=",n,", ", pcc, "% censored", sep="")} if (is.null(title)) { tt1 <- "Rate parameters" tt2 <- "Weight parameters" } else {tt1 <- tt2 <- title} # lgd <- expression(xi[1]) ## Cannot be converted to plotly. plot1 <- plot_ly() %>% plotly::layout( legend = list(title=list(text=legend.text), font = list(size=legend.size)), xaxis = list(title = list(text = "Iterations", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "Estimates", font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (j in 1:m){ plot1 <- plot1 %>% add_trace(x=seq(from = 1 , to = length(a$all.rate[,j]) , by = 1) , y=a$all.rate[,j] , type = 'scatter' , mode = 'lines+markers', marker = list(size = cex , color = col.comp[j]), line = list(width = width , color = col.comp[j]), name = paste("Comp" , j),showlegend = TRUE) } plot2 <- plot_ly() %>% plotly::layout( legend = list(title=legend.text, font = list(size=legend.size)), xaxis = list(title = list(text = "Iterations", font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = "Estimates", font = list(size = ylab.size)), tickfont = list(size = ytick.size) ) ) for (j in 1:m){ plot2 <- plot2 %>% add_trace(x=seq(from = 1 , to = length(a$all.lambda[,j]) , by = 1) , y=a$all.lambda[,j] , type = 'scatter' , mode = 'lines+markers', marker = list(size = cex , color = col.comp[j]), line = list(width = width , color = col.comp[j]), name = paste("Comp" , j),showlegend = FALSE) } if (rowstyle) { nrow <- 1 x.1 <- 0.25 x.2 <- 0.75 y.1 <- y.2 <- 0.95 share.X <- FALSE } else if (!rowstyle){ nrow <- 2 x.1 <- x.2 <- 0.5 y.1 <- 0.95 y.2 <- 0.45 share.X <- TRUE } plot.all <- subplot( plot1 , plot2 , nrows = nrow , shareX = share.X , shareY = FALSE, titleX = TRUE , titleY = TRUE )%>% plotly::layout(annotations = list( list( x = x.1, y = y.1, font = list(size = title.size), text = paste(tt1 , "\n(", subtitle,")"), xref = "paper", yref = "paper", xanchor = "center", yanchor = "bottom", showarrow = FALSE ), list( x = x.2, y = y.2, font = list(size = title.size), text = paste(tt2 , "\n(", subtitle,")"), xref = "paper", yref = "paper", xanchor = "center", yanchor = "bottom", showarrow = FALSE ) ) ) print(plot.all) }mixtools/R/summary.mixEM.R0000644000176200001440000000514014342153463015174 0ustar liggesuserssummary.mixEM <- function(object, digits=6, ...){ x <- object o <- switch(x$ft, "multmixEM" = rbind(x$lambda, t(x$theta)), "normalmixEM" = rbind(x$lambda, x$mu, x$sigma), "repnormmixEM" = rbind(x$lambda, x$mu, x$sigma), "regmixEM" = rbind(x$lambda, x$sigma, x$beta), "regmixEM.lambda" = rbind(x$lambda, x$sigma, x$beta), "regmixEM.mixed" = rbind(x$lambda, x$sigma, x$beta), "regmixEM.loc" = rbind(x$sigma, x$beta), "regmixEM.chgpt" = rbind(x$lambda, x$sigma), "logisregmixEM" = rbind(x$lambda, x$beta), "poisregmixEM" = rbind(x$lambda, x$beta), "expRMM_EM" = rbind(x$lambda, x$rate), # Reliability Mixt Model censored exp mixture "weibullRMM_SEM" = rbind(x$lambda, x$shape, x$scale), # RMM censored weibull mixture "mvnormalmixEM" = rbind(x$lambda, matrix(unlist(x$mu), byrow=FALSE, ncol=length(x$lambda))), "normalmixMMlc" = rbind(x$lambda, x$mu, x$sigma), stop("Unknown mixEM object of type ", x$ft)) colnames(o) <- paste("comp",1:ncol(o)) rownames(o) <- switch(x$ft, "multmixEM" = c("lambda", paste("theta", 1:ncol(x$theta), sep="")), "normalmixEM" = c("lambda", "mu", "sigma"), "repnormmixEM" = c("lambda", "mu", "sigma"), "regmixEM" = c("lambda", "sigma", paste("beta", 1:nrow(x$beta), sep="")), "regmixEM.lambda" = c("lambda", "sigma", paste("beta", 1:nrow(x$beta), sep="")), "regmixEM.mixed" = c("lambda", "sigma", paste("beta", 1:nrow(x$beta), sep="")), "regmixEM.loc" = c("sigma", paste("beta", 1:nrow(x$beta), sep="")), "regmixEM.chgpt" = c("lambda", "sigma"), "logisregmixEM" = c("lambda", paste("beta", 1:nrow(x$beta), sep="")), "poisregmixEM" = c("lambda", paste("beta", 1:nrow(x$beta), sep="")), "expRMM_EM" = c("lambda", "rate"), "weibullRMM_SEM" = c("lambda", "shape", "scale"), "mvnormalmixEM" = c("lambda", paste("mu", 1:length(x$mu[[1]]), sep="")), "normalmixMMlc" = c("lambda", "mu", "sigma")) cat("summary of", x$ft, "object:\n") print(o, digits=digits) cat("loglik at estimate: ", x$loglik, "\n") if (x$ft == "expRMM_EM") cat(100*(1-mean(x$d)), "% of the data right censored\n") if (x$ft == "weibullRMM_SEM") cat(100*(1-mean(x$d)), "% of the data right censored\n") } mixtools/R/bootse.R0000755000176200001440000004460214343155643013770 0ustar liggesusersboot.se <- function (em.fit, B = 100, arbmean = TRUE, arbvar = TRUE, N=NULL, ...) { mix.type <- em.fit$ft if (mix.type == "regmixEM") { #Start Here... k=length(em.fit$lambda) y=em.fit$y n=length(y) if(sum(em.fit$x[,1]==1)==n){ x=em.fit$x[,-1] } else x=em.fit$x if (arbmean == FALSE) { scale = em.fit$scale beta = matrix(rep(em.fit$beta, k), ncol = k) } else { scale = 1 beta = em.fit$beta } xbeta.new=em.fit$x%*%beta lambda = em.fit$lambda if(arbvar==FALSE){ sigma = rep(em.fit$sigma,k) } else{ sigma = scale*em.fit$sigma } j = 0 lambda.bs=NULL beta.bs=NULL sigma.bs=NULL scale.bs=NULL while (j < B) { j = j + 1 w=rmultinom(n,size=1,prob=lambda) y.sim=sapply(1:n,function(i) rnorm(1,mean=xbeta.new[i,(w[,i]==1)],sd=sigma[w[,i]==1]) ) em.bs = try(regmixEM(y = y.sim, x = x, k = k, arbmean = arbmean, arbvar = arbvar, lambda=em.fit$lambda, beta=em.fit$beta, sigma=(scale*em.fit$sigma), ...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else { if(arbmean==FALSE){ lambda.bs = cbind(lambda.bs,em.bs$lambda) beta.bs = cbind(beta.bs,as.vector(em.bs$beta)) sigma.bs = cbind(sigma.bs,em.bs$sigma) scale.bs = cbind(scale.bs,em.bs$scale) } else { lambda.bs = cbind(lambda.bs,em.bs$lambda) beta.bs = cbind(beta.bs,as.vector(em.bs$beta)) sigma.bs = cbind(sigma.bs,em.bs$sigma) } } } if(arbmean==FALSE){ lambda.se=apply(lambda.bs,1,sd) beta.se=apply(beta.bs,1,sd) sigma.se=apply(sigma.bs,1,sd) scale.se=apply(scale.bs,1,sd) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, beta = beta.bs, beta.se = beta.se, sigma=sigma.bs, sigma.se = sigma.se, scale=scale.bs, scale.se=scale.se) } else{ lambda.se=apply(lambda.bs,1,sd) beta.se=matrix(apply(beta.bs,1,sd),ncol=k) sigma.se=apply(sigma.bs,1,sd) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, beta = beta.bs, beta.se = beta.se, sigma=sigma.bs, sigma.se = sigma.se) } } ##### if (mix.type == "regmixEM.mixed"){ #Start Here... k=length(em.fit$lambda) y=em.fit$y x=em.fit$x if (length(y) != length(x)) stop("Number of elements in lists for x and y must match!") w=em.fit$w p.z=em.fit$posterior.z p.b=em.fit$posterior.beta mu=em.fit$mu R=em.fit$R sigma=em.fit$sigma lambda=em.fit$lambda n=length(y) p=nrow(mu) n.i=sapply(y,length) alpha=em.fit$alpha w.test <- NULL for(i in 1:length(w)){ w.test <- c(w.test,as.vector(w[[i]])) } if(sum(w.test)==0){ w1=NULL} else w1=w if(length(R)==k) arb.R=TRUE else arb.R=FALSE if(length(sigma)==k) arb.sigma=TRUE else arb.sigma=FALSE j = 0 lambda.bs=NULL mu.bs=NULL sigma.bs=NULL R.bs=NULL alpha.bs=NULL while (j < B) { j = j + 1 k.bs=sapply(1:n, function(i) rmultinom(1,size=1,prob=lambda)) bs.i <- sample(1:n,n,replace=TRUE) ## if(arb.R==FALSE){ if(arb.sigma==FALSE){ y.sim <- lapply(1:n, function(i) w[[i]] %*% alpha + as.vector(rmvnorm(1, mu = x[[i]] %*% mu[, (k.bs[, i] == 1)], sigma = (x[[i]]%*%R%*%t(x[[i]]) +diag(sigma,n.i[i])) ))) } else y.sim <- lapply(1:n, function(i) w[[i]] %*% alpha + as.vector(rmvnorm(1, mu = x[[i]] %*% mu[, (k.bs[, i] == 1)], sigma = (x[[i]]%*%R%*%t(x[[i]]) +diag(sigma[(k.bs[,i] == 1)],n.i[i])) ))) } else{ if(arb.sigma==FALSE){ y.sim <- lapply(1:n, function(i) w[[i]] %*% alpha + as.vector(rmvnorm(1, mu = x[[i]] %*% mu[, (k.bs[, i] == 1)], sigma = (x[[i]]%*%R[(k.bs[, i] == 1)][[1]]%*%t(x[[i]]) +diag(sigma,n.i[i])) ))) } else y.sim <- lapply(1:n, function(i) w[[i]] %*% alpha + as.vector(rmvnorm(1, mu = x[[i]] %*% mu[, (k.bs[, i] == 1)], sigma = (x[[i]]%*%R[(k.bs[, i] == 1)][[1]]%*%t(x[[i]]) +diag(sigma[(k.bs[,i] == 1)],n.i[i])) ))) } ## em.bs = try(regmixEM.mixed(y = y.sim, x = x, w=w1, sigma=sigma, mu=mu, alpha=alpha, R=R, lambda=lambda, k = k, arb.R=arb.R, arb.sigma=arb.sigma, addintercept.fixed=FALSE, addintercept.random=FALSE, ...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else { lambda.bs = cbind(lambda.bs,em.bs$lambda) alpha.bs = cbind(alpha.bs,em.bs$alpha) sigma.bs = cbind(sigma.bs,em.bs$sigma) mu.bs = cbind(mu.bs,as.vector(em.bs$mu)) R.bs = cbind(R.bs,as.vector(sapply(em.bs$R,c))) } lambda.se=apply(lambda.bs,1,sd) alpha.se=apply(alpha.bs,1,sd) sigma.se=apply(sigma.bs,1,sd) mu.se=matrix(apply(mu.bs,1,sd),ncol=k) R.se1=apply(R.bs,1,sd) if(arb.R==TRUE){ R.se2=matrix(R.se1,ncol=k) R.se=lapply(1:k,function(i) matrix(R.se2[,i],ncol=p)) } else R.se=matrix(R.se1,ncol=p) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, alpha=alpha.bs, alpha.se=alpha.se, mu = mu.bs, mu.se = mu.se, sigma=sigma.bs, sigma.se = sigma.se, R=R.bs, R.se=R.se) } } ##### # Commented out by DRH on 8-29-2008 due to absence of gammamixEM function # if (mix.type == "gammamixEM") { # x <- em.fit$x # n <- length(x) # k <- length(em.fit$lambda) # alpha <- em.fit$gamma.pars[1,] # beta <- em.fit$gamma.pars[2,] # lambda <- em.fit$lambda # j = 0 # lambda.bs = NULL # alpha.bs = NULL # beta.bs = NULL # while (j < B) { # j = j + 1 # comp = sample(1:k,size=n,replace=T,prob=lambda) # x.sim = sapply(1:n,function(i) rgamma(1,shape=alpha[comp[i]],scale=beta[comp[i]])) # em.bs = try(gammamixEM(x = x.sim, k = k, lambda = lambda, # alpha = alpha, beta = beta, ...), silent = TRUE) # if (class(em.bs) == "try-error") { # j = j - 1 # } # else { # lambda.bs = cbind(lambda.bs, em.bs$lambda) # alpha.bs = cbind(alpha.bs, as.vector(em.bs$gamma.pars[1,])) # beta.bs = cbind(beta.bs, as.vector(em.bs$gamma.pars[2,])) # } # } # lambda.se = apply(lambda.bs, 1, sd) # alpha.se = apply(alpha.bs, 1, sd) # beta.se = apply(beta.bs, 1, sd) # bs.list = list(lambda = lambda.bs, lambda.se = lambda.se, # alpha = alpha.bs, alpha.se = alpha.se, beta = beta.bs, beta.se = beta.se) # } ##### if (mix.type == "repnormmixEM") { #Start Here... k=length(em.fit$lambda) y=em.fit$y m=nrow(y) n=ncol(y) if (arbmean == FALSE) { scale = em.fit$scale mu = rep(em.fit$mu, k) } else { scale = 1 mu = em.fit$mu } lambda = em.fit$lambda if(arbvar==FALSE){ sigma = rep(em.fit$sigma,k) } else{ sigma = scale*em.fit$sigma } j = 0 lambda.bs=NULL mu.bs=NULL sigma.bs=NULL scale.bs=NULL while (j < B) { j = j + 1 w=rmultinom(n,size=1,prob=lambda) y.sim=sapply(1:n,function(i) rnorm(m,mean=mu[w[,i]==1],sd=sigma[w[,i]==1]) ) em.bs = try(repnormmixEM(x = y.sim,k = k, arbmean = arbmean, arbvar = arbvar, lambda=em.fit$lambda, mu=em.fit$mu, sigma=(scale*em.fit$sigma), ...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else { if(arbmean==FALSE){ lambda.bs = cbind(lambda.bs,em.bs$lambda) mu.bs = cbind(mu.bs,as.vector(em.bs$mu)) sigma.bs = cbind(sigma.bs,em.bs$sigma) scale.bs = cbind(scale.bs,em.bs$scale) } else { lambda.bs = cbind(lambda.bs,em.bs$lambda) mu.bs = cbind(mu.bs,as.vector(mu.bs$beta)) sigma.bs = cbind(sigma.bs,em.bs$sigma) } } } if(arbmean==FALSE){ lambda.se=apply(lambda.bs,1,sd) mu.se=apply(mu.bs,1,sd) sigma.se=apply(sigma.bs,1,sd) scale.se=apply(scale.bs,1,sd) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, mu = mu.bs, mu.se = mu.se, sigma=sigma.bs, sigma.se = sigma.se, scale=scale.bs, scale.se=scale.se) } else{ lambda.se=apply(lambda.bs,1,sd) mu.se=apply(mu.bs,1,sd) sigma.se=apply(sigma.bs,1,sd) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, mu = mu.bs, mu.se = mu.se, sigma=sigma.bs, sigma.se = sigma.se) } } #### if (mix.type == "mvnormalmixEM") { #Start Here... k=length(em.fit$lambda) y=em.fit$x n=nrow(y) p=ncol(y) if (arbmean == FALSE) { mu = lapply(1:k,function(i) em.fit$mu) } else { mu = em.fit$mu } lambda = em.fit$lambda if(arbvar==FALSE){ sigma = lapply(1:k, function(i) em.fit$sigma) } else{ sigma = em.fit$sigma } j = 0 lambda.bs=NULL mu.bs=NULL sigma.bs=NULL while (j < B) { j = j + 1 w=rmultinom(n,size=1,prob=lambda) y.sim=t(sapply(1:n,function(i) rmvnorm(1,mu=mu[w[,i]==1][[1]],sigma=sigma[w[,i]==1][[1]]) )) em.bs = try(mvnormalmixEM(x = y.sim, k = k, arbmean = arbmean, arbvar = arbvar, lambda=em.fit$lambda, mu=em.fit$mu, sigma=em.fit$sigma, ...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else { lambda.bs = cbind(lambda.bs,em.bs$lambda) mu.bs1 = as.vector(sapply(em.bs$mu,c)) mu.bs = cbind(mu.bs, mu.bs1) if(arbvar==FALSE){ sigma.bs=cbind(sigma.bs,as.vector(em.bs$sigma)) } else{ sigma.bs1 = lapply(1:k, function(i) as.vector(em.bs$sigma[[i]])) sigma.bs2 = as.vector(sapply(sigma.bs1,c)) sigma.bs = cbind(sigma.bs,sigma.bs2) } } } lambda.se=apply(lambda.bs,1,sd) mu.se1=apply(mu.bs,1,sd) if(arbmean==TRUE){ mu.se = lapply(1:k,function(i) mu.se1[((i-1)*p+1):(i*p)]) } else mu.se = mu.se1 sigma.se1=apply(sigma.bs,1,sd) if(arbvar==TRUE){ sigma.se=lapply(1:k, function(i) matrix(sigma.se1[((i-1)*(p^2)+1):(i*(p^2))], nrow=p,ncol=p)) } else sigma.se=matrix(sigma.se1,nrow=p) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, mu = mu.bs, mu.se = mu.se, sigma=sigma.bs, sigma.se = sigma.se) } #### if (mix.type == "normalmixEM") { #Start Here... k=length(em.fit$lambda) y=em.fit$x n=length(y) x=em.fit$x if (arbmean == FALSE) { scale = em.fit$scale mu = rep(em.fit$mu, k) } else { scale = 1 mu = em.fit$mu } lambda = em.fit$lambda if(arbvar==FALSE){ sigma = rep(em.fit$sigma,k) } else{ sigma = scale*em.fit$sigma } j = 0 lambda.bs=NULL mu.bs=NULL sigma.bs=NULL scale.bs=NULL while (j < B) { j = j + 1 w=rmultinom(n,size=1,prob=lambda) y.sim=sapply(1:n,function(i) rnorm(1,mean=mu[(w[,i]==1)],sd=sigma[w[,i]==1]) ) em.bs = try(normalmixEM(x = y.sim, k = k, arbmean = arbmean, arbvar = arbvar, lambda=em.fit$lambda, mu=em.fit$mu, sigma=(scale*em.fit$sigma), ...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else { if(arbmean==FALSE){ lambda.bs = cbind(lambda.bs,em.bs$lambda) mu.bs = cbind(mu.bs,as.vector(em.bs$mu)) sigma.bs = cbind(sigma.bs,em.bs$sigma) scale.bs = cbind(scale.bs,em.bs$scale) } else { lambda.bs = cbind(lambda.bs,em.bs$lambda) mu.bs = cbind(mu.bs,as.vector(em.bs$mu)) sigma.bs = cbind(sigma.bs,em.bs$sigma) } } } if(arbmean==FALSE){ lambda.se=apply(lambda.bs,1,sd) mu.se=apply(mu.bs,1,sd) sigma.se=apply(sigma.bs,1,sd) scale.se=apply(scale.bs,1,sd) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, mu = mu.bs, mu.se = mu.se, sigma=sigma.bs, sigma.se = sigma.se, scale=scale.bs, scale.se=scale.se) } else{ lambda.se=apply(lambda.bs,1,sd) mu.se=matrix(apply(mu.bs,1,sd),ncol=k) sigma.se=apply(sigma.bs,1,sd) bs.list=list(lambda = lambda.bs, lambda.se = lambda.se, mu = mu.bs, mu.se = mu.se, sigma=sigma.bs, sigma.se = sigma.se) } } ### if (mix.type == "multmixEM") { y<-em.fit$y n<-nrow(y) n.i<-apply(y,1,sum) p<-ncol(y) k<-length(em.fit$lambda) theta<-em.fit$theta lambda<-em.fit$lambda j = 0 lambda.bs=NULL theta.bs=NULL while (j < B) { j = j + 1 w=rmultinom(n,size=1,prob=lambda) y.sim=t(sapply(1:n,function(i) rmultinom(1,size=n.i[i],prob=theta[(w[,i]==1),]) )) em.bs = try(multmixEM(y = y.sim, k = k, lambda=lambda, theta=theta, ...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else{ lambda.bs=cbind(lambda.bs,em.bs$lambda) theta.bs=cbind(theta.bs,as.vector(em.bs$theta)) } } lambda.se=apply(lambda.bs,1,sd) theta.se=matrix(apply(theta.bs,1,sd),nrow=k) bs.list=list(lambda=lambda.bs, lambda.se=lambda.se, theta=theta.bs, theta.se=theta.se) } #### if (mix.type == "logisregmixEM") { y=em.fit$y n=length(y) if (is.null(N)) N=rep(1,n) k=length(em.fit$lambda) if(sum(em.fit$x[,1]==1)==n){ x=em.fit$x[,-1] } else x=em.fit$x lambda<-em.fit$lambda beta<-em.fit$beta xbeta.new=em.fit$x%*%beta prob=inv.logit(xbeta.new) j = 0 lambda.bs=NULL beta.bs=NULL while (j < B) { j = j + 1 w=rmultinom(n,size=1,prob=lambda) y.sim = sapply(1:n, function(i) rbinom(1, size=N[i], prob=prob[,(w[,i]==1)])) em.bs = try(logisregmixEM(y = y.sim, x=x, N=N, k = k, lambda=lambda, beta=beta,...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else{ lambda.bs=cbind(lambda.bs,em.bs$lambda) beta.bs=cbind(beta.bs,as.vector(em.bs$beta)) } } lambda.se=apply(lambda.bs,1,sd) beta.se=matrix(apply(beta.bs,1,sd),nrow=k) bs.list=list(lambda=lambda.bs, lambda.se=lambda.se, beta=beta.bs, beta.se=beta.se) } #### if (mix.type == "poisregmixEM") { k=length(em.fit$lambda) y=em.fit$y n=length(y) if(sum(em.fit$x[,1]==1)==n){ x=em.fit$x[,-1] } else x=em.fit$x lambda<-em.fit$lambda beta<-em.fit$beta xbeta.new=em.fit$x%*%beta prob=exp(xbeta.new) j = 0 lambda.bs=NULL beta.bs=NULL while (j < B) { j = j + 1 w=rmultinom(n,size=1,prob=lambda) y.sim = sapply(1:n, function(i) rpois(1, lambda=prob[,(w[,i]==1)])) em.bs = try(poisregmixEM(y = y.sim, x=x, k = k, lambda=lambda, beta=beta, ...), silent = TRUE) if (inherits(em.bs, "try-error", which = TRUE) || em.bs$restarts!=0) { j = j - 1 } else{ lambda.bs=cbind(lambda.bs,em.bs$lambda) beta.bs=cbind(beta.bs,as.vector(em.bs$beta)) } } lambda.se=apply(lambda.bs,1,sd) beta.se=matrix(apply(beta.bs,1,sd),nrow=k) bs.list=list(lambda=lambda.bs, lambda.se=lambda.se, beta=beta.bs, beta.se=beta.se) } bs.list } mixtools/R/mvnormalmixinit.R0000755000176200001440000000322014342153463015716 0ustar liggesusersmvnormalmix.init = function (x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, arbmean = TRUE, arbvar = TRUE) { n <- nrow(x) p <- ncol(x) y <- apply(x, 1, mean) x <- x[order(y), ] x.bin <- list() for (j in 1:k) { x.bin[[j]] <- x[max(1, floor((j - 1) * n/k)):ceiling(j * n/k), ] } if (is.null(sigma)) { if (arbvar) { sigma.hyp = lapply(1:k, function(i) (apply(x.bin[[i]], 2, var))^-1) sigma = lapply(1:k, function(i) diag(1/rexp(p, rate = sigma.hyp[[i]]))) } else { sigma.hyp = apply(sapply(1:k, function(i) (apply(x.bin[[i]], 2, var))^-1), 2, mean) sigma = diag(1/rexp(p, rate = sigma.hyp)) } } if (is.null(sigma) == FALSE && arbvar == TRUE) { k = length(sigma) } if (is.null(mu)) { mu.hyp <- lapply(1:k, function(i) apply(x.bin[[i]], 2, mean)) if (arbvar) { mu <- lapply(1:k, function(i) as.vector(rmvnorm(1, mu = as.vector(mu.hyp[[i]]), sigma = as.matrix(sigma[[i]])))) } else mu <- lapply(1:k, function(i) as.vector(rmvnorm(1, mu = as.vector(mu.hyp[[i]]), sigma = as.matrix(sigma)))) if (arbmean==FALSE) { mu <- apply(sapply(mu,as.vector),1,mean) # mu <- lapply(1:k, function(i) mu) } } if (is.null(mu) == FALSE && arbmean == TRUE){ k=length(mu) } if (is.null(lambda)) { lambda <- runif(k) lambda <- lambda/sum(lambda) } else k <- length(lambda) list(lambda = lambda, mu = mu, sigma = sigma, k = k) }mixtools/R/mvnormalmixEM.R0000755000176200001440000001555614342153463015273 0ustar liggesusersmvnormalmixEM = function (x, lambda = NULL, mu = NULL, sigma = NULL, k = 2, arbmean = TRUE, arbvar = TRUE, epsilon = 1e-08, maxit = 10000, verb = FALSE) { if(arbmean == FALSE && arbvar == FALSE){ stop(paste("Must change constraints on mu and/or sigma!","\n")) } x <- as.matrix(x) n <- nrow(x) p <- ncol(x) tmp <- mvnormalmix.init(x = x, lambda = lambda, mu = mu, sigma = sigma, k = k, arbmean=arbmean, arbvar = arbvar) lambda <- tmp$lambda mu<-tmp$mu sigma <- tmp$sigma k = tmp$k diff <- 1 iter <- 0 if (arbmean==FALSE){ comp <- lapply(1:k, function(i) lambda[i] * dmvnorm(x, mu, sigma[[i]])) } else{ if (arbvar==FALSE) { comp <- lapply(1:k, function(i) lambda[i] * dmvnorm(x, mu[[i]], sigma)) } else comp <- lapply(1:k, function(i) lambda[i] * dmvnorm(x, mu[[i]], sigma[[i]])) } comp <- sapply(comp, cbind) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik restarts <- 0 while (diff > epsilon & iter < maxit) { if (arbvar) { z = matrix(nrow = n, ncol = k) for (i in 1:n) { for (j in 1:k) { z.denom = c() for (m in 1:k) { z.denom = c(z.denom, lambda[m]/lambda[j] * (det(sigma[[j]])/det(sigma[[m]]))^(0.5) * exp(-0.5 * ((x[i, ] - mu[[m]]) %*% solve(sigma[[m]]) %*% t(t(x[i, ] - mu[[m]])) - (x[i, ] - mu[[j]]) %*% solve(sigma[[j]]) %*% t(t(x[i, ] - mu[[j]]))))) } z[i, j] = 1/sum(z.denom) } } z = z/apply(z,1,sum) # z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) sing <- sum(is.nan(z)) lambda.new <- apply(z, 2, mean) if (sum(lambda.new < 1e-08)>0 || is.na(sum(lambda.new))) { sing <- 1 } else { if(arbmean==FALSE) { mu.new <- lapply(1:k, function(j) sapply(1:p, function(i) apply(z * x[, i], 2, sum))[j, ]) mu.new <- apply(sapply(mu.new,as.vector),1,sum)/n mu.new <- lapply(1:k, function(j) mu.new) } else{ mu.new <- lapply(1:k, function(j) sapply(1:p, function(i) apply(z * x[, i], 2, sum))[j, ]/sum(z[, j])) } sigma.new <- lapply(1:k, function(j) matrix(apply(sapply(1:n, function(i) z[i, j] * (x[i, ] - mu.new[[j]]) %*% t(x[i, ] - mu.new[[j]])), 1, sum), p, p)/sum(z[, j])) lambda <- lambda.new mu <- mu.new sigma <- sigma.new comp <- lapply(1:k, function(i) lambda[i] * dmvnorm(x, mu[[i]], sigma[[i]])) comp <- sapply(comp, cbind) compsum <- apply(comp, 1, sum) newobsloglik <- sum(log(compsum)) } } else { z = matrix(nrow = n, ncol = k) sigma.inv = solve(sigma) for (i in 1:n) { for (j in 1:k) { z.denom = c() for (m in 1:k) { z.denom = c(z.denom, lambda[m]/lambda[j] * (det(sigma.inv)/det(sigma.inv))^(0.5) * exp(-0.5 * ((x[i, ] - mu[[m]]) %*% sigma.inv %*% t(t(x[i, ] - mu[[m]])) - (x[i, ] - mu[[j]]) %*% sigma.inv %*% t(t(x[i, ] - mu[[j]]))))) } z[i, j] = 1/sum(z.denom) } } # z[,k]=1-apply(as.matrix(z[,(1:(k-1))]),1,sum) z = z/apply(z,1,sum) sing <- sum(is.nan(z)) lambda.new <- apply(z, 2, mean) if (sum(lambda.new < 1e-08)>0 || is.na(sum(lambda.new))) { sing <- 1 } else { if(arbmean==FALSE) { mu.new <- lapply(1:k, function(j) sapply(1:p, function(i) apply(z * x[, i], 2, sum))[j, ]) mu.new <- apply(sapply(mu.new,as.vector),1,sum)/n mu.new <- lapply(1:k, function(j) mu.new) } else{ mu.new <- lapply(1:k, function(j) sapply(1:p, function(i) apply(z * x[, i], 2, sum))[j, ]/sum(z[, j])) } temp.sig <- lapply(1:k, function(j) matrix(apply(sapply(1:n, function(i) z[i, j] * (x[i, ] - mu.new[[j]]) %*% t(x[i, ] - mu.new[[j]])), 1, sum), p, p)) sigma.new <- matrix(apply(sapply(temp.sig, as.vector), 1, sum), p, p)/n lambda <- lambda.new mu <- mu.new sigma <- sigma.new comp <- lapply(1:k, function(i) lambda[i] * dmvnorm(x, mu[[i]], sigma)) comp <- sapply(comp, cbind) compsum <- apply(comp, 1, sum) newobsloglik <- sum(log(compsum)) } } if (sing > 0 || is.na(newobsloglik) || abs(newobsloglik) == Inf){# || sum(z) != n) { cat("Need new starting values due to singularity...", "\n") restarts <- restarts + 1 if(restarts>15) stop("Too many tries!") tmp <- mvnormalmix.init(x = x, k = k, arbmean=arbmean, arbvar = arbvar) lambda <- tmp$lambda mu <- tmp$mu sigma <- tmp$sigma k = tmp$k diff <- 1 iter <- 0 if (arbvar) { comp <- lapply(1:k, function(i) lambda[i] * dmvnorm(x, mu[[i]], sigma[[i]])) } else comp <- lapply(1:k, function(i) lambda[i] * dmvnorm(x, mu[[i]], sigma)) comp <- sapply(comp, cbind) compsum <- apply(comp, 1, sum) obsloglik <- sum(log(compsum)) ll <- obsloglik } else { diff <- newobsloglik - obsloglik obsloglik <- newobsloglik ll <- c(ll, obsloglik) iter <- iter + 1 if (verb) { cat("iteration=", iter, "diff=", diff, "log-likelihood", obsloglik, "\n") } } } if(arbmean==FALSE) { mu = mu[[1]] } if (iter == maxit) { cat("WARNING! NOT CONVERGENT!", "\n") } colnames(z) <- c(paste("comp", ".", 1:k, sep = "")) cat("number of iterations=", iter, "\n") a=list(x=x, lambda = lambda, mu = mu, sigma = sigma, loglik = obsloglik, posterior = z, all.loglik=ll, restarts=restarts, ft="mvnormalmixEM") class(a) = "mixEM" a } mixtools/R/WeibullRMMSEM.R0000644000176200001440000002035014342153463015005 0ustar liggesusers# code for Reliability Mixture Models (RMM) with Censored data # D. Chauveau # ref: Bordes L. and Chauveau D. Computational Statistics (2016) # Simulate from a Weibull mixture # lambda = vector of component probabilities # shape, scale = vector of component rates rweibullmix <- function(n,lambda=1, shape=1, scale=1) { m <- length(lambda) # nb of components z <- sample(m, n, replace=TRUE, prob=lambda) # component indicator rweibull(n, shape = shape[z], scale=scale[z]) } ######################################################################## ## Stochastic EM algorithm for Reliability Mixture Models (RMM) ## with Censoring; Parametric model, for ## univariate finite mixture of Weibull with right censoring # x = lifetime data, censored by random c if d is not NULL, in which case # x= min(x,c) and d = I(x <= c) # uses parametric MLE for censored weibull data from the survival package # caution: when fitted by a survreg object, the weibull parametrization is # shape=1/fit$scale and scale=exp(fit$coeff) # averaged = TRUE if averaging of the parameters is computed at each iteration # (cf Nielsen 2000) # NB: averaging can be done in several ways; # DEPRECATED: the current theta for E & M steps is the average over the sequence, # but the theta^next not averaged is stored on the sequence # CURRENT VERSION: the average is stored and used for next step # # About calls of survreg() from the survival package: # maxit.survreg is # passed to survreg.control() for weibull MLE using survreg() weibullRMM_SEM <- function (x, d=NULL, lambda = NULL, shape = NULL, scale = NULL, # dweibull() parameters k = 2, # default nb of components maxit = 200, # maxrestarts = 20, maxit.survreg = 200, epsilon = 1e-03, averaged = TRUE, verb = FALSE) { # warn <- options(warn=-1) # Turn off warnings # x <- as.vector(x) # require(survival) n <- length(x) if (!is.null(lambda)) k=length(lambda) if (!is.null(scale)) k=length(scale) # at least one if (!is.null(shape)) k=length(shape) # should be define !!! if (is.null(d)) d <- rep(1,n) # noncensored case forced xx <- matrix(x, nrow=n, ncol=k) # x repeated k times, used in E-steps dd <- matrix(d, nrow=n, ncol=k) # idem for d # # note: d can be used instead of dd since automatic recycling gives # dd*xx = d*xx, but we keep dd to avoid eventual futur change # init function call to do later, in case lambda = rate = NULL if (is.null(lambda)) lambda <- rep(1/k,k) if (is.null(scale)) scale <- rep(1,k) # to do : init.functions(k) if (is.null(shape)) shape <- rep(1,k) # # sequences for storing along iterations lambda_seq <- scale_seq <- shape_seq <- matrix(0, nrow = maxit, ncol = k) lambda_seq[1,] <- lambda scale_seq[1,] <- scale; shape_seq[1,] <- shape loglik_seq <- NULL oldloglik <- -Inf # notdone <- TRUE # for handling restarts etc, ToDo later! # while(notdone) { # Initialize everything notdone <- FALSE # dll <- epsilon+1 iter <- 1 post <- z <- sumpost <- matrix(0, nrow = n, ncol = k) new_scale <- new_shape <- rep(0,k) ##### SEM iterations ##### while (iter < maxit) { # SEM version ### E-step ### scn <- matrix(scale, n, k, byrow=T) # for vectorized post comput. shn <- matrix(shape, n, k, byrow=T) ll <- matrix(lambda, n, k, byrow=T) # handling censored & non-censored cases post <- ((ll*dweibull(xx,shn,scn))^dd)*((ll*(1-pweibull(xx,shn,scn)))^(1-dd)) rs <- rowSums(post) loglik <- sum(log(rs)) # loglik without the constant term related to h pdf # post normalized per row post <- sweep(post, 1, rs, "/") # posteriors p_{ij}^t 's # check and solve NaN's: may cause theoretical pbs!? snans <- sum(is.na(post)) if (snans > 0) { post[is.na(post[,1]),] <- 1/k cat("warning:",snans, "NaN's in post\n") } ### S-step ### # ~ matrix of component indicators simu checked ? z <- t(apply(post, 1, function(prob) rmultinom(1, 1, prob))) nsets <- colSums(z) # subsets per component sizes # cat("it",iter,": sets=",nsets,"\n") ### M-step ### # new_parameter = SEM(lambda,shape,scale) new_lambda <- nsets/n # or colMeans(post) if EM version preferred for (j in 1:k) { # for each component; vectorize later? tj <- x[z[,j]==1] # subsample from component j dj <- d[z[,j]==1] # associated event indicator # passing maxit and epsilon parameters to survreg # and current shape & scale as init parameters fit=survreg(Surv(tj,dj)~1, dist = 'weibull', control = survreg.control(maxiter = maxit.survreg, rel.tolerance=epsilon), init.beta=log(scale), init.scale=1/shape) new_scale[j] <- exp(fit$coeff) new_shape[j] <- 1/fit$scale } # Next parameter value, depending on average strategy if (averaged) { scale <- (new_scale + iter*scale_seq[iter,])/(iter+1) shape <- (new_shape + iter*shape_seq[iter,])/(iter+1) lambda <- (new_lambda + iter*lambda_seq[iter,])/(iter+1) } else { # averaged=FALSE case, just use last update scale <- new_scale shape <- new_shape lambda <- new_lambda } # new strategy = storing sequence of averages lambda_seq[iter+1, ] <- lambda scale_seq[iter+1, ] <- scale shape_seq[iter+1, ] <- shape dll <- loglik - oldloglik # = Inf for iter=0 1st time oldloglik <- loglik loglik_seq <- c(loglik_seq, loglik) if (verb) { cat("iteration", iter, " log-lik diff =", dll, " log-lik =", loglik, "\n") # print(rbind(lambda, rate)) } iter <- iter + 1 } # end of SEM loops over iterations # } # while notdone, if restarts control implemented # final estimates depending on average strategy if (averaged) { final.lambda <- lambda final.scale <- scale final.shape <- shape } else { final.scale <- colMeans(scale_seq[1:iter,]) final.shape <- colMeans(shape_seq[1:iter,]) final.lambda <- colMeans(lambda_seq[1:iter,]) } cat("number of iterations =", iter, "\n") colnames(post) <- c(paste("comp", ".", 1:k, sep = "")) a=list(x=x, d=d, lambda = final.lambda, scale = final.scale, shape = final.shape, loglik = loglik, posterior = post, all.loglik=loglik_seq, all.lambda = lambda_seq[1:iter,], all.scale = scale_seq[1:iter,], all.shape = shape_seq[1:iter,], ft="weibullRMM_SEM") class(a) = "mixEM" a } ################################################## # plot SEM sequences from weibullRMM_SEM: # color by components, one plot per parameter type plotweibullRMM <- function(a, title=NULL, rowstyle=TRUE, subtitle=NULL,...) { n <- length(a$x); m <- dim(a$all.lambda)[2] pcc <- round(100*(1-mean(a$d)),2) if (is.null(subtitle)) { subtitle <- paste("n=",n,", ", pcc, "% censored", sep="")} if (is.null(title)) { tt1 <- "Shape parameters"; tt2 <- "Scale parameters" tt3 <- "Weight parameters" } else tt1 <- tt2 <- tt3 <- title lwdset <- 2 if (rowstyle) par(mfrow=c(3,1)) else par(mfrow=c(1,3)) plot(a$all.shape[,1], type="l", ylim=c(0,max(a$all.shape)), xlab="iterations", ylab="estimates", main=tt1, ...) # if (truevalues) abline(shape[1],0,lty=3) title(sub=subtitle, cex.sub = 0.75) lgd <- expression(sh[1]); lcol <- 1 for (j in 2:m) { lines(a$all.shape[,j], col=j, ...) # if (truevalues) abline(shape[j],0,col=j,lty=3) lgd <- c(lgd,substitute(sh[j])); lcol <- c(lcol,j) } legend("topright", lgd, col=lcol, lty=1,...) plot(a$all.scale[,1], type="l", ylim=c(0,max(a$all.scale)), xlab="iterations", ylab="estimates", main=tt2, ...) # if (truevalues) abline(scale[1],0,lty=3) title(sub=subtitle, cex.sub = 0.75) lgd <- expression(sc[1]); lcol <- 1 for (j in 2:m) { lines(a$all.scale[,j], col=j, ...) # if (truevalues) abline(scale[j],0,col=j,lty=3) lgd <- c(lgd,substitute(sc[j])); lcol <- c(lcol,j) } legend("topright", lgd, col=lcol, lty=1, ...) plot(a$all.lambda[,1], type="l", ylim=c(0,1), xlab="iterations", ylab="estimates", main=tt3, ...) # if (truevalues) abline(lambda[1],0,lty=3) title(sub=subtitle,cex.sub = 0.75) lgd <- expression(lambda[1]); lcol <- 1 for (j in 2:m) { lines(a$all.lambda[,j], col=j, ...) # if (truevalues) abline(lambda[j],0,col=j,lty=3) lgd <- c(lgd,substitute(lambda[j])) lcol <- c(lcol,j) } legend("topright", lgd, col=lcol, lty=1, ...) } mixtools/R/logitfns.R0000755000176200001440000000007314342153463014311 0ustar liggesuserslogit <- binomial()$linkfun inv.logit <- binomial()$linkinvmixtools/R/makemultdata.R0000755000176200001440000000227414342153463015142 0ustar liggesusersmakemultdata = function (..., cuts) { temp = sapply(list(...), length) m = max(temp) g <- length(cuts) + 1 cuts <- sort(cuts) if (sum(temp != m) > 0) { full.data <- function(x, maxm) { if (!missing(x)) { if (length(x) < maxm) { x <- c(x, NA * rep(1, maxm - length(x))) } } else { x <- numeric(0) } x } x = sapply(list(...), full.data, maxm = m) } else { if (sapply(list(...), is.matrix) == 1 | sapply(list(...), is.data.frame) == 1) { x = t(...) } else x = cbind(...) } cutfunc <- function(x, lcut, ucut) { x <- na.omit(x) sum((x <= ucut) * (x > lcut)) } n <- ncol(x) y <- matrix(0, g, n) y[1, ] <- apply(x, 2, cutfunc, ucut = cuts[1], lcut = -Inf) y[g, ] <- apply(x, 2, cutfunc, ucut = Inf, lcut = cuts[g - 1]) if (g > 2) { for (i in 2:(g - 1)) { y[i, ] <- apply(x, 2, cutfunc, ucut = cuts[i], lcut = cuts[i - 1]) } } list(x = t(x), y = t(y)) }mixtools/R/kernG.R0000755000176200001440000000011414342153463013526 0ustar liggesuserskern.G <- function (x, xi, h) { exp(-((xi-x)/h)^2/2)/sqrt(2*pi)/h } mixtools/R/plotly_compCDF.R0000644000176200001440000000603514343035706015343 0ustar liggesusersplotly_compCDF <- function(data, weights, x=seq(min(data, na.rm=TRUE), max(data, na.rm=TRUE), len=250), comp=1:NCOL(weights), makeplot=TRUE, cex = 3, width = 3, legend.text = "Composition", legend.text.size = 15, legend.size = 15, title = "Empirical CDF", title.x = 0.5, title.y = 0.95, title.size = 15, xlab = "Data", xlab.size = 15, xtick.size = 15, ylab = "Probability", ylab.size = 15, ytick.size = 15, col.comp = NULL){ if (NROW(weights) != NROW(data)) { stop("data and weights arguments must have same number of rows") } if (is.null(col.comp)){ col.comp <- hue_pal()(length(comp)) } if (length(col.comp) != length(comp)){ print(paste("Please specify",length(comp),"colors in 'col.comp'.")) } # First, normalize the weights so the sum of each column is 1/NCOL(data) weights <- t(t(weights) / (NCOL(data) * colSums(weights))) # Next, give a binomial count for each row of the data and for each x f <- function(row, cutpt) colSums(outer(row, cutpt, "<="), na.rm = TRUE) bc <- apply(data, 1, f, x) # bc is a length(x) by n matrix; each column should be multiplied by # the appropriate weight(s) and then the rows summed to give the # unnormalized cdf estimates. This is just a matrix product. cdfs <- bc %*% weights[,comp,drop=FALSE] if(makeplot) { plot <- plot_ly() for (i in 1:length(comp)) { plot <- add_trace(plot, plot, x=x , y=cdfs[,comp[i]] , type = 'scatter' , mode = 'lines+markers', marker = list(size = cex , color = col.comp[i]), line = list(width = width , color = col.comp[i]), name = comp[i] , showlegend = TRUE) %>% plotly::layout( legend = list(title=list(text=legend.text, font=list(size=legend.text.size)), font = list(size=legend.size)), title = list(text = title, x = title.x, y = title.y, font = list(size=title.size)), xaxis = list(title = list(text = xlab, font = list(size = xlab.size)), tickfont = list(size = xtick.size) ), yaxis = list(title = list(text = ylab, font = list(size = ylab.size)), tickfont = list(size = ytick.size), range = c(0 , 1) ) ) } print(plot) } invisible(t(cdfs)) } mixtools/R/regmixmixedinit.R0000755000176200001440000000720614342153463015677 0ustar liggesusersregmix.mixed.init <- function(y,x,w=NULL,sigma=NULL,arb.sigma=TRUE, alpha=NULL,lambda=NULL,mu=NULL,R=NULL,arb.R=TRUE,k=2,mixed=FALSE, addintercept.fixed=FALSE,addintercept.random=TRUE){ N <- length(y) n <- sapply(y, length) p <- ncol(x[[1]]) if (addintercept.random) { x = lapply(1:N, function(i) as.matrix(x[[i]][,-1])) } else x=x if(is.null(w)==FALSE && sum(sapply(w,sum))!=0){ q <- ncol(w[[1]]) } if (mixed == TRUE && is.null(alpha)==TRUE) { if (addintercept.fixed) { w.1 = list() w.1 = lapply(1:N,function(i) w[[i]][,-1]) lm.out = lapply(1:N,function(i) lm(y[[i]]~w.1[[i]])) alpha.hyp = apply(matrix(sapply(lm.out,coef),ncol=N),1,mean) sd.hyp = lapply(lm.out,anova) sd.hyp = mean(as.vector(sqrt(sapply(1:N,function(i) sd.hyp[[i]]$Mean[length(sd.hyp[[i]]$Mean)])))) alpha = rnorm(q, mean=alpha.hyp, sd=sd.hyp) } else { w.1 = w lm.out = lapply(1:N,function(i) lm(y[[i]]~w.1[[i]]-1)) alpha.hyp = apply(matrix(sapply(lm.out,coef),ncol=N),1,mean) sd.hyp = lapply(lm.out,anova) sd.hyp = mean(as.vector(sqrt(sapply(1:N,function(i) sd.hyp[[i]]$Mean[length(sd.hyp[[i]]$Mean)])))) alpha = rnorm(q, mean=alpha.hyp, sd=sd.hyp) } } if(mixed==FALSE) { alpha = 0 } y.x = lapply(1:N, function(i) cbind(y[[i]],x[[i]])) a = order(sapply(1:N, function(i) mean(y[[i]]))) y.x = lapply(1:N,function(i) y.x[[a[i]]]) y.x.bin.list = list() y.x.bin = list() for(j in 1:k){ y.x.bin.list[[j]] <- y.x[max(1,floor((j-1)*N/k)):ceiling(j*N/k)] y.x.2 <- NULL for(i in 1:length(y.x.bin.list[[j]])){ y.x.2 <- rbind(y.x.2,y.x.bin.list[[j]][[i]]) } y.x.bin[[j]] <- y.x.2 } if(addintercept.random){ lm.out <- lapply(1:k, function(i) lm(y.x.bin[[i]][,1]~y.x.bin[[i]][,2:p])) lm.out.beta <- lapply(1:k, function(j) lapply(1:length(y.x.bin.list[[j]]), function(i) lm(y.x.bin.list[[j]][[i]][,1]~y.x.bin.list[[j]][[i]][,2:p]))) beta <- lapply(1:k,function(j) matrix(sapply(lm.out.beta[[j]],coef),nrow=p)) } else { lm.out <- lapply(1:k, function(i) lm(y.x.bin[[i]][,1]~y.x.bin[[i]][,2:(p+1)]-1)) lm.out.beta <- lapply(1:k, function(j) lapply(1:length(y.x.bin.list[[j]]), function(i) lm(y.x.bin.list[[j]][[i]][,1]~y.x.bin.list[[j]][[i]][,2:(p+1)]-1))) beta <- lapply(1:k,function(j) matrix(sapply(lm.out.beta[[j]],coef),nrow=p)) } if(is.null(sigma)) { sigma.hyp = lapply(lm.out,anova) sigma.hyp = as.vector(sqrt(sapply(1:k,function(i) sigma.hyp[[i]]$Mean[length(sigma.hyp[[i]]$Mean)]))) if(arb.sigma) { sigma=1/rexp(k,rate=sigma.hyp) } else { sigma.hyp=mean(sigma.hyp) sigma=1/rexp(1,rate=sigma.hyp) } } if(is.null(sigma)==FALSE && arb.sigma==TRUE) { k=length(sigma) } if(is.null(R)) { if(arb.R) { R.hyp = lapply(1:k,function(i) (apply(beta[[i]],1,var))^-1) R=lapply(1:k,function(i) diag(1/rexp(p,rate=R.hyp[[i]]),p)) } else { R.hyp = apply(matrix(sapply(1:k,function(i) (apply(beta[[i]],1,var))^-1),ncol=k),2,mean) R = diag(1/rexp(p,rate=sigma.hyp),p) } } if(is.null(R)==FALSE && arb.R==TRUE) { k=length(R) } if (is.null(mu)) { mu.hyp = lapply(1:k,function(i) apply(beta[[i]],1,mean)) mu = matrix(ncol=k,nrow=p) if(arb.R==TRUE){ for(j in 1:k){ mu[,j] = rmvnorm(1,mu=as.vector(mu.hyp[[j]]),sigma=R[[j]]) } } else { for(j in 1:k){ mu[,j] = rmvnorm(1,mu=as.vector(mu.hyp[[j]]),sigma=R) } } } else k = ncol(mu) if (is.null(lambda)) { lambda = runif(k) lambda = lambda/sum(lambda) } else k = length(lambda) list(sigma=sigma,alpha=alpha,lambda=lambda,mu=mu,R=R,k=k) }mixtools/R/spregmix.R0000755000176200001440000001230414342153463014322 0ustar liggesusersspregmix = function (lmformula, bw = NULL, constbw = FALSE, bwmult = 0.9, # gives Silverman's rule; or use 1.06 for Scott's z.hat = NULL, symm = TRUE, betamethod="LS", m = ifelse(is.null(z.hat), 2, ncol(z.hat)), epsilon = 1e-04, maxit = 1000, verbose = FALSE, ...) { # m, not k, is the number of components here y <- model.frame(lmformula, ...)[,1] x <- model.matrix(lmformula, ...) n <- length(y) p <- ncol(x) tt0 <- proc.time() # for total time # Now initialize z.hat, which is the only thing needed to start the iterations # as long as we use a method such as least squares to find beta if(is.null(z.hat)) { z.hat <- matrix(runif(n*m), n, m) z.hat <- sweep(z.hat, 1, rowSums(z.hat), "/") } L1norm <- function(beta, y, x, p) sum(p*abs(y - x %*% beta)) nploglik <- function(beta, y, x, p, bw, res, wts, symm) { sum(p*log(wkde(x=res, u=as.vector(y-x%*%beta), w=wts, bw=bw, sym=symm))) } lambda <- matrix(0, maxit, m) beta <- matrix(0, p, m) for (j in 1:m) { # Initialize beta to weighted LS solution wx <- sweep(x, 1, z.hat[,j], "*") beta[,j] <- solve(t(wx) %*% x, t(wx) %*% y) } iter <- 0 finished <- FALSE # j <- 0 #plot(tonedata) SPweight <- ifelse(betamethod=="transition", 0, 1) while (!finished) { # j <- j + 1; if (j>m) { #browser(); #plot(x[,2],y); # j <- 1} iter <- iter + 1 t0 <- proc.time() ## M-step lambda[iter, ] <- colMeans(z.hat) oldbeta <- beta for (j in 1:m) { #abline(beta[1,j],beta[2,j], col=1+j, lwd=3, lty=2) if (betamethod=="LS") { wx <- sweep(x, 1, z.hat[,j], "*") beta[,j] <- solve(t(wx) %*% x, t(wx) %*% y) # Weighted least squares solution } else if (betamethod=="L1") { # Weighted L1 solution beta[,j] <- optim(par=beta[,j], fn=L1norm, y=y, x=x, p=z.hat[,j])$par } else if (betamethod=="transition") { # transition from LS to NP wx <- sweep(x, 1, z.hat[,j], "*") beta[,j] <- SPweight * optim(par=beta[,j], fn=nploglik, y=y, x=x, p=z.hat[,j], bw=bw, res=as.vector(y-x%*%beta), wts=as.vector(z.hat), symm=symm, control=list(fnscale=-1))$par + # NP loglik (1-SPweight) * solve(t(wx) %*% x, t(wx) %*% y) # Weighted least squares SPweight <- min(1, SPweight + (1e-4)*2^(iter-1)) } else { # Nonparametric loglikelihood beta[,j] <- optim(par=beta[,j], fn=nploglik, y=y, x=x, p=z.hat[,j], bw=bw, res=as.vector(y-x%*%beta), wts=as.vector(z.hat), symm=symm, control=list(fnscale=-1))$par #res=as.vector(y-x%*%beta) #plot(res,wkde(x=res, u=res, w=as.vector(z.hat), bw=bw, sym=symm)) #browser() } ## Here, we might try other methods of estimating beta. } ## update the bandwidth, if necssary xbetavec <- as.double(x %*% beta) zhatvec <- as.double(z.hat) if (is.null(bw) || !constbw) { res <- y-xbetavec np.sigma <- sqrt(sum(res^2 * zhatvec)/(n-1)) bw <- bwmult / n^(1/5) * min(np.sigma, wiqr<-wIQR(wt=zhatvec, x=res)/1.34) #print(c(np.sigma, wiqr)) } ## density estimation step if (symm) { ans <- .C(C_KDEsymloc2, n=as.integer(n), m=as.integer(m), mu = xbetavec, y=as.double(y), bw=as.double(bw), z=as.double(z.hat), f=double(n*m)) } else { ans <- .C(C_KDEloc2, n=as.integer(n), m=as.integer(m), mu = xbetavec, y=as.double(y), bw=as.double(bw), z=as.double(z.hat), f=double(n*m)) } fkernel <- matrix(ans$f, ncol=m) lambda.f <- sweep(fkernel, 2, lambda[iter,], "*") ## E-step (for next iteration) z.hat <- lambda.f/rowSums(lambda.f) ## Test convergence criteria finished <- (iter > 1 && SPweight == 1 && (iter >= maxit || max(max(abs(beta-oldbeta)), max(abs(lambda[iter,]-lambda[iter-1,]))) < epsilon )) ## Print message for each iteration if (verbose) { t1 <- proc.time() cat("iteration ", iter, " lambda ", round(lambda[iter,], 4), " bandwidth ", round(bw, 3)) cat(" time", (t1 - t0)[3], "\n") } } ## Print final message after convergence if (verbose) { tt1 <- proc.time() cat("lambda ", round(lambda[iter,], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } res <- ans$y - ans$mu xx <- res yy <- ans$f if (symm) { xx <- c(xx, -res) # exploiting symmetry yy <- c(yy, yy) } ox <- order(xx) np.sigma <- sqrt(sum(res^2 * ans$z)/(n-1)) loglik <- rep(0, n) for(j in 1:m) { loglik <- loglik + z.hat[,j]*wkde(as.vector(y-x%*%beta[,j]), w=as.vector(z.hat[,j]), bw=bw, sym=symm) } loglik <- sum(log(loglik)) a <- list(x=x, y=y, lambda = lambda[1:iter,], beta = beta, posterior = z.hat, np.stdev = np.sigma, bandwidth=bw, density.x = xx[ox], density.y = yy[ox], symmetric=symm, loglik = loglik, ft="regmixEM") class(a) = "npEM" a } mixtools/R/ldmult.R0000755000176200001440000000107114342153463013764 0ustar liggesusers########################################################################### # log density function of multinomial count vector y with parameter theta # ########################################################################### ldmult<-function(y,theta){ if (any(is.nan(theta)) || any(theta==0)) { # stop ("The theta parameter cannot have a zero component.") out = -Inf } else { if (length(y)==length(theta)+1) theta=c(theta,1-sum(theta)) out=lgamma(1+sum(y)) - sum(lgamma(1+y)) + sum(y*log(theta)) } out } mixtools/R/FDR_spEM.R0000644000176200001440000001270114342153463014021 0ustar liggesusers################################################################# ## FUNCTIONS FOR FALSE DISCOVERY RATE (FDR) ESTIMATION ## ## USING SEMI-PARAMETRIC EM-LIKE ALGORITHMS ## ## D. CHAUVEAU ## ## mixtools 1.0 addition ## ################################################################# ################################################################# ## EM-like algorithm for a nonparametric univariate mixture model ## - Component 1 known = N(0,1) ## = the pdf of a probit transform of pvalue under H0 ## - component 2 symmetric shifted from a location parameter mu ## NB: stochastic=TRUE not implemented, parameter removed here spEMsymlocN01 <- function(x, mu0=2, bw = bw.nrd0(x), h=bw, eps = 1e-8, maxiter=100, verbose = FALSE, plotf=FALSE){ bw <- h # h is alternative bandwidth argument, for backward compatibility n <- length(x) # if (length(mu0)>1) m <- length(mu0) else m <- mu0 m <- 2 # fixed number of components in this model z.hat <- matrix(0, nrow=n, ncol=m) fkernel <- matrix(0, nrow=n, ncol=m) tt0 <- proc.time() o <- order(x) # for plotting fhat's if requested kmeans <- kmeans(x, mu0) # is this a good init for probit data? for(j in 1:m) { z.hat[kmeans$cluster==j, j] <- 1 } iter <- 0 finished <- FALSE lambda <- matrix(0,maxiter,m) mu <- rep(0,maxiter) # only component 2 mean used in this case while (!finished) { #while (max(abs(change)) > eps & iter < maxiter) { iter <- iter + 1 t0 <- proc.time() ## M-Step lambda[iter,] <- colMeans(z.hat) # mu[iter,] <- apply(sweep(z.hat, 1, x, "*"), 2, mean)/lambda[iter,] mu[iter] <- sum(x*z.hat[,2])/(n*lambda[iter,2]) # ## second component density estimation step evaluated at x_i-mu's ans <- .C(C_KDEsymloc1comp, n=as.integer(n), mu=as.double(mu[iter]), lbd2=as.double(lambda[iter,2]), x=as.double(x), bw=as.double(bw), z=as.double(z.hat), f = double(n)) #add PACKAGE="mixtools" option when integrated # successive plots of fhat's (for debugging mostly) if (plotf) { if (iter==1) plotfunc <- plot else plotfunc <- lines plotfunc(x[o],ans$f[o],type="l", col=iter) } # version lambda_j f_j(xi) specific for component one = N(0,1) # NB: this is the only place where the known component pdf is used lambda.f <- cbind(lambda[iter,1]*dnorm(x), lambda[iter,2]*ans$f) ## E-step (for next iteration) z.hat <- lambda.f/rowSums(lambda.f) finished <- iter >= maxiter if (iter>1) { # This convergence criterion is too simplistic: change <- c(lambda[iter,] - lambda[iter-1,], mu[iter]-mu[iter-1]) finished <- finished | (max(abs(change)) < eps) } if (verbose) { t1 <- proc.time() cat("iteration ", iter, " lambda ", round(lambda[iter,], 4), " mu ", round(mu[iter], 4)) cat(" time", (t1 - t0)[3], "\n") } } if (verbose) { tt1 <- proc.time() cat("lambda ", round(lambda[iter,], 4)) cat(", total time", (tt1 - tt0)[3], "s\n") } return(structure(list(data=x, posteriors=z.hat, lambda=lambda[1:iter,], bandwidth=bw, lambdahat=lambda[iter,], mu = mu[1:iter], muhat = mu[iter], symmetric=TRUE), class="spEMN01")) } ####################################################### # plot mixture pdf for the semiparametric mixture model # with component 1 pdf passed in the knownpdf parameter # uses a weighted kernel density estimate of the nonparametric component 2 # a = object of class "spEMN01" as returned by spEMsymlocNorm plot.spEMN01 <- function(x, bw=x$bandwidth, knownpdf=dnorm, add.plot=FALSE, ...) { t <- seq(min(x$data), max(x$data), len=200) f1 <- x$lambdahat[1]*knownpdf(t) f2 <- x$lambdahat[2]*wkde(x$data-x$muhat, u=t-x$muhat, w=x$post[,2], bw=bw, sym=TRUE) f <- f1+f2 if (!add.plot) plot(t,f1+f2, type="l", ...) else lines(t,f1+f2, ...) lines(t,f1, col=2); lines(t,f2, col=3) } #################################################### # plot and compare FDR for 1 or 2 EM-like strategies # for mixtools 1.0 # post NEEDS to be sorted by p plotFDR <- function(post1, post2=NULL, lg1="FDR 1", lg2=NULL, title=NULL, compH0=1, alpha=0.1, complete.data =NULL, pctfdr=0.3) { n <- dim(post1)[1] cs1 <- cumsum(post1[,compH0]) # local FDR(p_i)'s fdr1 <- cs1/(1:n) # FDR(p_i)'s if (is.null(title)) title <- paste("FDR estimate(s), n=",n) if (!is.null(post2)) { cs2 <- cumsum(post2[,compH0]) # local FDR(p_i)'s fdr2 <- cs2/(1:n) if (is.null(lg2)) lg2 <- "FDR 2" } i1 <- sum(fdr1 pctfdr # cat("index",i1) plot(fdr1[1:i1], type="l", main=title, col=1, ylim=c(0,fdr1[i1]), xlab="index", ylab="probability") if (!is.null(post2)) lines(fdr2[1:i1], col=2) abline(alpha, 0, lty=3) if (!is.null(complete.data)) { # true complete data available V <- cumsum(complete.data[,1]==1) # cumulative nb of items under H0 trueFDR <- V/(1:n) lines(trueFDR[1:i1], lty=2, col=3) if (!is.null(post2)) legend("topleft", c(lg1,lg2,"True FDR"),col=1:3, lty=c(1,1,2)) if (is.null(post2)) legend("topleft", c(lg1,"True FDR"),col=c(1,3), lty=c(1,2)) } else { if (!is.null(post2)) legend("topleft", c(lg1,lg2), col=1:2, lty=c(1,1)) if (is.null(post2)) legend("topleft", lg1, col=1, lty=1) } } mixtools/MD50000644000176200001440000002777314343400153012455 0ustar liggesusers270a40ed5bd2992046f325a0ac981820 *DESCRIPTION 9966bf4ceb520ccd6daf862c72d27578 *NAMESPACE 42d2dea1ac3c0b7ed39c7fe3e1d7caac *NEWS b5e2b87ba9803aa4f1f8770641aa301c *R/FDR_spEM.R 96eb008edd1ebc2806b5434abec323b8 *R/WeibullRMMSEM.R 13dd98fd3d2a18d733dc7c1bb00cbd4a *R/augx.R f18b7cd3707169418f6cd7be7583425d *R/bootcomp.R 30953093ca9c5aaf02e0e8102230a94d *R/bootse.R 99dbcce1ed200436d59d035818a844da *R/compcdf.R e2442e00a19de3f3c7d1b2938e61bc2f *R/ddirichlet.R 059b14e5defb7a753aa97dad8c53606d *R/density.npEM.R dda8c96267a045f0ee6517786c06aaa2 *R/density.spEM.R c5ee44461e73caf8c367228400d7b102 *R/depth.R 7b34ff227996abf53f08d4d56935e340 *R/dmvnorm.R 5af58056044f75475f0e3f863457e04b *R/ellipse.R c6208248803f53a4da829615db3d66b4 *R/expReliabilityMixEM.R c5f3c7e90d2a3179dfbecdd4b6478e25 *R/flaremixEM.R 1699b871b012d5d18651764f7bba238b *R/flaremixinit.R 2cd9f3978d6ea6e563f96a282277b68e *R/gammamixEM.R a056a87a053c20e07e96f00163294a98 *R/gammamixinit.R 6e2e3de7fab7712a39e4a8b119c5e3d7 *R/hmeEM.R 7d443f685764995488abbb46a0ea0b98 *R/ise.npEM.R ae96a525e363c5cf8bb2050f3804f02e *R/kernB.R 17f792c11412089cec2137163f3ad16b *R/kernC.R faadc75b1c05a357cf1a5521a552721b *R/kernG.R 80ee6842adac9ecdada0a80616145082 *R/kernO.R ed42f2f65c534b3934113cf175ed2cae *R/kernT.R d008157391d459c1ebd97e0b6d63df21 *R/lambda.R e45fb22e39852793e902b2aaec245f49 *R/lambdapert.R 363ca040ab258621547b87f9fd483c52 *R/ldc.R 032531819ccbcbded68c198e157d0464 *R/ldmult.R 3595e4fe4208d8ab0f1ba337a2df7dd0 *R/logisregmixEM.R 928f44fefe43811ebcd2ec09e8f2ac16 *R/logisregmixinit.R 61e764f3c76493bee0965415c85356bc *R/logitfns.R 56a2d4a1563e033194716ed2ead44308 *R/makemultdata.R 25c1dcebc2d339b6721c90f1223d4ad0 *R/matsqrt.R d93b3c1d434ff057cc6ed8198732c777 *R/mixturegram.R b00067bef145c26a1e80ef7a4a5d1042 *R/multmixEM.R d1ab4a3d41015ace82f2874b08d58e6d *R/multmixinit.R 6fe03186e33348035370558fb73975ad *R/multmixmodelsel.R 6cb9ac591955760d8cc031a1d6bacf0a *R/mvnormalmixEM.R 937dd2fa6ddb32592fe9f296bc450d58 *R/mvnormalmixinit.R d313ae47d8d9ff8c642c6dd3b7da5076 *R/mvnpEM.R 50a070a1b9af8bf763c158747b3fd346 *R/normalmixEM.R 087fc04146099dce86123509dea45fb1 *R/normalmixEM2comp.R f1e37c4001808412a10e1513bfe6666d *R/normalmixMMlc.R b3adb02fdb94f3d915bbe1699ef1813e *R/normalmixinit.R 000879d20a17f9129a56faf28a891cee *R/npEM.R 8f642b28048d551bb24509e0d4e90f79 *R/npMSL.R 972d8b4ade9a0fdd4ce7ad4da9579e7c *R/parse.constraints.R 45082d45819fb4d9d14f870baca9579f *R/perm.R 00ec0a98fc4eb484aaf623de0a431223 *R/plot.mixEM.R 1e424fc76c439f80a975b9095797054e *R/plot.npEM.R 4e085b2843070c797f907a5f088a6b51 *R/plotMCMC.R 3ade33c71dee9ac952f2949d8622209e *R/plotly_FDR.R 0d89d3c55d2c0fb6663adf01189c8454 *R/plotly_compCDF.R 6cb8369a043a8ac22e3d69642b8496ee *R/plotly_ellipse.R 5c9e9a357d5414a57a76fb0867a4e0fb *R/plotly_expRMM.R 311b725308623155126851a18282c469 *R/plotly_ise.npEM.R 43dd8a0d7fb55d8d23447772e78b66a4 *R/plotly_mixEM.R 763051064302cef9b0b629945df13918 *R/plotly_mixMCMC.R b2efe39596238d0532a7d7fd46c36f9b *R/plotly_mixturegram.R 32da8b02b4d7a73183cc07c3d4cfdd3f *R/plotly_npEM.R e984429af9cc0f4b8fe07ce51d79889a *R/plotly_post.beta.R 2a91487b315e3c946ba31b7093915658 *R/plotly_seq.npEM.R 8839aa836a0feefcd74c510cd85453ef *R/plotly_spEMN01.R d11b3c0a848a662660dcb511b3526f9c *R/plotly_spRMM.R 20f0780577911aefa2a69b4038ed6078 *R/plotly_weibullRMM.R 7fbf03a9406b6ced9e35c9e5bf8bb02d *R/plotseq.npEM.R 02faa99327eace5b409b3481032ea014 *R/poisregmixEM.R e49fc7b49dbec159926f01b6514fe4d0 *R/poisregmixinit.R 7e016ef4d058c1e94e4ddd6f881d4c1e *R/postbeta.R b2174e4aa4a36657d81e50beffb90d64 *R/print.npEM.R 462a5c8f309b2ba25707f3f66eb4a3af *R/regcr.R 8d72c639d2daf98ec0e91e2f7a7199fc *R/regmix.init.R c4d7c8180c138d466589b2addf1c9ecb *R/regmixEM.R ce39ec2a845d99c195d8b7d70176f4e9 *R/regmixEMlambda.R 7b44dde5886cebc9084378e89a256ca5 *R/regmixEMlambdainit.R 4cf188ef80c5e5cd4e60fa4b60412710 *R/regmixEMloc.R 3b25992254faebdb30ef0f0b04e7181a *R/regmixEMmixed.R f991619a3c3286205cd7969efb3cd1e3 *R/regmixMH.R 9d88ad51b155591c16a371cc5b107597 *R/regmixmixedinit.R c6d490d169fe3b56c5edc36f3936525a *R/regmixmodelsel.R 6f785fed55c31fe9b268ed7d77f34315 *R/repnormmixEM.R 8af2d7c7f46753fafe07fe4520e18a17 *R/repnormmixinit.R 1995eae3b993f508a9807631aaa21c92 *R/repnormmixmodelsel.R dfc1778aa1914d929c52d63f1cbb6a5e *R/rmvnorm.R 80d0ffe6d790c8a7234126271d5ecdf7 *R/rmvnormmix.R fb34d52c691679b6d56d25b1057e79e0 *R/rnormmix.R ee0c2b4e3d590a27c5f0af8820470c4e *R/segregmixEM.R 355032dae4f99792fb201ed841021458 *R/segregmixinit.R 2f0b7f0a574080f57c84a4d59e65f0e5 *R/spEM.R 718d2662e5e77f92b2c3f6f8617276ab *R/spEMsymloc.R 9337850b826fb5d15f89aee4de794252 *R/spRMMSEM.R 1c6a0b23bfa6b2dd4eaacf71b6c639c1 *R/spregmix.R b7ddb8a2c734d3e8c082a3379ef6a814 *R/summary.mixEM.R ad53a43af0b057d55b7c9a72dbf432d9 *R/summary.npEM.R a875916a07049e1ff3c4c46748d7ce3b *R/tauequivnormalmixEM.R e55cc3fc2dbcd3077af3e40b5e8222ba *R/testequality.R c1846ff0b297a74949447e5345dfadcc *R/testmixedequality.R dcbc0eec3af7fa19cc0924d46912dbdc *R/tryflare.R a445dc664ab054482ecf95121a835d10 *R/wkde.R 129b83daade32c300c7465773b82c8be *R/wquantile.R ca9bcd6b4fe5232a308a77a04632e651 *R/zzz.R bda86cadf46e1b31d5aeee0d702d8cc2 *build/vignette.rds d32a6f9223d0455635e212e4df50bf69 *data/CO2data.RData 8cafacfe19c67d59d429a3569970e992 *data/Habituationdata.RData f4d36947145afcfdf9e30a29e3e1a9eb *data/NOdata.RData 2bd5741057a02ef36a5e334bf723553b *data/RTdata.RData 2a329c7bcddcdb6930eebb0600c61008 *data/RTdata2.RData 3cb04c901dfa71aef9c9f09b87a57aba *data/RanEffdata.RData 11d247e4ff8bf69d9b7a7ff18ee13943 *data/RodFramedata.RData debde669810513397d5821349847b79b *data/Waterdata.RData 3d480b157c35174ca0321ee3e989987d *data/WaterdataFull.RData 6cd786ef84b29976ad2c0aafea83129e *data/tonedata.RData 965a897972d77ceeaa29b3d269e7da54 *inst/CITATION b58bf32f450e3fdcc9aa29338d7f6998 *inst/doc/mixtools.R 721406b832d61b794a5a2d3439fb0e63 *inst/doc/mixtools.Rnw b7de496732ed3ae91c28f18cb6028e1f *inst/doc/mixtools.pdf ce15e705998acbfc5e8f1529da8c9def *man/CO2data.Rd a07ffa6092f579070260a585852c0667 *man/Habituationdata.Rd f69789f43c3d19c313ec7a6246f08776 *man/NOdata.Rd c2b5d7d2b58a312d15cca3263f4bd5c4 *man/RTdata.Rd c367751bfca4c22f02149eb7a1ad1f35 *man/RTdata2.Rd df8335c4cb858ea55bd452b10e0fae1b *man/RanEffdata.Rd b7a2fe3dcbde5ffc71c2b5df4bc84213 *man/RodFramedata.Rd 2ccee00d91e3de60c2f062b90db012ed *man/Waterdata.Rd c16678ff4ff5c955ee6f6f68b6371747 *man/aug.x.Rd e43e359a47b16f3ec38548d247fbc640 *man/boot.comp.Rd 35e1cee20f255158dc438eed5db2b3ba *man/boot.se.Rd fca8ab892f2d864299a841d65d405a61 *man/compCDF.Rd 5423f1bb26fc39b61d7fb52afe5aa421 *man/ddirichlet.Rd 1dff44003e07659287e1a04ecbf7f6c5 *man/density.npEM.Rd 2860ecbcf63169201eeae7f5181e1d12 *man/density.spEM.Rd d13316f4df7c11794c4da96f820068cd *man/depth.Rd 859cc432c2c0014974ff2f43c0d78bea *man/dmvnorm.Rd 896bb2e222f9c7a8f651f001e008a692 *man/ellipse.Rd bb4590d9e01ffc138b754e4861245f84 *man/expRMM_EM.Rd c17c3c82e281deb849a6537a8f9e9543 *man/figures/mixtools.png b45a859f647026e0834449afbd42295c *man/flaremixEM.Rd d417e710fa3d920d8636ab881381e798 *man/gammamixEM.Rd e92713741a6a900170ef59ec6b0db06f *man/hmeEM.Rd a8d92274b4c4134c57d276d48392b77c *man/initializations.Rd 75eef340021a87cb95c03bc8190f15dd *man/ise.npEM.Rd 5915b4e20695e52e1b37c9b237da30cf *man/lambda.Rd fd08fe01bc6e4156ab9f37fcd163f745 *man/lambda.pert.Rd 806f084784aaa77ba3de702a195fc1ab *man/ldmult.Rd 7dcc255e3db475950d0d5a60c7559478 *man/logisregmixEM.Rd 6f3a941d9400dc69d0b7b750f792bc77 *man/makemultdata.Rd 1a1a5b5c6f7c8c3a243d42a8b276a9dd *man/matsqrt.Rd d56a91188bc37775224ba198d1e6a133 *man/mixtools-internal.Rd 532f9457de1a130009a124c137025c0f *man/mixturegram.Rd be018feb5aed488f15c3af11e9dc4065 *man/multmixEM.Rd 94954f75aa38ceb4e494b271fec94692 *man/multmixmodel.sel.Rd 3e61ae93fe655651342c08486be77628 *man/mvnormalmixEM.Rd 6091b8400e8741e40c594d138bd12b92 *man/mvnpEM.Rd 6eeb8a223504b799e659156a4e346eda *man/normalmixEM.Rd 36d3b68022633008a49fbc9e8dff7cbc *man/normalmixEM2comp.Rd 60306cd095356851e77187eef8b4be09 *man/normalmixMMlc.Rd 496b6701ec27721345bc76b79e2e542b *man/npEM.Rd 72e434f64ee18058b710cf74108320e0 *man/npMSL.Rd ae258c402a2b46b3579e7777d846d91b *man/parseconstraint.Rd caeb3e81a3967f6f24546ad91f9c0dc8 *man/perm.Rd 7fb42e765af12a7796b818e6b03fca49 *man/plot.MCMC.Rd 8a05e74457672324e42dc2fc4920b928 *man/plot.mixEM.Rd 661ee1767e1e59f633fd51dd692a6bfe *man/plot.mvnpEM.Rd a468309483c4ae6d9bc4101dfa7c3167 *man/plot.npEM.Rd b2209409d6529e0676e462c94d4bff11 *man/plot.spEMN01.Rd e87708441e3e8c61f828208e47ef5bec *man/plotFDR.Rd 52d810df891b59019b294d4fae691e84 *man/plotexpRMM.Rd bcd35283ddcfc1969c89ef3397345ff6 *man/plotly_FDR.Rd 8b00e2dfd27624f7a5262be457545f7c *man/plotly_compCDF.Rd ebe1df032b470fe8c61af90b7427b319 *man/plotly_ellipse.Rd 3582d8ce9272e7249fc3946477e842b2 *man/plotly_expRMM.Rd e45a4c95908ca08d93abf45defb3d5ca *man/plotly_ise.npEM.Rd 798bc28934eb8f51e9ece8beaee17a1a *man/plotly_mixEM.Rd 91d58d81a3b5155b966715ff7db2085e *man/plotly_mixMCMC.Rd 43b04e54a8951e8937b2303e45058f6c *man/plotly_mixturegram.Rd f11c66e9c5a0b949f6f8a78bcc39ce04 *man/plotly_npEM.Rd 0ddd508c6f872350ff6f8758ef47ea4d *man/plotly_post.beta.Rd 7f83f3448af5cf602cd3d7d76fdde0a1 *man/plotly_seq.npEM.Rd 79dd1089818727bea9e6b40cf89cbbef *man/plotly_spEMN01.Rd 855911977c604d40a0132620d1a02c35 *man/plotly_spRMM.Rd 8dcf17721537615d8cfa7ad781e93a15 *man/plotly_weibullRMM.Rd 53be9f3a2b96df2eab8a22500e9df420 *man/plotseq.npEM.Rd 9a03b2361e83b275c78064e8b139fa68 *man/plotspRMM.Rd f59fdf287538d1c02bf2ef18afd6cf3e *man/plotweibullRMM.Rd aad7cd694685bbab7d5c6bb49d71cb84 *man/poisregmixEM.Rd 14ce097edb0e1646eb06d63f53e5e73f *man/post.beta.Rd 547221c68209edc9b6a94998f5d3ed94 *man/print.mvnpEM.Rd 002a8ea6ad9a392548889c4b40603408 *man/print.npEM.Rd 48f62a2a5edbc51a548ffd152c3ceb68 *man/regcr.Rd cd86eb069e82f5e4b75608264e74e5d7 *man/regmixEM.Rd 66f380bcbc7b3acce2295bc2cc958fac *man/regmixEM.lambda.Rd 34be77565bbcea7d45aa1a12afb6466a *man/regmixEM.loc.Rd 5912a91ec4c8eae883c131f7b0c45a24 *man/regmixEM.mixed.Rd 59c53259489056358fff325dc0d5625a *man/regmixMH.Rd cac402f4d34ba2a2e72c42e63a4b2b04 *man/regmixmodel.sel.Rd e5c39657c9e6fb25a70ac513f9a94327 *man/repnormmixEM.Rd 1b28aa913a7e3f2bec0129da9f534090 *man/repnormmixmodel.sel.Rd 4ecea92b3ab4ec6fda9c61aaa83d2d9e *man/rexpmix.Rd 283ccd2e22e6bc187d3b412eb3aa1859 *man/rmvnorm.Rd 91e761f99f003c6298cec7885060a56c *man/rmvnormmix.Rd 6c10958f200a83428bb5648c3454e2ef *man/rnormmix.Rd 759629421e7b9dafeb9c4af939b27d2d *man/rweibullmix.Rd c13dd8b7b8df7f76f61ed4bd76a96f22 *man/segregmixEM.Rd 61f993cbb217ef0ba2f36c258852e83d *man/spEM.Rd 2f1f7c0458163ea6070384373ee38576 *man/spEMsymloc.Rd f53a191d7396316355de08958bf1bb87 *man/spEMsymlocN01.Rd 80090e0ddf2e2a2e97ee2f95642720f7 *man/spRMM_SEM.Rd 8cdfd07205c82a7a7ff15dbdfa16f830 *man/spregmix.Rd d2f4f5d0a553b8dd5bb3e251a1cf91de *man/summary.mixEM.Rd 33b88c122cc1df7b4391da510315dc03 *man/summary.mvnpEM.Rd fb2df20e6f0077e279fee305e1859040 *man/summary.npEM.Rd e82e6a9b40ee75508d729e8f442b9457 *man/summary.spRMM.Rd dc7fae07ee408ba28c53960a7ee54ff0 *man/tauequivnormalmixEM.Rd ac7659fe36cde61769fb5c8fb1a2c102 *man/test.equality.Rd bc5650d17b0df897af8568a8adbcdc08 *man/test.equality.mixed.Rd 99018278282ba70a64ac736aa1e8e5e7 *man/tonedata.Rd ec184a30d24e76b13c021e9ddbf47b9c *man/try.flare.Rd 8dd2fb956178f9f80b5d69c9f2de9843 *man/weibullRMM_SEM.Rd fb40e0bf60b0bbd717f1408dcb5791e8 *man/wkde.Rd 6c35d1136da65dbd2f2583e19a7ece69 *man/wquantile.Rd 1512fde5c77cc87a513bf0bc0c7ec7d8 *src/KDEloc2.c e9ddda60cf37bb1b91a564c31bb26b9d *src/KDElocscale.c 6141ac8718537ecc30d5d768e55c74d2 *src/KDErepeated.c 418488e632cfbf9ec0383c8e2a6b4d68 *src/KDErepeatedbw.c d998563ef2b3b533ae43bcc756bc6953 *src/KDEsymloc.c 0b31b6a360443624d117d3d0c4e8edef *src/KDEsymloc1comp.c 3031711e3958323aa555081e7819333d *src/KDEsymloc2.c 4e866de60a0ecf51dd1962ef3d6f3c00 *src/init.c f2a2b6580952c87546e89ba91d8144dd *src/multinompost.c 92c56f68808db44df1269a4d18a23ade *src/mvwkde.c 949319e5b60fd36c2ed398ee94b8bc34 *src/new_svalues.c c0841c25090c2cc258b4974369238512 *src/normpost.c b6a84b03c05c76bcc76da25eff787f11 *src/npMSL.c 98faec8e3b8a3f838f510800b2166bb0 *src/sd.c 9f56ca76cc30332bda95b27f8ece61bd *src/z.c 721406b832d61b794a5a2d3439fb0e63 *vignettes/mixtools.Rnw b509b00eda098a844800f8ade63048eb *vignettes/mixtools.bib mixtools/inst/0000755000176200001440000000000014343400152013101 5ustar liggesusersmixtools/inst/doc/0000755000176200001440000000000014343306355013660 5ustar liggesusersmixtools/inst/doc/mixtools.pdf0000644000176200001440000122624114343306524016237 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 5234 /Filter /FlateDecode /N 83 /First 696 >> stream x\s۶ |ɼ$@lnv'4˝~-fŕ_ ).Lj;FQH pp6 ,b1ӆI&En & 3,Y#mY¸@GK-ǭ1~dpc&"K f1xٰ8eR SV)+Lט*,Xlq L5 p #f\Gh D@,bdbI$ë<p`pcL,s rAiGXYpCJBcx `.Gb8ҜI}FcE(€ #ZI0rl# pE#Kxa #Kk#+0&W1 c^4012U5'bd- n0 FYPEcdm ALifb+Fa|A# lꌑ-g~6f>VR#[B%=r#'QϿHi2 b#Y|-}^!}MC̯O?!V|ER8W<<[t%KW!(`V"[l}fC 0|v{p"RxGGWGSJϲk^\kXdx2u/كb>Ml^&R?/wMWX؃'X^,%0p:-(ܟMb>,d3`$ IJK`NϮ1: dB!Sx/s?̓Jx@#*]=*Zߎ*{oq߶_۱z M~Jiww?fS[>V0]d9_+lWq Ԣ /:*Z=ՠs cH-FQT(B+y@%xbQxzZ@O0Z,YÓ'XSv[`П~j.M^1Ų`kqIQ,j>~л" "hj2!_lqTRBVYᘘsvr,gp٘U,GmkOh-z?-%"3*<^3jy~Y\\^{|ː%2d-1u<'njKV,VY{=_J܌go}Wǣ4eӜGFj.b>&Z*-/^؋N'+I\(~ +qqh>qc_)EPImЪA:`?VP_k>[^+ƾ,˯&D~E8rbfaNi8aۇNwWK֢|\q#[4ѓ| f{N6=ΗK0#vCmM!ӳIGJl`=oɹxx>7NN d:-$LM~=Y|²&+w  ka?Z k|1'ͩ#'@z'+K Rĝ-}i3G Dj=o Tɱ[tA~E]:xr5A # սAN4ї&kpc(?& sO\\#~+wLj [,]s=v +}il?vzJڡHk_zuro;ͯ,|?@}NKHKXn 8\ˢ_̤jz9n{0K/V.g60tTd[KN6(jU9ˡ)g9˯ SzUWo&e{j?|zW k[a9-/rBת9+F̗kU--}Mdڤ?I5;2Uk]V|~v1WǦr̖w~u#a J5s7IBۍi c(g_9om)FtW 4?= :2.Q*ҶE/}i;Nl[ BtNBe8t~y}nyidiMT"B[l4)^pP7{՗7?>ìl~% `Vw- v0xӱc%-~bdɢmЪU;ЊlčСi+RzNYnyXEqc~5mYr~YUlQ.ʱݡk|ƈ9Ã*d aAWs cj.:kQ2Px* )FI$I $HuHz6ޛ~^褧FZ\yhU4S5U6EEi'$ZA]}z6zZ)I:+-R]Ѥ>̺l/ O;kAN@2}XF[mm$US;yQs7=mڸu×.|M$vwt[ul2t/TX/&_kUy2y谏[6MH|{?qIx?>yS=WYYS[YΒ豐6`d9%]7Coz,:Nk?X|Q9G]Nqd@twy?yF ^^2\1eǁ=CkGJ18vYm+؝MB-݈Z P6} @z"$rKұ7U7hF%Qq] ѕ޿X~z8 ߆IJU~!7i+~p8 'rNFη.2sƍ!a/z C  VT>y9< |K򧗓*{dyQ*RVjT/C%KtF M*9,I'W$cbgArl) ?Xsߜ7bNjR7oMP1ih{$ Ľ]:82xٻ3n4+7{8) #;!UG_m@ǩͩũX9eIZEVoJޚeWNz[fO:j)yTaMwvp8D'Cq8:xaW*{(DlKg!Dt" @ţ Qb6P2 bn)( #JQ :Ea]gQԟXkij Y TiTgMeSgK7o *Fywx0T 5t`slJ7ӰQ#V`D?b&VJ;ZӻrGYd F됴%ۍޡF~xMgVISհ:;ݗN˥X] gvqn*;6eBl+BG9z=znQ]QHR]wH"=͚`]wkkҙN%Lwg =I|~/`|Pla Tʎ8P\%Wr;/~*CKSmCP%Hy EWtlC=W1~up*:|P+V;_'ұ@sU냇lyUuaoQ\(t_^[tÚ vU <I*7ĒJh%P ٫9{681?[hoQ]_ks8C Q@ R5jv ݾ*n__bR; rvOY =o& ))4Cu4wa `Fot((&\VtHe7'EqaSyLO@lR^!"6#y__4,& =Ĝb{%8/ruLt=T`u0lA ڍ(aJ)\"Qں҈vLjJ2銶I_Qnsڌde|Jg{ 藓= F40"auZh6KdSIk?YRh䱜RX1 oFr:9.:( L؞\4dS L^C/q3q|MKi6. #kpg#o#T}AG ktŸcdFGKG ZG ȍ3N۬+oZ1p_lIr@lJy3m$p`‘Y ]: ܿULyqvu*UX"u\XDu^(.-a2wک[:u+[,\]ú8I_5endstream endobj 85 0 obj << /Subtype /XML /Type /Metadata /Length 1711 >> stream GPL Ghostscript 9.27 keywords, comma-separated, not capitalized, Java 2022-12-05T01:18:58-05:00 2022-12-05T01:18:58-05:00 LaTeX with hyperref mixtools: An R Package for Analyzing Mixture ModelsTatiana Benaglia, Didier Chauveau, David R. Hunter, Derek Young endstream endobj 86 0 obj << /Type /ObjStm /Length 3017 /Filter /FlateDecode /N 83 /First 750 >> stream x[ko7wQ^G7ظ v"{bk#K$IH֨a̐qx8Q$b**IE"5o6ފd;A^A Cu"%A=F[0Hk:F&PD _V V%xJka Tؤq3~]c)r ˓bbyRLXϓ o=n&#|<)9Ed9Z֘^`|jIBR^b~@Uͣ!7 nSZ[ZWZ_]Oj=`Cbc \cc+?ѢΏN@wtv6gnf˧9Y89sxը4N-J5D~U>xASzR_69k t6Mrl S`Tz4QZݫsu>asu.\]S5VSDMB]^_TlZ+u>Ͻf+B}TgDB-qlQgjV?fZ}RSYg^{B +Jȗ=Gu!wO&q2ԛ|XN2sq~L*΁DTNIKɄo'$H& I`ad4/8 'N[P6JC9NHeu$s7gU0hà",ٷ`N |"d<:}T#sA2HM}K> )6_D@HNڊg'=WeNXk>EiʛtT\afr\!IuVp{ Ar׀#ñ<+.0.I4ХtVD+HԄdPFN@k$`y}z@OSW`1v'{#41QpZ`erC Awx$!0a1+Y1Pۈ2}.}.qƶ8] ȵ}#(}3}lcaE;>0qlc]h+ظRݴ K`*uӖdщ.@ݴe<*upqi.:u T$3jL.}?^4l Wspc_8㺾@+3C0н&6^Wf $hx:!]`B8Vf8> Z=hO 7d[xu:װ;E% By|%Uh`l{H:\^cC`ٸvkPFb]$|.Şx?0~~"+O1H ?~=(Nb[Ya2)`$ā*r{kt  EaWP0#6'dwEZ Zz`"H{ 4o0e3AK>ma$>DQRGa ПTD$O>O-Y:ʃM 1<ҙ-d#E9)!md)?~cO 4`\ZclJ@U5(dxMm%[DCȯxvGxSw56PHlؑzCʯ@Yl\g~TPk7n>e, j D"oɕQE)$%|%`6 Nvr vwXO~CT~nPwF5aa" [c`j@`coN)ꃏ25"zC,9ͥ80(A~PDSa6 ,qDʾ{ =_洄+h6\?WKuBrR'|cn:x {^yF`q jBN|@6g m ʃ].26fX88zMEU{?S*i0i-#ͯ&7F7& o*A[&"2e{WnZ'wlubgQ܆?_)U6sVTqpendstream endobj 170 0 obj << /Type /ObjStm /Length 3688 /Filter /FlateDecode /N 83 /First 774 >> stream x[r7}cR)5-JE9V,N@mɦyoshŦD[ct]qA%LzŔu(53Jü0(-*;ig )!Ȕ#b@ Vb42fXfuG-JQ *P^ZQ̺b6Q3Ü40ZTƎ9c _;^0GKKżͼpe>7, E%hd)XRQ,X@IłטBjâHo@fmX*EgM`1`%#D($! m" ؕ% ; |z%`%j֠@3IS(~eL1Ҙ4P s,vYѶ(9aטl|s(h<JPZamFF )b;`b0!Q\0Vӷxl7tRX=VU'RMS-| Z%$f*AE22%.e.U*_3x6)f1(GKl#Yx0GV#'b#~8U)t)&=iYal~)㿔* ~*i y]!+użrs7zzc^6snz>ף3љq\ c?6qA^!W_w]_2?̏.:]Wu9^swXףL?||䫣'T`2bp6OϓƪvIWltju4ȍ$:]Uiv (ԿG&޻wIh[ƃ'oC{0AvXD~ 5 hCH;zjYl= 1J[ON(=`si{ c4uO(+6] q ^]S> S>OK>3p<||QCˊW_w=?ٗObH|yQ-<ؙ5z^?OJ8Y6ӫ-\^I`bOK~Z%CWyuO?/f&>)ϗHZ b~4:]AAs} k>IWOiF;wo>wL"DQAj{W; b8Wɨ w6 *Ijs#D..s<ϧkQ%Mz,W傿]Ϊrt6ib/&zJ54gꆹ6ZȺ!jSoL[$_מBTԹ4t [<OOAegVS8>ǯwe5&k~BvKuWP Af?Al*O]Ƿ5?\6'd_i{v1SR-`koQ5FP}`ǕjFg{_[ƾoƢ_ T `Xv÷2]E]P&ސx)7pr] Vzk\(۹tt_o!xN,V|'\6$KnG"zD(MyX!z64&~}%r{& ]s_`2ʯY:Fc^oNIt̿E~Zab-?]+:&|Tγɦ!Gdn7Azǟx rD.'jwRS;^BөtF* 2[t4`K6zWHf660 , &ma&P05$ MP*B; c!*`%QƇ/Ls3 )=Mh&%K9SkænM:E6u:uF6})ۀ{R6et)I 5^'j R6>ʚ~tmtVl f4%Sy:ZRrPVPTAP^Hʁ䬉3W5Ӳyosr%1Ҳ.`k.H@{krkb6eJKo:}PIp :{Jzn du(rɈXXMWLn{p-(WLr_ ܡH<, @x{uLLٽ#Y: %IWR֑7$6s#enResFu,Vr$B BfǒyswL@m:]&P~X]XHpExq #6v *bP+<\T߉(;GTMAR>TS7͒5UYT6vt.ʇ*De;LuSy,tw.x:,u^s(ݾ@>3e`AlmMA:ju5wtw YUwT6Pd1! @WxtwPj@ g!]_NQvdבLF zlD"tS󀲰>MXU"|PP "]Xن')@m5?P`t}ɗ>zgj7;*I* t&aTVD2p<(۽]6Vih$`֘J!]}^tM-| at%qꆴPtsHǂ1n*A|( 蚽M(fIH"@*ݽ?f$@B¿)<'ՠjrU7[g ewe giV4>HMQ?K[d -E2Y Y;tn7uvG dvvnH['7oy9]qz!e@mendstream endobj 254 0 obj << /Type /ObjStm /Length 2363 /Filter /FlateDecode /N 83 /First 750 >> stream xZێ#}W 8,0q^`1Ak!0bs-ͪFj"R}abG3\bLl9fIh D`N4&I=0)Ivb'Ux:iX;f>aX)S&/xLk8_ 8SթkTf{UqZ*֩iS܅?)^\I5r-.Iu*R&J,kD`xၱ%gjR-"ҏ@9i.'9 _khPWr\ʉHv%#ŕ܏TL ͕Sxx jz8%lD]IrU CU# ɮf5j+ 0 j"Vkj$ײbs-5fZ# } PFBLxi@a6ͻOo>:"?}z/V k߽w',? ~~o1ƘXX8ɁŸFXOz:S; YS.N.㇟7|BCFwUDӯ{^*=U>'/:?S@i>)&-s@"T}|` a1e0V#=B{3ZQm0" #d#X1cNh=Ry 9X!b*&D̂gSo{!_!6?&9Sl{NBe_1f_zN xs%2^Ab 玪K|?G#UG#yFc:)1BcR!VKV1DOSs]Mdć >J>C3x  "**VCy$ʓcQv!KcEO`q! ~sVo")"S0h H:`>l@9x-FHIڪ;j%:4܀Z.[ى%XmBG_R@ FCV¨s+6xuF?zVjjƻU%rb9QgۡVvq`,[C©!RRj}”o*$,2"Cz[9}1$Tl>iB"W\F\׺1UC` D>tT\}m? -(@}- i"bh_ pt:\c8x3vz`itZAuiTK bY9`cPgm~J]=ZR}|%HG|QMTl"Twy MAAm|͜p4ex7JO|]䢦DQw\ؿ9YslϠڻ>RSo'#C= . l쵾 f%G.!͋HliG yzJh$-*I F|p:xaLNj>*gME^eTȰ<ՔHBpVTk{]Z{Fm_®4ON(@:*Kr /B.>[g3=(ޮ|^1{-ә ZBMzkb.lA@Jk ’QKBcH.Е|@V7Gk4A}ԭv QO9/y'"4aMs'jE89V ,rJ&w$-I р_&+~Z֍ /@Ž cQd*U" N޷pET77fY ;a] p;-tW@Wrvap(V7qio&U=pƔ+t^P48gK߸oͶ{K!S\: )A_a:U胔 @7Zww[ԡq D{ qEHx7 7"[!Π"s Cum[ $PTSz[PPWcd2p¦ͫ/6_;ȽV$fD.ĂΘpx^̣N`XK#Y` R ҽ~ƮTD)3rm6+_<\թ_u|N)Fۃں غP gmjRkLR{HdOgLI&L7.ZMendstream endobj 338 0 obj << /Type /ObjStm /Length 2874 /Filter /FlateDecode /N 79 /First 708 >> stream xZms_qIuNىXNFjIHBB,:ο@Jb<>L0m.*Wtjf0'%ܱ3)"TJCY iƶckb{I3%))0 oOJ=SVO)Ɖp!W! I}{ttD8 )fn fH/(fD:c,th${fF`UZGOz d6ҼbN(D PҤy˜Vs%x|z+0[y!1(4oZ7БwRg_phzAAxXPY0 Kh40<Ǣ0IJ(#5Y$,p:ƿu)X $BHjB`-2hE*Z'$hlږ ;luiؿ-`l?łz܂vdoUQ'-w:Kw{hYcx{ߋfϾ`򦪋vaUͮhr*>4:|ξ*q<@ =!\r/ͦ(o"k2ɛイ: RtlSa*Oz@^HyɆBX![T6kܹS6@UV:jD8MfG #Ż뀽uVgUs ,<QG8ܘvk~,~ͧ< Ϊk-7|^\-rS4!󃟢tc@t> &}*lYͳʳmqUNr^n{f[mV@z=AԈ&2D檪svy-jlv8pLȽSSۑ;fHX}̶ `Rى5S7,<:u:Zxaq=.A'Xv s/E1olrAo m4ZWu3r^Uh koPea6:$>=҄+ Fr(re |hje*,zUN+L}7DN;>btc婱V^:[Iu~;,>[MU*/􁹹{ lLŢe_g]LޚFīT/lkͅ SM\;|Hs ?]k;V$ܩnaE{t|mDw/r#ًjy AZy^kOXvt}$ eVOŢ%KX;j"ˋ?]~ԕz n6H,49~Xؽ!wM, t A]34gv<`jJֽE$H79Vs vO w%#oƥzHwvm*ϱ)ѷu00獦,e0\蘕%"ZN/=B~R9|7HKs ށ"rr'%~][ȃDl Uj#`-و9"Ѱ|Jv:yg.,w8PG _RL>Ccègp9m ԷAط /򾭑 z f{ ݵSwjU )~*~>>?XV`=Ղky)*=LAj%OZ.lLjLPV7; v}< JEXE*E{x P.g$A%35G{ LSJ8yG$vS*ĉ<CvvFwRU!uW y٨'q#3SyP])sHEzd̈QFHOPP} A'x<,(T\l(d>y0Sln @cx\dt|ZW:w3A S(CRH }:lP㗈qa'.E<C.x"Ğj}RSƤ#"0"/>j 7T|jK'\txn&0XKd!qS샾uIvi>0O X3v{\ >HSART6'-?-&#S(LOfF˰1 mgtrJp8)sqp} 1usCn%m>ߜUy~]gBVT9b,;>aJ퉏G~7覺nOGk5+=2?P9[soӇ|w|9ȑ|o.*+Wg߿[<1=4r9X%~౰I_ɌeT jMcl5̚vp|dD6>P̑5e:~> stream x[IHv>ۀ\xf<=T}h*Qh`Ͽ[2Ld7\^{e}UbUWZU^JUfGȕK)^]b%.ZVic_We._z#;n778g?:]z9Xj1UU6ugyڔ6~dz9V ~~tl1tTuYYeKQ լc"p[޿5 [N:Ouq,t8EGǬWF(c/6 2qr)Rd? Ǿ9OiTG]ޱ U4~df OpSa=t!zu/X`'6`J.I)2TJY|K7pTҦ}G:c-; hA Їf۔Uő?uo ]st 'χdx `ɨ!pAl! HF3wHj#I.=ZL$? m&p;h 0c9~- -6VLSkc!%}^8Ah]tX6|P"0\ҠF\|4Cg3zkGxO2$A!kGf"m&B;$D<@ht ٌ +Aä+]﹙qsQ̼g2+}ՔaI9N[V+,>`g rȡGa(6XdvXjSj+ERK| .fžNN5Q%wطME8ç̢o,$QQt/SiwLP6יi U5s† '7=&tj~Tu=9}ҳ fЀΉ>@f\cUi2bD_D#R#R={2 bR ?9ْ(>NR{-T Ŭʊf {n1X;Xr% t{C%4c}tS7C(sU|\X~TH(QBT7Pg+Q@Uڠ/g>"5~iN3?fGWU,I3!̈́Y\Z8X{$8Û:"c=sTD6 +EYZ2z>9f bsU!XMMyx *ɇd,YRFЌXgH%@Q=*ۚʊT `^P ^wo G=l-=U=y*zժ?l`C @s{w<~/ʟ zʮ~9mw[>?o .F(FWj̥Sٽquafx/EDy II5qg^I͋LS2lc! BXiݯbIDtK$|#\E6xɫRx݉X(a列_P@IR Wd./uX?n\ "f\e\OascSr; !`/@M75q}GJNi5[ t1A?w9DJ" G ^\`2TQB@*2Ilgy(=T9%b_4`F\ҒunTFUTa1VɜL<|Bx'b qrQAy)adx橀> Hp辵5姀;A9S>vaYbARV3K\)j:!irhk XRMU/*@Aw Ki0В1, 5iL@Y"1CێOPgOD3^rfB\ -8Sb8l%Nj(f^[d68<"^wM}boUU ᜊv08]if:MchPз Ȋ}ЍP2Ttۈ?䛍R._>  Or]f?jc708MGz$8>r5Ѐ&6;< Vș]QS4g1fβYn@kjp>u8UHf,kE;F}Nr`8CkMY0v3hw_>qbd D9.Vz2LؖD9GH8t. "(TT7]"D !V+ x-{,N8TH`\L(T%8}w|]r>_nK.[?_` NyTIͼN+AZ4M:@.]VkR:RyʷAIulae|Wْԥݟ$6݆̉=,4J e/J^(RAy̙:]>:=AȚ.I`h|W잠_w?pCs _[Q*((ʐc!p5s.OI]ˎ&*WycltM?H38j[ q\U ԳU2,fGqEH:Cl6_>?endstream endobj 419 0 obj << /Filter /FlateDecode /Length 4822 >> stream x\˓#GĜ8c{A`}4Kgz%ygֆ/VuUVfV>~/gMή/`Yz%0 G]#lf!N⪻[A([͜uBN'/ lW ^HVF],v09}:*9@]n1&GEҏg\u_aͺH^UNZKa}ISLg͵NZiJzƥ9D:\ɉN w'",'R8勋N/\,$w!Zӫw0Tݓc'\]ou:D}!-xMWiMzw~]60VuM]D>6"͢Cɺͳ|8SƕVŪ4HU||f At7̨R`h˂?BьLjmق-`^Pʵ"(`b|څ#%٨1ۚKi,i|:-iÄ՝HN HD\4aZ#@l-1ia:O--\Hi*7TN!oZNr#2%JrL6P3q}c*,iW1QВl9/6`5qdc-1q'l X 0d- $1TQv6Rh,X^ ιC7&>F_us3-@)륢MkM|WZ5i.|_+-U'4,͓LlCb_iKW?`1=Bbr&vlEqY,v ׬r&+[0x&<+Oϊ<{bЀP^v~1HޗfH5C& x=e.JV BQC25P)gqƇ BzK?/@E}'"٬o\T#8+Iy1rYZwX͏s^$A<1Ĩ01cǰ C1y )c<|ܶy#ȑ55E|cs2!& 2? ?j%<>ߥN9EGS-(!Zy?1tF tr_'OigB*3WxSc+ F/k`]"5l瓴lM<9@5F\KLo&wYHξ 7!BRcz j?/Q|RYep\Hh0wd_Ue-b1>U(\䩚GceW};`> XNk x<߶ӹCQ+3:Ť=;ܜPz{fBɒN(Id~)e֑ld4гZ@M̡Xm0l[ OZ6 ea -7X+\crNH@ 3,,)0N k$ѷ-awA@vڃA"H˼,~=1V,rdr l ıcg~^ysX]wEm&;#FuW-0USXhk娃O;{v:2_1Ư&~^'ː<ߴɻpߦct<:lݓicիH1~A?Em.ƘjSXawy.ѝio|1@d.Ej c :r7 QjY2P'^aD{-k+x(~چ3LrϽJ@۽*6Px*ƚ>>T8h.`>& Ht I1 E3$hH W1 0'i/` oV%~kQ eA0E# {xdS5 QD #l*8^| [ۡCg%`N@۾y$ZM 3Q#ly"˕[LDWʧ\2Hy:F$hvEʱ|EDXy^ ty^6ֻ8دQ} BXy#p$)dL2gA ˞!)s@*_]Ef+VsAYFYR  b[Q up!\IӼ=U fh1h]lԕzIx,'+5xg>Q8ҁjq!`ٹ!2$ qGYnފXM?]E3 ̲T@so!P~ 5^sneG!O?>c`'K)L)|_:2yV*cʐ"@ Y.\}@y1O`,N}-byֳf#D0j!@RYM ZQ 1rMܕMI "SMm9 "Fݗ#| 4s*i4&cxC^|Մމ^`-Z&myB3N#T Ll$'%`:S$0K)Mgj)7MRf9K7cf<xx/G_RӦqZp0dÎ8(oZL qhIN*k>Үi|}/ l :-) %<[_HO |5]Zp b{oASq`ZrµcawF~' Z 8SCw'g# fru;!U_(Ǔ D2úv=cNᬳ=a=lC=Hup">x 0WINEQlMm1A53hz i_A D]PķbFŇ躽Q_tJO_{L%ÐeBO+zؚtE #ESU.6yWBvnF}jlYėyu)W4NYnfu{NC1CC'qmbeC)ǯ%*H+,eXHy„y =q/ߚzJZj.um] C鼉RV 0h۵T飏x4i{1?QRV~,[PlnfոRQz*0H{F ᣁ,`v:*\A%z"[iݬ I|Í 6~VCDCL X]%"]65.D:(޺dIə|Y#X>ηȨhQ4 / Qa-Lھ^G#嬪\T>UYU:PS%-4vTLiřiF7|7̿rz7]pŞu< obѾXAV~`z8Wg iYXYa@yc!,/ Dǚ\t`-KXu5b:x1 ._#`3 >B SE6C[Qc?XR.cS&:HMLhUF\Y++: Ka#DnH-'I("B[nxr ,_%(;}}_ =.?(Tha hpHQ;(xgB[%Wd 10%F %*f;@d,Uceg~>fNߣ}3<p<ވ] npSW!)]mu``<qߧ"T!MaYGaͬ3j͓kDP 4 6Xbt$V0`ZO%9 FLb@VyH-Ffd_oyw bnCާi8K![sKBmSh-5С?QM@zΆҐN{O; lH}xu>/8.+Sꛍw0=<~)`h&\({\Y`Dendstream endobj 420 0 obj << /Filter /FlateDecode /Length 3930 >> stream x[ݏ ?OMC;}KF[ N"i73$%Hٳ]nv(䏤\ l_{;/E{+4E oVK}yxʮVN6m ƾ_M޳nR4Ijlcvwp>7UZzq;1y/gwUcJ8KV-h|dwDυf/a0&JٗaʡHcc)Tȉ}a 5h)[C OԠwڳC.={-%PoW3E:(ao6Lkq=Wαb;^wټBN\\WAӷıi-(8Ʒ8WzLor~k-~p / j^N\[0i6FԖxWʱ?Ëi7E BWIڲ~zf_|#9>>"xM~0orNhB~nk26*J т}N7B hcxkAO \A{ІgEݔ:}phڈbub 枼}6Uz[Q/kmʰ)Bb $AI&`e!Tv!tl&e|(suL,W5"N9/aeR=J:H+~:AAfY؏%c\l]4v2O0Th(ֽȼ 㡻!NJ;r#n1'2Ulpj5K 2Ʀ:߭}Ȁg"4svwlLyZ_2J (A ãdBX )d eCB!:xr agΰ|!_]\޻lQ[{e27m Aca# B.|qL|'|vQ0HÊUSZPG!$#0e,16R6'@ q0ҿ +Y(.\ʼ"m=cG(#*=B.W\֡Ad]Z`ל E yl@Su! F}`WdD&Vk-4 Dk*WCbX;Ʊfq@M+)=Ёߐnϊ%$q{H̬E*Hv٦K LxsxF)Ds>ԣEm˞ݎ$ccqI<4'X^e_DE_~f~ӌgèڵIZv{ v0X b]rXz{heXm\oY(0~gPB=t.x (~Ï}w:Cp0o4#YS"`f 3 ES[|>P,08 Xŏ|mKX01& |{<7k,4fJ=gfbBn5~# (E T|X)C9Ôx{B~ùLQݶ <"\aD2Z\RlB@c^Z.0HPiGI }7سj uA*OEq@mg*c z<ש^lr=Nkz|Oz,fZÔIZ^Cԯk~9:-Q.Qs| uSUT?WO*QPո@:2Sc( œC;JêP[!I7D D #KՆ`Ϝm[lZ]JD#g {:d+ PۨrdГz }9T%HʥO\@QW}\hx!(.duh}\7WS)kj=IA$G)HUfx ɏ?a+ZUtfh-@,v;lVhjܗ zKy o%9֋a\ʞ+5"ekx"pF9 ;!%HcqIV)Hh8x@!i+uhJ+J\slPS'f`}hoBnN8E:qyWŽdܫ*UK |du^W6*ӥՃڿI(CGmi3x:{\C][ba%+Emk' Xbp WvYrGs1Kwu݋df7}NR጖7:?!l(~y(jSތûu'3 ̿bFKOLZҍD-IvߌzsB/U|mAPN)BcF$XP,qDCe]x=G)´Lp,iq+K釯,sVB {ÆgsCg(O-I?2yAh'}p7Ã^EQJr_rXֽA)[QES!oʶ%PRK$'Q!@$Dp3s `M[Ȕ;CT Ϲ'Th8l.:@(K%!V$@5V:t,p0xCŤjz:z0\Qz i ^ǾL ! #5֋4X Иcv:9'e.mA6Os:iGGJʤYKY]?R6}#iiEgx,I94QU.2yNqa<݈ $ƅNUzTݿ!a2VJGmݠ*ǛMܩc_o<jlbm/ȭPCTYp4F?v>*@FQFoa5.JLZ谩鞇ʱ}e32h}]XsPcQq4ܘme[ ϒ kA^^5z=C'ӒIZ79G ąZuy1 9="T݇^kпf?2|de|!]; qA41 9$1:`vJݜpN>.C1 H|؋É&XOҔ|V6zX x^▰|?ťysiX/%I9C׆։4(W9[8%x/.gxc.vg~BOۓ3TAev0>]$j<_[c]\cԇ:;AXo| P1;9x!Rh%Q1Z#d)%.`JPEpx5O qa9vΧe̻++Ru*PaI`>jA+2Bbت3;19PU>3DBG= i~/y-* R]S.jyuwHCgؐaWNendstream endobj 421 0 obj << /Filter /FlateDecode /Length 4453 >> stream x[Ms896fP*"ɒ5a]*K"X%ۻ)H̗/˂/X<;W;(~;0X>ە^|8]tѦpR^޳EY}SgeQjesͥ=_R[5m#l Ra}5嶲l9'MҪy&,̇KJNkjυfah?@yf+U;eq\I|n$S$vTY&2|>@9Վ$i).;g}VJ:؛&?Fr6s=U޳6]H`0kXLl@s#MKyV?C+ߐÜ EY(/\{v)fdJ:{uRbM9뺙lZ*b7#YZ؅0(2MjEf0v)~߳U󵇵GsiodCVTJ;lnnRFMuaAlEHJY@ʂH*ShgZe ntte3th`S1,e% t!J~ꫪ*+X$< pڔB]IGWԹ* #RNP|,^(#+h~z xwfzd*ݬ:C~:ۊ嘳i4,K_ o9e8eM@jIN 4:R&kdfj6K}6\jZY4Yՠ{S}A+YJ4Yvw[Nv}HV#k,xy 2!Gryl) !\u{FH +L 2cX} g߇pp q:MOD h~wWcЧ߮@f`f hs46J!5ifDd8դ\ ˴,BH[M2F1R4L@sh5r\/ĪA* XǺz^Gਗ;#)t?*.JD=`àUrqorC3oy[7>S_J7.ڬ|*j<uf: Y͸e0t>7J| ]mҒȶ8 @-h+=$'|Vo%fn8>? ڟt&0pBl(@-g]_#[5h(zl/7k21Djzw?Mrήr*dLKd~ۛEn4 hfLe!_^nSay%mnbUbd-"dԪB"spJ'<ɯ r/3CCoU:KJN3lNh` ?<\bU(V:M*8>bEZW"Κ*Yh<4g?tYbyh@lAE^6-֗z|-s:8:qh%P`:/&Whx\ y0 + 'ٮ>S yU NrHJ}wx*dqYfMdx<EUUSR8D^fj91 1pTGǤg؂ܚ]`jv1ىG;%9$'FP:y1dǛxkRp걿vi>mrF cT!BIy) {(KM{7Ѕ҈x)\^/-U{Ӌ1ĠYGD$\:Ƿy.}h8]1tx$HG޸K$TPS!ޟg$=Ѓ8 _C{2~"]u$"͇ \C'ڰOkE=a67_60niB(9Ib@U"`@3vL`k 4ʖ}ybCHDQX})#EVo!u;B9Nu):vvc$JuKIQP\= ,pgĤK F{*L ֤Z$pN`q][x%:|Rt\?,ų}DZfy]hL[4a)(X.Fl5v|/[$YDX+g/p$hRqynD70reӷJ{g|x2;K|G<1I`eĴ{-%خ|MgD[Cȓv1U=Bp5}Y'TQ1`Dj`JI%ŋ0gjeP_0xŦHN;ߎ*ۺGFqjS,&H΅p}GP*]ò|i,uYNZs\/P(+ڣ?;>*=)O:,?%y-98n\嗜c a ZȘU.fnipvG8wNPx3f!s?~}r9AVҚb/DWx`ʗu*V} 8WPFI70 )o ^,*҃MZl}'= Q}2_0T:(SiOX+(0lR{YtMl#𒥏_|?gxկLqqcV0\2ŷ27vEgA,ߝ{R*5 @E~d/fR|/$:n62N>o׍ ґ?rTmmLC'7mo~+sJb/#5*eWèl.QG~mgA~0X6FE <9n8]zjF#`OQo.~>_9endstream endobj 422 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1611 >> stream xu{PSw$FI@ԛXu,8ݭ묂 ڭ)-HLT""$PJTRb;ѵevܝmWYks_gugvq9#0136:W۶-IJd.ݥdٌ4'B4s!eb|=TS:grڟ#*RRQ^6/MJJNL_*)RG9יoN_؜*EE.9V[R`v70[l6m`~a򿂄Խ;b[dDBfb![!kI: I 5)d"bڈ UP.VyA\ŀ^j K|9ѸU]F|S+KBkc׷,#XaKMQM~`;Vqm(p}#t)vG{1lNR#L`D D. .[ڬ8蝖ue>r%w+k˫U {:\m6Ц&ήG+ C/')^#4+@[ une 8ꃮ^p{?: G@7Mi.QE*~-¿xj,{ 9p#8C30y^uQ Z;*o\?E䗩cA""KcD.$t]]m|p{]x~f?~ 7B7fٷ11iY>a_nb 73j(MK?=h/nM39n絿ye|LP#f#k\ۙau Ne">-FL satGwK0KMyJXr}YbJ$ODNoAea4͜G(-6};DmUBumjмee1үɾ K0;gdf<j5x4w[v(9V9V99gW# nӅ\_5k,rsQ2䟂QRw YP\]-#C蚟rF "AXMy|ǪWpT?K1Bp``!oȦİ|-%?&a2AJ{+~OSz4sc6p%فVɯ8BKe-X?}e7 ,_;;'w+`z .G`o!%piByiZ+z\zd<]|m$zW&Bp F\x6̺~<2(ڪVY c#vOw:UޚePqgFsЕ?05_5G{:>gߔ,+ s @RWj=g[)TP)a3 z<O#aXx> O:Z*64T(*ȰLtb }"1tfn"f}Gw{٬Aȿ<\endstream endobj 423 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5302 >> stream xX XWR f T&.ѸQTT\DYZApt&ҊDM̢F35&Fy I9y3Nf ꪺOI[F" \t:" r+fÃ&neqȆN`fYR=cG|AT"9G=>*tkNW&GNsw=}Q0ultX{@dKǻ'CG#WnYw _+5 L~+rzsEyG߹ f&6 .0~]Aoo "weXx+&ǎ?Q`!2f(Lg1Of8ˌ`V2#U(f53c0f33 73,`2EdUf y83nL3q`2;U_ƖIfHHm&ٴJH]*wd!r;:vąr'+8sX;١k` A^Bถ1/y1N='S{29.hvt zYč6'Xu:J5 xbE4.^%?lzjC1`2e ?"^q*y~*=G`c?l9tՖ(#JQQNo,b |Y2+T0'SfC|b+LzCY:2//)^BUk OfHW3*۩Ȁ\V}r"骧*qݾL/~Pcٌ#bIt d iń٨t+Z&A|,C{,@{XjMxD&)'pN)@SpDAi?6MJ,.4l/V ~=A#yiNgUWBa4q* CVBVFZazOZP5߱hn[c hC=M;f13%jD bc-C4H;0NQbܓZLDXJ|? i ;([/\8 PK暒s 0U*1a3 *W'$(k=z#_IqCV[,ru ,w_`ϚذY o ?J*dJbDPŁGir\#)ȶ)F~{BևlXm"pd؁~5(hQmEXb"#]m3չ+r <̦–g*[6@>+)`E%qg#1ICULw%uxO3.YE7BҎkdo;&M] ܆JɸGqju 4着27 4 㬫X$=LjAwgO{$1],kγl}+qT>H4Iδ3)f|^4^W(T*slIЬUy}(Ciּ(`Lȱ" 2*_'E{t.5]]2SN5dBSrSpozf͒r`w* Ɓ0EåBA  Mo-c0z8bUE[6Za@|L.*dAQ IF\z=Tc'&fѰw3+"%XΖb-JZpE\)؅ 0 aȑ6ʺInpV^.VK* ]w,bS IJw󔔐[X&3ej(<"~{RByѪdUJإ:8mYL5̍oϘVu^];y$vǑ?Wހ8] Nk4BliZح@nm;m0=z<,og4hD"z*w!^gSu@u6II<N<v~n8SjA)N_\ 3s>{Y R@ =bsߡ@BeZz0lƾ )yѐ2,' ZکO O3uOs)<%E1]!#+JkKvqF{ 6jqٱV'ZSbc, KPgH<|I)յ5e]9Jڼer3K^!6rNCJ~M0&r\IbܔuLPLv\wc T!rsW ;A *P\UliIj^!dZHm0$ &P}49E#:sE}*z2==aDqGwU5hCجU{L,y 8'!MKn;f3*>tQ e5 >BtdE %P;!`ؑ5S%05|vA#sy#U?f%k1dNզ'pO^LюAqT\먢%yɱV \K N %גYyַ'Q 9ft}kl.D;y) hMk_J"[Ɣni2|q'C[K'~,?g[5 [ @ 5ʺ *Nƛ7qψ ){LN 5cB+jQezM1\kl1:)` Huh4JȪPY(7gKzXGjfG:c( @nCzBcB?M.(JiTnnhUXn5ZyG1+'$Me -Tri>heO#'("-"l7NYsK>~ͯDaD&H5) q v/E6$)k*3MtL4>XZ&-{0p=ޠ"w?8ڱMPX6N m!g~(xpPI񊕆u㔌i>}s+HupO*w,ǰMk.>7\j%+zyOк-aۂ76כO4δ_z7I>|>ZHŋ^Tu.#?\bGǽĹLЀϬO[ץպ'FS:s",hXpߑ';5j԰Si  %̱:v17O=PUކ; )ӧVlei1V'.QҹXDI9%9_0nwMƨaBƈ_b9Sr | .*;gwC,h{32?^ڒX;TKKIք,"e '?TAƗUõ>(/˅%^K XWwh XۋJѽ9:,  RTç}`Qysv6:W<{aYb;|/.1T9o칊g?:^3z) z?^B6(MF59]ٓO7P -k/wSBd]mSQPv%,[hi Y a;[XC>%tʢFmaF faQ%jȚ@ xi>)\_vFye[eȌÞDtt/8QV: Y >4ጦm濡lI#2Qm0_JQ,o;Z nwҳ )SJ 봾n+?}ΔnJ.v)ICy&c^Pp䗴L090 ^rP%δh*WLÎm'>}️6|'<ҭb3|-\G vB5 d|x\yKۉT+Vvnko`y̘A.R4FHx}s9i^3܂\^!)ŦaR9E󶺠m၁'uiݹ^첨^G{O- ^n5x:v%idc1 VOJ?(:_5he1/g|}IB*e@0"AׄwotSD$ЙVW&Go'7+[NoRmj2F1';}K Sno-endstream endobj 424 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 9225 >> stream xzTTW^2 j`K,(jR^20̞zCq@@{%&jLbIP&1sИ7&׸\[~~>W@t٪նގ>VS&ں{9GnH73־TǛC]Ãf^Berjd_3.?yDwE~܃,N2mDlKp˅,W8:{ztibI,X:;zZZshioR[5vc'eqߵn#EQ۬}6.ݴob. Znx>,7fQnaD-Ɇ9(Tln9 o܃hÞH6*iAL!hd(. yr2&]6VC4G$C3Ez, zPaW$H<)6=8J|RPluw-2#)YtZd$YqfZ;6eRk|4lʯy{ ZȝEQMīIfqReF=âPl:Ethyâ'A iPr"h eg(晰}j [<Yon"4h Z#=0msQ Un/mgKp-kf<>^x8`O+*&*zIJ`eJLsa@(\o_okJ3780&o+0 ?lC4y-<.Lb6Yza%!8IA EW~K?|WGrqJJNMuXE(شk|^AVlxͰ/x`.(֫fBe;YԍgSTa:%A&1O[ھЀJ*UE,1T}7"4͹N[ כ߸-bu"Z[7Cczb W/Cٯ1EⱝPq+,q@OunhYt$船x@$p{wlGLLeypl~YyiXu|0yV"ɘI)*ⓕ.NE\e{oUֿZi4#K*rѠf*Tq@b KHISKJX4%HЇ>ąaB*(4ʻm@D!E]p#EV+w oRųwTt< ޼[y~,/xs0YY C ԴPr=z/%ЪP_"|~hkoeE4܀vzH5rl2L q}pS^\2=عc!~*nb+ "w5).ܵWmOZk?#r/|$ށ \k:IV~Wk-¨E>H8*CǣH%-KL>|Biqs۠*y0M8sR kETw yEqCڄ@?=We6[[6ص-h,S57U&%\KF JQt46r S#qZEXT6A1)XgːB#0Gk\miVyjo` {dB fd%2&XDn#ĸ:ғ7٭g1'rwW6ċwEoM7ê3Ipk|v^bP`[ 팦SaojJ>)8K:&xPJo4 Sc9a3pt*M%oL}u-Aeau*s=MMѤ?T9"#c)Z33O׻JO#:v($7=!2..!_'c*.,=>+b-w+] /XcY.6+WM-/{`ĮVHDC s Μά_R餵'M ԮH<~1 ht3cnSiNaUaŢ.9+:niGGUaiT)IJHJ2JѸ4`M:%+B|+t_aņL2aA1-n.7=[Յd YݣFHMC=%q$Ha}&ufhUɬ*zR 1qhueiO7O<CbwP-'UURYVj-u ño) <R~u/kQw^U2AM#tKI#kj-UwJF'ch+o9/ Ȇx:َcz땕c$gM"gsI#FHk;z!,3{PJyƀN%䪹؅xU+_hqh,q ]9V/[N IL RiC$+7+B34j.,3;epȉ 5Rͮ&tW<?~4~ajDP*P+*c:J":-IJUp:Hbժ `!Dsuy8jW%hS )+M;\ՊtZ({j3yЯH Ȗ# {yuwpe,=/?G' OӱQw@4ȗboP>E>i _[uM_{:2k!jo+it[뇲us$29r䀶 ` Cj J+Jt`Vh#M81wX-x4F3و[d4VYT4N`rd{`ya9r34sŴ HbkwnW89b,stdu.YLTW!&s83C}P_߮>]_>$՞!%ɷYYkn5F646dV%ONC,[]QŘ3* !6J][s3˫ FPśƎZr䡽yd3~Mߤjfg&x3qlȑǫT{l=WU 8y @%x60ԧgհ'?&/Y E?K`^,:t^ck//L"/&7E0(Y~ROА8SG૒]aC5euMtksd] JLnƨOWsbZ oCxk@'uDg֒vo$#Db ǣܕ_\Ip,}*MEXkx2X.[i`ndI<%3W含fkjoI2IH.t&W 0ziM2NHbKu玲=* t*{Wo_=z7g.Мj+_Ad-jf)`.ytO]YZ6m36*Ul"n]<p洡N.'I>{=*qwbkx07-3?zv)U*;n;C`u' ZL) 4o 4#MNN <$gL < 4R_P g|~~CV<} "  hУ6[s%aŒs|4b씲dCC"eDcDڟ=f'0ë MH|R.׿=Zu^=5-"X$U p`vsC{.{oVClY8zx(b0y*}DE`nupX%] 'BK#aΏjиU it[>'E=*'Z.AHQ!Rli>,C%#^׺Ҍ4e&--rU5}_6Fx?`K9o|};i"@B Y@sƗ #R)^*o %*0P(R:x:JMI'}sPiDj)TrPnXagpr0[/>9&庢Rm6.AfsiR4#EQF< qn"[On%d0;돿CsK-$9;q{\TbrA ^&zMAS>zTc-m tOH-T9`3[&4wj{H弨d8ZD\}t#Q.h# ?! ͗Wn/u|5Qm{j c[!5L`ؔe[v)T DHP% g@{@Uұx;w'ti+ >r$@}>0A.8TNtfK -t)G+"б L煚5S RZऑb+EHu75ڊ8m!~iC͎= i{)#oajˎHw7mL.v0{a^2-Q&Na$eheDta[ֲm2? 2| 6=)l<%BWN&1p63'#3 TZ*gp]"BힸM&.θ6 `!@thN w5gbѨR@외hjYl,ILKNi`mF$aZE~k. 1CS¥4W(v(gpj,<&?.E2i$;$Y%6Eyl#ox_PPܮ}m!Xm`]a#lg]$ܪ%mxTE%0"D 0r^nFm#YMT+<`E8:4֞0ѽzx{y˾ENE}%A:L2upC#,`po"-YO ߶6^Ǐ=YSd,߹}$!)H2k8Ԙ#ax]ocpNƪc{*U*3uնA5[Ф}nLNa{() #\D)/*(Rr(ZnF 9YHe\gL?$(!73d狢:t<ܢJQB<+>PeDgLњ?$'˒a\#U_ /hGRXSXSSQQ&9y#^f-jR>iZ5MfDVZ'&E aV̥_h%d78پG`7-]>u'ŠB 9!XR| j≸%BBId9m"=Ktowbjâ Gye'[c9o` qk`@-`*ԙU.l4)0sjzH@lT)e9,ݱ>w#ԅO y(ujuCOesӿZu5GɗjP]C'}rNղ65 a~wW[[ё+Yi:YAON} nk% ]y šnW%H;dB2Lv,!3Cgw7>J%_ڃnF{?Id)lPgDѮ0J {(GUʼnEJt0|b_ Pjg'r S(XUJ_AJ~jmƧ/ry2IIYq U|onO!/BO =(!݇&Gfh-E Q_?9ZER,^nby9ilz}"TmOOG-H+r{2A}g|"9Ypُcih~,qEjrz y8ꖋpW.O|KlZw=(~BO:$!~^eAUb}9 ˱.r{9a'DX+7';Gѝ:]݇7G3q-CIh(p_h+-|աZ+_m hU }iܷ,>RdžE*/2;>wiwC\P)딢Hƣ2pu-֓pύXbџB-~BSC1N2\ $%W_eZA~zv Jʽsf%r#F=yèi7E2 |'ң3ðn-OL=>c; #3̟ۓ8vq('s7WS  Q ki(S'.dJtYNyք&b$)/,' OVFf+pBΦF')Y b /D>fgkY˅iy>.X. ZQfہnJn]϶0l`$%I=Xj<nNkVRʨ _ }yW3Ogɶ1vM\ !τ́OJ( bW~b)yΉJV'?}QFO={$ΙrCApފ4.s"4L -^7Y\G~=[TԘ $6$2;R)B[s~"oѕ4y6 ~kiHHK ۙ=vk$'>vi~LL[p7+'C9|+8F w u@U2!4ޅL'_|t: 7IHN'0'l?uTK$m #i#eOu gK73w'I%;S!s#:nQI׉ =d{[WwS*C^K߬Mפkڴ^)qendstream endobj 425 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4764 >> stream xW TgRY7D(j n* (*KݷiM@YAAVܢ5gt$1.-7ޜwt:}ߕ1L&/r[POȏB̷J2i4B$w/C15"Jtq+9XY`cìoe2ЈQژ[¶MAokݼ'- -("mѤœܖD&Л[FF}-rU+|V-[jيq^0'" rnZA$k7-N YyKO67g|<0kR-f3YμÌaV0+U73Ye2I:Ƈg0 E/YdxƞQ1#83.+30vDZEƒ|-Ir{yLʵ*Kn6dAk?mj6 m jnf1n]??h?~}8UŀcDiC?,)S7A8G®,-1);E9x:8sY 꼲hy2F1Ql7=脻ЪuRD%*YaE]zOD;4 D#$q>_>a_@ _'^ {B| v&)諡,nx&~@^\ 2uW>CY-@X17 ׄoazĺw@+;H_gwJ|RFe2|8ۻκ ľT5Cx2wzd!a ɵa5[a%h31\]BIw\W YƤ H2YąX/Œz4gӮ _|ŝS4<<]KxSQ_\1Q(fYXXI. H B8Y $"lbi DAQ1ya =&V.gbPuT,ay#;\q_@;>vh!0{ƊήS]d 39NJeߊR(s*2wqSJEe4RsC: 4DQYΗ?C7A?Vf 9jiFьVKD;t i-Gȩd1]h"Q>, F9'#pKp7ѻXs#VCA&a4}vtٍ3,IFG~DT}g*X*yG.Q:q.{m~ĤN?WdI-v_aW|4 TГ?)ͅJA.܇=#V cN p_v+"DlnqިIΰ;ڲ2k2čړ&Tb!{DȨ.̅5k:~ s3NC);5_E\`2?V&]. D鏌vX{Ov'oz^lO۶zAb-t^U #CGyq~f״[j$Vr-2வVoeHa9>}jVx`߄cʽeP&U'LN zZqD/23}v5*Ifsܤ/V!rWXׯ$*2"3B[L(vc=)y7`R zS63€F2򿤲@b3Z\AǒYΡ&P혬mЫ2}Y.p׮NUtJb#W,z_Hܓ:pְ?j r ԏPABdImofFP<~&{H(;l垪=yfU\qx42:$"x}z8@靻9ck:CO kԉM:GsG5ʥHbaA4uNaX8M%MKGn_.|]4284~vYPfӦJlӍnBgxmgVi68}Ox 8jVB ĕ 纁GUCZߤ3 &)t1ޕh_t%_jWRNM_Vb4T:tZq3[\jhɆ{7\ʠ(N$}Nr/|H:Tem kξzs0x|9~pTLjO@'6i.j\w jT["jѣ/Bͨ.w_}, x_?W=q/=̟{*68 .Y,6ƤzZ[zzZ[{%3Ers:閃RM$'txRQZ\x٬R.*]y7š_R&]Q&YN9ICjV&Hg V}~d&`KIq`Zܨ"D?8mIw A{#V~ Y؈պpNR!jB}i~qa6]AFHOV^:O֖ GOtw *7l?זTq%oxZ@a`{xmgCc(q RۘZ a5=mǟC[rQZQ~!oAg5_g{f~=\3?2SHnPnTIarL*qߑg(֗pe)ޤ҂R@,W c9ORB81ӱBrͧ]8:B.u/0Crm|[N_s q+mGW^$jY6V(ؼpTWU6z2SrqdPyDjG87n|ӺWuaY:=Kqy߫.䵱o" Wڅ83lM 0%w2 mʩr 2/*gLkOi?kN@F#s;MIA$_ dAb!?.\QTُ#h}#y9̝W%ю">@Y@ "OI1 K/UuhsO[Š#Y9WzD΍g@/EpuhٻIWZ(NCVhjV^e%1~ j { 38Bwz7Ԕ*" \i54> stream xcd`ab`dd N+64 JM/I, f!Cß^ NlyyXp,={3#cxzs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k꡻g```v b`Pc0d0f`addql} P ߧp.b}{'~]mz߽ \aAGo?w Mo9߽|ݚgYl|<V"w~f@SZLx )֧.uߑ|oe߭~݈{?&x}wg\J=|l'nrqpvpo}@4Ȍ޾>e`qendstream endobj 427 0 obj << /Filter /FlateDecode /Length 7164 >> stream x][uF7>$Hb[zM^%A2*-rlivd~{r.U=UճC.zPtu];zq1n}XO{vsoO_0q#T\xq2Onu։-40 ?yiw3=]naCw_n}{q9QN b|ޙvWN/}i=V*]AK+im齵w7ww]Fq)otC[~:\׶Knp-RuI[g\p[ϊM^e Sy]axUw@^Vǻ PA^<'ۿΎzwʧ=UB1bDd: k(KqEʕpffSgȎmIGw#>sK*J IuU]\Lۡz3ixmC8iξE;bu⏼pDAhYDXEl8#ZJ"+!#JrkWC[<]$>U+_J҈j&1"kibaf*tz-?nW2a*ƅAQ`2HV[4;`sE3|%bvew6I|fɥOIMdiD賠4}A ӈCztNx8P vH]wo` &t>A-sN'VGU\Uʏ̈QpSaQ"uIm*)Zvw%[X_jM_ sbo4TJ= b e9;RB#p @4nqldq}2W'L'ij-~? ݻthb*zO訧ȐS,gᴶt.:W?B?D{u &og7 kZe<9QWzjR]bT(2xz67Q<<9.MȤ_/&?6;!>\[(@ߏ7:aSЋMvP*iPTerw~`O}>ZW>4q#E\?_U)5{yNNvf] M~Ѹܕ(Lkrzq p߂Kf5uo 9E\u͞k)uK(:)~vؑ3x!*:Hlh ?fʇCd9֑r"P N{䨞10 |)3A\lf|IQے{GcyŐ*["BLLB"ݧRuWܧ6K7U">Tn)%xP>f_t!M xF#w~!wVA_! }ԺtYʵ d.G $, |38l=aKYZ Un653,0'+ wڡ߁ hM:Tb5 ,DMcX1 0[_BŏK9YIu}Rׯ1}S༒oc>C8:FT,c Mmoa~TSNiUpn+ɑUxpHE+d sW&!6ނw0~=iT/k#>̻BpƘ !0\X.śz)MܯwdUx1$Ҍ;D xViDŽ9y菏Pn=VT]AiL3xڽ<^}~ F)^١]I ʇ^Z]8|$qKP÷\^}!)3L`펌]gV׭庿$iXn lUM4qmTvQKG5b >.K誠%?-1|S_.ET G2fl&LqUr~%hwZ?AU '襊l#Cw%ʐл8Q) I8u=hP̃ʁQwт^ś9~dfh~"';%A0 gdqbZ2J}Lӓ2 Т@_ihO9>upF l#o(zNajӊǼOU#C.PF/x}:;߻$v_]6`Q]z{" i@(L<br[3¸A eCC)U gGY ҇r~hkDt~4{Fo\y6}I ;1UZHh76b^ rc||c|Q 1+vkM[WTp!UG{VCqfaMCW1jH].pQ,bJqϿEDvJlQ m焟(YJJ9TC IC$ 롢U˶5mdz gXN妽,צ}R!_xZYӪԓ~j0T o,X&ۘ<7 P_g Vj`m+z=`kų =<~2{GyZ( kn(EM`B_FI֘BWPtugF o,`+4Zg&饩d}^4[=9m 6𦨢xUA|E mB>3ŹzX#)ؒa@43L@Ƞh=%2 c␝Хhn#\k %9}S|4$%G*$\";e+Ԝ T/ĜYS;%JfͭƂ-DN3>Ѻ/ &x/;:hՇp ҝ EN[AޗwőTfVળW$գ4R29lSwEc>_H!iLSi̖j`zL5nֺ( ңCܶZ?FҚ, +-s VVZdѸgJM@Ef<+d,; N*0%Je4)T0Tv٣L AY8wᵀtorNZx%;㖰{nn㊰r(ԊϘ0ť8]]h1=-5 '8-. ҩ#GTd=JGZO`.Q۬Ml+#ԬW-|,⮇Mp  #ZN6I5=b'ÉYT v "'A<:2£҅7#F]t~_ $\`W"KKW׬n p<}.S:NJ*{Tm>8*)֥KWc 'LDȹup4Haf8r& oeAYyGCx_܂o*-h Xp.R F3jga9ϐ‹5k4CŰ@7q]RC+׉tߵS.ZuJ tNgm9΂ )WX_%®x&ohsDƭz +mH m 6^IQ."tk yڨ8טhJMgл6rm1?~sry.RzmS=R=v> )B-5M%5ҞOIX xH*D0y d-1Br<^3СJΞt*Ʒ+3ޯ˪{,J(UT}*\՝prUw.39 U}(/* &I\ӒReo%jESŭsQuwqHEе wtmjZ'*HFX1B"⻶g>:RQgZ:i5g58wΨ{Oq \PN L _(Ri9`'^HLA0}?cv R!x[MCIT |J*A [ 97 qr  9r.sҤ|rr*ׄdjGh]p_评04YFWVr|BqYhs9@m |A kT@;V\I[@DqguҫPuNˏnm/IO0j~ {0%J17A1%p$` ڋ')+t@,ɒ)DR{j1S8wFb+Li%Z6`4xӏmĐSyU9/`Aurh@*K-yO<-9Y${B-~EQyڴqEciĎ4[Ϻx>6V둲"՛)`/j_Xݭw+OyWln*2 s>?`cR(8AR8AK |uqRN׷|Ia] Xɑ?QDI͔gaK])?0phZ)fްf⦅C@c[ec:{jNyƞT.}Uec-2sFSes?FLBkkmR +ɠZ{P]S&:枮+mLS[+Uv|ѥu3GHdt&ޤ;_)V`yd\1vB.1+/ E+i \/ѕ0UߧF^PDbe;G7qWJr8mEYh--R+}cuBIF~vs)UJꞇhoH"5_[V鷱Hb."a]iC&QVƇUe`U=\o|oPDA_:riy'>;Y-9%Qb (pyq>aGRsӾ>wqC2-Zx@ůVlm}Ĺ$!%ȸi&ǮviJ'+?>Yendstream endobj 428 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3583 >> stream xW XSg>!$Q93XRթֻ(*TB@4  \$~3$ W ުj mgغ?@3;^'y|9w}%׮ &Ϟ5#@%~qnB;R^F/]j|o!x76 ў1P ٷ,.>-1:jW[f͙1\L]:wMXԤ=ѾakfJnFN)&${7(pE@婢A}].۲lybR"%lYdԮM{1oΤDjDNR j R[ j%VSs5\j-FQW X;e#-r;/\.+j{ͧiWGČ,ӨQjtxfϿM(p"F_#o7bqC"M(ՙ*+c6R XG)s OTil Q9sH8@hiaW|>SPN@ΔUkRR-"}\"}pzhCE+o`A#ۗWJe ¯ 5rQ&J5gFҪϏ3Ɉ*W%߯@ŇwƈsO9i9+Q._=+|kqT'EČP?SG{:U-?!hĎ~3)x,aX*w:hfG =@ 5v B}cEmgZOcСB7eg8]Si90զzUnFe.RtR]d4-,g3S[ %_)XU% hC.ڹl\Vd"0Y;hƯ!=y XcߡN=oBS1?lAރ'bX[NӨmk H_tAWVaC(TiW-d+.NO<'Fpg#@y!&M^j'~$7>I 471z<Mu WҰ0v}֤xCd?O˛7hf-$ Ο|zFKSBc(6?E I?_E A'tXS"f\PlmC3_g :BIp~/6:0$P*ƿf'oco$gd7 v)-|> 7Ȟ9F_4׀2Z*Gݰ2{V@jECBZC>=/hJ lC.MR]!,`4VLo=h\Z^JU~rhmzZqmwZof zH /LW&HY$~PGSe'rJD1O?N{1 pz!hZE7J ND킙fv56sM`ktK@ C49}"pw;Pf>'t{I[mp؃pZ\z1T.E!V9TΓNt)? /<^DHĴi/WfaR`灹f[`e&7fBo{N5t|1[J}*Jugz3Iz1d`l7'V¯Ԥ-3k $ta1=crk̙FM)`-!tKZR]{8ht'Ë5}ds7& GwҌIX;bwwlâm՚:h{Tۍͭ]Mp "2ޢՑU14Zm>=pP}',Uu㲲;4%aTof, Z N;-CPx-o$K]b6AioD~ĩcFG^nH6e U*5KOOV/^(n+k*,2Lʼnn75׳7$`=؀)@3:d;)Tnv6)RhAmQfzB3Eo5;ew? _Qtt͠ ig/h: ? 褚mѤIPig6Q[ k1(>p%->JWe-wsw?Dx b*Tx aDayr.4;۴,I̝H W@jYL9DK3il"'ԥL=!Rz 2C AKs۩R|z*4\r@n4a :]qXj;^+LЀHHƿ{8'+Hlbzk[ (O^kϒzWKOUgD%vyfX36+fVSd˾3*|߆Ғg^:nx̬3d?y Xʡ,/KM&C#2׸twVWWT#VV{wrHt#w7?UU" B[wp9r' Vf- 2{JFFn.<_֐6=n@.g<^K/VV@joƔDޓ 'PoC#s5tzk<)dHINLɰ q'ȷId.C\@>#L~2<Z ce\ʁT~op;@dN><7S֯bWҖa+ҷ] m=\z_|H}o#R|  W8MTk-֨p _Yh<#Q\⣨\m*qpl@Bm~ݥɥ!ȏ SD)fjWΒ^"<` s!K! -xKiu1 qDM-@m d1@(EA$"?vR8+Dd2ތZzV"a .M.s#ܟ' OB3QĬ*l-1Ճ ȣ wg?-E$ rkBjf#Ag7*Ik5r,\*)udwͮ]A2]f(P)s\)'c/rύCܫ|5X4A Fh04Fjs z|'rwQW$oNg]II2e!ߓn믝ts!D;+a$k %mr˭EwehyJ_aTBҘZ V%5n4Ҟ [b爾Goڴc8xI,1&Gmyg-8b5{<|endstream endobj 429 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1924 >> stream xe{PSwoLrȈzo|jWY *EP  y\)Z\E|k]mK+.m}ҟ;o7sΙ9|?~WF)FP2L6hqgcS#w;2qqmlhr"5ziĤsދFJ*Ef@j4OJ!wgLJg+跧֯J0vW_g4Kx .1FIq Yq->.(1s­1 ?S+@JKtXj,!Po)5BDΎp XEt =6cziŏ0PH[y>[4Q5էq_dc]ꚫOZå͐۱S.!d$O4dR[EEԦg(͗O?^֓|4]W |u~Kbe44:%TpܱVj7uHK3T08Xn'Q/ >9x핀3!ɸ'i8ǯ1 %2\0I ej<5ؒˑ[/l]Xss&Sm8ժLb6;&@Б2DG3{QB]oYB7^ꕚEψ-0 ?= ,o߫>o+B(Ȍ^h-9<`!ܶW ƈñ"`J հtv؊]#mr?^ףzgi>c(\D݉$1>%ߘ:htqGuB*.3b|C P8vȺCe(ɐۍL!5]] N)ᘚ4K]]/ŤẒHzꯙfٳr${u$x\8=pŎC%%Pʖfl޴7#Do$+8 ΋V)h =Z Ȟͣk!k) 6EdIcl-ŊrQ•*w R^1s#簓)I:K$Ujc - YIs`LCvd8r ܆ңBU+uٗ4Y{ҿP 5hg!}N̽EѱRXY^G =8wEQ*W*--W~Ur٪mlJKFR&dǁendstream endobj 430 0 obj << /Filter /FlateDecode /Length 440 >> stream x]=n0{B7Xr|\kE $2TX+"("DV{?/봷^[?e⹟zKjuz惿 #]>cPMcjۇu!<{鿮u#1:p#BHl#0]A]\ aD5sT4=LJtw&bLP`B@ d$B  IKHPHHG& {Q3nf݌"Y2 e*Y(aV#f5lٰ8 412\&"jZqV\"LVF+he02Y0L0 6ps | $ % (0***0*B[| }o]E`Yۿ'6quendstream endobj 431 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5909 >> stream xXw|Te>Ðs\ WwD^jH!NʤM93̙'CW:*u.uo◻{eG揓Syߧ>DwX2VL7kfڄyi9¿f' Ob1ڈԸ &gX-O3y]iwǡ(hSz;Pۼ(3K;I̙]ȅ3"K,MM͈|ngɑS33"w%$Ŧ%Ff&FOa"]ai3~~?;6==6-6}W|lVRrntrG"6!+79-3cVZn\Nr eW #S$e] Ezo]bap~ygϢY1EԮm 5`5~r2 t,%SmbbĠ\Ԗ5.jv6>9Cΐ.𢬼'}Г2x'UXTv&مt3c!_&Ϩ5cZ|QWjonV@5 +KO I~7І2(;8X̐ 2?~ବ˽V*i ];9er`%CWA >&âb0c6n-̕Y@ژ.D~ji6h +D>_Q ¢x\mZVΠ85jojBkQ9ހ. HR!@5Ԃ2{,P& ǩā&ެGj0{$`Ucl+]H~zggKF.;,&ZŜ_6Y\k0!H zG໸"ȅ!Eߵr89pq1lk u K`D"5>-B>؊|~py:hQmdEݲ`uO+Oh*A*?dK*Ѭ33 3Ϯyv݊M@Ϛr <]3{,a5U9 ]ZbQma1q.9D({g?{*D(A&N͵޲;>ќY8HLR\ Nʠ.AME,>FlJ :C3:vJ H^[WhNz hD;у!ɋ$='GfWSSsUU tO})emtN\rZX6ݘ tT0XևСQZX!AOMF >P&)fPlTX68Dby)%h:tI>b,61O*=SrX$$h\]|,\FĀ#pȮDF#oC Deet`Z8yd5=6Dܔx[NΖE:jIWE\%IQ*7԰J.S( ':}"Z @y uU# UNdФpg{%>,5|NiVaNH"g/o?Or֣_-!kA%J/}5E3gq&в%@yy͜{nT1 vw͈˽rM*-:f>a1]M]j[AS'C4U8TXRs6qjJ_9qyP%ՙ:ro1,}@\yJ# |>p6n Htj0簜З !F0,4WiPTG-ᅤQϫ'=\ ,&dsHW3i\hܒ36C|7HGໟtהvt+.O!y|7)}}1WcI~dু&8M[G!ƩWQ2'.Io4'@ϗR86aBUSj5HSl(2f.ͤ,+ێJv.^]*w|V@Wsbt] 9l}!7Eҏ^H?)ۤۘb;_axDڲEJqL_ h)-'$z8oRErYg`M"P"h 5_vgN:,UL>RZZ\b.=[ni9< }xʬ3A[t-/%j*;d\D:`; Va͐`Kt'pVz࣪٣㥇J^9M.~VRԗjd|h&H):{B9]fg%l?ɞUL:4CWeߎE$36﩮,;4BrI%JUfO Q] t0[o,fWU!>4_E7h8;^ ޾J;E j5G}!yxֳx?7$~MJ8J Adw$5ƑHH-#SϭvaZR̤M:䅐bz|dlPWg*vu|f_9 ݂9y|e(btɱ#-hdKl=@_>a4SqиPAL!q .=oҙ3̚$K4G΢г6)p??o1D|Tx=4Zcpڌ(cB7Do*pd[1\iD_/(Ⴉ? ?xұ''%SY㓎(8C_]bKڶDM/k7a~`iPOt0կ>:אۜ=V'i;h&#~_ XDSCYwk>ݷO#5`Q}]k]+N+R|k'`9v_-`65_|}I겷cx&,IGȢ0K~g6В8"RIJrGIPQWbni,˓wۉ``4~3'PkXJU̖ه756Ց fyx:u '3&{?`xf -6KIRRXa_09|oF0cVWR ϐ [9?} +J2|"!G›Ql(<~dzi~݊We?`1nȣshq5^4QKt8HΩD_SUxcuYM5pol<0UϭiRȄI]ޠ8=cܓo7Z4BU>(wY3>'cg=Յku^gx /'=6"%՝@ O&[`vGU߽&Bo{s)9umP܃6_枋;, w.4v>tY}D9Ë=o,y 1 ٴڡwܡnS{i{-` C'jÖl DZqE 5>C _ 4cv K 2܂T*EAUEu3Ȁ^P+tHB9x:l G@tR$_ERxk㧘B2>H۫X"Ct68,|_Q2VM0.aI> .`1G>AfT‘,& wKak7d)0&nVg+}Ab߿w/K|FzH{u\9e%b,;2?AStԃ4TXjMt51G[H&6Aˤ$%&Nw7gIETU$%8u$b$ćpڼo/]tNTFBD]Bi0)y#sY"tFؚw!!I@Еpnsf G_(3s&9> stream x]Mn0 F"7'a$t3VU `F,& Yl:]tYic8esd]V2Hendstream endobj 433 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3349 >> stream xW pS繽B`.,I+p&!iiB @6 dIMvɟ]%[^-K&fٗb $1<&4!is]4oҙ׹;s2S01oKb"GXSZ伂RKџ2OO.` (7|lN› xO<7s DW@s|.6H+(u\^5P+^~Z|vu|Mn(Siy*bQBNi~<7?~G^z|j[)R,[O~"W)qEeRA'0l~y/r5E)%eߘ;0, [mRX*a[;&l3ۊbnF#zcӼaSQFᔟM9\9i1ӗL֌K3bb,,Ѭ?N=³:EًɂQ2Ȉ3EYQ))eZB'7ZptCh:J]zrByzoO:_X[*Ȕr֛: ~eZ(&ESiT|а~ub[k7z=@>tVQ#MJAܠjh)].z~&oi_]tq$PCERYح"%oOQJ͞|X2){1IRŗB=;X?G ]S^ɜt-nza*T|QC P6#>f۝`6I_V&C4F* ER.t+ @[sL8Wڵ!MTxp?] ?A/SUL4i{(7}93NTbA`y ZA GeDF4g ʓil7c+wBk.e$n;z~nA4KQBQ S 8{ y8ajO%\ubd߻=>"(9DpBgUEy~t4[&-@\I\C!衋gإRNHh*uFf{uTr,G%$^~(:a/ӛNؙ/< NN/kɈҬJE5VRQ+zK<i`rHwאڠ]ծlD\/p 9E %AF[]ksV3 9~qOO.\4-d{ѓ?^EM=1ߢ "Gx"oS3xhA&Eh@I?[7ynD{1=zπ!!Q42 k1& 6 +eMm]݄a?lI:;;pԼsН{+9ҟPoqGwqzY{t:j'L"^u3ЦyհH]//X.eVYSZ` ݯ]Ȥ0FBjY]zSAYzfUeV*u:i (in@bAldKq].ZXE4vBjk$ȦV-[aQ[zIXm0xl4wtP,E'(n•>~ϑVK4:[!ۻ;2 6ܾ0qDFF/Ùu[wou] u&>5;^y}hJ?`uٛtB.QUdVM'L*߭wHD֏ҭ}H>}pQpKk*!v;ڞ79؞oU~]<U[D ӪbHf:V5о3!hk:}̞}n }C~z8yk {G}i[kwSfB!E5E0v`_>tmAZ**aKR(@ͺBw LTbd][Xqܾv6''&NG͘PǏ0ZM]lt3Z2^rZn5zr8d&a" `dK_X?~v_o`awTY*>=؈VROrt*^P̮,i붴ho ӆ~4 )i\Gᷨh;݄օb[>jDjGc8uh'!OCO*ts|9K V%j9E:5C-h_G#~Jf߼O4i{?:juonTl@ 2>`DEW\uMVKWn .Kќ*#K[K--۴Vh3rӁ^uQ +whJ!YbB9&a#ۯXuD-'DR c`2 +ȇjS3SmD ,씸O1>esMTf-YO-f9؁2Ы`hBqL6}f}eQ;ejV 3O]BƆ/u01LJ{|tz9asMMc#CUf3%Nw$_ ~yFcVvoTZs:abr5t"^kLpXbܸi0 .}6Ņ̎6Ao6zYrendstream endobj 434 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1413 >> stream xmR{PTeJ֮;6Ajeh>bpDED]X`ܻO7VaAE4|dӌfNMMhgSשi|g~3w~!($7Iʤe`rR:<y,,|hztƌEDg$ρh\8<䛋,HAdVaE`+%C2ͤ |^V2ME uic6%%2[j1K|D^( LfL2%B|!)͓(2)R'$FAɒ$'bqZh2Zӄ+7ޮB9j59Z*WQon.QW.Jsoq5w?| * WKuzCoh*EEbOU< pP0vޅw[;p84x1_X?5=ot堙E9 hb (< >Ww?<}ԥ^ mPJV-3Ӓ@!r y9 ІWC[V/ rgn>nP|Z(Cɓ@l\B/pJ)ԀU\~N>$Pd^ϧod=d#. Dž҆v]e#p`wg5Ǡ]Aaf0; PŇL.lDUP#cѴDYTrYOfӳԺ7;ıs^6.?Xbݜ{ 7gendstream endobj 435 0 obj << /Filter /FlateDecode /Length 196 >> stream x]0 {C11ƨ/0Fkv`,[%_?n.a0O$Y9-NvL+kzEV_}<8M= s)_Lfp`@ZbhiE"D*:%<+JX+bVR#bWmI"Ηfġ9Tb>d/eendstream endobj 436 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1894 >> stream xuU{PT쮀$>$:TL*n}("˂rY@DEElDMT*`ֱӉuv,&[ [^5f?y9sDP+W2җn2rg [cg^ QػU"NHne8fx3^}*L:!W()3—C?'MA$Mcrr[3,6ÜY憅g!e!:ܴܰiKNaޖ );հ<|UauN!WfdR4CN!޼ސv隵ekM[;#}Ȑbf` ,[R3r3Ms9lRi5Yٙ4olb5e@dXs!~Bl#3]To'Ԯ@ZQf(z1u3ߖWguUeLUwVGE:P rg\=:w[|rEI_l`WW6Eɍe xW҉_)y}:b+j?|t"KPcWoIfA?1G<3)gqY .ȇ: 7ÇM:e&s:XH^=3r:*aoBэ1yW@N wB L,YE[,;YS[Mڊ3 6Uukxk%b~3y+K4elkCҟLAŷ1Vr, `$*5euPjt -0FjqMnQ]}|NJpmG™%kau(ۙOԭ,,Gb=MТzЖg-N_;5 ;uou_Z17Dm8'ekfiG>X5[mi<_Cq/98yoyx 5‹wq8JI:uNA9kإmIP7h5P!/{GEM 4d65Txi J@S::S|A"ف/-E?eS,0ʑQ4بÇKF(&޽9 $if&jƉqg: t^'N psqXza>'y,-6dvyA^${l7 vrZp7:h?x(F% _ i#}EY1]76o"П jOCQ U;*nwĝ7Uv{((/Ko^yn^< =5hlg"hB}Lc?PmSO 8\Nk;H;Y4M ?Ockw7sWn7skء^v}2AId4>{w goxGv)#V,fM/dxixXlz:U6.2>'` 7tTr9kܭmNWm u4` 0`endstream endobj 437 0 obj << /Filter /FlateDecode /Length 263 >> stream x]n y I/ݥMӶ ĩr(A4=g;4!>Ӟl}kK*{MdF,q`%m?kҴX> .yxAޔ։n%&1_9ZyƆ{8) ;;vu|#'Qa* !)O2ۃ>Hv`:KQBUz;)XAQGu& 葄d%?B6^+MFėLW"]iXMendstream endobj 438 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2328 >> stream xT tSɵtIy=Eʫ[HKhM4m4iiP,XB":Ax vKussOc$+V,Sn_)U+fM_#.K$$'q5RȜD[pü@v[<~x CCl\'7,uJYLήOբE3D˶VT*LM|U2)=&˪+D KK׬=k?:vyYݶ2B)+n7RY'.Sĵe"i`_ҭbqF,UJD+SI yբgWϯdA1 tSiLb D)'uD t "ݤ>bA"ǓrpgD2*)3}~+}Ck9IV7hT$$-RH/*4h[syhF3Bun\^;t1Uӂu9?|@&o ˜sCy;/D[ƁE8I"],xQn;tѭ+S2-s M`Ll pl e:p:qPoodRXvNY߽ ]/3g#V`L@)6T#MF[yB$Z׃gL}ᇎ c[iꕚ\Ig4LFnp6/z^SƼƅByaY[JgLVż *z[4fU}7kN㋃Zfer͖BI jթߝK|Gnt~* XUc(w`lUR1O@ ?)_EUQߐͤx<,5@@#Q:rO|9\ |6I@kF-O&jdM1kHYGVI"f;_qȃoċU@ӳ t/X^/ Tt`~5чgI` (^QV+K fJШWHdϞwݔ <ʊogt! B ܐ!3ZKg3*хrz B l›z̹!gPF%^Gm@n=Ԕ SGAKpRuADF hMWH Tڣ{zmIjw-T5b En >8bb=;;w|8nR!#N~,^ӡV+arL0K׋ 9Qq}@!t{w,;uH}Q7Qh Ȝ@fya$[YV:EWQcq[RsQ1ӟSs&^G);wa񺧛gRFKwrivzPƅ+w':3zE->;؀ V-l&c9 3 -!f'P{@[ ; =jU])qr]#]mO' tQ^wchGlMRJÜE՝2x󮵢pt MDYWD<8| ѼF4P,u)槚8KSg[e9]U{V3*$œ1ESBX~ li<"QӖ\뷥l_黲2֔pʍGGWJa>\r tm`:z$n[nS AK<!3nB֜G*B9CPof/'%F_-!֬wЖ7P~Et5e'>/䊺D]? Ooǀ? s'P7KgqM(~\ހ :.fwvvmäA gendstream endobj 439 0 obj << /Filter /FlateDecode /Length 190 >> stream x]PA  ~֨IE/=hJCPzxM݁sgMz`!얠8K*QJU.?_ij@򫜐ݛcSդ܀ #sj-Oڭ^tfT EADdJ?d@6e65{ZB@Kʒ"o,~?;]4_endstream endobj 440 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 729 >> stream xmOAg) "l7&(B #H`D#$p01[\hvhk J&HxSGM)V4dyf'C,@ĕή.78F]Z{2W ,K,W@<,-H/rAA[kȗ| T+:@K(Y6 A.AY'fkۻ@5RPZri*͝3䛨geY_DN痠CT4Xx&FJ)]pE')W0ӜfAuZx?,Arn& VQup}&A ]!WWo`7w'CNoѯCw8 ?QHcrުQ~ &]w Hn,fP,Bi> stream xZKs6=趵J'T*qJ33n$!-9֖x6+/?[<*w).v~u/;[==t|,߫tU8N;L/иYc# gt8=[?oVaV@Jh8)Rˊ mNԕU5^eUZ6F(I2y2 ;rk,}z k_EYhiL$OC; ó&i7wβ3|l{Ɲu'@kWvNY˚l( ~> ;_nbɦٗ l Wl=_ ZdU*+Q.azfMсwj;d}u?P=75Mu ,@,rd*b8l'tვ0\pXSiSclh48;G rX2;THNWɴNMMŞX  ǩT)-g9ǟ.e؛}YæRRd3 ~;ZǪ"}4<_NDa  [8\In_T",?'(\܅p}f ENUf0Q%(RbSJYyQGeP`ϓ'9gOfI6cGlPno!Zy֖lvs90Y%.o%4{o]tZ@ .~&ݐpvAO#swAVjJ`5\A*KPQeOI;NsWO]-#'pM``B`$*gqt*զ-|f> `K;3SD7Hϰpd!i fYAmG{=|lLWH0f$;L5NfY_y18m_D{U/gŎ_{;O,7DŃ,%dh2;ID 'X4,n6ae'D8(ȑ+ӠEd5GfgCBFkQUO9"0 -& ͸ nh{ L@M9+='D`ϳeƔPBNJFV:ޣdC3QY7-y]߁{3 fHgdz֡%7)X/@ ̯.|KTbY5KD`3Zzl"0YC*% 2BoWdGރy!. cETJ3)ꋨxF{$h=o1{p1oqb?Ni'Ow~) M f<ߣPG t l{pM1=sFUc٦X53\ߖg-~_pRbq0d^x;50_6I8(!cql3A^2tH|{E~]XOv[jd@GnwȍhJ WE-]D]oGԑ/#lB'`f9Ebۑv@Gad>6@Gl];2·L˭4Az ;VcaKnb(|WFql(np6찀 {p *Zb0iE'vwj0(H18ixJonoo_6ko>1w| yUo}-bǰ^ƿɰ fNp$xILxń&@q LF (4pJKȿ&Q=zYuRt/Ĵy5lzz$WB$3Ʃ=%ԛ8yWN``O 2*@{2z{'F /3QTY/nԪ>Y1@|s4i7BJB%EB^WZ  - ף1jBɎT]h y:[5J4HR k~UP9C:<l9&MjiT˘0G sC]%cM`h|R8+ z k ]!T ZPGlw ;A(0hm5(}GHd %Yڞ[_ԱU'>e"4n ȁ5f rZs1 6wi]dFg50Jjf5RlӯzR9A~[s#anDe,2}#LO0gVJ F=Cj,U0-'E ُ >akȼcod%l'iޏ,b_tTy:Mn >¼=6rp -/}9Nx:HYL`wefR`e1cT @S[Wŗ 28@&FqbJ RWkS3Pk0@pB*iTpoO8z4^K#Z6* JRyH+8L"lKˑt}*c >H]mT0U?`Z󻐆JJ GrQbhUlK8v0TغH -/g==zO={T .x@NvIbxMc=trtqHTYh#MSt:L.xP<_U40J PxOV~KVP!+jXʻd(}j.? 4>: oep'a]3Ȅ[/@bXL;b]YU *X96<~}n3~LQHXF)}2ܔע+&g&dVaBCZ|1`Z[SX}׎M|?Knw32dSO/_a֛ na$>,2 2m.TGӭO5^!.**Swky^ 7 y)wŒCȱh|YK޻"M} Ѐ9 ?yx+Aȋi.Y59Yۨ>-Y0^k.R0$&_4Oau+C<[Yv3@Vtؠ=?4, <Э׻JBxjO !OmRmP+ , ҝo_iYC']͎ iYu]Uwi>Ks1CLjD2K4:t퇝8endstream endobj 442 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 521 >> stream xcd`ab`dd M̳uIf!CѬ NyyX%={3#cxJs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k8a```Hf`dpa`za#5|:]|.>{ݒs;˻38٧hhi73ƺr?[`G]wTwewX"w߮644vKV={bu+&g*7kn8Ѿ{gATݤPв]w1n.4EVwWttW{z4ewsxwRwwwutt7׷tr$*Xqҭ~v'SN;N^EY{'r0{ܩ3s}b 7yrόyxO_`ɽzxxFՕendstream endobj 443 0 obj << /Filter /FlateDecode /Length 192 >> stream x]M ژ6vM @P}.x|3Cم jfFTh)+ZvUM"h]LP> stream xm{L[u{iw2_Ulƙ]LDbƘcq1];ZJ)Bˣm텻8-fDp3&*.~/,Lq0ǟ/ƿ:ۉ#w2QpG;iRWZ[D?4ͧ#\1.T6Q"(xWlsH=4^'$Laxit7@(>ePNuj]W({LiV} It[ʓuoehgWbSk[Jdr*1EYT^r* l#hdFsƅq.3Gkp0@^߾u:4sV9tj%Dr ʚܷ=16)nٖRD{Ȯ7ڭkY/SC GOK']nnPXN{@$xe]yU%YN#| dktK秛H R&RTD(E{^swdT;4xt"8:D`oqJ诹ʒ>YSX|C򼡭He 8I>8h'z"潞 Ny屃 0DCWG|r@S_lϡW.opa.đj eb͏*~ O{nY]b8vPz k%ҳ)IvN20V|Ox.?3h 6qZR2$l(1zge f:&:!adP$3r(& DGCeN\^eY68̱I Hsendstream endobj 445 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 659 >> stream x]P]HSaܦ4uQy<JniA7V!iش79[G]3L$u7a7 6o, !&k]<K!Qw`{}U6`[Ԉg(D,ьRпyB0402wỹ$)ꎅ[h*T5;81tCݝQ\?;kn0s|;W5M\f-S9B(L,= I-UG=9)ЁXL)'%OX x OOLGM1I1}:kwW#n0{TqT2kj ܊qvr|U"Yv©!J4l㴛`'Kb8. Aj[ILP! 6Apq IZN#ZRF&v7qT@<D遬`^e JsL|f^8~ |xu(`o^T)d@D\O@8EߩH M er`wU'W* Û4agBc_ "Ylg2^~o 2 ˀ70 <1'8yendstream endobj 446 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O0 : 0@p' aߗ,N>~l#GpƲ5 HeQV-ƃ剳B7OfUiZB 'mQt1 7gBUUJM5☛&e=O) .S+endstream endobj 447 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 320 >> stream xcd`ab`ddM,M)6 JM/I,If!CYed vIu0wY{" , E% Fƺ@R!RIO+19;8;S!1/EKWO/(ݙE  ] L,gtڜEyY%e-ruwtwK֮n2e”I}r~M7{$_~ -ߴm?~n9.p{nzzfL02&Oe`yzendstream endobj 448 0 obj << /Filter /FlateDecode /Length 6948 >> stream x\ϓuyˇSrŽ@\vMSmRU*Ւ\ÑfG>t=3%l{70z5j5?ZV__(vlW"DLVW.R j5ƭ. Q5^1X,zqn;.:_HݫˡՀ/y>GX8qK~G\8v߫?],SIHe,YڐL,i$L2acH4LĂARuO2y Ŏ,*Dtȿe|R*$Q0 4!mFaXHc(DBsFPj16V3IzDi6cISf|\gFxU0Qy "S9ahHfQq Hca ۴ M7g 4Fq3F%%P<*rG9oܢQ C˅p(\Hh5QOǤJ%2VJWVqL3 9D4 eyD+P笘ĶA4[[yf+yCӶCD4DLj9#(㴅8`77D= =D"/ubpvcvP bD铄!q֙U ~MbFnVW,JFā!]>|\W@GF8 (,~ 20uD8VOpn'"%?_::zo p*Y!D ԃ gA3SHpݓ!-L=64(gW*o0ݣ $q\L? r~'e &8DqB5j9.}AB Nѧ?r#$~P1NfHL?Id 3l0>Ͳ?^ 됆0 Y`C @L^g%!T_~Fd {>K?6}'rt؍汆g eZ?2؊Sk9ԌS ta~%EƑ2fь*iK;%,3ȎȺ6T7k k| >u/XI]\Z\{n0u.8}Ug#-jo' B>?,{8־.E~^ޠ$) ]lzlTtnı5o.mFws3JÏ/$qD%#*%DžVy,R=0,LEP?`.s/ *[mQ$3ĔӋl+LO?4ZsOgUo6OգsEy{ÚMc'} .HQ Ѷ:Gͷm%(A@\hj/8F/~ݺ!H Hy .]W'XP]  JuN޸.T+!>~sf ?M2n38L_;!M2SgҒ ^DHj (*MSԮ#1#1 tRkML4'D-ןG=DN1Y\dsFiVl,ǫ5G>zQW{Tt?J{yѽy'3ɜdUI.tN) #t559k M<'Uk7KL(Wd a+7/ @I(R|D;f̏e9MFia_c2{/=S'mjPߠi!K|]ן:䞣I3g rπHg8rc!gg C(W& 1񸘺iG8ߠPlxlB(q~l&wZQz/8LQ4 Gj3*5afo/sfZ~@ - BA4#B/\9ש6<7Gv2' b}.:ȼg/txRll]0?}#LS.[[]L&˪i}]HFv8'c}yvSl5Xj1/@+ߜR*5Z$Yt8/˃B| IDTܢ֏Ω;Bf*Mx5 ,I,vy7SO?^e.eH0^N B|s.gO(Հj3QSg( ڸ 18C_o'_asyõjó ,.7XVK;3k\W1tY9#dNPQ-R(ig-Zep%Zjt Z b ??KoZP'uѢLEvA4:L h()w(}yu$zLv}Q1}w|ԕL% C6$kTR/G6;rN7F_b,ͼt5ySs|qϻww;Vb\aWm+rͽK{}k1^:dDm{YkXUi1^jZGK[SJ96fW-dNCl7ӹ.tn߼K=(oO8 ?K/zJqPKiOhF]Ȟ=NDeFU!PSyU֘hjŖY.% ўhg].t$H~ BnK1 ֫b?IeQzV*C/ 5,Ln9M0m2U|VK& dGq|HwoQ !r'9P/Ir/'2bxSd %/i ZB 8h(+rAx+XAOf6pBw5w_drzg -o7ZX4OD2wi0:aV}&f=sK[="^'o؄hvRj9+jeƎS)6S?1I5b6get>~@rU'UQ\lVz6|kLj36zGm'w1ٞZ| Tro88(nk:|Oکxp&G粷e/YJ4w*2`B_ơ}VRy:ܓ/0tC:6'-ޣs٦szuyy9us濚6=˦G~ɸV]seSw+ڛL7S!>yrsl_-c'k]45q|kWf ݿE.Sğm)æu,cFiu\<*Edk}T {D8~.'9ӟeuϓ # d=EugbXLw"@%&g>[ߣ#hw$6 6)%pć${Gy~ԩˋ?j׸h! ˿& @zeecx U,В ;lpdBY7iQJ:UE.Oﺜ~[5^xy}xyP:6Q]=yCAdѦ_a/^^XHl2F^}#5xUEk~ן}f I(-۞yƉEF}!EKjL:7>xCE|~@TA䇖j|/Z[>JST.6,s9wvySbdSUKA:#v8.c> stream x\Gr'c?.}I`0rXXuX Kh5JSU==܇ @W& \p鯓z[8xzI'Ozr>i~-/zY^~o3Zƍo6t&%4y3e-r6/tcjjS2fkH ^FZ`Gw50aY"r&u n`[Q9}4f,ƿrXoWKȁ>Y^֢MokZ!xwsu˰+劅mY)9oʹ*{q\Eoz-˿%f筮a eW@e˘1D: 2Sm}9$gꂗox ȼeBRq&&3Zk~:(yK>e[ +bFP]mtpr'{D: RU+6B*6@;"oj-gJ="[(y8 i·>R a'bg%!J«:89a2hvR6'r̷V> nk٠K@DzMhl/D: OדcpV R㨏^l3v:Svԁg6B l"7nST324a` >̳ln*Rׄ#v)$̶)cq0"=2" AIxOsAU9Ym8x.j*-5,k~@ *OK`%ؖg ,a]]\a`aKM "-ȅ͍5>OpdEϪY3VUB&SASp(<)kkkd5B9mQA6_M+ *`n#Ct1F" 냽I XjvRk.D˥V2kZ#zYW蒸cCo i~m%^rYwOem0ߪEQ]G98F4 =GtӦ}UjnШR`?ySJU&oC|8@OdP}tBƀEuXT+ʇ ' 褹!b\x,~fOy80i5ؕt^53RY_(gdI IUF7۰5I[Ud΄vK G p^G\ f=SR o5&NLǾFT5r@; ÎE(.&+hPqaG 5"tc37 2IWݣ/\opR1 I휝oI+Hu4*S31`udmYk۽Y|w ,M4?iUP$muyWGHƽFd8>`An$4ihT6WN!,!BPZ'-\Sơ&5\N,Ff@'GC4١}Y+Hʀլ-A'㥎M\uSHu-Zs"8T/*^ ,Aho &_8,D죪I3w @:oPg`x2ul=> Bb^N0UMXq E '(Ԋ&C .leR P4aN lpYew(֟7@`q2|0,臢, i[Q0/",#W9YvOŮ' ں>GSh,1rc#HSջ\rE5K?E"4A)a$\.KlZ ngPPb5_Vv3(mq^)5c\pS͕?;q]_'cJ M$8v"@7rYj43pA!Q&5Ry'Z B3kUݛ;O]t$P P@+n[1LKK%#jţJK5S_݀ Հ&)75CJrvѩ|v3Ov{&}Mj!fG]~/Oߧl HA,OCp%?.jb x@RDi}9d@KKD$ZZ:=kxr@(QynA5fl&X>kaȑәpOq|ˆ'F,⎢^I!0?׋vy,4eYau9Eg3gZM_\DR\#a^^Ϸ0xjEHҁjQQLd7?57y4gEyyN]LHrjUd \9= .v6jXM ݌tdTW0frTf_ʠJV#g[|CN+0r/L)V3 `ee)Iype]+]߄ #J1۟Z0 9Bh%6Pf PE|_Y|<hU >903 IJ=N1@j36iMIL(^=X4b:6ÄPYoqBfLJvR H>KМJШJMO1/ᘡܧ=NMT !49]F(b.jL.^ 1 .+DӲHk>yRru?1U.<Ԡu84 TV\lO1zUh- cԊ}ViV>b[YHC\';^pda o "FWE]@dT {̦/ΟFO.?*>2 iTO,wzJګ> =bQ`P TYYVnuGIÊ5hobqz]wQiJHn%zu1pJ 5S 6vX=<o4])n  "bpE<yj,/GJ&7ѫnZэqb8zt["dQ:rtEJWh` *H-ٰ'Xx^Xm>C -y'=8R*V$:WzyɍKvP)J~5@ʺ&mthb+^^g9838Tb-i/[(a/ǵtI[ኲ> /@ MbKG Za`bN(Jv؎Q/8j JO M6ŭW%i0|B]ԷʚQL& XIyU~ .CWHor#GS@7TRc 0V3ףh,`M2GFH} (8/:OA|o7 nPg Rt kh` Ok1&k|]o(]ϵeGن?h5(Fa4Lkq6ӖѭBϖV ]]1AmMV .'iv聕Q GYbw]7S0NgDorEYPm` K{nI\D[iybQXt/X`^\{)Qӣ%-t=_S.SGËz*m+ge9F,x(oi)nUDq]sLzx_8& WMnC{-.6O?KRP zDCc<I9]{[ 5Y%9o>-g&1Lke~|tlb[ΥYK`"]m†&xm-4@؈tc~Q gIП6MV5`T]',rY2>ĵ%w݀NXh' mGc"JIޏԉ4"zϼQB| ɸt)byy|>tZIq|ÉGn-0ԡ7"i.xX$;YJb̽X%^gpr۝J\|I95$ dXBC3SLNrMWfU]e6WvR248=м rCP(ewA1vib@++eR#w!ơA-8 ҄xcFg_hm#ה^ ghWB*$X \e8UbSX>!tO:3r "{Cr~pMDV _WV24Ulh/jzPQĆF3pU1ŰG*R@`Dh`GCZ;"Z~%a< @ :an9RG-+!!ehg׃eJ 6}`;bN/f,"91MI|W4a]AqGĤ୎g?OgZBfΟŷpo.cUVP 9_|hL7o(ު*6]a*Ζk:CS:|H`C_1"SPbX\ Z77~uyƜ?f$~ryu_>,"yˑIdF,.l\7SqkQثi}~E~X-v܋n<@*ӏGF(U$G_e7GY]'hHsU—˰ BBTRjb\*v6+X 5Csԗ@qTW:pXX L(bnJn{̀9:}i/R Jgin!Hx*V^sH>;ǽh1EaX7NNbЦo9|C;9s#!?ƱgLg*6ſ+9}-CqqL9`/n=8r^ p,ItB@+3n7 Ba/aR~iyt"FnF P:wytÃ7_4bwad>$kifq=M_ei9itP3xעe`فpX18m/ɠ(}-/Vǟ%9THA8议 \vISqCTzryCKZ@S^y}^m/X3W~tצ~*%Z=H՟j\$Re4ƹ_P{r D儸 69zV."U,чY״^.#hq_> stream x}]\q;vw:ԳK/ya#5ИH͓'nUOLRHή[>vr {~ٿ?sWKDrj[sϿ~GE)ew(ZH}qӶ|~~}ox}<j5s|–q)3Z\9 6=W]ZǿTo|p\]m7Zt//M-VcLJmZgDMǿ7싴ZFƲ7*l5㛹Q1suP)&sgG>gi!?$Wo{/?8ιC>t>mˇd bSsˇ^|}_׭py^7΅Qw̧XB=sۇd*%_rK T8޽20{lil9'_c҈&S3.M6Y*Gm::nФh An>B>.$XNͅL2&]S.YJ%hu.DR9Z^c>6)z]9$+A]v /xC:O~*WSG!6@H\fXuC~E(_$)œYJ?-e|)ˤNQVt}NED,Qy"g,2YF'o5Oe^=YF"-弌6g'LJhmqقlbz z/"}$_BE@~!{wrf(3{IFQ%2AXU >@"jZ]j\|oI0y5)N|iEiBAٷSp:%vH')!hO,HK`-DHD;ޒU8Qb.<& O+))6Q$52~;1TQhXV,1{=[H-g9+u9h$)wHJ5Q%А gZ.p(sTO@"ˆ褞bIJJbc, n P D24C, ii?jA,''/(I`C> '7}$iGd&RO4Eyԋ ] B[۩:p Gbw:qF2}(G@. &c|&s>ء JPR[&ާSRI?^b,JPy i>DCP,$H9O+RяŔH'lR$%XZ8I砂l;X2;TrzAbtRMC$Zjv1:H6{*CB"';2>ekzHB5ETHdJtKZ3XJ7h9}!5o_, FU3b5ɜ6r77]_ƧjKk"{ces 6AsDwFȢt?=^0R[&َA]ئbeHvIAOTi$TUv'H"GC 8*m7=Di fQԚ3kYNI!=*:Qe6UoKRl񶍱;lEUi:1lcpÍ2Uȑǧ(qTkHj-{+#dTvQ HZLAKL1"Q(7+*F@#)o$t -C'Ɗ#kr<^Yj=$e8U xpU=Jtz;>"iO4mT7GYBDhq1к|lM%'hFM5iHYܔ jldYŝ7XlaVs3'Y`|N&QqQ$vOɞF%Ee8>%fXljw|@lJ+kޚ rMEB5VJ [& Fyg㻰lMRYl`Alf5x &0G^nAA¨ b" ^jPI&!eOUW>RwǭeS+C2Nb$%ڨY%LX|:5)VZ"Hz/]bUR U:^G&s̨Q3({e~ZgzEUϫDټHlRJ;xEx r;TZ)"͹T CwC̟Ipd < .(rQFٍsM,DEX,) bfwViqgEV*p~֩+.wCe|'"kU*oT Қ*Rb; N9" &LE ZiKc&"bl1 |9Ed -h,S@Bc-GC,=8g h 1h ӈv@";4.2&1h\bkSޡquظv81R<ииo4nHuh@[ezo+FװqC`-qƽyMP "aBq{ φl g1:&>PL^MFFw|ܻ>q_9fg&cYd׷䝺Bx/,Fq@Nxi<sGLx8{cǹX\ǹLqV3JxK eOxK _2xa&wjqu_cQ[֗cqvpvxa)=qv8-> n.;j8o8Y8=dnNb76l>8^zE #^ۮc EiظKYp1aU%t%q1VV1h4wKsubs2_9T.Ɓ)-}#!1q@X+4}! l|{r8^dFŎe93r6<"Ǿ:FPSoqxd/T0&͎xfʢ( x΁es{r q,sIce`|w߶eM <EjGّ!3}3f%]3h?̠y9̨mZ;l M8%3F}B΍ ޑs9s'\9xܫz6LKM$~\ (d7j O-0ޔ,mz1wSǥvɞ̌ITld*0b%{蘲a/KR8̑9e{=ÏL<3mOז-x;s7ązP 3D?S^J-ڦR]g.D\s/4Kf~k'KmOg O¶G8{޵Me"@yd͞,2m٩}~UƗHTF6: rJ܀ EkTg ahqۺq*Фd 6%t! ^X斺u mnՂqJ0$@hD=AϵK& 1HpzH&0;VYÌP 0Pˑg` Ψp4ۉo$y,RW"RP_YD@PI&opGЫ z3LOe, ln$- lv@葶8M1khʼn6N-ƂWAbL^AS%WXmp'ع`fk6g-!D6WՍLR^=TnmLlAU`||/$o f!"i\"BM{I$B8d͗%5HժAhX-ўjxE(qJ[mHEׅHUBVN$ۮxShT捅ISM,nNeUF㆖͕rlP[ =j7ZLYXShR,n9Es(qٯtx, Fc@л3@ȎAUA;F{k02C YH(!L !Pr3JXKi yC_m@ U}G mt$:V@R,;Z([vj }D80A&p+6@ X? 1I2 C n4PLbT ns!۽9PקtHrʚe:xC4|!t;ao#\3SBҤ wqgq0p?'$an JT* K?F=mLYRۘ>}Ɯ~(ˉkz{\pU{ ӑ%yސYi|ɑ7G{V1TMYi&M-35-[FN`{tWI}htSԮ% DWIA ,qͰG5$^sϹ|p=8\+ʩ oTO(r(e1y[057re%4es4 6c2SFY%3 \s,&z]V.3Ж,p?7$JL9خy-: (cCZ1rnQ2aw;p=ʒKl] V}n  lV{U.KUT o<|(:{ooHbNL45ǧ # QA%`ɜUQVKtC}cֈ9Ѝ,rez5scbf&`Ecvh&X3HD2* ;C Ħr\ \6`]h>2cH-p]jD8 2D#$9mk ʍ&4hXL"K{dStm h^fD1n,i\9jM=RLa[P"Ti[d}a L'މeG+R\8evQ5WKBƩCAN\F"إ.-InebhXPG^ݮ @i{b}3r0F›ڌzA͂T *f@G#K]V[Dc`n? zٚb<% $ f'Q_#Mh`k𙶅+q~ ٢Čy`4~q=\fN1.X?Ǔ%4dֹAw&W]3@ SfB3ϭ0~EZi*) ~k*K-{gv#'"`3d3/`߹zNFiy#'U!/Kc}YVЯKHFfjn=M1F会( xa)J|Q gn6\Z|!L =G$-qu[uXK #ܞw;Φ$]Bmoױ~c=(1?āt#?`$$d+ƻ ȁav0a aʩaE J5 A5"Z;H63?(`W",w?,Kf)W?L_vX\`A#`_4E*VjsπRrkIOq@Ol׋Ce5E(a j>7쯱$ +f_y5 XFKGҡj k,&J@说Z^?h@ 't 7\5eʢvaP{py 'f'cK=lc@"1>;Gk n;oS;ZXрŲ(pW@䟷DfMstQQ!WCP3d 8QU_:z9 )zDRzd dQ ÂE(ϱtGAAv5} 1m"DjgMCN簃 $2f gSyP/' ϩ?{gqmYcXlel? "4i?B b 4t8bA/@gE9 y :UFHC.͎/0I A-z_s?K̝ցָgd`~ C?CX!VBG" Б?1:҂A/2`WT$7?M1?nL GoGg)C8 ӂzl9L =In1D9NvԟAQ?eHvԟԟ}73wke:'sםBadZπ4';NvOG3Hw-a{Ў%V?djh5? f0ڡبwoEc:8x3g] p~dgOR)qN; p}M|aI"@\`z0"  ɀv6g-g?4DX0[o,cS. M%t` ;Yo^}{4#bosD9Fz_OeltZ< FUkCՎ_Oί'k8|S=>|bx:>qz%Zuonۚ~?ʞoOK4ߊFxӫ7o{᧫ǻ{׉~N(S:w7?'EOͰiMddDl[>; f66:҇Sew2/=Y"ᑽB[wל9k$v5V7^vl7r.&SýTW77< ]KTku\7^[Wۛ1Mn^X|vJ^/=nK7h92:DM(nY~(2Wa;~}1F|i=^ҀLƠi:_ݲl8`캯(;ރDv?"79mgn2 bnߵeRbL?կu; =\Mz P/\Ŷ4. 㩜S4#G£-?ת+~`tS_3%fYPk&Kig; R{ό =f~mpOa 9>(VA {oؿsvN߾~uNׯd8XQs=A-|>_p`hKǪ>'ofra\-f9^AUL t&Y5s ֫j*1U'zjw *y9L=Uy_2?Wc|ۭ֟ǿp)rbWWYIQ_~ןrS6P04-?Zzּon<ʆ󳽕nt_xq//;*7)~61AJw<}{$<`,|2ye  oJ~\%yO&rxi@ k}Â*޹6UK }82 /ua4݌07X  ֮FtYuU.os=+;k*\3r#6wx;d&.Z Ӱ 'FG i/Jo]?9aܠQ 'X2&䍲mOqDK8q>邹ُu݂oo. [ ?GcXIb bm(s{~0fi?x`*דć.X7|)D7wf1Ae$XB_+;;h8&#X@{ 􊨣ԤqTj'eAMN1GI@C},NV"Vƕi wĆ~{s *Fl˖Ua4m R^t.'MGzm FvEzC'DOu@ozKZ  ~ u;Nbh:?p<苋n8ǁp5]uR}z)YnxL;_Aek) 3;pL\o-Qs:_5鳘&=,bß׏LNC-ñw㛞q<z/*iE}3FDgfs YGPtǺ@ :R VaߩU.[Ev3c`롟XVCmkg~YTyauooY.oK̦ӲN]vo9sa]ra &]]!-鄗kͻuK#mQW8#{)Dm,X-%~*,6 R3^ %3n֟u!PĊ|v\=KkAJOKz; 7> stream xY[o$;~#ՑLFt,!bPN&;i'g^=Uet6 CzڷrWU_Ujj/_|VnhW.8̰4|u",W7նRjdӶʰn껧u۴Z9=)EdՎvC]L؅[ҨwƱc`?>f<\bm1'J\h6Qzjʎӕtl*e=ބ#M:eKyǣ@9B z=;B>tٻ՟r.tQ҃mL.6JH8cp)N#9{8l˱/Xճwa׆ݯqlP/LQMgPtm[}O@VOϞ==;rxˆ.SjҰ?SТc&E\݇}R xT"[Q9XA0\Rr T'[mA+/` GFWE e ~O )9`Ԑ Yv*Ƞ3о- 6}{nSt1}OjQ|,\qV!RF_'Elex T4{" ޏfjN,B4NGl8h6v\=C "2]"nOIc#|Mԝ[Y;h\c͹pŒvAZ P#mDpA񦎅RaD%{Y=adHCu]ϧ4S8|eE[zVܸ$K̶ [Ų,g{8XYaNK8`bC)BfMFBG郎6z"gg.ǁ (sq*[%dH90z)g F $]H}XVAB 1Nc9S&D M¸%n!VLm:Tve -mcQ8.8]!nPM=Lg2s=n__~10ҟr!+?OEZNՒ !Cr8$WUXedd"&a y%ICLK,S F,$M8PDBܰid>"p 8ɄрЀp~! Ę7ǾOt 3DưjSpT;(@,1#bBi,'`b#k:DG!:8b[.IH9zYĹTJҹ+cHG堟I3".m`qS)Uw.aϣ(1ǟax>>lof?Mvϊ78#xgCWu>H,_baRUhKݓp;uKYm -Elv91r'ZڔN1hma.f+H3ԛa^i D]k"($oxg"R03QSQuqu;E# 1)p,%;w/BH匒f~zua&sA>@ d2GZa^ERc$,o҉:lnh]Y _Y;O@Y}w0uf}9tm!cbmQ܆., :<)dAU['UFZ TӨ%jr% oہCLSS+U:uaFH!*2tǾu_،k [hhtmV)q.eKȐNu)V|any5.B4{5=Y.b:nw3? #7Qٻi=o v5t3It8 $4/E+H,xQ'I/DJ+y)Պ@{8rƟmhkIlKGaP>݇*B,x:RlYw铀>u3;2V*endstream endobj 452 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 714 >> stream x=ILqghP'v-b-!aeJe))E"jB1@> stream xZYs~>a&N@]#zI͚V+t  9+rA~Ίf UV?{M(4fۛͥ:\ffuFk}Uޭ0kIprk8zҐhWWk.T7Օ{5-,weHɬeۈ~|Z3로$&4|'oJGO$`j?<ޒwSi#OF1U$z>@8?E!nPs& 7,܂nW+۟Vppte1w X>*"Q^,|-m7>ݮV)L32hg,h_p4w.oS9I*NY]*cԁFʾhbJ&5nI]J a}VlUp͸+I9)0Kʳ>;gʩ.}݁F|A)y|<'vF s۪PWwø MY}j낧d\\wQH[)߆G륝aZ4)\_﯑zC YG7ܭ FhBE eѠ3^'G霦9pD" 7B?O YGOҼi4/BHXCFk,ӂ0#XpcOա &Y ttP*$M:- ]$]U!z*! !|sMR?'7"͡pKhO0f&/+ZdRwMV{EZ+R2C(”ckŕ PyOFOovMO?oʄ^hԪ7JN {'ڸI>_X0&۰lY'2MlTzXp h¼{hiױ҆EӺwRN+ΤuX{tAͤq]!Ԝc$d¨Va|LzgUR\O+} (ӣX^{tiڎ$skԬp56}?giA8/o8lb_b[v@;~y_+H!]zP$& ֗Q5Q/T̓+WSĖ@qoKo.2z)i۷}I1!3L3xcPChcbݣK fq1~ `Qח1$N^y: 1Ѿmz j~`(b J6cpE"2;DTexA*D{<Om tx% 끱")P6Jt>!Fm0I pJB~٤ ^Cœ3#Cb+ Rʅiz^uzr}}TɗzqY^yL6I^69~PPQ_j9PPPQϦ@,(dllAn+bg;\CF0oцq Ϧ<JOo H.N2o/-@R,u^(1NA$n\R{ )!oI~z|:18^8`k,3P?dmrg$ M0a D.ٯtII%PPBPmBT'U9Di /ImI;Nb\13ILGX| >ZKJ43O'.^I\$|/`vOf:0 Kb @ IńjyfS'42g'.4pȇ&J 0rω\/;?tRy7ͱx:K zË4@XH2K`-AHqR=>y+"WzO6P~&5sûAxkz\7% `Vh́P{ =/NW?œG |)JphDA~$ rܸkHXK^L3'(:nOLCꢩ6>+Ӟ|G'P$8tES˅uA:5XMywr IUa%u$ś'MLQɜ }YE/KXZ ,;b u7[t Daݽ'.:(v֐Dl5aq&4x=Xw{XQ]R*'N> stream xZ|TU!Q$i"M1I:6df23gjzR@e.jB\W`]>}̈́@~d&wߝ{=n@ B988Y>rWtk3 I/R۩g)15r8ʕrRnK=O@Qébj$4E9QP3MF&&:19z8r}QLw>WLsyزa.`{#_yQsG:-qԍ^:e6eϞǎ6Fr[:s~}2ϫ_xqǥw7ڋ/^|;?4_NX3A5ȗoQ|-Xn_:5?5U/QLJCC_ig"! ==2 ,eN&Sz0ڤΡyi|HA骊JaN49 61GtoqՊ.l _*6œ ^`ǻul KJfXkP͓Nx`A)0hA4.ٿ\+Z.b[)(^5>6c:m8?XFZw#yhђ˵N^(;%tā*J4 fb`$%]X{`&Нh+_A*9[!+~$hvWP陳]OiA8"5h{x(/lAG>W4ysF JIզA_`ޖ P+vd d2$՟R{3ʔoT [aCQ-FS);:ҦpV(r]e!4̀f?3mAY{(ź;Blj~мCGnQ hROҦGXP$aQeݢW$^݃]8 GZI MUKXc]֌C\NLBa[Cu|8r*5*:U㗝KऱawDr?0OLi=5Hpќ~$4H`{oӻ:mꅐzn[kygfԡ.l,_fsX0PO~G!8LľZ`0efiS?J {w 53쪈tN Gj{LHN8‘ =n5(n\H2{ ;THv=h#h?)js21߱9|V 5ZE[с<\#r$~NXG5eR"E6*`ѓ FaաڢP&9R/(֠cJ*<}rh#!AS y 9P `.ϯE Zv۰pk /Ia؇"{`' Yzrn}NW/ՕDf-՘ۜ6ae+d' N1GdQ~fwdK<':1W+LLݻr| |؝n<m1-.u^ӏ=D4CEInzCZKgN4vv>#;HœTaA"N ~NZf˼f4W`65Ǔ#m*QЯ< d3A2o3c+{%BUR }7o ʻm/r˱3@. mnRJ3&\JHF,ZؑXkV 5$\a1y9höv4&Ɯ"E1@Y~QьXd9Ed8:OZ_HG$9$.<7@)8\Kc:ܙd㱻t8s98u7rHOc RZ w̆jCY?y]2JWJY,T\&ܘ8°!JM u1۵^72Z[]Kp`q= (~_G 1'jEG!\WL[e`]?cD:Cu^h\[`O5O">C,X^ҏ6ǀx|͠t q с?1GL`'ƣ_NDb7o@ي^*I83qȗs蝴f "@/ 6p#9[6ZsT~'E~B[WYM c2.ܲd jQyp*@a*W$d]n*ڧ'[>kT2`%Bx"n&)vyJ#/↴Nq~fIL`޲}~M݁N q]X+_D_"[?GyvVllN!KʍQT&5C34F?Ο[¶jP\x)yI<%ܞ∮#' h8h"I꾎q}m_fFvϓ,9rMϤ_6-&C&R_k_0׿2 JKۻΥ]mLj"U#VpW]op/z֪#. F!ƯxYy WCϰΠ(DO͍|G8e8F]"*tetʉ$t".o p {/sL)ڠ0z7V]t9CMG1O'@g1v[ g˖&r*uF/7Н't\x9MֳĊ2 M lHa}ޙf36翿eG1Rш-F s9ވ[xV%H  Xޜ\-gg(_~쨮Pc6]/-OzuDAn%Λjy . Qlx$, Z ͨԬ/-Tۮ ѹ lWEIB5!頊c4[p^jLE)G̦|ӫ oǧ"g}9rweៗ:/v@2)o@2u Mxܡ' R|ej5j2<_&]d"7S"A `@Ьw%KfMiԉ&͂($Aԡu?vvCAgBu"v*N`2vWyzS東hIOl*#_\L:Dȕ{3_[ 9Ep4@ĄU<{Ԁы P*3*P&m$5X)O{p}{ _, ";co:mQ֛?/Uo JsĄz`Zo[$b\5m׽$-h &5\w5x235[Ҥks`ZI.*-f8cփpBV%Ut$繒h5)㲼TZ2CHRLXX]iz'~8xAli4x6,y%mNi$zBĢ+HweەšN>""=+ԣbaUMxy6dDf{G,"K_L"Q~jZ" :!&Jj'<]>gsZV6Ԟ!OW!ώ#混wA4'rڠq'9 Џ{uF߾Y$2PNdd>\\v9je%Vp:c6.D"E" sțYU$ǓK` lGz4{7:z%O FbSK> stream x]ݓ7rO^9˥R̽dx߀\zr9;U7UITV+ZܥLZOwf\;)=;?ͺ:}so%].O^̞_B I:fo/HVi63ʴNrnEuR7jy;NI˝kuV4ϯ ‰N&kt^-`K腙Vֹf޳jl}3xwI|hw6qN4/=C4km]grܱs>%|\kn`@I+M>a( !U٤N sos6ay+|s06b!awBVk| .!7́[6,#tۅy؁1 1jk"D.6ԉa&'ԋn;M^"/pxqoBҚ 4i5BǁV5ROfN3,YOv#t6+F 5no L+@̦ts^Σ?k"jp^779J lcq+k8 :"ͫfGS!y7)n6 _͟.z`Uq#ϭp6~TپIa+$$nD~jO2Jinft1lnFS5{\BhAgiS<#:.Ti ͗}Swq7u~syE)"ĕ_oSvϿrw^{Y%|6"6کӦlёL7>!vFW 1˯@ ᷭMIV1֪{ѭG/eS$y@*Omˤh/*tS;X@}iy>lէGVcjZӧ}i1Hyi%&dhpTg  Q6 c:כjt AĖ#ۯnHA&R=Q t }_\^|sc5ZZə6@{1H3E*'˨]B8% |h.W?ו$=u4޽΍{y8GZS!Wo"ƿon?ـTґl W_Wt.DR,o\V;?D$k`YLb֝6d0G,O''>p%}|(lftЖ>ԡ̈́/fsxWrx%eKd$$h)T瘿"m(8y\ 9B j] Z-cm Mp6H!S?̿F~۲(TigI 4O`SMqFer],_8Y0PΰY`D׊T7UF\uQ݋Z#;`y. ` o.SJ^f3+sзlGչjR%u~:EĐW[ɂ-Q2]0YZ݁3}bQ10f7J0}yd}]=[1 0}j[w:22mf+8sXR'50T< ИyX==2C" -;M,]Pl,IpW%XgsZNCP%g0_)GDZ+8KG1 08PSᖥ!|+8Lo8ֈf ldyO[#]}(t&^]ѷ_XԹ$1EۣztbY1BFPjz2.;EI/.q,r#rvRW- 0Jٱ3{CLX N$gH` lQ[MIH9[-,.T6Ĭ >+2IX\(.iH\ v,住Q=Qbf,4ug\jv@;Ƥ67CvBlhCPJ3Ds`|rO:IXUL(jiނ *35]|9> :t쎅 l$Q yd N "DDDm)E9ehT6jԪIKTAU<̆Vs0Ed/SHǍOlhׄ0k ۰ 71BhNJeEp%ۢo;8հV8SRMJ sf߷mp`YlV( g?s,b2M[3φ~xui0kaz|u!o}.|#|t㟦#@WJ$ϏDg=f %q ЁNж\;_h)z9pX)M 5pSW&PQ6$4(=~6yh%#82Cf8x0} u}XX7~( ;U6Ȝ 9ٟWV\AI 93 q$N3|(،hH@I%A: 3x:WDR!B [Y '9H>yJ/u0M$ U~#ojGAF ):$_Z, JH!;)'Cv}hZ6cN( ݲ G.T#yZ̹h4ѽN Bu"sY4_E [Iyt ӌ.acVWxA2$xwफ़z[B9罶zp>w [mIH<)x& K%W) 8}-, .a}$MswI˜srIr! T#+xρ@BR'5-z1ݘ$'şskBƗJR|] II}SPGրO}pg? icZ Ws0>wL2>>04_ OPJ6T$Bô96LwsybE;a~Y ryn Nk_uL2Jҙ L ڍA)b +D1STf}&#/4~ .(A]bXn  V:gb}I `dO!0c 7M䶢Z݇w_9c`9gQ۠ʋ(O[p (dan8X]II8򏃻E0ry~xn|'f] a\Ep "14Yza[ >{FWFTnR{$ũZ؋ ι]2Vk @dHWK>G+1  J-?!;p-=SxApyPF]+oder]UN9ZT2BR8>Ε]-Sb1]:]s҂P/_t+l;rp#0G*R<]NE1HTCos0)Jٙt;VFݎF̳m] "#W#uK5_%y7yIx \(tJP &W jQ2H$3lKZkͣ,Yhj'KDU"NeN^vAvA`c">dw)*\n_E.;)ld ڀ:NR48> I!qDLi^/(VTbSMk7ѯq:J"N]Oq^n@p(X71B̈́E9V$>HԤ;nq:|u A3ATDci"uvv+btuL 1;ˀsqP 8(4ؓe'&͸A͢L~8 K`G(3 8qr3" ,9 = V&^)$Z ֈ={||^^!Y3R> :$W=,qxI>dZ=G26Y{sܳ9q~Bq̥r 54&^gvJ į z+ @"D>k!Bg% @%F\:%o_ \0VDpphP!bS^O\ IIq| W;Xf {V lw94x`4)2U ӭk@w5 inuS`gty8'V>4onX#}˯..CFddQ\Yr7o;"XׅU&Z@t$5O%q⬪SxNwZ\ (%̨(}ڏcA$0gs|c"m1g"ˡZ}τ"6B0pЋWNaTIӓh)T.M UQ ƥ#l|D8u9l(=S o`t5-{؍!)|D)k#~ 4nqBB;TR#)vFV:eaI XMEdǼ""ƘH,ӪaK™k-Nd>7&QILăWb~U@C`z "nv뾦 $@c?ȭ%R=G>00 T:3$gZgeQZ›5N`}Xk}G&sU7)6+=2 [cʌhbdc C ʺ֤I}%k!`᱘-Bj5$$c!j(lҹ>6Sւ*ӕiNсZwW~dW@ѡ Q)grC5s.NeC%W% „yG YSJ91;Lཾ4nC7pZ&2@+[ibڀcFZL^$)T$OjWa< /Ex]Ԍ1[-I魓*6zYev,rZu"\rKw݆:5.UgWKSYP\?|Ze\( QY=unꏙpC*L|06rԓ]yi҈ 0a)rM?)qm퍸lmT Gxz(-dSݘI|1ͪRM/(ZGeq:*xG6CKٝSP8"*:W8yz07DƁR} B_Qa.f='"]m We57+xSh~*$R@| NU+q 97H|2̠WbǤ߰d z6V7 W\ᆝͦ31K=\&mhE\bF"m6^|gݲIPjn!<-0#L oӢz=V-AZh)gf_aWkqD^fkbA/hH.^O!#*!/Xѵ *X!x- 1*yPqUfL&Kbg{"Y\XRz,VN-;<|`jrqe>V'=l藰36 e O$$}Kg9N}#4nD'AEngh۾>e=vp+ԶI⟀8p t$#4\'u&窩me%hkc/k`XԪ+'RߚR} 9^cf} M%% Z 7O/HCeI]e Ħ -ط4D߇Jwi_|sHY![> stream x\KIr}ł7am;w=!;dZj$_bfVݭ5 &2#Q~V|q{b۫\qu{]G8p)_8^S0b, _\=ngn9,WR{ս^ii9{gpM{\){sYKf!E F{\n>*.k%u [o6%L='XPp+K]28ޝ}*[//ײ-=3$82Y| pضph׺=ɏ' $2X3C|ͫ ˻K~}HqɎ;x^Vnk Vݨpƀ̧83<^ =(xZw˕N^t? ,,!KZI/v2r E9eׂ$cclgZR~xV{V!z+mP߯7 Bl6"$~M^RkL&`F NZ&ӵ 2"ZA~mE._h ܩt\9_ǖY~YF'ϯ&PFBjpW̆)hfp- 7[71Jq Q vͻ*iq;u+5ʻ8FXgBl$hu\Ok z6hhF CƕrݬW/yu+<~Ȍ;[s |%`~yҌvw[hs5?e;΄fw%DTXAa 7iŢ*T/e$xx<}}6%twb''HWSӈs 5wc pH!i{;7:fLqOL>&N!>}s ^/ixmP4fe%cZ 96]5Vw׹CλBա斷E!gE"`#LFn+jppx)#Xb ψ™sE@u/wx5<5* ]BmveV{/"fAHvWݦ8=VA+mdX =UJ`7 $Jޕro s]͡L2L#Qh @XqpRD߄ ml"E9#0V (|Ӵ1/:I,OAI@ کdMr#L. 'd=s @6 :}(i3@ӂ*UEpLr LZzFHCCd}Nn]t,e(4L}84Q7<)͓ \Zc{E`$P06<"*hzE2$@&68,2x욛J\A3ILU ϊ9wK.DoI8yJ1(s8 ٩wIw($~$&QG9VBFvrǓqH8wcqݫuJ a'҅#=TaY ORLgV 4|xS }l~?nC%\ZƳB5fp*&#*R2|pݮ?'2b).@l)bU S=nqcP{LZYEtNkvJ崬TB&XO4M VI(> ̫Td*B\C,lK NS[yn,Jj.yÙ;u){0L%=d! ڨ4SBW6G#}^(574_`/ iX7B7h1zZP йg;4r(xK-b,Tqn ٧:N"4֞@\ ]^Dsm&&j ߌJh ZgTcJ33e\ov:<ć@H1:< r{w`O1>ŁJi:^u_RNQu^GbX1f4vhP~^RENvV ],!Ӟ BK 8K dOـIQ'J5z QV[ԀaI C >6RlڤB1$Rjp/?aPB]uqT$++SE_ΪYq0#V4Z_jxџ۲κM>!2zbQ . ,6pHa5Dz>vJKT|)NjaV7CLgYpɽlPC}VLj'9dE[HMԸ%ڻxN ًІ6p38rVX Myd/q)].aEںCRY:M&:'#) 0 //y)#,/]ELUlS1ţ,o.ݩ z'4&y3X]x>&d'}4]]u|cfarYA:VÁ;:]`P.ԣuPP<"Aa$E8=7>I5B4e4mEawrv0Au x%"_c]„RGԂo{@}q 4a%%4 9ɥAz&3cd !j!DқG*gz܆U{$ m3-\+xGݮ{T?6"haA[>1rwXg<קƟKP[ZK(# oo)PMmoisBq64-Si[Vآ0Hr[k ? w ˜6 ,;iU1vr޶Nb8F6$bO#[2o`46 9eb]Gmk)vFUs b")`YtTrK/̊VWr{mS"o‡gG[o#Ùzuͩ(✫,%Xc; #NZ\dԬWjuzpl8RpsgEXL_":VW.UpsdA$FOExi4dmF%}}N8'𖕆ҥ;?^Sj.N&iDaڗ:x .j!Qfՙ\,l0a`K'̽ L: txZ`Eͩ|'1 i1סڂb2[ji2+/MfST;@R{ڮ _d# /s@ iW RO`M@o]QIP':;d#QPl:l UQ LT#fMgQP{hk,zzyh;{:.Iuӈ86Iyha^@rgkT$vCi궿o>Pb*ujߦ3OMGn`- 6 w׳&"\pp*W@ I|>yh+xxN"ґlt(>.ǜb>'^³J'+:S?9n[nBy"̂=>Sb^&7qpQ+)M[(ENQYR@B3qQ?1L8zRV[RVe%kjQ rHF|^=I_/>)7'PN>S!ԪQaO|q,* \Ǘ¹o5>-K r?]/X~endstream endobj 457 0 obj << /Filter /FlateDecode /Length 4618 >> stream x[K#Gr}4YC^X- afJC6G$_ŌdwaagMVeFFF㋈O ˅X]t%"y[|u#<飈rq}{E o}]\:)?`/` LzOrB/~{\!tK ␟}s~^^nL/7՛' dpOu5J>8X=9r% E*LtJ%D|f`#iovirwԽ5Q-|uyBR a \vwxY E - &#B\!!瑒a@%qɉ3q{)%*R;89R9#"%d (g1S-W( Ic,<*Z5"Ntj V a:RC^p̏"҂OA\\@Cr< ($IDA90-\]ؑw~zaSGxT`U0ΩQIF,y&puE /EtRe@`xPa'4*FE `gqeh˜,ߞkV Q n;?K}}6Ӱ[6_+m)|V N~@M'mNZT\tGr6f7=kѩ21dX|Ywp#A p/`ӽ}iW6 Ԩ!`~GyF-LױLb<؈oRy = ,- N0Y)Fv_TU@1x(vF=<FAE 47nQPI LNv݉xIYpiH eж[#"H (PL0 1qDSdշW s1ikƫ փ58u@&h DT_`*y"<.!ɚQ˄]0"+ҟM3y(zѭSwIL\5DnBgt2p*x+ \xv=%~,a  3?SuS˳)[emk$zB 3.z#Cl3K 9vzl y佂WeB ,Ҽ'4K2_<Վ_ ЩZbT.Z~9 ՈnH%К(DFioaaeDzxۜw2C𡔙T8F.w}I VJ^Kp 9@&y(]T !'B8 %ބ(E>S&oRLJ QoN?6eg6r_y c1"_:᧕`Prr=hG^T&ׄskܧOuqtOg wk(ZKUr|}nGj`R"Qny%R)Z)l=M[+mqrA\3+Gav27%(j;UxU"ymjEǢ\WJif־jvu!%;zS̃NdOR/b#a'jOöydvZ :aZrHM>V(M(A|) {j& pmB$6j#hs'] xbdmlM/#;x(CBW@Tp\5A{'7yP,H:ıXa+C0WWpJCxcHCxk#7D7 =zY-.M7lr(^{Z4tjѹ enCOi}{7Zendstream endobj 458 0 obj << /Filter /FlateDecode /Length 3327 >> stream xZK=pMlvl-$Z}w~)=#+sb4_Ha븁*qؗq #8]+%oDS#%yZkФ׮(M`-NF)}xr>?eU9iWTZai?DW ;9=iH8?i|!J |fnݾX[ ?sWma-ϖI^csQS֜{zw}aDQ?mv۫MAdW^FtI^ "Zv& o6=7W,XҦXa\7ˁ1{]҅H}`Up-EzѬaOXomf}Wɜa_Esg$8W&w_|_Z`ߊ8mibHˮM\k&(8lp|usQDC& r%1yvKnqEx[h屟 P#&Q57zGNJw!W{}`=nlU?vL蜩`P&~9eE|8 w|}}Uo?l=Xm{.0ox^Â1J#F.M#;B!xzb/Xv>DV b82K:UIu;w9:Ĕar3aHM2DsAF7QC' Йrqnwn ;L"JX5~VbL-3"߼2dPcǰ"0caQPE$ #_]ǣC `ETE/#Œ>Mr9/4[8 q} vN$(CyaMwӴshci0gZHΉ?GMә45|R_aMKg<pp"S$D6,Eq%;xjm\s" %V=(dC'5q 4D&?#6)\Bz):4?^X"a cB1hsׇ&"ⲒZBz il5*"XM@5&gh?Fq_|sD K%u!;r7ԅDx@A/nB2&#' $GLZ/ ATAJ{#]i!I~Q,Fs0k uʇ?DD)iBM ŵ${}%K"5-v.#1FXMBL$t(gO8f٦0(HA^Aj'&1n [P7<.-(k^'!4B)[bQqQmKڿ.(3ji4(% #0F28 Fuii?T Ee>&&4إ"$ i֛ںo3Qg2aˑ / ?=\&(,lQ)|KRމ>~ =0i#7>`^5C BS(J 410IS8rSMft\E>`>y &uͺ95ApC@6fTe+)O^gb Cb i8_R {K{bS`}i"?WϸORr*J@RR*8QQ*9 ƀc.,8*iՠ7G@[(IWe C#a$*l{IA`O~z#M7DRL7zkp5Y$nMUTsmKD1 #SS f:V6zrSBrSf' t`i W V@+MͱMӊi.+% z5^Qz26KG0"Z"Oma}+~¥@bm7U:DMVf>gJn L0jSDu,}soDTG!Oʇ f{EzEgT>s XNɒmH[d0\xgZ V̳.P}e`;vpVNJ\w uF>&禓+TFGc"`pZ+[tCt]B޳^O&hb͒r#N=@p{*VQM#7MZ C/*l bna|REaFv=mqq @IE/){@4̉\$:K8Jv݆7Qe_mIn0an?ė2" gEw[ <ڟ%_40shs5>1M="@wz^T=9]widt=!nM%.^`Ig(6$}{fy CIٶCԔua˧i>.-4yw48=vq<jWw+G4DJ_LPh l4qX wIS mss;4t\z%_i[) G 4J/Q}`И|9GX%[(i9xT(ALiu\Zu4cޕ(۷<= }[W:zs󔪬*>ٓ0DVEI' _?ş^q1f?À,R`ͤK_oߜF!^endstream endobj 459 0 obj << /Filter /FlateDecode /Length 11856 >> stream x}K]GrKv^ikޏa#<ɶB9&FCMtG:Cjǘޯ#*+s}~?ݳ|+mybLn|e즌.C^oy4wO-O۾q 5-PJkdKu۟ӦH8{};{Jڬ>NyogZ']=s˾Cٷ{xg4[ݽ'3o5l!Q]5c>ƵtKHKtENCE(ZI$e04/H)1ҽ }R ƈ4E(@eTGH~I"H }'B >H5$Rie_@SY_p5NJnʘ ɏJX1*M娪*$?VLNBㇲX/4~K!^3>?Ԭ^{!5FxjeNMV_ES`(ttSX1գ '0!ʐ:ڪEWIO&NuU4Ӣ!ժHX1=hw*ɏӫ"$tZZ$tҼbz 34{$-JBhyD@mҀ₉6ZR ɯtnU2!i9VL#b M;M רPY4|*1vM 껒"]T1C/lEH|R-uiG)ǽI~Gy ӕ4ɯ]u~"ԋN88kb}_T$H| ɏB+I~:U +VU DzgX1U^M$'P::zU QǣTC҃Z0l)BrŬjz!Qcb+bUn'LbOb[A+ZzѱEI|f,: ;-,K PKXMV] 8פ5t'L]ZVxa%l*zHJO՛!A+VV(#%ҿ@s &: 02hڞډ$ ~j& IvB4HN v(+%gOH'rw= Y|tPJvd(T92|^+KPjRGk X"a`[("z dS3.ë'^ v)C2}yz?d}EDiz$H0+:$J!pBOV=Z kqj&!8,Va.!A.B1^ >A1):鬘; C>(D9VL5HNZЉhK0FX/g EHÀ MxCH uuF:]x'^!(.xVuE2Ћ$ 3Hk`g)C^+@g8~i$> cCCNkcH$>bdTL Ax1%WQO/LR&I37 BzE[xHv8"%^ ^|8B Bְp1]ŪrɯA4]$qa*K$̈! U:&^iS7l.9+Ck5c 2LQäHV;#n(&L ȪګYVS&(28PY#A&+Y%0O2rfʎ`{PGh/N:tUYN4 E-Rh2{BD "(h7xD0gH  {CL &J Ȑ$s!6eh:`S&g6M3MUlJUe.ȦT#"s)Zj'jھ9$qZ.5| ͵oi[浖R*i-}Kgf%"gb}2lD\~{ Q}WZ$c5N;5Xj'Zm IXIIMSD\%[@+K vDc[Xjx;vKr!RjԁԘ*B}M MR3aE&$j BSbl%RLS=3M&_BJyWSij9dHBS"TԼIiSBS>O M͈JS~(ԌH<45o2NI3M͈Wija>dXBS.?ԌRZ^ f*DijJԌԙfDŽE1ɦG_kYh-QWXj$WZ夝%̕BaOV1BR "B"$J(G̀BQ 2Scnf[(jAzbdFF( _PκNN{W(jFUis^+f̎Q+cuAQ\Q+c5S;BZ+G?pW48j H+GmР` E=QOp  (GMQ'o\$80zNv&0H QzEN~JRԄ(o$%Q҃N'$uҘc%Wd+b$y$I=R{M=AS<,戣6`P^JQdP+RbY)iUzP+҇bE=AQHYRC- zm(EAO0i;{Y vzEP"^<Ƞփ^Vd XiE&zڐVd YigS@T:QkƱu^knLuǤ0TYSp gd\|)eTK2@\,u$εkNI]~W:폼kcz$w z$w Z=9CߜSDZsm]111%h*ǔ(7e)q%! 8 'cb‚$Hf@"'dQM"otIى͞3[xHM&HfD_oE<$ ʁׯҝTͷ$i%4+ 9I0"D(c@P7/GNAniB8st"!t*PlD i4& i!QQ!f2$a1;5kJY4Ǻ vScdku sճ:$;(X{-u6 ؀9P !Mb|6 _t͙zYk$3(Ku4Պ-Vԡ$ZaFșZ )C- lpS697HQ$&a' ")(P!H L3 b(N# b8pUW8fsQr.LH4D8f/iL2g\ΒQ)̉D?!3t),$3"1sLP^A*de3ͣ3K+3!jr1;$6WYX#Lp̄(o$3!a U!B3Sެ9I;h̜̙O+Px "D3 G)c!RQ7dD3!ѼfQ/ёi*avh(D3Y m+l8n~9%i?qsm_zI;/?˃NС>jm/'Kwӱh2{07mJhOTV.NSvӉoBOdo\`}R>Ν;69P5_T#p~;԰SUO8m| )00iMU p8UWW# ԋ8ĥ@[/dyTѯK4|Acw ֶa鲊iۭ?֝x uYs L^χL[-OLl)xMkMAkcS0?w m*M$O7|u AY~dsf n1.I(hx\܏&b(>p z_{rIYcX[V\@m)M^x{8YmG6vi@x9W(x,mnI)̝8Ľ:6,e_ǫOV!7 xG/B-iCO5T?htκP0‡ l1xȧÇx ? Y^ o(ȁ1nj`y0jtlck<Ir٥r)rѧD9{9[jUrز,.|lR Ӗ.n2D!I /DY>#דnMd%%U>IBAn+wn3~fAO<}K#?^V>qk%\mSL26RS\O [OKvN_j)9"vY_'\OpzǦgȱv~OQd GӉ5O[}JR2IᶂNw)L! 5M#9eH}aO6D{o)O26;T[ Hgߜx=zcClI[ /0}Oʈm:-A;_$6.{84d)\b*n"OÌ`#Õ.,^l~HyqNHH|{nHky1-f3təLK6B]Sȝy̵ԝ i3pputarBQn+܌Q'ܰAS&N$*N{0J-dvS/Ϯ=g١*?[ ̜E~S۞mcMOPR)zs[$|tǞCH~ L-(0']<ӣ+l$MO[%Domb4231;L0?LΛ'nH~pbAZNnjz[?ۋ cSrd[?={YpruGzYkioߝT qD9\)fR}GM {5/z*&5-tZ* =A­k6$\V UeZY:o#Y?ktAp"ɲqU#DQ1]CL3xqbn.db{a&4w;w;f5nno̻}/8bǓe.f׸%"indj'σmk>b'Κ|v#Suh&:QRh}peXzˏ(z- ^+d9Zr'Ss@DOlĻGx#] oodz$ȷ, 8Y2qQM3R{Q.ܷ.6|/C ;w7O6>xeۦnn83qJ9췝|sɷܐTH$΃?r^Y'<_%!19TS,tIplz~6֟6C5]6b_ґGFx6h"Ix\ u*?ىl;'' ,˥DMѴxWdxr-Դ9='bx|æ!d>hq&4#5sXqrxZ86|Φ$i*mvğm;a1™>x?>|B| x ~YI_Xn.{B /w{XlUH4ҥ>cl[.s Wn.PgZG?!mF 8?ɤe qp$+ljşɘendstream endobj 460 0 obj << /Filter /FlateDecode /Length 56510 >> stream xM&;r%_\}&YlI,RGny"a&K=T2$8듾.?o_~YWXZg^3}ߢgo4j?ӯ~ZyRg~Y6_W+\wI_k~'iqٜ_W_?Oyh{\]ʯO}񀞾͇hf;.e|7gŝyKϽg[^#9587Fp6g'g+e]//7ߥeo?|O_?-}'ϯԯ+?־믿ݷI/7^/+}.HLyX'%Cު},1ȿOĞr"ONod>mzg{#wC].Dڧ/1oucKY5kL|kEg%fFY0}dM70^iNF֮r"sW㞯S҉~<)DֶH]S?NЪaZxy48z^nVVD}#|Vi70_1Mndq{Fs^ +Sz#sR?ވւxuy-sؗKqB^cZһQF%Z;"esZo^slRr7jT45q޹qC-/i|xB{H򺤿Q^;z ^0_(%-0r,ʭШ$Xn%r/Yd^ZAn0^ݙ/jW^,`@N R r_y=k_}WoI$Z 卼$$IwD y ; A^bno%DKS| ^?MXKv-%C s̗zeR_k!F-B /,-%BKogw77n^bz|#/ٵYZK --o1-KQLo^*KO8PYcYˡS(Kql|=}mJ9,ű^@N9T dz"6)EaJm>G=LHI 'J! "!i "!yڎ[ ٦ $QN]` 4`9b@728Ցɡ|"jK>D5"|a25HUD*+_b24jN X|h|ё vym)Z t4ƐA.CIA} Fd+‘[q2VP#4[-%W@_Ji! ZHd`+F }YΐA 14jA \ Dn5-zޠ(q t!R*eBh!9^bn. \\ ;B^FeBk3zCoӰp-6:EA l$^sbi 4q鴟VϹ/@jLa).<\-$&BYz_=j2N ˜ģ t אR V 7P8ާIB\ra(c2[ճfB&Y+on.՗cڋ]-hA>Cr-d}Vv&AjqZR(Ur2y2h}אA )qt!- j60!.¹ :&=D+U3(5`KȤ]˴>9ږXۖSd)7*]-Q@@3^w^†ڎ88Kil^ itdR{Il#- Py GH[ 4DU, Q~ WFDUoD~U!eUWU4H~.{:VoV=\1uc{,LJc1S:%w u l6M̟<ٓ뛠>vWMsY: r&j}碃x#;uO\͡ %?ZTlT)!*7x=S fTգl;U+[U|Sq][Q,PN]E)v6,mQQNTɡ.}][Mj _0:<-uf#4ѬF R3}Ly;vMf(jNU_{RtͧP/${A,}-RxHӖz躀x-Хe0Im1BvKdU" ɺFg]բ2`Cn.lJXqiXCNtFShDƍk~>LjTִ^^.#5i@ F3g!| pujUP7KEt9ѝC3S$q޷)lUcBTp4j|) $@jvv_=ԁi܇:0R]u/z(Jc;Fo»T}\=;8v+DXQ@bw%ǫW_>YxR+G3~|8պ[*d.=(]~ap21Qq!`78Pq_[W##'@J<݊sڈcUAIټ6g8;{-kRGO-p$'VTn"RMZ9ZNdy[%fIeƔ!k}|ݧFQuIB\ 9 k XhCk-pf[ :s G"_veNv\Hf <D2/KR򃾅L~a[k'sQCaZh6B @0VaLY?ƔUI+ _:_2-1eY))pt9yZFk[A;d̵a!rV#sXzg))C17P hQ uIO(\q Z( H۲$5%3|W̗9٧BH,5aI?UvBƧ q:;.eb$urWۀAotĸKG48!5P% ;8HXOBoKKF0F0y0}2lA Q񜗞ԼMX8fԘ2ҁ@KgX^ [ 54z%(dzrP i tZ>0P,kіA4խ#%0hhT:SQHY&' C V9t,7y!ܸݿrh6QvE#!lp'5Ʌt18G57?gB`}sȣL!VԜH!zJdBfͭ(x{ܒBkOvBtb+@L9i!8;ۭyX 1mDrQMiv݂ZH׷n,dRWv{5k>7"ݖX۰+KH2ЙPI}L />j!Scw--tm0*0 #gBj5K&U Fmq!-r{29[P W@鴥b|n,v`IŽGAI@-۔4/`ϢI[)R1ÄWQ2&G-}qm Zk 3^ˌM}jVM#af!ٜsv!]ƻhlR;dziXȚcfkg2^Z!6W 魜'!%`H,#AᚺdT3C\,D Kl'Y n@bOkR%x$*%@gngȐ3M\k܂t7t8[P0ėp JYyyt|hCRCmX@0N# <.҄2[P4!n--C86y$5]ľ Er!c@ vQp4aUЙfhpP ?{Bqk.'=Q|6[Owc_pwter6.r51V C[ */&)`Sp"| ~c.ю)jt;Lu>-jl_dKSL_~6xD'w}mp3ϯFs>\4psmn@4`kTZU\E7?!hLpB,ʘc:ORNm82"eί8eጋӠ;O.`(JnCNظ /#2"nWxS-c)byrYr*if!>ִoY䇽Qpv7 G&[emfFK`D9FSx)Yd~mB p~A;}V>=} HrG[)Rk[Q i̭($ "W:OV2B <'Ψ`~LN$Ř6 @2pGH p3 ;;<'4EUI\m0QΨ`_xE #c+ V=z+9ZL!wx JC\^YC3]e}@ IY/1[ %w̰'9@\]9@};־JJTݖR਀i04Em x7@!:JjJ +;d"; k~8Bʅőঘ!eL!PO8K˜;h*A ?tngLC>hBEwLn; : iɻjHM&̩R/CmG4 )l)$BaKaW- Ae#7 Af#<2RBfBsD+ӁWnLFQ4k&0AQc 1Qn'U0''U0 TRL,8`/-A3 nNwc T^!ۧmS 6K 6km=p2RaV4>n4%T.aL">>} RTQډpHūclCzM݅\5b1.ڣ].Wꕶ"kR75wծH!F-ݜn!r]k”"o9Z%U꭮hAOWaقE0-8ЂS]Y|ѯjE[P*.S~tҸU X-{NĹԃ˝R;P&鰣RtTNك24bmPT |z;}d0ÇСz>=s-頻?L]tꭟ3sZm~"c_ {>-`/#XPsn-#AM7"oӑsgK2)S p3%^tzQv!`#idG0);VtrUߘ{\ћtֶ`ALg;%ďK[<NL?٫AL%M b:$~W6ÚRn 3xpՒ?b ^:օwsNXQ~P㸑{-))fᰓsk-U0g| ZR̠Uqzt8uv2_W'#8/8-N/6 Z:3i-$Xp#`UzmQ8b<׳ *xC):8vA 7vAJqtHt1O} F:Ğӑ@`CB%Hi_R_@0+`CL3!cY㐂OC(r0!TgN!>8y7xfgCHųs0yP|t@R>}Ķ!=GBHB<ҧ3+#}ifegS=BP/(H{g( ә" C$U!ә9qq>苗 /^a`U?)vq^)a )l|t1"CFƞ#>i/1>]Y/+c|*$b|7DjK8.Su>E#Ě#S-BHKM)x@%dVCU"Uæ?=-lCޜnGc9g!AHHUNL xxX0n% b-SYƷǝxjf`P"#:`C[iBFqZ0!vnl:!CnO Q57AB~KzfiՀKĤl5K{epRF"Mh]#BKaG/$VΝ]մEZp)IMf)U4t@8M-(<8%gT.ijAIʂڅxu.H!%ݜڨ"bmFJ9B5ɗؽ琰"4AJ`mq\ 4U=-2#aԝAJ:h-d HZb[=)fAIHIw 1q#$SI2Qttw}̻_tn?ٽ^ZbGpMI6ia82m&iL)LD8VtsEn=UEn9 rWxrY s('OJRwB69I8RM7#nH}/ޞ3j: zJJM=#ۑD = #nH݃)ݑ0j{SI[pGO3G\) S26Z b:⣐H݈Kq;%D󜊐H%T -#ALSq v_V=)eEBHCq6@NE'DQ$O@Q2B ԿRz! XD*c B:T~v)Wx : %\ I4zKk&Y\Z51B<۳;5vR#)NTw#JBᲫ}'xjwF1'юJAK9Z+&%JtfG#{=x3*D|Cj3(g{O`R $R43 8]Q4w$HU`" v$HUI}qd [e{=0nvҍ0`M`i ՙ.ؽq8U9umN͎Q!5iZR7ͷBJ:Q:b_7ciqmFTt &T rdӶP /bSK{3I F:;r(~Ovvs d4cԃ a#KNȎԴ.S ڄAI2'_njރ]CS$g97ΑAZiio7}˛1ٛڻkZmj゚-2:ReT~ 2Yfy͌z>bۻ_mU-6D,fFW4Hps]єE./]ltYS͕ν7Ѣ&ަoZΫ.6;h$މ|z']dt{5]#E\&65HW<"W(E5L0q┳hQ"[-FGF/ - =92*˓%# d0%^q=ѩB΃ltQ%72t݊H\\|t=j.SЊ4IFUe:c@TCH7]ۃHld=rQ# .25٥Z2Eվ*SDDEw#vVʈ;}9rԦ(Rku֦rN@dt7ғ'sI"=N;Se}I卌Wz8S9rE7Ҕ#NNgɌ/%Ft7Rhzt;KM"Fbg/Guqʨ5nUһ@>KOfēFr),=kDK.BUFe1z?t֞(r7bk9kMed][ZOzv{WFdod<ړ_^c l)o$%g[#(Jg[;Of)Y|ґf%ZͳTb.~>鈝/Y}2Ljod\h~hZYˑWY~2L72SKo$V[@~֟t^-lnɀ/%F: PfD70Η,@Q&7Sz?cذyuo(3꿔sgz i淈VV-} /`b0-5=V@-62ˉ[1 R> y"uL[ H]c[ U(UdnD$] 卄Ufs޲̔n;JH/I*A +dF&Syɡ/ CtVȜbJ"f:,Y#W{yగrM1!**b¨"n JTz U.W{n񫇫_ȯ^d]rl˹[u72*؈*b~".* -6`cF:,|(#*Z&D"gdez{dW$`+*:h_.FT "J]S)k' uUĺٽ쬛̈b0U~UEMmZ_5ݪ5>䝭=J&VhrC WUEđH7"v72wQ"vU>2 U>r,*|M+Ც/iA8+n{U>8Kl2IV}G±*G:JtNxïgw 鹪5H Wrٻ1W1|DU|vp1w bဪ|/ɻGgwP@e54zkޒ`j|T~I)i﯉1YΒ0i[z`dlF(EMOIH}/O/O ӂ,*_J~,^$Kp*Ğ[@ &QN\FepTn.EK} {OS٦>6rzl N{snAҁHpq$,FR]qё-= 0unaBP!dP4)#)AIs#s3FB _ٛER`ү}\[v}A ֦sϼo%M<뷏\ BԻlvFa$SB] w#Sro?_˷7 / ~Zko炙:O?W@\᫘㻣|_W__znĺa#䇻\AХg45P^f5O)j7O 6]7[*Hj#U韼tm_ZsoBbe/yG-5xgsɏO_ofOK|JEo `P"[ej Q@!-yڎ?!i;nDI| t:2ۉT7vM`!}`X }]Fj[͋F~"F'e'Rh$Hd'Nן٥HG<p#VD&!.D3?sdHFxt uMp#mڀ軬 ŤJ[ӍDIVt N)n)O)o`{4S9NdKu#7¼QߕR!Oy#ʎRw@<[U FT^BƮM#Mo| ј IF~'2 ZC|w'R.ވ^eq"Cg,a{#j>DD27R(Zd@Fy])D(loDe odR m]CDҧ}u#ve[b.Gt%BLUb4Piz!Ko@$] Tz6{:}w y]`Z72(J}7b@qՍ$WёNGO7P{"QtnDb7bB:U X:NbF<߈Z VV @<5ވ&0P>(@6!$ORx :RvsT@3uN[O  :s)dUy dU!#v| dUمK!aJkSQJ|"dUycB@w*/`Ʉp4x/'x~"bL%{9[W)YN4!mM>~R4!؉()P εH(xIUl%2N$UKpmF:MRtGVۭ~b#3ȤR'nENɴIY  ܊b~mG[Q^N |"y&(1PʀO*2x(f>O]57iAQfE` IV1v9xlFAPkK3k?JY!zm^1f#v1d?3#.fRmd^DFڢ@:<}482ۉȄbTBpw)'AEB8b'w״,ى;|;|O! jܻ5^.ݍD~xƤ%v7Chwod*60wE}l\܈b.23vE}#.IÔ!!m䝟KƑQ тDnkZvܟl Q}LQ,Q~k;7`fK3v6و(1#;3%^bm | A$` *&T& U> "#pZgRIn5+RdFM ;1&N?*s;){+xBf'i:RwNv#NBCJ .Ue$yC}X_dFtw&UC 엦2HTZR]zL^3ي*$ ݥ-bصY'VB|[H]EJ$VI0MEuZ5J܉AYHu]{i"Vu?'Nj'W%LH!tB|w5q:L 'X*YӢX׎)Gž 왦2.&|@ 5 ߓӢ݊YEՐ*!¹ZEjU«YMof~~3+-0tjM7 ARت L UĭSpVQʬ@( GzXdq~;#l¹]J]ǃH"ZpnL{C OnK ҫFxR$DxQe#RS"Y{aU-*%Pl@Lv8Dx'PJ `rkv9vtfUdKnF» Y8VTIvUݤ)#j"¥JR&$ha#/VR@/)i\ )nwgM]&$Đ!z*|@qQ9b!m =KȮҙW (BxKv3gW:sRS68SNpTf ݕj*qqRٜ`Dv94kb GȮbsdl(L$`oMb<iAYnAAv5@922uw2ȗ#$ jٝF!"23/ǔ@)%y2UDK )#0Xɉ̯.!r6U?x`.d]SFfeSFEs0`AJ FtGh`b UL%[%ɱmBr4eݡ-&ESFŒ@zJvُnHJv##p{a@0~\TsS}ezh$v^lUL&<@bpULL[,fX~n~i6n۰q;_-,\qm o X# _#*Cڷkdo;I)4z꼚[2*\7e魮@t )M rרTR\:P;H>U^|r)UFbW&U kH2H2VReHm9ӐEP٦La7 &.".}jz}[͠NՔ (TGbD<4Ơ2kl<Ȩ2HsǤTۢU\(7UfE!uj o*sB Yz4f$GHNҩ" :I"\GDV&଒ѬjOZMsVlZTl*i2p{l}?l*sJTԕ Y&!9FUQexrLUw{o@k)H΢<U Rg".BTk $gŁօ8˂:ZirBHL O}03U@B $׍ q%AulF IPt "썑ڨx͚ "NT ?NTd\ωTӪċ$$fԩ8\VRzNBp$̦Mת '< c Q2/*Gg&f_Hd4URTBM(E^\!u}J:{p&%xT0\vb&2A2 ^"^z"{/^[ej @xҞexRfPQY@(5'l/32Q%'G b+,QiEɽj^`R%&GM6#TL*x 4mtg!.IU4p)4D" ,MKn3uZpE R.r}3 >vT*vgPy@a@%?"Qc/F1IVC`R$KM VK V lWOWD ,EMC =.`HheIU|3+$W͝rW,^uH+'C ! Uq'[Eh!qer-U! e;lTXZ)TJ_vF[U6 ǼT*XH/xE>rC _>m| _ǔ=a=vP0$XDwB˄x_۝a>Js aZ[9jCn~xȿBƐB6dFhND*6) YfUv 0HgSx2xTp[,dh5 ](; SAzNY|i pWpstB]uO=TPnz #U )Q9k%, IbFij,U_Сy%x1GÀ= OU[y@ YZy ]>ʵuC[npZBP5^*r@9Lآ;;3]6jVr6nJa!p߼zc\`aV5QCVU;WU=Hf})|'h/G(;97Fu;F ʬڡ?@̯q1y gF2;:hSN,;tvaX79*FsGtMqy3H1xRHb4U uTDފ3XS7 3xO#MyvIytt9m7X0#??7~Lc4i9P9EV4XLGϱ,Wֽ`I\=u4\Vս1ufaAO=1Ƕd]zn]"vlos Κ&Aznmv;܆znɣD{np^@НoS8[P(قBv8Orݖvm!ق~vsuݱ s>=n^=2S ͞=n7xVo>w{Χ\~ӂ}vcvO;ӂz> siOz:`ózLL HiΟpL xsi/<fOv9>>Db/s&~Zj'Zhozs?wa#}ď)ܜG{gx@os=Yho}}s9{>G{r8 RqQ)O\@.Ĺ{n:2qۇ2Wuۇ͎X~H/$B^S u?` {R0S>wdiB9a/$vT#8]GdBUyj( ! (b!%2(bA<. f,yv2]Nvqa>%q|n) ޹G(e!_2H#@OU Mv](=lUh퀇)\g!A> a؏#GhB |>yBs; {D*- v0SQ\<P"4UbDhĀJs{`Lm ƄG*Hn!< s }؈{ q瀇2oA=C ;|p!A=C T!f#Tq!TF<. vLBznM:2 ~C4TFq. (vB2L9QYQ$A lOglBZĦR-̰<6xh` ;Pv!AS#3?2B9eT.A~D 90r)p!KP#HS%Tɐ#UrT~R*y!]2B%n:2ɝ~HdBR+IԑhD҅t 眲QLɢi\/AI _LIf8=QR !_[8R΍iUR17F9%:b'e҆3*bG,'攜)csnfrj$S#9ء$v+:q]72pNݨ<-AROl(T$n/|sW8j(zꤛSһ#u/tsʝ_lǙsg?#jH7'GVts:_hw%b2|sBpdRo%nQ*$n.8f(K-[=b(=b(r"T$nR$nqVdtQ# ݜm$nc$n<82HA8Ȗ@&.q)$B3FbJI9l^娈E0Q%HLelUyQ#NՈsoSu?#%4uI9Dgt '2H z 4v'>F*,_TyQE\O`:,ʼ4DLYuFJ/q>{ cӟO"65!ybTue+) ?ϨrPgTuyBD~.x{2DU/FHM".iAB\6_F2DLdwbLB9;2ˉ[F?ʺO{$[7Isl7B9r;`H7d=KdxQ+!i5Tխ5^<RΩt#Ns*Q%72ٝ;۵&ª(b~ Se\Jpd@H:BQW{#Xˮ!3 ٭~G.>0v!c︑DQq$#v'Ю]%l' j#ʟduLKb,L;r=+>syM9@nKB@9qƉvNs2S{#w݊H[mD]خ?+I$d1ΩQFYU&JRa@Z T`HXTFM6d,>QE kXjcYn@PQrE|*Dخ?+I a */D7(X͑E7)oܭ݊B#Ju FQ(ndpDodrDnݩ~ LDѨuFM'ҨH,"x7b8co$]䍰s"_ Kވ Kv*/j%V7BBV3j%s%cjOf$=䍨HvapLv"Fʮ ,)ʒBZhF:M1OD VE@dJ=Q\ X$5WvE2v]d!sEY}#RciE1NdS_{." i. !b}1*72^??odR )Hu"ޭ} ar{FZNR!x"QwȎQO$׍LI_2$ڦ7? q"4TQ) i_7"CFbX9AF'2/JIQ`D2׍J'2ډ4ڦLrdRF9D Q1!?&hHBD,HQLn@{ $ΠKjod?I5'2O F]D y"RF*DeЍt*dȨr7b'0(ndRp=Q(n$Qp%*v@Hp#zD*iBn)eZP7`[O$֍ȂYPO$lҍ6))@2t"RFM'ύxR *\X{ ᅰz ku)E?~ ۷WoWsϼo^1Hge@ ߈EV6D"1H|̽"1H={ %rco2Ʈ2CLƈUcՋ&dñcBpuح)LFT.Xg >Sglp[))c i3Wc7-])6y並1TUtY2{ab K$kӯ-i$fiyCκR#Cbazk"oCA^Sm5=sE~@߈KG* _=&tt6ւ11)R0R^-ΕW@9]'@L1iaWlNϒs =v3qAy&wRW?0|V~lbG4@`xB@FDZW0qNTB(ɞ*&fL/j*^, f{([N &$\YW+$EhˌITix`#%#=T:փ{(9r#1~@^.H q/ (`qrtU֠ŌC -dZA.ts'! 8'2YN2^{/Ȫ\qU&k=8f.T{UhDA zqح^{0 "e:$!1} t ԫ=$9]] 6v$Mqs (e М66Oh)݂xR' Q}i/p.L(9s2' |pMUe#=;99PR0Ryb# c M؊YD!TW~T3XSdWr&wʣ*y\Bn.AE|wQ\U7Vw USw T+["!}\!+p}G "HTgI_k#tv.~h2<$c|w}Up\K"+DdcEUh anD~F\W["iWf q+#CT[;wj7Ā"qGd@F ʈ Q4SV ;q f 2.;u|?ŞjP;9Ā`XDRRlᔌ.tïr]_&7YP_"d2.XdƊ$Yt DPpH$}p"r Iu5Ű2zp/PnSg}[I+jer':j胮0+$(2yTD (l U$x8K+rB3'>8A^||X+,G`@a,-s:pvXdfc.TgWXk< q̇_qzp8Rqv}|#L~銫=>pTLG]cd9vv7 }?HHkgɽKܫzgyR..c*bb[q@~Ul5<oJly \x?myޟ?|qot/_??O9=H _/?5 鹉%廫#kXU@x^W1BªrJ *8Z/ϋMx\ Zg| G&aŊC>FW_}k_X{y}?&M ctiEeW>C+G Jd+ӯ?޿~?_~]pO9^4_?~!xPyn+(V606/~Jk7('H8\;l)4[jPؾ~7XGMFR_C%K?/i{G))a7?zRd0?/?^y?L}>D|#ǜ«~p =n //dG\|!8?q ^5!TC1|_Y/^H;o$Roed@C!@VFY/$SɁG#R[e1T'rhIu yZtRo}:ZDBz >3rJSÙOhH_:, Bѐ)uzSjlSZsN_NPccjl^<)0JBPH_H9ҬBP(uJN C!@!S!TH"}!ӕ:*d iS@ S!@`S!u*5TU+y1pJJ:xz;D1өJn'!C1=t^*X^*8 X⅜^~NUCꭐH_v\f <)k/tPqVcUt/X =*B9PH@y1pHR[VBU$}PHz+$ oWbTN*VcUߎU$}"$}!_dɇ[CꭐkKHȔSW ij#[Iïz9:<R) U| ǯ l)l @>~U ꃄiHߦA C i_Fsz6zv~;.-W%IIm=m |b\ uMxs+ Q8~fXq|.0'2<{-}@fz#/S5_37}"!|T{H$sv-oѐnKm,x:L[.@w" dRE@K*dԅ\RYn%ZH"rLWij Bķꚽ혮:װZ큄TOC j&SKDv&Һ{&%pIQ :?E$/3Bz+MuyJ`[&E5LDDBJMuJ(;O[:LFV@tJM4]T@)-93%)aNȄk@J iT= )5Jy{+H,b|v ,Ͻy P ӛ'0JQDD*?)2P ' TWiI} }BGB0-d)މfHP+\.静s)gU[r"iXlt@Z:}i2fݗ]+i7RiqH/f[,IhV/1 }j" Kf)um,otd55w(ъZ卮6y.ŅTzSk iZn|HԅLMD֊%ʡ=op[9TtJ$hcjA}qB_wqi6uկۄf>ZA'hegߚ*5vr:j Ξ"7j| =YŋtKfgzhEnя֞~ɡi?N #jhE¯4 .Ceu }7!{CE#yOGk3+PX#^׃9930[s:a h99МN7HUg8t:"Pb;Ρ˗+, YS׬HsaHdT &2c' %.4eKlƸ/ráx#n `iT+jC]%[W6Z%l>hbȾP몗 .*va@`7*k)vs<͡`7?a*J0 L(B=h5R|ă nƂp#J+I'+ଙ';:Ե7PcOvtdUVb 1dTJ)6H 0iE߈!&rٖJԘ䅆70`Z]%csM1CaB5wh^^.U~.UC]wU% qfR;]vŎ7bzeY֮/1,,vt$ʸoQk3d`W3.vt]qhh Cm،t-XY1)75hJs@ص uH䞥;7ޤi 0L-n{OZ_oX#,BpN:A{@(ջ"XՔFKu#W ]d`<3THT e~ ! g1csL1`Bup$m#CC83P#fr2h&UrC 7/&L`…KEdь bZ-$6^ m•o;A5$z@`B&1$TL2ݫYpcQL5?&_հ !Eƌ.°U0?ʶ xLoK2}YF|5^ݐV0>֐ f!6qE5rt4_y76uhȒ ]{IRhVp!(nͦ yAޒ:4d,#tRqR I5m#riL!Ҙb/H)dx~;#s=H4oN7@7!ӌoUGF` ԠHO`* F&UPVD` hӜ2Ѽ=qIט`F<3, )T2b̛,:[XC\T>0-p&ePCxB߉NTAdn5$4IWe)255H7f;ocV zm$<@itLV$J1K'&1h8pa3yZ7 +SJ6e@[O #z d1rB*Ydi<`dFg7( G xΌf6 5˾=hn\TCXVAj Tq P[f! 2wClrE[b"So7ScϣJu_Ck䃆y}jU?5r 0.0!*5P@l`A Ȑ\; $Gy72`85}$O a8qk-HLPa-(bEPA=)FF9I{Ĵ_2bsO^M CY&KeLNg` 1DFh78Rxh^wOoAq/>m &t7Yg"A S% Z~?pIQ38pC= >eD|dDS_DR~A 7W3O@brP B?i 'Ux淾'D@ .?D x@V+܈^"4kz-otb`Ã= d <&:> !Lvȫ'@;zqM޶&Ūǫfndea"~M\Z~) \Fb.t:Q^UߋWAߔ,yu‡RƸSΜA!e_XSVo.f)idH ,|'u`2r? Tk |f,mV6M=9H9jFd&B))JlFJ:)Ά'* MWR6{J)n>ɬк:RIHSNEja#b&ޚxԬN:Pqq(.s$!Go@SJDDxL3#݀g o屑k{|pIqt݌ ΨN 1'LjyBw#?"GѽJ>2" 'j d}S%ވ!5 xH?tK"#"3_ 3h< L)x4 [wjM3|Id\`vpK'_"Tz$=Frgޅ'D.}7"v܌[.䢻ͳREw#M~p%1)@nAT*k 6luYB)fP3Rn`J?5?xL4XȜa>OK1yEc|T8'„jY0kP1#3ŧ2|*K1R"Y@}f($P>OqFy+2Z&Bbi6zLѓ]r#Y=*iE=y*'_ʚ%ŒO_kJI#VDL "(MQPfp#/#\bh juܸ@3Ŧ殓1a{x;rD KDDDTAyR=f~lJ|]Dt+  ݿc̀߈oDD#@d1У.]1b g6DGo|TXEAB蟈FA:*L[CDt0^ k/޲u>RL9@" Ph#d*oxlj^qd)dx+k#]w"t)=&/5JAy mj!&8Ja-X=~'j^%ơ"ODs8gO{|27 im ~^E 8,b0ɒ[pd%Z>cU_x,OB!k+x1' ث9aF5EԤs6Xy[脥'^5R2gXU Y]}9Ɉ瘙6"E@/K\HΛ6auJn6`aI[Fu&7m2ouhJ[TlR>'2&FIxĝ#KO"E>7eSdh)zTګl1{&ހU=$!X"F_po] >w'0gɗܼTD9䒪~.BUTY瘽ː<])gbiQ!q̚hznD/y4X#y#mR{bC>\<7i8rß*\%r1琿i>o&i0vb 12bs%b>oV+^b5Şos=鎶tdhK%6rdw" G$EeY*9V%1\"Pb!!Do @Y%9dژ["CNdy#WTa i2#*'ldB@h0$,#R,d">8iUպڨPdu#+Ʒ:C;do @8mx/iMpr-d _E7"9F!^"6ǔ:7#NO@4.RY=r\BH*wlި##[ `A4~sgαB7"P@Յ_*Tt}'yQuMm:@X_BVG'rP?)jV@T_{dsyH[6a )>UIrmVǫ0U蟆DQfOqYi*:Tc7U tJ?^'$Uid򆇦/KQvuREpXI ׈%{u! ^WM=ejʱΫF$[eo'2DD`YgV3H„y _ +ml!yD"M,FFw&9d1^qc{ $ ҍ0$XK^~߇E2 H)^H3SlG&=.Tz] HZCsp=H.)F,%gw#W2RSgC }\L͊fzA>BR& rl@BYHXJtf!O-uFD=(Pmx2c'Xh EM16NF-ɻI(zgǺn1}fgdeW@SWlPsHJܫD?yw B~ +_mɻ*-D=Z?cXW/'PR홻=ʔm,r1?Į#Az3ė_BW1#)aġ {*3pBK bCҕ⸫!u韈{%Mq1s&$rTFRĦBhv Id.I_"+WGa@m\$ϱzHoėУ+4U!Z@& $s?$ebY}+uq$CSeQ.ʢՒM?TK#=~.xZPu^1u7-ܒ@Vr#r1qwB\LSZhB#"b _%g\r0eWdg4TW^歓* tqSJ0AA)@wyBc`M4OGhBˉTD88Cwo:>"E-F~"vV/Ebn5o7ݺqj` $BM. lT:S]=N[:jD t5bmU]6#Z"C"TEWRM@wUoh [HHU#&}*sAH2XFN9s1k7 .gxwKI Mē7],fQFLu]-*ڀ8My!6-1߈lSH1:{ { {Ysscjȸ b{L)4F卲@ޏub Rb#IpE  ի!>ףg=kKbWё߂YT㙤O)7=>gxrSx2cC{ә].@b0>(RiHX&GHDV!IͰLݯ8@/&&a` gga2Ya؀Zb{5=bth5KG57*B@dDtM_db"DKKerFL *J.$B<:Qm\UE$@KWSx=m3 P*&ez@4o3[BH+PKi+a)"D$11h,'b2cgXϪ]\TC)@x#"XjRcsxDsD|eϽ1߈瞈)eGqs;R/XEsOĞg2D"޹=C]cVx?^yi[ˢxtLX^&~,"2-$,*޹A6#yK)HHy`_t㓯"#uua20 @Ak۪R{kbMl"˻4lD#Z1crySʷQ's ty_@ }=Zګ@B{e_gZ{u %*MLR兢˓XMݻyhQ&[]AFṙWFIy8V\+$t7HCGMKF,ʗy+FyNi@Dȴcn@+2H&?pS-ddr!p!A!~g'ʏ4F\4~ַ={Mh>b\嫷V\%tWϫMW\>Ţѽ&pY?_E_wܫ^+u(⟍?M4_}&?{mĹo2b/v?xR Hq[Pw0w_5?SF݋w`?~!xw_??BukpY eXeRRf~_z@h[݈* }E9n6Ϗ 鯲M9Kߐ<:h6?O0֕t`b~O_~~7z3Ȼ+x Gu NHb~wZO}{#If IGڷ'*I+xBi=Gڷ7r\Ժܔ;#i=퍼;'y/~'0ᴣ:s?~P^<:YǐiyN:<:#i=+s M=giȻzV녌zvߎˬgzV}Y?H:RN*ֳB]DڷrN?!'̣)8ߍֳȻ:ߍ֡ލֳ@9Z#k2x?gnIhFEpodލֳ7r)@>r=R>5pO}ֳ^HY72}c8{nR$B:|_5pO浾]]FCe":a.끬C!uKH:CyC!uC2[es9~sR@NJy+  7VDHh~+ 7rJWӕ*.{"cD%pOds)UC!j@>L$0_Diq iId C[ǐg8@).\ӡS$5S$5R3BBR[cӕBJ[q fꨈ@JݥKžzXŅpO9͹1m|'uRZ b0r~:Sa~k16:LxpOdC!! I眎M!PcjLqOԢ29THt|yRt=r*YO|ҾIT?U\F!S!TH.{"SȡPPc{#Dž\F`S!@jS ICjI{oӠ*텴I{"SNdCQ[!t^jU& ɇB:Jz!WUz UtzU5qOd|;.3dY猪@|Un~ꢸ'RޞjuYq(O xV!vU@>RU聼]U7R;ӯBz[UŽuN[hGy8Uَ mvT[}CS>H0!ͥqOSPFRevh`3]3<)9Fw悸'l l$]?O@ ukz#wO4@vVZOD[y#ݞY{Ƿ‰/@|ĩtڣqtk? ]r[1;4vl\LfiDR5龎(E,_G"Ȗ-ͦ&J*~,5bFlkJ#Z]E@Dg?ll=:icb]v9E:" "˿)rKS)=N3"aUJ"%6jσP]bq4JTWEН[Wnð:Z&G <)VD,~xE;r#~NG ]齵v B0 }ƝEbĺ:{5uyR JlԠ#>/՗#5׈Y!Zx{"AxXFR~'_)KC"ȓBO!CǕ-GC"쥫Ys Pq;s[=d2a3>csA*OڐPjF/Yl!4yA.OڀyfakYNM E6ZN7&ʃRx#oޓP1>:frمfd6 j)-E߹=66Kr_E-z؏Tf -U%49>.&Hl.-w [#vf˗jzX:jPG ˽C5Av^_aT}=9# ^^TC>(3 Y~9t`-5c4POH0Ґ毪To6kHʾ }aEfe #)M FF}XRdi#ow!F 1 rPd*qqOX{H F%F mX;7W/߸ [Lz6/߉PKVA!lH0p|+knv)9hː`8}h5ա ='t-?/``"* яR:RL83`~tOA&i˴4q7Ooé١N*FpEM9BaQ"7oC<T}R]S[LFjH'RhIizuI{YԖw® lIz-̮M69q Ҕ-mKMTiViHRq ګ;|]{C;@p5 T޺ڒ**«Jȸ)ac+UF@JLVm#D"TWJKxl@q+b.R%6n4g^eo"Љ&LsvЗ "YC*ܪЗʗuZ]qV ].Sih=6~3ֵ4WĸpF/wJ8T$5$_ .yȨr۵X5Y5t_}Rr,4$j;%[ČKmC#7-m0BխWfR[C>9+#;URѐw/o3pM_KC|#jX 4@Pm}/K3WF3ST-d,4T>Z҄fw#Vs-<oU`)nu@?-P4,E)5Kdo|73 pOUxXͦ8&ǒ7x,yS(y㪗TF Ug ,׽w#U0 =g/ʙb QᱥHnC:Uu_YzV3{]P@qdcq55`#o>ղjd5V,wNJl7оH7T$ hu{7k57x8Ss~Ԝ+6۶$@aufR40=xܧC_z'_#ҿ:@ࡂP#L^2HZ^oL)D ]l#v*0Uu/.'. <0qe\ğuUR#Kp 5# 5Xtu ?~ < s?rݐ/E# YPɁ@{I>'H8E{U`̍N2sJ Tu<6B $S]ϗ?ę$TZ,ɝLrʕbf_Lu i5 6I˽GY , zq2M Y0D?Iuϗ'Dhe~E B?'C/~(ȼ<St\t]o-:R B[t,x4EfḟG#EN#>c|SG2YSG#٢_Hn4@"ԣ#S 0=m.p7.%G*E([Fu[Fe&r.cGS 6>ni37%/P7n/ `QD "Qݍ4J#_Į%ϕG@^>LqFHTSa""n: BjOB' Ю$7*E͍ȍJW09%}%2+܈a3R>̠tNڵ T_9[(1Vkxs4u7-[@q] ˉff8l5 |n$3'OOxėULqyAƳ0'G LI]I>I`O@㓲s 9>3ޥټiU6:PAbUr{)`ξ8rr&$RXJl  2^A#v&%3 )dD2hj⨃AX̉m=<.0։7.2X9E)0f85EQ{BEL(h"Zu3]uWP]ui0ybSmm&.HSZ-8-Z8_Ska 5DPe7"ԭ InVxYf3D;AL_YuVcJul 3*o8^Sup=}SD @o tFuh3"RXMRiks}#7:"Cȫ=1ִacλDj0OA"s^KF΋gQ@}K7T,( _݉3ZqU52goM%u9r,](]CZ!$UC F3|Hh'o=T*Lp( ,%*&pft/t'3TLTuHOmf=NTrES9@^F6dRG/ bKfM3E<6l$S}$2bNSp8PD@OM¬al"UᣜLJm@p7ENCQK'#D ΔENZ/,jEN~Jt8^5/VkNyXyq 27ӽp7(^ݣyqN؊ȐFR,x<` On&dd$ C2{PD9/UfM0ZDV Wgv#TeqX5Y*J&acM Uc7'L< 7MĔVQӍp+WbOf늏LSQEM&]MtcI!W&j:&hmdLCcggӉùbM͜2_Gt; R#A27ڼrM="FĪL9) ('C ,dR$]@80$ E΍n]#f:d#oL+2a 72#]t@Xp)_vFۓAt/nȸ,cbciUHPU4L$Vijtk0 +! 1!_ bI.Q鐽OtHmb;%"f:cŚf}Ox)֬˪3OEߕG>|ȩw>LǼ덌&J|NFL!ǻy i:n=EL|s)bQ| * E.8UDYl27-$R:$ύ2O92GWO"Vu e4ce%./:¨2ZZ's};Q|sұLY.L׳G°6GSe42!Ȱ@KVC]u`VP/"jňد#F\#EMbXC\Cf erxvT"'HIeղvkY] Z kD6P{]*Aoj+! e怜)@ɾPD|/*HDHrL)BBPZDQbLEBR ߈G~ % '˭`Yzg|Y"/ UdR,@ V4!Gwi3ɋmSIY6.^FEdt(gF]j$ BEbo 2tÐQaB*:"*:-+S3ǷZR,(ϰUr⁰1; G449.{ CgPa8F1?3.}a0/6й2z2ae% lql$I.>S ,˛~V#9da-0lޝyDoKEZL]4t!1 וֹ ds{QMR["2t!˼e' PϦR|oOE9튈YiL @X#)'Ãq]X݌b{dD4tHu%5T ɯf ~dz })^@읅ȫR! ciY Rq#F: xR/sҚtfX*bټH>&^53%J:9( 67u%J: ~KT HPղLJ.^[rzuPqoA7wW /#A5YbRbĤf3BA*(}Jv; "Y^KHBtੈ@P hrYh  gW5j`hC-DĥKh9-%"mC%> ?"1MF+E i<~e~hQ+& Q!OFcV25*E,eI׋3jLNeX݋k 3J1/IE"cun..&"~fͲ(Zjڬ,u9X}R|k($Bk X[Yt) QP-a() IY bk(9BċB5 }ar7/"-='ŭ< I3ZDJ$nMR:j({Ix C4]2P ӊxé"⯡5^Ut]K'^5Ut@dF+ dz0\c^R@D/,Rn@Hx80ͨxCFR4ұ ׵zGvFu}BHz";H '1i!bR`o#2Mld¢ I K HcQ ˥.EX =HBT0H)].=H&ك..C)=HR=H`99,'ҥy.n:o1)ݵZ,b:~E.:"-kät#?h(ȷ#k-$3ȒOs]{椻\k kh C4OBC"Rč؋".Q͚P}]-̓iJ+Wl@lht~0݈™u.S]W)鮭 VRWR`MݯL)" @W%U ^J|˔tWaJ+BrQ|@/@=2XWv0h$Wyb#CEp%hB ] L:&$RDud 1"_H8)f0!}LSN߼Vuz@ՄhÚKDjDN@t:Mvb#[=_fHb,ϙӦUU_BH@,Ѫi$+H٤hbȗ~UFlP_4!M); {|1Ȯ5yWQUL{,_H́V 'UQ|ؓ3~.F-Xq/"{b dSlL_WW|S}teM$eQ"$M+66k|$3-P|G&SYy5HgD&6=xoD*Dk(y>縶,E4~ )o{:Y=>-Z5}DThGd7Gkzwg4~I [1n8; < _3$QiI5Y3=FN)qXM\D]ƜHx8Ezx=TrKxcS[Y͹)ӭZ D)hB5[h3,j~Xjw"Hy8*ڄ-ޛg gض(e PYSkF9JCȊ@Mlf"Հb6" r{"TB3H%@ɗGz !$/,$7 B%TɧLY3N57KJhq1Z3Á?&;d53{fiA `P0wӁ0'2d ĝ 2EN/S!) I~+Z d4[}l)Eį7Ldz4~G_,0W?@gSmMJM~~e y@C,@ʥ^3R7J6zP|V|}z>t3D|/R^meJASR_?/_׿\_×?|E7 m}_$=G7,W+Ffۻ9r쳰֗5m=N2^` عC15VkKҿ7`&Rk X}*IxfC-}O`ڂɅH0h2 "l[BC'pߤ#n?YWMRЖġMI.l21n\[2.r3.{ۚ&2$mqvߤN%El=%nꙀE"Q13".Q\d%J$J@6r䆒C4WSsjJ+rTC¡?pfcGM)@inĢGT1O_}f4R `\#oJr^vyK < ބMU1<¦_M!3eY5;'# AqN(!$O9 < JZ-%^ <=uGBt A<֯Zd ٌ}̵7{8$F =,Ty#H]Y;'`p6FE(Ra`J5'\$vR,$\`@E._vpbҎQ# 8y%w^Gٶ'? $9 <FXlY5*qaaIC6Y8kl-< b3lxu-CPTxGcŤʮD0Uq:fNj'} Ӓ=I`hΗі 4ƞg X3JԌػ`#R`8UfH@* ;33!Di+i{8H&W B"UaT\](9HÉD&DA$+TFMWa1U 6,xߎ6.T8!@ }3 3<xQ$*MIJ㾈x6Ru!xL3+N[QTG'Qa>Bɵ1 %tNK,oE%^ZVTb:x0K62$̧0_I朔xqr,9Hғ(P R?Fo2QV:I_G7eCvp?k:vwm~u5mjЖoS,;4@2uDܯKm;`n%lMZh&W`mAgXI,-:)vQtbXaݎvAwh-a]c4%cȣ9qQ6t߯Klʼoӣ}X:Nc1e6љI;6/WH |,Kɏ3,lj$3At"3[yJz5¦[\qe/o!p9l^nqbm0eL)v/2.~g>z}\Ig?;G\iKEjLnE~-*e;??$"]'n@I>>VbkXy3MkNHd˃ǚ[עZՔ}W Ej9D܏@j"#VlZd>S:O@7zJvTM)Ԋ;ek~ g~@?sJU^-mYnz"JID%NY_Q:W_HOW,wvn(p}H>$Ah嬆P٣Ƀ(ӿl[zXwy8j=at.o9!ٌ%w]`rof3߾wbKz̵.]oP | F<<"k~D֋?u폥yV7tPN-eL5pȧk7_4p VZ2O@`oVUp7hB䕓]מҚv2Iޮ4=]9ZS{uHٳO%)%j);kYz$@ h(X=RO焬HKϵ%GӒM"ϦU $/w˵\M x&6CYѣOL6׿9@Eedj~ݱ]/K'j#8띻CẒ y'3i:n3XYOMl\\'at1q ̋@C&~9䙯+ʠz>> wNϥ.oqH<*G $j˭Q_Vsw5⋰زTK@2_Λx.5~ dف@5f!'%qK nrl?[>E`b@#?ݯ!uS1*wjFcV)dةe "sQU$S GC?t_ sJ %{aNK= G^`BL Gi'}\yU`n~QsBgrADмz$brqp=.owԲv@PS*g_ $ q:oF.Adc]rŶ8C"g? D;h)k@5m^U{(>d"㖧6E*)T;b'?4pHb=c8;oDuLJv qBk9K ZiV{xY⒱ wIoS? >Z>iC)ZbKJ9E|jfM# qA7y}ǘfܼ8縲p\Ya:/j5s\Gge#7Yoz"Ra_a+&'QOlʒ͉{?v;Yby>xendstream endobj 461 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6852 >> stream xy xSe B4Deeղ}%miҤN&itoS -nP bY-23޹|=_ڢ蟹SBB}1v p&oٺ39)B‚y"|/}}r)n*_pIkV=%l"L„o>t6 r8!qԄ ,7,02;pMQ„Qt[nK/&NFG$&gW]wپk_dhMZ񺔠OKߘ)3bsV쨭bbLص[p,[>k</ "xN$v;Y.Yb71CN~݇??2&fMLj}tʣMn3c++;2`Od?9o6QS t ro?z=9?wpCP Vyz$*3i@x\ C5 ͅPT@ qF첗^GSP.<.σ<ZjL3:1< }Ϸp)!w{9^se|T2j)XBmʮY"JUZF VJV8Zlv[*nAi0qNch0ai-K`! ;M3c57: N; % khbwC,b/$r{j!VJO W&q}h}C384:}gX.!@vOw[4;b%j19 jCxX^L'֢1אkA_]>쬙oo =[!<}0X{o~ c={k,zd1 OՅm&"38A}<=o(0XC*S[V_Ql$+dfYs#88a4͡I~^jx^ w(LFKAc0B>,LOԂg13`w=o,b<(L. %tziݿs] gDy{-V_x e2fh5  =%8v'K@\!v.;5utJd,k7I>f6noi"V|C/;AW_mT˒kujvX.xz<`:S;X*~j}u_Eu~JѠS2y8MƲM$-͕Z0j*k]Vr ."ich2I:skyN((2*dQCx9 ȖYJm.Njܼy`0XD ɩ [snsR$~&K(CCukیTl0u!]*rFRfϪ)iyw0ě¿PLO8 =Lv&N>Hho XPL~s9Z >N׎LS`0YLdkuT,+ytN|0Ťz/-[ϡ)oqOʲH{%ʁk[NJUAA-9GJk\ݑ6#y労NMu*WLa>-N\V?=\؍WI=gFю 69?1!p 2Ȕ; T_dlzC59}N;/ȹA#h'{xiGDX{"ьnqNbrD,UFG'NѸ[mYA!X.pwԗ@D KPb?@~wxљൢE`ă1+RͣE~/rcZ^T)?OZkqb9wjJ+kK)P[4Qт1c8řI*RGa4٠˗ EIa@w6]lcm4A9{>?ᓱyjɤVtJPj!Ξinh8BPC+TV{\F(0#w;}Uw)!s+Xւb =m5ZWAPvmTt$"=Vs=}<>9Ԯ<|Ȗ[uVv`i).-XtUx'[<Դ4UeQQGRLB\=ަkSK `8H.,:^Fu|z8~3oWHB CvJcJ!<ׇp%bV _l7d&0?uۯo|xojAWOc S䅋\Dkn!J8#'2=D$'#NzvnjFcdT Gy׃³5x>m>IH1$j7&w1- c8^14ΐ>N U =!,+1{M[ ǡԊ7Bdbk4-h&qf-Æ(|Dq1R x>eþ1sЀs6N4$J 3Ů#[3݌*}&ibp.CTT NMFJtݾciQi $2VÐS`WC1Yaf>}yJ^ѴEŞqo!1aq8&!C@]CM&)j2O/C@Fa@"bKNEsx1?ܦioGZLRQ…,.v{ #&"mAazL GU<7XқHgGF*_9n2/E ;/e=*QTvEHa!.[63V1j8)s^zWH{›?|TL"p?JR+y 9@I?S+-]X[tő'qJjNn> g-gt2X`qY} ȳo.: P+WcC.鮘P@)gfx62MaTߊFapmw b=x@b`eqm.dvCƿ _Ҍȭ;‘x`JR3vOgĦS옡lT]7Ny&ֳ` Jwfp[sAW rPr@\QЊhF-*Ҵknwe][pdw3اgA/|O#8 G6tv2xhxS"W|S^1coI.a;>21~}ă,/ ۪Tg 8P@I^`.:;!IM͌hbd>:FI׈^: *u$0deuǿuFr `p2HĮ__(j;,$(m+1n:O6=t.\%H~;w~!>>)zu= Cuz9~ܞ[^YX4QhşXXG)DyxSK[uLc]IB$tTC̝P O-C3|^N|㉟M:?DNIJ|.Z~P+,ҿ}E۷~Qs|Pkٓ$ڗY<)kh5 F(w0oj)s=oN )ښ¦V2zQoąތbo SvX.ReIKcgKc#}6 (Zo<2ם$& K2=MqgpA@a-(TOin]9Ѯ1&4B;_nJN~}(]Y]9tW XB'{\~1mab)i@_)vJG.XUPe59qs:OkIS8fj0:lU(ls9H].^z8hþ$~Zo(3>oLllZl/r dFQӃU">ͼ*ЪT|iCEX[F6nO1i2g* ȥsyH42l@%4`3B)?TINɇ! h*3Q#&0I{.%W7k= ź*kL+0T^UTYY;r[*M<(&9jF$>o޹#'M7XF4 k\΀PbR\ۓn*wR`Ld$|{FkҨAPԜd2;yۿ&r=VQ[]H]^ F"XA’(ՐP_}Dr ގ@v\J˧7·~[^}~F.7:kY^Z:*2zHh mO9D:}=eh_]'ѸgW2-]N me-2e+A)-OarmG{Kg/ G Z"_76шVWvoPYSIǫ׍8Gh]\ŒpOAN]Hw_0?GMCa|(׾j-_MΦS+هgx)\[.Nt&56in0Y./շi=V`4?{A)]+-ΟL'' `_ma+^%K%i{uO24h½)3zOLNw +*XUP٪ahAcD 'Ys$SrT|MML:s -ӣ*dG2H&VQau,2 -b9 !VR9)n=eP-io 2J5BgjE,zX@Pw^yt#'}:׫Ae[a7#h,q\U3gVaz UFCD;D%j֨eԌU=W Mj4Y ol߳[4##[==l[/&8\^_U!+J Qox= 4w osghR{b"AׯbYۦm1W]ՋkMKUlظ: `P73_WŎnV&J4PEYr즬@+/=folQ4GW:P0r9֏άƜ p\~-٩?5gVcѸ {;5)p_+L)7 q:`*̇ Acp̭qH2Rr\r_Z؁I" HU-7#G0iZ['8 \b_~=r˪vxD=@uvuqIyho: kȝ|&kXv1ki ړiuڕXeb??NYQm=@*SP2О9\.J7IkQ"aY`r_ٷ`TZƤIO0b.(.pq <7Z,n(   Ld2٠By`rB ܜo\ITejh./We;WC')_FW.qbMZ5qvALήd"4η+ R^ѧ7ɖt덳fLIWG蓰X{\*<dtڀh7lbSz}n b@XA)KK>4$R P4fwtnEۻ։K> stream xYX̎H5v5 (*t]z.]zKQ+V,K%k4I4MMy3}.Kټ{=s~gQFH$I*}}_`o0@x0 9LM}9՘]*L= &H']+ GZ/^hɂ>v IAޡ:-vPk_nۭwqe;sE[j']n>bC(hwؽN}w p t xIeX163V͞cs uFmSP3wW+5rfS[96j.NmZjAR({jH9PK(Gj)ZFmSN3b(/&SeIRV52xj eBBLqjj<5HM̨$$dQ%bD  S _y05oSL1c䗱]sMljÿ́'O|1)h5mfͶ˝<r+q`e{V{xʱ)?O}kj#SOu84^h@_+rQ+l *(I,HϋB u)G9(ţ_4nj41gO \ ^_l?rg@L j:Q^ގs-Br y^X~Ri#/VHXOb~R6zcGWHa2=*%B{=,4gBqq% Al6A+ѡN^QLD=vDͳrQ͔tUW]rhrR(82@ (1w}dpRu`5GP8 AnjUEcEpXܘQieuY֢FTzEFy v~ ; U=XLFmQށgә- ~p%H:r&v=b$'\y(+Q7?Ωk`rn<&?,nWp-)Jw[mvN*U$r2N.K!X|{xƞW]H}|S;Gsrr+rQ1b>Nvy dO}Egx6l)^3GDX-DS|e7?R!ZEg3xK hm|hPPd̷_ʹ> Gi0Dx/6܇1F`ɗ0O0F .Ci|O jis((foߟ4CۜHG.({ţ^>ʾ+98F f^jaڬvvVkq@ش`l:6>v!Y45;hOFDHFaB *(.ͱ52=}xoS`Q/ׄzC `sC+9%mMr ^ Y}+tJO_({J]3gfx$5?|e(8oV^o5_ྙziä́>j?D|f񾮺*6<8:r:}=Y6j¯fj޽jNBkؚgMxS]:2FŠ+_!+N$);q'ڐdWgx ^ ]ccmoM(nx1TRs(%V0촤ds+KD ;v-jOiS՗55 M7bC}<{ɓ.ߵ cvϬY'NwvU.b-J珆+_X732A*i3"4ޚ:"jrd#-$O'E/~4mRݵcV_x&׎: {C4B(6:D14/9wk!?9Αy<#^?8 K0][x  !> ⰴ&eD~ڞ%GSt֣$O=T#P&F$A;s"ΑJqp!EDgBڬXj>J X JA{/SܳDم)(L rL]xW/ 6풻`/VT Kr;u&T6աK plNVɡ t,J[a%72M(IB1e-A)4;8ʰO?=}+0y&+\_T]X*(O)+O鸌Gv/Y񮃛c ԾxB̰%} P_&ąP!8t{5TW%݇XMlVi7H/9wt֎. QEIeY~Y. Bmi:n^wupIAAQ!cbdQ?K'O)8W\*>)=#=+I@R( I#(WW TBzGybyB]aԊTUum fHZPjeU ;u ~ tNEJBr&8L954p.E]e4'cjX=@6ɻ`p^{Eiz* ǢΚ|k籚$Z 馃EȪhEHʾ#k0Ե0>.^O;!r@/q>|0J* _̈yKs]u{ߥ؊|Þ8 s0%C2zr>) U0}}ōkD Wբ+êFWŢTPUPM5xsC؀Q6aة݄7 4j/xzښOZO+̣XlJ;γm7ck5fOs:{?^.s+xeCF}o\MΈp;p0ŠФAz2K`習7ۦ!4{:w0J>Ӈ]=p״j4EB:OF(22~/A{sx}O*cl4ke?as0`})g;bUfLͳ{wojOv<^ մ6Oc3xI1YYHj2*k9,6& kKaUi~)6ьMܤc#U9گBSӮڜKJLQ0endstream endobj 463 0 obj << /Filter /FlateDecode /Length 2655 >> stream xYIw|͛Sғh@^x27ѓdiD&Ϗ"GCسrHUu= [Rr@ZAAp`O¿f#\;KaH|` 9Y .WbheJ0BY+#)Ed'?8%|3anYuK_cUXgՖ~sEU0%k9ydg%`p?@s6΂}NY+iYF{*܉/Zh- H ʤ|tpl 鮐fOx_|sq{^p0Rݑ,25_~S%LXp$ ќ8^xyfس|VkƝC 7eG&l#Ь5h WAg-Æ>DB\HrYYxwimrlZ.nOWta\&~_7CI! Ȭb/w`eV('I~Li6ˆ\ZRw!. Dž֙qqŞ-WM!1oϬbÂSF'uu/_&ӂ>Ь~?URϦY ൛$\!O1nAeX-{DãN3 t֕'< ($R6T„^K2$UhF};ޅ:PQ)Xl(!L_)=%Sb;JY 2-$@b- >9'և5F֢Z l BYv"c64Td0=wʶ\Z+q$v;GB* TԵU$m teiom9=U9J=}1e$A7 UJ_>_X|LNARq7#b!־H*6i<cM&wA/ĹU{R hT # J,cY$E vvjqKbЈY0S5!MK2 خ|lW2o t,_,2*YOt(lV4$nAfUsۨ~Z,n\v=ngqS@ڭ:Q#S>Ŏ#}0384Xu+›ƈwlrp%s~{rT{#Q:oTȍ2H6ٷ`u"7:kq@n:n 'WWG8g8Q.wJP;.ϝ|4++ 61$E6:I@"bIL"h5((TE̚zڀ} Ք#LnW,N9PD-NֳSl )rh@FTKR~{]4WOW]-):vwf|_NmtJL[Hu.+na/_EGn}8 rP._WF*׽E$4g?CtX\eUCJ8xj7XVMҚ+#H{T2N ϝ8^Pu?z]@Yl}*FWy"ÇT3 VikpAh^Vϐ\RU IYv[V:+WrjQ=lR.] 9 H <1u7cڙxH|2i "~Ἴ/zv~ROJ%Ay9xx]lt_ݍJSnw]A"RWS(%#9vWDJ Nr^`I,,78byE*ؑPb /umk1v/R\z\ | lX1e*¿"9fect8CkF52lE L$=BCr5Z\o"^f8Wu4 bGբ_ɧANmr!WPSL)~.EGl(>".n[K@dbIbECL*IAԖo1򹲙PG{}֏]cmz3V^̓Mendstream endobj 464 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3217 >> stream xV{\vvu ** #Q%H|~ª kƋ&U* /(,`D^jLִh@лi{gצc~;3{}߹4efB4=20A3G_9 v0DopppDP($3E2G[AHx2iπe/2uBƬ)In,T )Ii*5Lh7&enIWǤܿ{o/4EQi>څ}6dl8.$>4!,qIRrJxMꌙTӜ(*D-쩥©TH-VPJʇZHM|)ʏNSTFR ʝS!T(FQeCR45:AiʔYLKtII,\͒~,h%m_&y&~&.gg1?d~bg,wZKf"ːUnB\T,eZu`l cTB}냕!yO)Ȃ18T>  J{[Ѐ g^]Н WXpc-Ѻ18dnVkG$ix`+3`ClX x:*Sh.r[i_b f+y|.p'#濷wproOgpFt]!cG.[ X< Ox'(T(dC0'jf.d fǭg`}šbKsIa" Ie}Ms6IۃXyrҗtWx6.JK c`n5Lr\绺ƞ[B:XW ~a,~9D|YoTqlFP/9$Wb>KHk!- Y+¯[Vc 'CH3x#ilS+U,8zx"%L~}QDƇUoSSenTɻyIӚ&0&t Az,LOًȆǦIG4E|_l9v}֠D ۏ||Sd5>]t%Ԋn&7`ˣwB3*E0 f?E~q8lfO[6% ߴ`{&pF\؞v/: LLؗJēto" ]UW/J1rx^?\.̬**W>~}وM9C=A SFDPc#HRECN%Uz:Zbe0ЊiB;2\{XIH9a&.r`ق\U❇x3Y CJbhĭXpI/ )%_pe,JdBU옃WʾElۉsv!k*+29NA/oD6vgFQA*7;n_+tÇ DTNgy=v=͖;I-|b뢳PZ9e9 RfɎ*_4E/~1Hm$&v"#Hge\]0[<c?`>p<ln GoLÍ_T+ kUtbc/+.p"NRjNl"NSqBgJ]b* 3mkt)]P+rWwǪX[# +L!.巪˦ޛJѥ z2.|!'n %E#&>oh2|9:>&{;c3/x:=o*xdEo^І/QɱO/pyj&֨dsZO-b;9 ϔ DD`Zg0~ 3=^_&;rbs(Fޛg`ٓ . 牊Fܟ8D?uEtʜSyAOODu|{.}@P  nb6Zb}dŖfBa }#8;㻆 Y~K^0?1yH@htaԑjab`OK#>2UhEzbp<Ä-_U7+}Ak.Ҕe+=s4Mz>}[TOOh>Lq]> ~!M e~.rp,{K vSjJД=a,KPa"b= S5p#nI ń8 x"\G-jhɘDWe}$<dK{ҥװ]9RUsSս[|4n>;E*qKROlҿ4/rWLWNDfX?镯9bpCd cܬh ?FvNHjsWdCXy]rGʞ ܚE,,Cʔ% cnx`i!{38_/nZnwx=a g i69o?#z^Ѫʢu~WJД{ESڏy Jyp]S˗. )ؓP JS3}1,7\9G߫^VN_H φ`:|K㷭Yu1E-g˛Q:ZGp]Qs築 ^*roM'F E'I`9 GQoMm]G09ַE5Ɂt_p2XW=\X++'QOU>r=#. k>%-N-E'5}(9U?@͆K6^&n3 92r9dLEHxDc91T> stream xWy\ڞ23%hQ.ATdQ"U[[AjjqGmD-\B(*@5*k;鉿{O~ߟ/%3sQ(Hd,E¤Q$1I2#cӓ6 X(61X$6*| {{ߍ2RR\]fYͳ_򖴔 +rq"9#+8Mv-;7EQ 3VlݴoY]0{>F겯`wN(vC'+ }QB_V*`ShhaaWXL$& ٹ_O1 3hE>Ne˶G,I'6\Գ /2Nro.+ˈ'3ўR^W* ݢÍC;|YL]F?dgf}"߬9X,A؜Y0@o]?NIb v-1$`͆i4?tVtTYF/O`|Ħ<\~Y2 G#i hNEg-N4cOYsYn. 'ZFZe!w[p2ndRTsaH#:S<EZ)*~I|Aaۘ>a) ;XvuLHp]c=bn's<|hk15)EeN'+^W.t"ᵍV0%o.l- ۃ7!nwOl}u.&Wr6ϡ3׾ ɗo (9GW^gaqP;I$D-a pJilñKhŇqVJ`q`$CpF*N"uDabo)1Қ-A6HJżMI<\`4#RMvMf#! *ӧ gHӘ@DAJ\wzüuyȢ}/)U)t]8ts':hM&./u΅e|HY`(V` caa~.]0wMb#a ra'FnW b!u<$ сZSߙtLА_Sjd:>Dߤ&bX?מo?`p u3_-pȆIC SɤtZ7VHlAiaN-y;hps*{ 8b1ރ` =-@$8d-M @Q9\,cp~El_G~XqF8NBdlp.΃)R:6]A0x\_a#5?klLFL#n#^/g~}7]zˊQ Y+{`GQՋxW.Gp]T_400$&yt#*(zca@++ @3Q;?!zͧ9]>zY mߍ]-V#;~p񠹴6c]N?6%2.yb'o(kdT ιKD3[ =^.k d[ѝM>vxW~N&AO}9]/U1$g57 #+. a y"yrB`_,6)f;iK3b}_#jJ~nƞv9.`3+ FP;|Ko,tjav"bXt8!gկO`Bwb5tP̵߈_(FU;/} Է溅i}80rZXO \y.w>Pە͕?)u$tIVbݫ=s/6(Z8a+5$miMmmfvV\ZbޜB/GLJ^4O=UqqU UU OjΜ[KSv8<\H><'ce#c[&#j wN+r#g5Pr"P荨"pSG¥A(C6[BV-ͲGx"vcNE.4l]mz<+8N/ b'%rZƤcq6<)]ʘdN>j:6MQgYendstream endobj 466 0 obj << /Filter /FlateDecode /Length 12193 >> stream x}]d9{}ɷdJr}1˚`;6е6ݏ~Նo^}x]}_y{w?@ط|󊏆jǞ՛WP*װ(xM7_Ǐׯc;nׯSR.oS ~qVgxZ̵q$MJz*r __y֦o_ |L*W'%t%ǖ&sDŽ܏iW9c~@PkZW%cT׻B%|r^G9f-_}UG^W!,1\ݽ!c/.h$!ŵDڬK&RӱYkLZcͳ.9iuInjNGZLJ*;:ֵSk ۦCwg8pӟ4Vt$y:%z -m,ZMk(Q0Pi EĬE9iM5̾絎cG~?tikyO?IOiwۧ廸z.C>'tץ[rKVgakX%Λ}Xz7ϭΙRjHF%PtXIū~<.շnǤ3łv a :eLˑz>s3IW:Ofʙ BA9&${Hs  (h}*jc`:A1-& Bt7!i'+j ɉUU: %LlְcAU; *Edk͹a|LƪCMRtmkwNeTc$4F%Q=N.0R#J*+ښP$_*΁}6u&iBSGjZELN)(꫽5"JǓ>): j: PSUNuQ*|S XB/lVՎND?CGkXr3wkD;KuUTKc]&`ENIâ*[HXH/ɘ -N*Kr]+G$J`[6AE!]nj=ŇtQIWT'/ֈBc:J2iTEuWP \©n%$U+$:n&XWEOŵXW*I0^V隤aJ%6*J‘*}&KXW&*Qg岝u`*eKhNOM@ѡzIlq*JBxJtt]$`:e-7LP?aei/L"4L5(mZ&z][:|z.H^os; tt&`a{Xו.7J2U|ږ DI*0 W l|Jm=V^-шEh5XW ۺ )Qȡ=g.,@(\& kTs ݍՂDZrhpOxiԊZj1f6Iͫk`C-r]bWU]- WU)jᰊ5 $\:p)^91/jXX 'v9%6g뙢'N.Rw>z8)ZQSopn7esVYga9}âR)xn Q-$JN 6B?j5\L[КT`FӅ(]|%5!'j c9.41̸U],9eXii/$ i4ml:%j˪̋bщPWKtblo 7`d}tiSGAAXUUҸN5qi $ jT.]%>D@pA$jlҞ6.I}A$]F^V龦vε:jZLIǴ CRLPeŻa}]}] IYוbm]W*Ҙp[וJTu7VI%j{^%mb\"i#2$,(*:@N[e]VqkkZ^F>q}zpeѴJb?諤*j4.+ubGꨑ_Fkq*)sJ5˲RIfoVeՙYl3KtqruYTSW5@ۺTҖee.`.~]VQ b*g*s]ti?s-Ţfy&]L4/Sed OY)AfXdkWSEtѧ9D@P!sP"%o8z0":`TaK@ `]tƉaS8'\0e1O8l0V=? -ͭ gOIwD%qX6aaW$dM hGD"lzU+ |T[Gآ3ΞA>y.'[cl B,qFjCM@ biK㡽liDH8 gP=ǒu# G[MeHP П[C^8T7$+w3|Q4z=Uأ<HԌCgx'g =pdc c,lYN2QQEX`~".2.e#29 9B WL`8n 3AN(ajunaZ:ȂԼ4W2f4 qZ1=Z#fO!屎z9{ & "OKDn[D)*(Gd,LQAƔ7B QX@%{kOEOU:ݟWۻ8*+^j\%$릭,Y YzX^ąmKDEU}MUj^m{icA:N%b6$Num\-*\-2+׵afIiȑc(_ZcAN֋  <Mg,W]+BQ`tiLM[F!ـy^Fyx Іk;+Mj;龦Zgƭ1}cƭa:&5DOR``o[M,<%zw21JHu .Dz6ݐs?],4-dYG( a4씚)^,?*\Td.qPb+%s2XZ諏ȵQXB}Ν&,m[.rQ1r bQ†ڞ\rn#\R(юSZ rM5`WF%Y-F[{J[X=Ȉ&P#l9yI%9 @Hصa:2 AD6!%w"v "q>'3M.pngn4Y9J0\#J֒i{# #:ΔU$Jyd$ԙƞ¶ #97*i|HWN nl/X_0$2yFu[І$+A[%XZlQ6Y M<{Dx(ƫ{ۓDNWDW0 wCF^l"5pܬ,ɜ F[@G-[CM"]#l7. 3egKyQi[/+]մ[BG}":~XXȻTЬ4)j d (̫SKL?K!g0dǏ ڥ׷n]cc"MVNOCQQS"t,ſ33խu2=4v@8{`vRb^Pp+sf14Y!eKzYIKR4xiX;3k4ׅČKzY %Ƨ](EꞽDv <5ag-ۚ1# 6oF(bZ%{.1S.RIi5֏wT.sa 2ĜLN 3e؝ntGm(j8Zj!>AK wH i 2Ml*H}c}{G= :j5,IHq3?%LXG>I<4 | y 'w'¼@DiqE\J φ͚1Af"浧Jk%@g۫[ЙPIc8G^X8bƀƧ5`8 Gp.En` ed"sy@_sIg"r@63T!l(EiL ֘Q,amž0|pg g/8sgy(pg NU'%ZЂGV tܪ =y.ce'nghb^xђq@SX;ǐH/04DӲ[rI"o4!9hp8Z:L],MVaKjR9[ȚNg֠`PڋzsIPb48 !I8sM}?| hEڳ<M)4t;MD`+76 HV6c״S# ;(itf  7]=76I0y భMRӨ|BK%f I!ƴm۲2+@7`[,$ٞml,25v+Sam/Y &9;Ld"̬v@lna;%՘8i8F;CC iZ~a_4gf,l ۆJ'.vƁ%U$#U c.-rB&#U@A3HI mf Yw8EȤ|s:&S(ԑB_iD' ؞uTNėFzraf1I88QY܉_8w4>i Wb o\B)ЋDBq^#L;&?۱UI96gؙ6e8Ҏ!OӶXL{_>s>S%!Dž,gСBxjk\3*k4E;[I4/L1meo$1 $$9?ϟJi>6d2R4GB&k&L|2KʞJZRaz%bkN<~ZWFsrP?#%X )uWPW*\M08{ z/˹OIY t GʪNJR6bI" J_gY%lᄀ:X!Lk} V.݌ݛBYnBU' @_%r6avL`󇲡EVbBׂ]_8>n/Ce/-xlN$8$05c<{*vnIҜ&KvrIR&K$<~ҬnY]%exYL }HDl:cxr =RHN6}&PLvmz"ٲΞ(feƳfiNGr 9HqQ Gu+&w7;{컵SS$mo~&'NA0w^WrLƦzpa@iN7n[ec9 p/ 1(9K`li #xPQ]0D.v:Սژ Ł5:W5# ,64`Yf4,)H[ N͐(pTd7K _`k/ 6UR 6eGێ9yLviP{IiaKH_EQ N;NbV04$LƷ@`V"FwZmth,s>vr(3N$"IA~($Ufs%G؄)U-uYpg܊p]H]Q.0P |>cix>n)8UQ!6lDp)@MHId±Z=de {9 I\rJ5F~c< I1&q=лXbQ[%1Io١b$tPm;a4b81jnƫݬƉzc4z`G9[JF1*:j]=qe)f5 @hu$7br%!Col$%A.8&)6k>8k9]QHpV!7^*Ih}<-%ˎǛFYM8͋`@-ԍ3"IC$-c~DŜ͙ 4x~8)` DK[rSQ8yd4wd^Hb(΃.XO\ddPwΤ5$@v(#O\ӊ[u"!qY=90=ԩ&8laѥY H: (af^3[tqKW Aޘ.1=9@9tHK8 at6$!3~e&A{0.ڤaqeϿ7# Y<# @6St5 'JSDdL;I&-ivĤK&-c'/o%V#']r:oƿܘ6_r@'^ a;]ΔE%U& )MZ. &!YpφY%VM7Z.A'-+,[Ș]`l {iqꯣPB®PL9uRGI/*iIHdPqe\q:Z& O-'<J;[ v#KzYIKA->&ƽ4OJZRߔ6HkJ/pq5vpBh0pB(9̄Baa&3TAEPʽS;g$Ǝa$g61Iq%RLm^ :~،;dA&8,〾`sy dwQTbdBQg$PbiL̬cBʀq* kiq+ XTDn#$+.sUb,$`o2@v΂ꐹ K閌/ t@ H!k͂q[`N@CBgOK5r.$6-)xYp#Ϋ!و)wYz8ۜ)tCiL;KC%fÔ3U RhvSm$م)eKe^ p̤H5HOyEiM;)m1ٳKI$p+VM-!Htc=sqꔴ]bj6GP`6S-U܏2cc! V4 9FV/+Xx1pH )68yµ{fҨ^k,KT} yQVion 2fKdvMb_aL"51}e-6 nlN,;+w$sO .0h[ LI(Xan6w_ԫQ+qx2-'^6$`vXpeGu.4=&h-Md|Ƈww|S`y&/n9'#;՝ײ6A.8=МigDO5r">u;aN vvr+`|H@˫NYO J23^Rv\y%'Hݶ$.>#jHAlJVxvtv+ [\X$m8 ig񋤞 nWzƫzPlmk3`w霶"b!XH gT%U`.\!J`Wވ491OV>Kwr\lbrvc9,6MoguZ?K@KBP#URF !bZueI Vtvǚ \2:zbf'y%,BdY$y BuP@Sևp*82#\ywfI_rٶW@UJ:ZPoT-?G/#iN%,KYUՔd-Ϙ̒UFl"AlWA^-yFtXi*D%ψ.K~Ō7QdxTkN79o80IB\v:os`8UM.66f|="҆WkN38e$Fv oTڵĵ9 '.%{$=RjQ- bV6O!D|ơQYv(]t"iȼ/3X+ 6F?[E1j|EߺQqHH2 Js.XT}tz'/1,H2NjRO5z_2WpbΣīId(8<hmƎ(2Ic>Q`$K(pJfA|Mhv8*PHy$v7xwd]f(8z qU r/%vv3 7:Il <F+P =QGFcBQ/jiÑ8RIMÑv+V GldmdͪXQpVQ.lEs8 76#YǘS,J*Xbp`n=vUY> 85vYv #]S%"Sޟ…J~AKIppۡ]- @FWYv?n9 ngʶG { "8ø`~z_ʐ(XpvH ޒtyKΌC`lH1`}E=i/8Zz+I3)=8w:얞t~t{C| h wiW> mٙ$vۭw#ec,ۏiEjd=x /ш'1nl"e zt˼2qHSD.Fk+؊=baZ$N#z"9㎾'l234"#nӨɏ4|4OC)< Syc:t3}/3 x5V9y2 _<w'GV;w6 yIm;g(d֥}_pHz{\z~2`3 ,HO=Ip8Oә>C2i}x~?ws* ՑB8ڭ5)P_J7pjHUx}nR__ն-_?N]5~?񙡹<9~u/u"ދx|qԑ֖)~V- Vz 0u/k- nUZ>px;~XKUal#G ,nfi|҇[ׄ@Tќا3_j?QMHmYowȷއ`Es FVv}~6 t2`2> ͎my_I7ww// mWϹ\ρM"/]/v}<ܗw?%&DM^w;,NX?ɤOFws{\U@՟?~z R^nW yGMz+{fûmjğ_6{i}PybXRǰ1#)%4cψ&$է0ϔGVTh>D'^Goaٞ\x(= g]E?u_2w{Ny#eiu7O] w&)w7BKQS7)n&vs 3(l[ӮXu/j`@r5]/RһՍyoaU;Sm![<]ώ/ /KzGrqʽ/W嫘}ud+I9 J/dξyόit(ґ,0eSc:Ƶ- `,\!3&*-_pv<8otvg_Z}\֎Vzj/?7I' uCJO5:j7@ pd}8'Zʌ'/nDåHg@I[## ~gBoߊ䀚o.~ FFTŠ myFAg{8Хڒ 'ŔO<^4:na47ա=wyj\,%n*=u<y)xټa"B9o-0 .I< ~8~ey>endstream endobj 467 0 obj << /Filter /FlateDecode /Length 11815 >> stream x}[mqc9[dV'B$;$80u3zf$굻^s9<4♚^}=|ł~zFwÛ7o/?^hQrlKs񆟺.J*Ƿo^~{i\8cQ>7no{wo.B&-\K -{r|+3,9"_~6t9>\Ru5׃?՛6}8w/-Kc _esK9%\uʞ{+cL"5,h7ߣNqovL2IgiI~%KCH>/25WV7Z)cNlUd@YЪSVcah,EdUR):el%>:elYh%aYb.~rJW..(?s"n Ձ,?;pݧ10a)ؗە+֑VɿJZ%Kc+L8eU>2.cCNZWLR$lM^婟Ҍ) CPA" rΔP"LAV[.TWbr<e~03n29PH*mGVH' +A>V4RbHN@_++RTu,BdY3e1!<YАJDhPFɐd)'Y$@˕•E e1B(K)6H( Rjsa (YDRX9ٞDg}$9һ](¸\] zx!,-"SpS"Y8jбH$ev ~KH&Ex-,@Pd '()clv|Kj!sfx F!M  )HlaU)De~r 5sA=i$)BP.mP*0J5&cPPNCp@V HYP-ڪHd ދO䙒Jl3![)ab{*RO8Q*Uㆩ&G$3̊'J:ynD(,ʹISs3Q*uɟ~4 i.4%.=(WL:ggUXƖ@%|J",, CCBhGf$e$'ܢBo h4Ji7Y ZeDTmܫ'NC_j.E1*u$"yN! 0X]9Py'FqRUo#fiI-4 TR$amNk6CH3$ي uJU5c!ZZՀ|LEP\NF+F_% 懸,ME祑ݎja QSYAMg*}nJeCua"7 ?R{ѫ"A"zSF\ݒSx-IZldI v7Lv.dGo"YJ(sMQQQR؍fjDAi bM` ,>d\,\"ZI*G {{ot34o7}<%, 6H-fsZ=CXJ60W#LEp5 -66]prf͖ :9(;G4b l#Y0@v1Dq{>F: J.| 90KdrnNdRG -#wLs+9H NBؠ]lF@+DL)})1%Zlۜzܤm΋[d 뛫4nn.=7:m.2#T)6㴹l[\0fG"F¸%{U۱9W^l2G-`2b'hAEpiIIYrYY*Kh¬dAsʎʶv\+m:*dM!<9cO@1"OA1r.PAUZ2P;2edڬww~9|vA `NH>WԩixŪE X\cSQy2< Zu*¯cJ[i$u,\)c+?0٬gXk\s9jfAA~~@^QO?=_@%8]) 7SLkhFɆVFZVZeliֱUL1Zejp(S+[jĻ`1ܵ ˸Xݛ7n?&7)¸O:_W3J͉)s|@XFiZ*^n# ɇ><ЬSri^GrAmeIW4*y#W4BODcˍG35-=_hNFA>֝on,c?/A?Ulm1n\dkfK4/H :_q;4:+ dZPiG!Q|*49O; Țsa^:CW%םU7߃&@.hC#h%PJ#dP\G<)(3( zY$~jժfB*Zb(b{X4%BD!6a !'N50 U[*$87ₚ79TzbdgNWJx$3oci*,5 FПe +:2C7( E$dM+ZNs8fea,j xʚl<GVZ㈫(N$~Ub F$]|(ȹ8|w-)R7 ӴEĕ22Q~;GrgTF%)Q}*%%Sмe~4&`F$ m%G4OM!JXK* <5"$T?G^؅/T?JMPwIbu"rYpչKX^ei5mJ&Eΰ-Zq{DRkSc[o,m\ŒX!B^mfjE%TЩ"G``Q+m== "PJ/EgA ,*!B]ȷur9irgug @+OJWȬfjބ,Z;m=]eW,+'9YL>,F {zP\^W_BM[jruc*mzp!E~phzɇ&"kTGi" 1P@T˄rFWMQOC(x dx2f)E_3ҡ))W؀PB_Vэ! Tt0;Z-v\ۥR[ΞFH]] pycdgҊ hWe Yw*Ooz޲f1x- 4oQl@'هpfbW~ĢҌxbu+2tB7> U)D7w2"bg܋p:.yEYozpVyhQH5<[NXQ.lScxw\+kEق ;Vk LpQМ1G0!B^PX)u rAd[Eg*=R.*zW̡W 5E2K0TE z\DDx%TU zL, BY0)T`Fa*`=!ǣirJ (s z&!Ǿ{PJc(IW ʾY#C+W-2c 22oD?ñJRM^W%!֘]UG18^q5Qҭ~ho$#6B+e^%g,4KG+Uk7'\/ qd-xFóى_5zo(d(XW0BP{1-dMb/5t a4PRubg)95ٚ\w#rw\ayt Xcfh6j{:=R_Nq#zH(H"b.($&~`;>&[&ʣ7%Q+ص0KH+ LqV-dD%v웠v/90 $rP?-`vDAL9M_E5~gR&|駅p{=Pljk@B+1bnc| :)XZ*bLz}F`K?'FwQ֋,~cϸ#`݌Q+g$=`V\Z,@fZxMBsoIJwr)f\coZ&K:2B.ֈKkNa;pqd' 8IG\dh#*Ebn%B@*8\^3&=R8l])u$c|T(mv,HX?nmz+&C(3bq|3j(8R . ͥDZAZz{ӲO4eo͇#{n8 +Rrxxj~YoeunbKxjSH:xs7dQpK VݴNqO u2hi뻾*BXQ5wxFʪZ`Mkl;` W(zqۯyxC>A6Kb&Q N䋍0Oގ"[v gwEWLر׫9Qpz-iteVgbG] #p_|7_~uWŭ&o{|dm Pj\ ep!$g8v'b$6rrE©@! ?%FÛ=`dž`ôLc GE68dt9D,iDjgrג1r6* T~r?2/ 24-/ǙO[ U܇=.oT]y{C ktۃsD7h 37ۯvGvt=׻JΑ2$0d\'8 x YNB3gL~ 1'XT.V9.7eO Úm+y, qP ꟔'8dж0ٴ+aMq> V\ ̽#M+[ú?Ʉ)O?*7ez+t5)*=iG\u%|F%Lݺï&t~kjX^@~֥~mL=Uivf9@/V\i`3@gh&0rϿ 2\q3 d_ m֞k*;ʃ( PE&u'3[efdZ}R@ _yY!A^b+}3_kOG?KƈVA!2q)yf)J?<#?[ 8;9չNYaq=ϪN}Vwz 5oqѺCo=,LiV6Mhޝ֐,xxlÞ5Ÿ2(S_!+R-6m?$pSqy]𷇽 L 3]fxceϘ._{=17TtFA ksH93_XŰ?. w |OD ,@܆_]lqtgp4.yl7_' z}VHuJ)l3G\oʳk|+7asj^EWyE {VF?yy}l#Cy $w; ܼ+kŅn6Z~5|Jjϴ5Eg.JΗR` owUU dr?ood+$[]z R69;b=W@ FSH#խAZ!nw4^@UqPbP\}ڑr`NY,I5hS*ܓCm)ѩr,KvV ՔD=ŭ_M^rrYQ^c8Vy?XPpߖOi;=arJoO+kN'i>3mZD\8|38߮?S nLj?Lz7_[$/uAǩg6|}~;e{~ ΅ @cւ40 }e.pXxމjo; 4I~R NB^U*)L\!0e3|6Tz*l\Bo[jϞ'Kp=yMJWq[}<7_= &0WYiwUeKY~CA jJ0Ӌ w q+.Sa3.t)iD$%$\-kjE-~5?~2I:%odT${W3E?z=g9'X }8+@]sY%Dº:W{Wx~_g˜豆M)ik~<4/jQÇO˂"8уw|F8oޚ\#F'; tV?P׫LUEu>"l4w\h9o$bau 'Ɗ7 [Ҩ\j~/發:׏]g4&Vܹ_Lj,7y?D: 2d%Xx1ϢAi| Vid]:7iqƒ3Uy9*kfE ~on+\@W=#)h-Oƹ!> stream x}[dGrdOz1p."BZ^jMJd찖&o㋈̓yj.!y/"2̟wfow}~{_ v^];ݯF!ʾjwx!M]y_}=X|'T9}-<{qr{ʕ.w7WS?^>[C?+ j񌹄_ڽ1ٔ%*!hhb%zg1W]>1l޻ ݿEGmܽ'ZPRn/~.՜n.l[+SR6RA{A)SJ`J-e@q6佩#ś/c+R{uỗ7o^dHfLҘ!Cc_wu_ZT|DL$Evw.eJ0.Hi}" В2)q$J尙 c pY^$H-(4GFo{$߫ߧ<4oev+뮷膺2ZhF_0 *2G2@ <}EZH.?aZ1^6j;t9wE41 :~$ rS9kz 5h3J82Bn@C!ehh5(y]*ڥadXnɓ%p4Fr!8vl5+C/KBqW2!(Z>nᰙDrk-G4/٠q4ݱF0i2m|3` ̌Z]ޱ9AeQ. e@mkPP b2!ehh5(yb"-c(dIor@6\BRIYeqhe[%#Y2m-Qvøhly ײl)t*cBBewdLj`ȵIv=_9t-]٭b2ZQ:`XG !}{4 uUbeacZ WeknBg;):zRF DG YO0"2ȷ@f05OfYADVnAFѦV<$|$0oWBE*'bfM%}/rX8c+PhXоn)<! kRDB]ؚO+eSٽ_)!t\]SИVFXAVɻY,}pFaoh@DChFjq+ye֬BM bᔓ^~.NC r|tP,m@1WMCRF DG YHQJ4 [];Z>Z[^dāC+7EAѪ񬏢Qv<ل!7m,XSIp],C!_0աFL+-jܠQs a`JCBh5ژ43% [zAR O"IG4Bj^i-w6wR}?r&pq{DN )꒸~4a((l--y!A wDmQ8e94A)# Ŗ|磓% 4S"PPRhȠOPhC~IwDi|ȱ5(Q(]BXMpE;Jr; ]P%2lKW:&?+A+B Y,EG!%>/24GVY@@2v`H璝RLkDN 2E քQ`jX@`%L`K*pf /Fp$ PdȎ,k,spW,BSPBZY "Uz'{"R(TZŠR`F)V7Z]Mp"D2w(,! E'$"B"qĩH)}l8 ,S$Ru옃 C/ԬYIdFRH$K,,5lfPQ.Kʁ%B1z1d2x}b [@;&XAYhB+ `ilB9) m1i{ Cx %j_YL'"5AV1Rs  LGq77( uquauD@ێuD_cE>kXGqźxږb)iuDpVH8E( ^u %V."RŐ5(܄"f]V԰a'bSw C:WcJE$-E<0 QĆxL #1E1EzW(yC#bSdĊy<>EJe<6֭y xżbh0OBIA£'R gΧ`;%j{|Pwse-:CJeNA(z6a7-_K)ry;PȔUùFL4 -#(fdH V>_ ̝Y1>mFr! ow=P88$߄;H5jYS^ ^>ТQ v+UC˜kQ}a3!y#Y`ؒgPǰ5X4kǀ֩4HEPdيPdP(ai'2y:ގD1wƧ=h<|-(,z^*nAˤ]FĎx n<%yb!sx~aB՚@k)@#ÒV#%-"CxɆvC\k=.j6M+mƏg&}FFKޥ04s~l;ܐ=Eb;4kxq$xGJixg[w>0"C#w ' wwι3@Iw$wA@;txi];]Iux'KyΝ\m+ML^̓5|],:2=ͤAVǫ+>rsoUih??y'[]ˈ}aؠï9Y#Fg!&yWNĖ$] +HwcůAG#;>q)1I8~uY#uk{fGo!l0p{Y=ljaC~8G넴ڕuq_7>lԆ\o//#8dM6[*PWy`懵KtUc;b$L\^LJ˓\iSN/} 5q~J܎p3 v㌰i&cf)s[6oj[gfaXdDLRq\HZ gKZ~R72;ؽXrLm򔯃vJȗ_lN*ϕ]hphMNq/)l#:=/<}B eo$B7b/=lݶi^9}P$O˟ Xwڏ-#34}K) '}{\-+U|l}{|f\{;XwbR_2/=oI)(fM~&uT?A]X9gsp[_8,]}~\My1%v_G( K\fH{#R0#=SamR;S$7F&onk]rS[nRH8M{m3\I<[c8`uqs9W8x`;-!uRAESW^ u\ sMkH&6(~ (!ndeO߶WR[y [1SOω\lJWc_峹-rݓSێC:x.3-r(h:R'm SI{^j~k>dF}{A.SiY<$'-o۬1: ?:O#8N>T?ևxzM\sE%(,?_5W2 ǴHA=:IW,szF/r?o቉7nY [m0ϬLNNg3r"G9I&mҐi{|f OYɎqA痕K^7/޽ on"_S@lϝxq0p5ɁbqGgk / wyPQZEqu,u5*-Ovf(-#cma<0:yۗ5q޶0Ͼ~d,t0_8-ge+$/#d:oF²Z 㨴Y^ V,rih^8W=\PKw=W-/ =橯xI7i|g?!x8\8JsC7ϸ9Sp╸F;]qy:1x|9(rzO%tNps%Glp4X$VaBPJ"h:gNg|n/ 3|pip>Thr1,shrf~NU)?4'׿LtYv`yyq?0o (x/(H(zu%K٤#%GKF䰇WI9+B7}J#s?AcKr#Y$#iVeظjINt]p̄ IcCsYuD'okݜpJJ⻲_!MU_YX)ouY[L}xRk`ȰG#{)#)W.giR9j6u.=̝EQN:&>?~2.Rrtt0%S.6Q#??q@ “Oʼr"yu%8>~yH8?9s"ǶeO^8ҥ }ԓ(=һ>5:=ަ+UpOMF7WfS azv{%o\2yxdb*C,;K# Qoi~DVAi6}7o&Iט^! o }vt?N >!:&c87̑cb>Q=-*A1vD龜[8endstream endobj 469 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 354 >> stream xcd`ab`dd N+64O,,M f!CgO/VY~'ق]R|<<,+={3#cxzs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k꡻g``` b`0f`bddI?SUe/>0K|o﷾3{i V[Cs/~7b"Dk\~sU> w5.| pB\OXBBy8yAoMټ~e`5endstream endobj 470 0 obj << /Filter /FlateDecode /Length 4004 >> stream x[YoN^ y3 v!GہF$E˥vWW~}!iJ ˙ꪯn^//|so_\O o?şNa鋓)<Ն/zq99kNN)t^iM\I)Zd _xɴkȠu=Ƒ0 ͗Ex+-gw;]hxY] pِoɘ͗]υnqÛo$ojʎÕt́T8Se|c1‚ԠI,UZ oԠw7Rk0j_rtU҃mN/N<嘕kn18r?;}ޛ7ՑZ]f>DS3(Za㸳fC$+nap2[h)NԂV*#B6SF.V"/@B,l7F+I᷍^k_㨋}@,/U-FUl I. o5xc/f? sG9;awע$"\<=LA=Ōk7}T4$y:B(/یMD $% &A&|VrQ5M 4 μof4y^y :zY+HW.@Ŗצx+ m~Fr&ԌJ!x/䭡ٴinpy+"0ߜohDƁ e:=$UͳS*N3% ]!l6MTWl0 dI]4d ZQ)syFmן"+v>s1:"(Kjo1Ud*mZʩi8auwA4IP%"t+t&5ڪ  A8Q.6,nPQja%!a% 2 `Qa"j <0kMԚUڪ2tv4O+BCi?S,UM|jRf\5stpc N1 XMB (z߅Enً6<"t_LPOqըַZQϰ d|HLb}^xzOw룺BrqM0.G94J%b0U14 =)K_31;6o8xkH{`顯 1dICmvxDϝ-d&i!l! DniӖbD 1ŁP \Iݔz $üC؈-pn >*m`5>Bâ/=mX ?ӕ0KV139O>Yrʓfĕ dL=<:v)\򂺜D\?OcNtoUvQy* ;׌ɆDF3JP:c +P>VFʲxC[* Gt /QW>G/Bb<` T0Ú @`aVHT gR5b~ ēvlکbrd>Βж,i/gjoPh2i5  .?Wj/=bascۨ2zbft9ܭܓ^17H\MO'3̷qxp[{®s'Ld[|#ZM~vل~ ;j(Zp sޚuÑvPX'GbZӾر WudnX抜3-uk)WWZ+?];qb nc/q `J5jS\mw?챤y|vNzzDžj4;#P:aьpq}@:mPoS?_E$T<>oPԾs3(!x_9/Ɔendstream endobj 471 0 obj << /Filter /FlateDecode /Length 4217 >> stream x[osp/])iFF@PX}N'_ߙ]'ْP~0E|fvâ٢%?i'N}]ηg8›5-Nߞla(S;ۓ0ذl浳&^a\q[7Lj+!`eS7J}xoM ,W2VjduӘVk$^JVHZFYf` `=őU$r%Tm˕j`zëכ]]–FhW p໪W7ۥ@wx댪8VWa T8{@vv՜ 8}yr/U#ŤU/!Hj8J񽩉7nye7A4v6s 1myuFdaձ'P(^FehX͌jVX-`EMHlG0^mk~.?RmqO)np79㴴xN(iratyɊ3^s+&j8C,n771\#@]#;[.DW⬑@8nwmI2U)n,\}3+ry/Ik%k\t1+ #x7UR?rȝѶUE:ik Cth*vn3}w,NjGkda^''nRw0' &ޏƞK45,<:ύbw8t=Cxr{ eВڍ7@sMV 4%A3.I(朷:q$8q(%̺,Yk"4Dٜ ϡS䷳0`"bJFm;KyJIJC!5\[0 YLRV9 p բ:=[.kTz#2Rw}7ta,Hr m .>k.caⱵ`U8ӓN^tk !Paʔ fE> ANF>.l>݄?r7F\H ^|&UjDDVsPKDHdXFmDҐWɜ dG ̑g;|"r-!Ȇ,B8ZɀGIЌxK]̚}6 gQOD5cÄ d137jcq!$3oEsσC`c!Y%" B.{R 5Ũ]B};dhQ ]=mӴq;2KT/C- Ku`ɳ󗨊騋4(tRؠϺ6  P ;0cIek en$+ C&֗`̄Q~Ԛl]4I 9P)(/*iIgfb -JVi\׽)@+CCx`}­ qu F X1]!uqłsCyqr0 Ёl]ʧ7h :T>O M#&0SRq@BZ7S@ա,&_Eh 7)t yPEȒ9I7*!|0 PQ7~C*rIu+exİd"L撼"o]|sHTc3ט~arLCo8 iOu%e\(f-؀sqcEˀo9 &`"uduZWԡS}30fXvs"W9,WLŇ⣿y -ʨ&5-0MR M]`'Ζ]c€~hѷ\uĭyƯ$Îm7Mgs"0)8 nlh;*"2 ׾`EXE+=S2s|KmNq^oJjfjjÛ|2Mݸ;2LRbΊ}NOKhD:6aKqe~q%Lhr/G;Xuwͅim 6br{/*nř߯Jn!*7@bC:_ts78@Rn[mdžAߘCg y l&;9ͷjbsFf{u]]o2_p֭)$sVQ.@'y< 聕k\29jV riuk,Cx{'uT1ΟcJ^?=dQmMސAni 岛C΀3:ܷ 9*nw{?3oFh–mtmB, 88aƆ,Oj2&q-h@1KϘS}  ^oǫ]d)^ )ks iUiito~RbNM@D~1AYQg4z?AƤ"E L.p8%BJY>mptIB&DpEΪ~B2jG2fFEG %`?YOu<::>t-m߯j$IX"!}9ηqe(_Ig@(}Q<ݝ=OdnX%~NFbN%\ , -,JȺoq7dS|""`U#( u@bhQg9mP.ZW _.V-0M6Y[ŕĨω~Wb &b/B=/Q/x 71S/wcFc<&cF!fa8ײmT9b;)>!\ ¦>NC,s5˙~0Ml@Ȏ*z`׳6%؟w((cZoL¸飴f a92e,Hp_#eendstream endobj 472 0 obj << /Filter /FlateDecode /Length 6018 >> stream x]ߏGr~Kl"NwI>$rA@yW+R&)KUu{f* Y鮮_L$\ r]+)$[fuVP)b\&¬Ml@7 ^mJu(7x mդ3-rYc)JG=cY%m#&ka[c0&'h C( ܥͳL^Ɲ 3u}Wv|d)|g6YYcf,6@l. hBa1s!xΣ,:gI(ab%W CΔ6p&F?ٙV'B4<qu2cMmBBmj=0+|8ZlkN 9,y.Z%Vy٩YIÙSj Oe[Y|/N=rs-1>v7zyJ;^Z]r4 %>h)Ya*G6ݼ[:ͺ k)Movh_!ꄜPmDႛ- JʫdWIVwlx+e$>i%p˴5u;O`"v3Wrƻs)Ĝ\NG34Q8eJlD1?ȘAD"?/k~0jRl9 H,0I W@~c¬m|&r'cgE]A'HJbJF0&ͯ4۴ ,okef2 ^' 'W*QV;mURI&CD?E H"yQREo {4 V^8>9٢y#j}tb@{?WMҝ79;g8fPjKc@_@\ ,ab||s2GN×[#98 _Y'E\cKykӠ [wYpIuΉra5~v6<6#ҭABmQx2'zuuRNWiAQUт5:pKUtj~bKŋ2Tp>ʃc.cҥ`H mbF7(*"+#AGoPy; 5c³bn<ՍJE'שQ u(?)Յl41<$ U qTdrc-YhuSO:"wwEH!yQ#!PդE )c%=. *c3L>d[Yt2wH+*u*䬴 #x_8m`熥K^TOiTDQlXAI#\46 wM)IC$#7paX#I_ZҸ$Ra;SOY"c;e L'*h\qj70\mėR$(,EuE9wy<ˋGg~yH?5=\YQ&Ћ(s>uyTsʹcѴqr-)Ao&b@c.#~@& l( ϶+YhA'Ha~r/ JG¤B@ˢD zL B|=&ҋH7eӝdJ 'ag *u,G&ݧ3>;E6]f԰o%8G?W)WyhqOZCzE?2H<"Id~odE]]Xdrrqqh!j=$LZ*b\+LH u}b|EpS'0s'jMQ5/Q0$ky2oX/a `0CD#I08 t?N>ۂ4-~b <[AlNt̋8fH-zv~[?<>}>*pgXz@^-^T 0K9 XⓏ.9I<߿;?<܇_l;Bʯޮ| Jcb|0N %ZdFpE6,L[f\k:tV1qqHCp1rb'gkωs3DtE%:"8@?0!G˔@u-r$"- /̠Wy*U3{^ RXC7-QKL Y͘H̕V^peJ_1SJ$+SJ\\W%Џ͇d^aõI.{ m6A?fhz<'<=|<<@@>p'Uk7Tkc1Xi_T Ux`TlS  KL)m2vgKSJ.0W\d.\Rr V]ȡHH fGm}9gG7Xx]*z>hMH`}%Sc%O$,HEOLFֹ)QJ4ɂǺTERq%|*U :3AJAfy&7N*N=p'YWb#KQE, *o!2^ ʓagF:iJo眆LgH~˛p*t=S*y8D8е<0n2aX݀tL5bMkFRj *݄0nb s#]τ }H3Nw0qG #yMmi[w-EұvZk9{c\Z\il4(E =eIoZܞ H'>ܘlMu&OI(IRO!4"VѹOJU4>;1W!*z/|3@K %Dr{䒔 ΍)S, ޒB x>7%f&?Pc$=oL3ށЇӞ(pfB#$lmh#\rT6OpZAݞ" (]k?-t1r.mgX>{`"(^$ޗGq>SD ΑE D#鯁Rdf^~gpLAF Rdhۢg+{؎^VL虌L%%?2Q/y4źUoeG8Ֆk`2e`P:^ݐ X@I%Rr#)u))^T:OGũ/J,<1/R<<Am)usJ,i1%܅SrOQd:CH%-](}vucJ*iYȷݞ\1%,lEiJ.Ku\ s^eJ,|yLGiBiN#nII,u (DFJN)je>#!AqTRΎ/KN:ERbH S+pQHyO{T`eJ,B@"!4SRHֱvPba8Tл-J,0)Uǯ U+/HI*%sx):Xqʘ UJh=RbyKuEƔ\ ·3%<0%VXWrzJ9M%0L/J0+ғx#{, ( d:*O-4`xjG)~f< Ig&)'xxxhh:@TΨV}q7[ݤ*ug;w@GSMKǶnаę}MW4{fͽdgKO!x:YrUA>Cq5|Ow3pM{ݼ>}nY-E]i}̕Geo.cq9r#Z] hj/Kw9GlKӇЯMyqԂ{ <1d c ov14dkeiW) OSQ B1: 1`C]g~~sTJA<>B*@8Q \i!td!0[t}+:~0SBQSB [Q i4gQrwWSiLX[9?Yi-wzh1N&-%# qM۹/N@7e=ycr.`ysn7|F~L?|3!NqIkN&5¯k5z^hCin;=Zhmi.GڊzV_>Q*e$$7_36C es|'|hGEy")SW?BTK'ceOwLa17tG!3>3l+2:ݕ= S#evLA6iBt\{/["'.1Y`U- M*ŖXw! OIFS96Es/JXܽ)Ul?Qn ]YJ>{ 80w Or?,/`q6vendstream endobj 473 0 obj << /Filter /FlateDecode /Length 5467 >> stream x\Ko$qGC0]\KוּWeZkxa@TCrfvtow<239pmv#22g/];/jsv֝ߞr_ߴ}׫ox:<Ɲܜ5O06(18_^j6bc)7ben6o.s&~إch~97 fG\+Z4+kt/cvU"ke\g^.6꾇5Vګ•;כ]1/XAv'm N8N\ߌ<G}lr ZJK܊_aNNNafr}圜=Ҳk8pϳ >D;mx$F G= UC1y7̣ʧ6$UZ)VߑL):y7K0IL 8g`1%7!lp*b$tKG*+Pu[\p `|ÜQNZB8(qJ)Hl}I\zY*8[kvW/`gZ皟J2@m[- wBdESvCnUt8`Ygz%Enx>7t :y0S1R^F)Ĺ[$(ݣ@)g9 D.SOOXbSt@C ~piSw~adؗTbNoX5[%/P-sh)d2|"j}ˀ@V[(hzAS _cܙ1ޒgI^&~vҲpB4r3dlڸT 9l#}e}{aSvZUsw~{zb//هvps r>S\jL֤x"`?H`"0mh \s PDaqU̒! @Cn ũe(|=ebp)8fd:Af]inkB 1qH*G)/Fω#]%iu>N2kPnIMY-ߧtYSwk w…# l{fNrt1[YM.LJR umb]E6`|-n}TSwR8u ߅RGÇQKTW_4 (<ᇲK.0~8f/eS'lj7=W ` 8πɗ!  V%)]͟_'ChppciłR*v#6g6Uizɉr`݇)+_!!;o2/4&ؔ["p9`Da ғRy)}H^VqӂNJt'̔).^́( fȈV:Qf iÐv*î ^ŕ ǘ'%Ϗf9[t}Hd9HnG`RD^Q逸Дj>HmE iYi#nO?|gA4QT$[D26T22E?4aG%g'vD :)3]f") ;!|EiگKtvїdKỌ%!tx)uqϊ+psNhjq>3TcXJT&ETJ]q^Uʡt։CY +լi"'_xSJ}8oPQž[}@?;Mc1 Yp;4bP@eYJ29U+&hunAWAbgRQ.s2ۀG'KfEҾ+ x2!{ٮOD@$zge- Xml()lSJP#7dbsdKU6F`^qFG Iw\S2 }7CH&BHʬAݕGh 9g?kǨdE<%bH=O,VSl9\~8Jq$qi1߂x̘V)TB{P;Ԅ~6[8'o7g:Ni<kƆzsi4RwZ`3piyCP]N^o׿pk]k fcД1~ShFoh.c㱣Zbz_h5]#zB`.A8%괘jg֘Ja5:?/*S\)YӰ0 M_H+ٛ`;xaE|݌̌"$ MC=U`5`ugML}'5g̞*$du-x2@-zj̕-8EHV [l0 ;i70vZdpyz6pp|kw*B;^_~!&vTZbCnV]?BB#(R o}(rPEą~xeEI>-;y3s Ӏ(" C0KJ"JЀ/}n ^%Iauz5ԚCQm9E%A.3y$,]'N9֟}~l'=f~T!7t @k7#?f`PN׺pdF"ԁS;mӿ&R.OPt-71dvYC]8p?^487 .!e'oxǰ\R'c%\K3ɟ^ܥ}?:9u0~6-Ԛ-|=u0ejed|5%~67wéA(.5uRZѮN 0c!O O@ W(4N@7[|oEǻ¨B{a}l#!𑙈- *7$psm"0dBNG ebջ[tX/+l/BpeN5b~))g]lg g c+3Nܐuc>xu`,LG&JG?_ֈx9 z/!@a3~ŗ\`N=6nas[1*Զf0𼹐^? HVAzUlxjN?-@M  oQ `?^6wy*H_m׋jl PG,Rߘ^'7*bxyDg۬!Kzw7oQ/ˋߚDiJz h߿ۼc}z)M)??=mendstream endobj 474 0 obj << /Filter /FlateDecode /Length 5472 >> stream x\K#9rᛎ CbJ'րi3]1ѬT/#%tsbd0AƓ O8nҿ?IO v] 8"N3nnv^͏@vArƄ~x/WS+2rF`λ 4Zэ'$=~SQx7fr\^4 )ULw?a{3>v:!N-QW UFaqsdF&PY\4ςdB FO^\ h~2Kz,Ĺ?l"v~nNWa%"_mvx|Ouwj޽[3,o4~[yykZUÅMc>抮0ix7o~zĦЙiҽQo+}TtrRP1oPE7]3i{}~"ڲ_jRBg鬞l0`!Ȁ/&5\9mI|?mnk[Odl57*18ElN_]~sWmkIXٿZSB.tKx֧$|q|ҡ9m V::kX"7=c> j n=:{IL >Wm2˴֏̔h-ihanގ]BVЂFh"Xj2y FaY=H4Y1 b=Ap#Zݙȵ]81dµ n&?;]頢kzH=^ki_`;tI#Pzm1Xtk0B\)nC[ڎZw7n" Ԡ{fgǖ|-#mh&G0'3,c=62wua?WY"z~1ܮY]Ȅ&:5byh#@R1:H]>m85PfP(>*8@s3n\\4ﲫ$y&3u6zѐY89S%Hv.raA0N|*7P]8B #ιANIRv#H> Jkt?"XH?- t F i~@:/р<]IHXy! ~LG,ǷB(LG 3!n ;8Mici=4ALHZFlc 3() yנBAyⰬǷE(|G 39H6%pA^/ B{;JZ2:o1(P-*Kh0Ƣ+cQ0tE!aFP&1uWK!3{g7U46*= 0b 1^2~,e@f1E C.ak&5eQ" e n<ҐuQL' A0a@@a*Ńq(t^B ĩ@'E)I@P@RA V7ȕyHI.#KB?0TQc I)DK}ewfB2'li$p YԒh+\ aƘBW`233fDjH*bG1 yJ cU EǬ(Sj`5,f!}fyv+B `*IrDWxR1 G3}*33< (/ʐdX^Վ0y8*bX ¦]Ux&A V^AWI,DKN2;W92f2E"/ݠ nEƄfP+fX%GCS-EfPcDq 9G\c (35Ҙf$.#1Z!>Th0C+G LВ(}|$/)D`yH< &t?H <UM`!oeDUk)odHwi=qȳ Pcr5ɀ+֗ZQ`jRH\MH T,5r5` :hW(]t?H!&= 7BrU1 QQc Ij)D-KfwfBD?Po_LŴ_fA՜̏?SSc+C_Bd;/be!n$5b@i',]sJʘ~KX0R%eK.pRMK䚋yH< id݊c:MV(ǀTIf9э`]0;[ Ty-UD nLoIX=% ereH,S%XC,3!Ǡ)z(Y[+|0ב =ۡFUq\&dn^`y8 yu"J#247yFx ex [Puمx; (q 85>3<"2.V䢱 b[$|j %n2uiq a'$ d nE b_P3r~@uFŽ?sO@g_ CXWk:႕! E%3šqQUj6[@EMȀn1.W:<^ߓU27O_Q]feBŐKBUX `9EER8fT 1RRjTa%HU,* ?siWtNY3:tq'nPPN_F> \}gv0ۨ bB,QU:^^|% UsX4H\z)5Q/59:L$bQKզUTd$V ˳rVUI?L )wK ɿِC @_Ot][/)$0A8*8nf 嚩ءf\W;rq]c_2$20_B!uR%.?yphSSaU&4= b9С⤩:nbA$Ni":w4?MO۸:Ѭu5Z׃hm2 ?#{㽃T?;U!J44$R~ݟ@JM(h >i$>wc֡BS/"=,@Fֿk[C"CBk[q$HMmWzԡmm/QgpbPro .gEu.YHsIàzH鷢F|'Dj8HZbGBU^-L6J Zuvh#uX*!1 ?lKT\o7wQ!x4VY{VMױ*wч9z"H+{saTw s璕{bߒZuR_!Ne0n>>;~<~,|BkD}^7zY$"9kK_gHJz =c0q?R_}ۺAFlHܜHa2["\OrI*4kCҟB1 O۷e†z"xLZ?ޅnp,/KJk,ǟSueȽ=KT< 3SxkCA<9J&=4~fAt*>fP eC (;,7]77'$'"ؾI)N1HO\QgnS gmyo|@gMgzƙan0=Pz.NF_Ey7+lvv`}g>!Pum[ #TYKV)z ~ EWJpSiO6 )ݗ`méIaV?qVSM6]_*$Dq(K.#.jn=n%*dFtĻu)ۦAzwb:]mh-`L;\MG=ȰE64uc䔢z{jʡ紹lov$:O>ӵr:9%ԘԍX"H g>#FWeIXG_ɡn p@̆֝$RC4+2Sf:ĸhkEb !Ԩhp%Ўk台@hN6]=;:?8<ԁܝu9Xw 7xc`_.lj=Qf<3U@H ]KޥiȌc+EOmCN`%ifCS@Ό|`T/*\:|(kW/>%F.f&lQ+-[ >' &\&-=ʹOpznnba$usߖ3ܸ&p"߭$gIL(s>.*=Nqz]#n~<=K5,OOvV@OT"qe!AIS)$$%'%fUՒjs}p nt{ (AX_PbhliNpx{ij(T4Llk=:m:[s[^B6gҭJ&H(/=c "wi#d9qu *&Y?y;GLtg+K@N:ׯl_XvET#pW,$ kyBc}C3+Gޙ9;3L/hbm-/Ufv ŏM'^=y*P]sgg~)Jۛz@?(^2jn>Ydao:&̆=/_<7c`S0Uw& { BL/=6#D(F9=ܟ]o{uzo~8K_(3pOGur*jkشNӻkQ/]ykDb "P c@%V4^Z[k:W,_y]ǖªT@aH?+֒ˣ?.\endstream endobj 475 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 379 >> stream xcd`ab`dd N+64uIf!CO/VY~'ق]R|<<,.={3#cxJs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k8a``` b`0f`bdd?Ӿ ʾг*URmf]@{8-l_bOVAn7Ʃ33u/<6NJ?DjC^];ǂXOy҅?|\v s=g7y'Ly7}:Me`6endstream endobj 476 0 obj << /Filter /FlateDecode /Length 14479 >> stream x[%9rS|J*% Ea=4`ej]kfWODž Vw h+df#.\_=_r~~{^?A)Z n#\JN%)Ru+nr7=Gw7QrconSw߿#DoKh_<_S 8=y=O%o\oobtt=~O p;-879Qv$ϩq9~!XklTjz=U|ܕ#:?]~_J^~Zʒ7[W{1Ӈ+mR^A['?>=3|OULbՆ13Oj6ExIRuxmWA +?PB/%mJxq^GP]26%<V:^W`MI 6k褂:Cܕ&xǮГ+މW{uW]-^IGE q+rBM|+2Rؕm)?ݵ=jSe/2i/r#7*^d V|PG +s!JG sܭxepjA}+2ƂBܭ8= x^@ ڮP]^݊Sh eW*Wbn)d+KnE.4d}J^e)4bƽԷ{{{G9JCfJX[wh[Ą9w65KGZ꨷^!}SF3{mˈzl z+fW[M}M(y;fS/[a[^*]mj"I=t E=6pHQ:XBP{z vl_~)5ִS\.4.B'6W,ㄩ-0d5tC~},b;g\a)裋5EA%RrbK+QbJK)xI|.zx=tKnn zhtvOKiSȩ唎OJ 7!: }ؕ﷠FsѪH ) Ÿe]@GꤹIFƅ"娡P3Js8IZ+Ռ\7//g؁.CnUOHݫt~B`f6EJ.yl f< 'of6`//f}6Cلӄi# xZ=M0MR TdI|F}ȢSȭ #z("|nѥBn8G=X9RscA؃r(,(hpsh8Ss_pܚNQѨwzqEP3NѩI/lo(Wr T J9@2䦌ripS|#c)B9i3A&rM׋r8A)Gu__1$@1SsгqbLoCAs8E1Gܶʔ=pbB*@[R5V0&hsxE0GEFމ9ji7ZCSw)J94)G?I9"-uQ)?rt /Or8E)G4ZJ>B9`ӳ휍Q@ B9:N}K)"ir,(!gpv6c) 9ҡjBz%NQȑy#B'@OgB(V,wnc 9I"OȱzµgS01#KP1oЀµP'X (Xj@.K1KQA=-srLAto8EY6"ހw ((E{IK06*7bx)7bxc)7&מn0)٘RLAUvQ6 6`c)6b`)6``c)62Sl,R l8ER leȜK1 6ؘƭX0a q\cdb~4Ӡ}hnw,VX1oLLIFvx\UZ2 ՌyX1gma(.$,Pe(aY*nkcvʛVW|ŌWb|:Ţt ;aD,[!r@K9cY θB ,%p7(W8E) s?zi,NQʂ5KFY ` ,=eAWQ(eqRJ6ܹQ _;,cEP'}xR`:l)YatlO,)6W1lh|D1WZtfX@$E1WfacbF1S^}ffqbqef6-p6( [V_;ֲE- bŢ  4zjPS\¨(jiMԂqDC-WZ" e-iZ"UY kZ:_8EQKڜkGZzVoiԫdNQWZ¬öw-%(iC'iEzDQ%--a8EA Gl9hԥHg+Z/E$ZF+:j񊢖^ jFQ y)A[/(j&LwTt`)Z`ȕ Pml VĤmP` 3P 9D8EQ yj!CZZP5)Z0wUđԣVE-52ԒzZN(jD-E-`GеC-^{f[PB= PK9W7E-%/ZJT>QWp`aZW")ZJ1~e¨e Z0A-*@ E-Z-(qlX8EQK>QKV\$ga-Uy(`T8B4Tj4 0ȂWާAdi#05_'eP.Sʂ5oWK,NQG)˴&eqRWe-3yʵ,N {%-NQe-XVd-ZGgXWS7cE0kqNݚ E-}8C-^E-NQA-N1rbZ,P ]3b%Zݞe)Zҡ/xB-zbC-Se2ƉZ&<$jvDbpbtuK$䐥@V0SKD7|DU1E eu|F{s]3u`R^9kjBSRj/{\r}up ҝ`pʛ_r~d: zEr\_`ξ4Ctm+k 9Tw 9V Ka8.V\ٹ C2";byx ⶴ4nk|;+ S*+$-n%{8aAW\dwx9LZg6iTvܬK =^t3v[W*"ZMP \.^aۀǣp#Jd0䥐{pV98CK1SX)->~*d^1{gn 9>4-Ec^rc0%r45gX),r k*W4T2Ktf`|7!vu>&UV,rἛ:%i]TV [ga%qTWv@)`,u|V}XOn[fCv./0Tkuw#2π\g۱SOOLfrvuK0˫g?oݸ8EKQCv, vm)| [ǫK?X3Lu]iyT;.Lö}ls}231.}v -1Egu$aV+bONʤ\hjcB)tLAbKtwl^޻\ qLu { P8R \RW<{K%WqT.j*.Ջg VH>#}򣭐!?#n!?fvH=?kO3C~D.}T>L5C~T.L5C~T.q~Dȏā͐<ԱG}wQz?<vo;} ,%/Ut&AF7sxAqB>@7o8tOeL.ȩ`C!7._Լ$ x]AԽgߔV›xL>!*-#0vaިS)BgtA>32"Su2uPxEؕPyN=taE|gɖPU @/:%1/_}tyy̸99++MfqWQrn2ÎU]3K2^1n8d8cR~M 2ODQdzsrB{dx^Ma_,ۙ6a}es|uy ޝDsbSoϘߢ5d -ZٓTn"ZCZʋh t2h [Ag֐u W!cv~֐1;Ek5[ 7r@ʋh }/r{!EE-ZC!12n!czPl /Gɘߞf^@( `20[- uyAx#do`2K將*Eɘ"𒓶9½ȭ`$^0[ c; Vd0ve+sƼ yhڕ0_+a m3^q5x7ULt`fؕ鏘"y`ENߕ.៖B=QZJOSE?M#ە៦^5RqT 4CB}|lbBE{6jdпP~iS`P^H: SKIj:߽ؔ̌+E#R34#Ę2n %lJc0x*,a?v%^h#,%jp]괄ua)Y#$HK(+U#8E#`Wq5:S4'o@#u%,wJ%'@}uoJ5dcC]@+x&|[hH@,\J@Xh#9/dӒcRz] ;xN'c?GY]ԏ,aVh$Yݚh +yYYJ8t'쬑%JS9nH} kGYzX5I ]$a*$בI$ K1% /ck8 Ս%"jvMqN~c02[dk8a>@gI@iU\( r!Z, 񘇈 ,z1[7m )e=ɫ9?I,K(:AػǀR 4p8E zzpAI\A:C2RU%.%jI\4‚#.NQbSWnZz-%.NQRlX4e.V(sA*HC J\̅',%e.!˜S@j̅w" QR1),FWԨ;N's%5ce.^R7R2R(PQa. \p#OQe.pe.Pe.s8E ߞe. d.NC`"V1l8E bR8 O5e.- 2g2f.0G \,+s0~BX`E.1)pr؀ Ly+\"1:(q6[yF\0n)J\B*Rlrq2KsGV\`p( c.S=t52v)\6 PYP䂇_%^zMD.PYoK8m L"kN8E V\ ?8ŘK}ֈ0/uI^ObmuYQr.Ae%i(E]%捹Ī&sq2MB ؆:c.{hDW;$FK Ֆc(s0P"GdVES#J]`FxE mI>F]` 3=q[.uY֤.NQRu)wqQm.NQUaRt,Ũ ٍ.֨KcxEKVۍYxE bإ6$)]D.^CM2cdL.(w "q(w62G]tO.NQSFw ָSxAw@ a?6.NQd.^ҊڑvDž]Cׄ Ѕ(.-CtucrBl.<΄.NQ1哺8EK `$]Xp8EKjbg)]`2m,8G]l x ])]"إg 1 smntS#vBV8E ,-@Z]b) ]") ]Х"ɠK N.N7.肯be)],Z.*7md.NQRq,RC.&K8" 9B0[,E[`0[sRttRlRlStRlRlE9kQsL)/EXגyK޿c((ۭے ?ytʢ/E O'Q(^ KQ){Es"Sw^);EqSge[rᔙ` ZEkub:lK1);E L)cfc?CuQ%c[1,R)J@XV\x%JDc:i6ʐ"|hc 6WxE %"+6E:EWl ^&AL"Qd  آAt"F2ZU0@ay!rR !xF@ڠ)"Fq1Wg(R^ S!D( +P W  !XENQ"bxE@ vm/p"V%(7El /Dž3ExJ$tDR k+ҷNQAsDi#pWP=R2Gyt`)blBNQM"{t` SD :jϼ (:>_hIXv,8_-%d`9Ȯ!8Ja)~g_'ew ]>Siy o3Vs?y#)/=˜خkԭߋSxB,tID;>XU݅)ʝrW~-Auv9 ZK` [8o ^6\#%DGr|/R(,;kR؅Z9d5|Ja)~gOtvt?ϕz?CrcN0v+D3(Ql%gX!,rV`sqBg A&!3. n 6đRV 8z*N켂+2j=he.^tTլ|š0kv)|; P%<_f ,2o0 sYȱr\%b,I[;>㔻Pye`r0 M$<3 z 3Yn\rq f6.Odi2(+(!of`r`J"93w]BqRX-.ΛV.NH[ VI|-3JϾj ,;K01q'T|`)v痖Mf2@+:D5mzrQ ]v'H%;+g"Wϼ"AE[8odckzV PF6pxı~o$X Sѐ~e^AqRX5Λ(<.NI/|0ٓR5 ç'K gd* y^ky9 |}yں}.{q،JDC VN)0#roŽD8E^8 ^x.(h 5ڑ$ #rᦁ o[^|vԼCT:>߬ C@RYKH&nGlsI29Zp8JdE'\"v,8YL̑^{VTIҤEKA_b!d>2l NtL M>Ϊ ?5bQ"hk2Π­sbε9Mw *и 隃:qyZn]VXb,3ٗU[?M[C?wSVV!XVVTVNfQ<5Ѧ-M8Kܦ"/Pֵf99XK9yF2cu.4[^\‹kXak.ђ.qV^d,5&&i3Ft]ZXrZ&7[1: tqm&dH7QdixA.ybB@yH_4mƍ3#k+#^d&2Z!#jÂJAosa7ςܯɁ=ܢ1<V7s7wS[|dq%o-GZz |~p)~_Fodi%zk'| Wzz~*qvOoXOe>É#%:ܖQY% ^ZR>,߸k5{ɵZcۯzYrʊKo;Oda~_Ш=ǒ(׫{<陒Jҿ/^/ Πz"鞭 kq=IND?~K*@|5<=-9a//m%M[6mW'm]#|IW'WGf^EȢ|ΟZ=ix`3bxyzWDvԟ3<}t*Vn\Q2cad_Pj3,}+4mFX.?9K@|?ӯnSYrEM 7"׽r [[~R*W;uu[9^4&-<2P-fzڦf=v0OeAԱ|2r}{{|zS) 4[!*-|RKe6bHQ|?%Q}I?BXe9Է2Hʠ +X>lÆfzq%5V%Š7d[Nouũnk%x]ۭ\E%Wsl;RWfbBe$ILjfmO3ͺaNcz|pO_%j}`6Nܻ l2|8 Jt?_ĦA2}~_hy d Y)滋Ȇtxdq=Z7zsOJC9}or#/u[`Ͼ%RP}96FoM23dEtըZ3wT'if%{60;Vk?ZU>Ϯڶ;Gn;l a"lKu9꧊sG-0$O_K7Jig<k>9"Zw Wۛ[lt;WLͧ#6. 3L-?\eR׿y}~"t:P3jI`PaxAz!nt~|6`S||"PSaeykFg)=>HZU{Mag0BGod3P!o?> stream x[oHrϳrOy 0noཻ`ȝ$8kX=ђ#F=UAv͑2 ]]]nJ{ٞ_9Y]g3bv94!wgn*YiRBy{V>IKZaٛm> eE)~a ^[We%"|{W0vBi΋nMʪR.8|Qmqb%4R>&0aR:V(.Y>ͱ w@fBJDS7uU a XCxI9A%4FZTez \mH4M)>z 6hR]Y^jn( 3¸k rho@w8엔_~a1Șm2']+HP"(JE)U(%Ʉv mFJ8M򤠰*+QJ<`.nHS(@C%HuvSYE >(3'22# {eV%J?ʛB\3!#5)I-s =qofL)qRRw{)s!=`]rT$A6Hq4JBxhY|~y~3Ī{l" dh w;teʵNzK$\QS9ηcp5fCV6(Lr=kT~Ï)G6g)F5b+[q|d$;I">t/WnEW8Pl,]S"x1H_(D$.rr!VpP6jCp10]kDәOXF!ɣ'nCnw$—{<JԚz Yt@Db{Q}TZD35tPFz)8&>`,v{e)+U i]ȬYX @b.e6DeI6KD1(Wb Vl;Ɉ!|OC/|nE-ee`$( H:HWu(*𺫏 =Q=FXwI,-bd;?FEqo6 m|po=5 !5ԉR0-SJt@$D?C||tGML5֘xilZ/Ɖ 5% xFray3 h_w ` R[]If%<̊C{wh׹( ;qQr)BK߄Q>νXJ Q4X"˯%# STďdbFA9DX}Sc6AE+ۋM%K<Q_ sJbA`p !Ks܉BLQrcsrG9DL\u2&H%g%;5/ȜcA֤(aP<3w\ e@:zћmI$<>iv&Cq.lU[4evi_*(i{W]2ojq;gPȒ*cM6Tpm*b G r'`Jkhi\p#} -lS`A`e>UY=Sf كZ%us#%;$Ѣ dOD53Z,.C)TʜY%KlxYF)(\ȵLNJ7CE?H Kt ;b ,xRD5GzȒmR ;B!*]IVF< ?)ˢs  n{eqEҎđU72B8CT0! ػQ93"M* H V*+_p bxu~}Фnwә5tq(<t33iUbDB`L=Lw 1@g +,AB;:<#RY}՞Gtx;{&74Ix*nL,D!V+](!{Qy&,w gcV6K "_ 9 i8H^ @om0jF.w,YzшX9JWT? vZKdNfP6`L8,X9^0ۜ|&ӦrV:l>VQm4')x|VcT@`p'fT+ ȡ!Vu)ЮT@,~"l?iƇ61?"  D]dfw*PU4B7yd .w-! ZSp/,{f5.W,쭁4~Ɇ)q|ΰx'O^t{]/h 𲂥.)!@K~&%UlxkFRUn)jدñ[/R$0BNy6M] LAIZ d\)gLkJSdƽ>&Wvc/ocYَ'7凰h>7DaKmo0HdzNx۫3JlXrPioY1>v KiCc1~f3~JEotqH/uv\HI~=NfekEAE?%#"}\|.xn&NptE6 |L(UǮ֓'C5kAk왱#m 1ewm/ hw{?i-h0sΡj{U-mej W?plU'N`P:%&:ĪY )x/ wsCwFP꼌l'p0K2/u--$1IGc+x!m B~#s7rl64y{և XBv2pk8-I.xS-59d}Y!+ qfsB:yPHo?~9ȩKU 5á9Ajaǐiolw|ۿ?*~Hj%`eؑv{Vi,=::M;d:cG=D'6{ Sql~{Q;qz(o Lxb)Qa3 BP1';$EmQ.&ϋC@M7nywbk6EcoW8Xd1C75?ov!BYе-F}O^Ql`7 :u~G}D6ưO[S5oF" ՈEEQ<'g'daщGBoNwyMU.QN(}\K ֛Q|8 /t!Jpd,f fTw[WmM، ͶgDtַyZ7ñ"sfiwnSj\:zg}S`YC*A7dۡendstream endobj 478 0 obj << /Filter /FlateDecode /Length 4873 >> stream x\ߓ6rV^jJq] ܝ`[$grMRRREFgvJ_@$fw$X_tv!BVk lrD= t )7T/{xjp#Jhazǫl`}\^U/- b:, j} ]w`)vHзJ2e gp60gʾK&ݶWuq NLB>A/C^ZmD@?ߜ=U:Ӯzͮ{z*mp`;.h>m\%]fXɳàaaz7Gnx1KK6`_'xWu?әΌh4hIƌ'5j  _k<{4H#"(%k\N@05(9$d]'PX]л-K7Yp"*mz\ (YΤp"W:3tX?DHqoMl pvn/p`i0f\_(ZW?2Q,{a n6~g!n٫Pr9Hx(Ьȑi€2^80x2 iY&Uu h(+񚉨oz[~[K+A${,C΃|u"C,TqSHЋyD{AAl)<}qx.6/J%92[ܓɚIܞJ",+,HE0Iyc>O Bqǧlt1 lAUp)B:G_Gz8-Z\-F!CσiL 1W7C[)T@( 2] f{ZTnC0y{(O`YeX+(#moA^yez5L]m2bXH}Ph,<=dZq(p@ӝ-T0"KfZsٞ0On0]E=67[/>:ף7V q$p,BO]c79KkSpxn3SMцaR#rK%)Jmu){/;k1&؟Tuea*?-:YY*{\*:9v⚺,ff>CcV]AL @]GU Gu5;ڜ!p{?VV ![),_d|BZL'|Q.?yog')HmfL(Tz CJFu>%r 5mRX…=s SzeObXkLV3 [ߍc~GY[`ƋI1a3 x?cqY[+[05w!1ju+5aי>Q1"e7Yf?L|ٜrA%Ě.(we0$n俱>VT]m2ۭ:S< d>2- !wkfMU? HHi(d!mj<uiyil vijft`6;αYΘY|ղp+s3W@Ӎq`͂10n~4cf-dPlT%PΗ_ɁLS%MyvW'v4HQO;zZBԃhGQo0Աl˓qx&lIREͬ'ig+a`ѪK5yFnnnb~KкP'~)M͐p8Ti.8Vhz$G;`L!jamOqIA76tI#)*m Oz =1KQ 0fk`5_xč춮PDPcxiűVɪXP@܍4:fU-4Dۄ kWijuWF;H˰k;(xw/Tc5L/ga|Up>+4V}Y֬b/͂CT3z DBЋJ,RǛ񞔣~ڿ`! Tfέժxe][WGb6,wYiWt~Z96YÈ7({5s0g-q ʒY/S,`L +j^X8v9 (?S',6,A ^e+:1x1o'6 ZHjV 󋈮Y)fv]%>xlm9# Q0哠aVaP~qWc%T$?+ ZxP#>Fz!pŏ xp"1H2^5p8`04b23,Zh3d9Y.+*B6qdpXUv3]kY>8/uQ=_FbR hK9̘yR^^s:EϧFJboaec}6( 5z_苝W\DfwbzNA4(3rx>.,CƹoX^^E h``Xߒ(%e &]Jb9~z/\K,KsB:c,91Hc1ӈ}VE>jY$ 6|ZGP%Q}KƧƩh)g8->K>uşwDYꜗki(m~w-ftcpY]*N~&kb/V췾EPzY ."'CY)p C+$Cۗ"hpM#XwsϦVT#B1dCo. o3j7+O6` f i$:4|Dps޹nݫ@A%08ݾO~ƸVtUDuLFZ(ی`]$,zvꦏBh.His Z;o$43N40,S$ SzHRЉS3|7QyќuezO@jN($ACw2'Ǘ(ؓ> ybtC#nyI?S8+ :݌/3 Bobfۨe55deni6jdy;{qaV]>8=?MIR}fyIѬHSbۅ V5#.u?1cf\Cm)qDž fcca;]6]c;PpБ U_7[x۵HN N))>!꧛ᷞ'uW.) }?rMGd1w2\(ڀS9YR?r6zz?V1{W8B+M |Z1hgctG [/K|ft_,@B>֕~Ӕ%^}?!/cQ8"~li{:ʸŀͿ[,fD#'cş2Gaendstream endobj 479 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 947 >> stream xmL[eǟK]ni1b \*Vkx)(R-rK[Z )d6 #ffdnQ&3]sWQ?<9<EEQK˪LmuEgr+[[ʱA*~(!-glzK@x OTlJ#m:- \^\1[ٓ*h2ulLŖzd cjg&OꗫYuUiB+I, m y2RN.I"YPn귄oq9wc&UZzD{83C7̗mSˆ@CP Bzg x 6x}>WpcVp@}2P78̛CEǵ^6Tyv@B][Ax\nU#}C310E&܊*DSa}:&>ًN{30i'?g1Ϙڐj!͐Jos /i%5'}jV0>u¢U ')JxGWqnd0 _NGDʌ vS$v6*V+/e)pهOQpM\vGjkM|X<5FY|l%q50nf5@3Q[4n}3w -2K}pVW[^AG,)|I`;̼Ic'$$.h$ǂدb4Ndh᣼1i<{/6 (@\~J}cCH< ^iaswaȟ=VP?uP Ã_Żi=@\(LIľǓkL ߷c>oB.{>y2!_;endstream endobj 480 0 obj << /Type /XRef /Length 309 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 481 /ID [<6aa9539ad17e4b7ec0f4aeeea93c3c5a><128c34a11deccff19d1c103b37e90f3a>] >> stream xcb&F~0 $8J?u@6;#(H"3hYF}$A~Jx4Ga"(Hg~ ůX"׃He RTD|L@Q  RD26el`^ʃ` ,"`qN6-X5X,)"ťA Vr-.]u D ]lʻ`[Ad ؜ 8Aj l"9 =`׾!qD-* `{}w:L endstream endobj startxref 338521 %%EOF mixtools/inst/doc/mixtools.R0000644000176200001440000003543314343306354015670 0ustar liggesusers### R code from vignette source 'mixtools.Rnw' ################################################### ### code chunk number 1: faithful ################################################### library(mixtools) data(faithful) attach(faithful) ################################################### ### code chunk number 2: geyser ################################################### hist(waiting, main="Time between Old Faithful eruptions", xlab="Minutes", ylab="", cex.main=1.5, cex.lab=1.5, cex.axis=1.4) ################################################### ### code chunk number 3: normmixEM ################################################### wait1 <- normalmixEM(waiting, lambda = .5, mu = c(55, 80), sigma = 5) ################################################### ### code chunk number 4: geyserEM (eval = FALSE) ################################################### ## plot(wait1, density=TRUE, cex.axis=1.4, cex.lab=1.4, cex.main=1.8, ## main2="Time between Old Faithful eruptions", xlab2="Minutes") ################################################### ### code chunk number 5: geyserEM ################################################### for(i in 1:2){ file=paste("geyserEM", i, ".pdf", sep="") pdf(file=file, paper="special", width=6, height=6) plot(wait1, whichplots=i, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") dev.off() cat("\\includegraphics{", file, "}\n", sep="") } ################################################### ### code chunk number 6: geyserestimates ################################################### wait1[c("lambda", "mu", "sigma")] ################################################### ### code chunk number 7: geysersummary ################################################### summary(wait1) ################################################### ### code chunk number 8: cutpoint ################################################### data("Waterdata") cutpts <- 10.5*(-6:6) watermult <- makemultdata(Waterdata, cuts = cutpts) ################################################### ### code chunk number 9: multmixEM ################################################### set.seed(15) theta4 <- matrix(runif(56), ncol = 14) theta3 <- theta4[1:3,] mult3 <- multmixEM(watermult, lambda = rep(1, 3)/3, theta = theta3) mult4 <- multmixEM (watermult, lambda = rep (1, 4) / 4, theta = theta4) ################################################### ### code chunk number 10: mixtools.Rnw:575-581 (eval = FALSE) ################################################### ## cdf3 <- compCDF(Waterdata, mult3$posterior, lwd=2, lab=c(7, 5, 7), ## xlab="Angle in degrees", ylab="Component CDFs", ## main="Three-Component Solution") ## cdf4 <- compCDF(Waterdata, mult4$posterior, lwd=2, lab=c(7, 5, 7), ## xlab="Angle in degrees", ylab="Component CDFs", ## main="Four-Component Solution") ################################################### ### code chunk number 11: cutpointplots ################################################### pdf(file="WDcutpoint3comp.pdf", paper="special", width=8, height=8) cdf3 <- compCDF(Waterdata, mult3$posterior, lwd=3, xlab="Angle in degrees", lab=c(7, 5, 7), ylab="Component CDFs", main="Three-Component Solution", cex.axis=1.4, cex.lab=1.5, cex.main=1.5) ltext <- paste(round(mult3$lam*100, 1), "%", sep="") legend("bottomright", legend=ltext, pch=15:17, cex=1.5, pt.cex=1.35) y <- compCDF(Waterdata, mult3$posterior, x=cutpts, makeplot=F) for(i in 1:3) points(cutpts, y[i,], pch=14+i, cex=1.35) dev.off() pdf(file="WDcutpoint4comp.pdf", paper="special", width=8, height=8) cdf4 <- compCDF(Waterdata, mult4$posterior, lwd=3, xlab="Angle in degrees", lab=c(7, 5, 7), ylab="Component CDFs", main="Four-Component Solution", cex.axis=1.4, cex.lab=1.5, cex.main=1.5) ltext <- paste(round(mult4$lam*100,1), "%", sep="") legend("bottomright", legend=ltext, pch=15:18, cex=1.5, pt.cex=1.35) y <- compCDF(Waterdata, mult4$posterior, x=cutpts, makeplot=F) for(i in 1:4) points(cutpts, y[i,], pch=14+i, cex=1.35) dev.off() ################################################### ### code chunk number 12: summarymult4 ################################################### summary(mult4) ################################################### ### code chunk number 13: spsymmplots ################################################### pdf(file="spsymmfig1.pdf", paper="special", width=8, height=8) par(mar=0.1+c(5,4.2,4,1.8)) plot(wait1, which = 2, cex.axis = 1.4, cex.lab = 1.5, cex.main = 1.5, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") wait2 <- spEMsymloc(waiting, mu0 = c(55, 80)) plot(wait2, lty = 2, newplot = FALSE, addlegend = FALSE) dev.off() pdf(file="spsymmfig2.pdf", paper="special", width=8, height=8) par(mar=0.1+c(5,4.2,4,1.8)) wait2a <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 1) wait2b <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 6) plot(wait2a, lty = 1, addlegend = FALSE, cex.axis = 1.4, cex.lab = 1.5, cex.main = 1.5, title = "Time between Old Faithful eruptions", xlab = "Minutes") plot(wait2b, lty = 2, newplot = FALSE, addlegend = FALSE) dev.off() ################################################### ### code chunk number 14: plotspsymm (eval = FALSE) ################################################### ## plot(wait1, which = 2, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, ## main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") ## wait2 <- spEMsymloc(waiting, mu0 = c(55, 80)) ## plot(wait2, lty = 2, newplot = FALSE, addlegend = FALSE) ################################################### ### code chunk number 15: bandwidth ################################################### bw.nrd0(waiting) ################################################### ### code chunk number 16: plotbweffect (eval = FALSE) ################################################### ## wait2a <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 1) ## wait2b <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 6) ## plot(wait2a, lty = 1, addlegend = FALSE, cex.axis = 1.4, ## cex.lab = 1.4, cex.main = 1.8, xlab = "Minutes", ## title = "Time between Old Faithful eruptions") ## plot(wait2b, lty = 2, newplot = FALSE, addlegend = FALSE) ################################################### ### code chunk number 17: gaussexample ################################################### m <- 2; r <- 3; n <- 300; S <- 100 lambda <- c(0.4, 0.6) mu <- matrix(c(0, 0, 0, 3, 4, 5), m, r, byrow = TRUE) sigma <- matrix(rep(1, 6), m, r, byrow = TRUE) ################################################### ### code chunk number 18: gaussinitial ################################################### centers <- matrix(c(0, 0, 0, 4, 4, 4), 2, 3, byrow = TRUE) ISE <- matrix(0, m, r, dimnames = list(Components = 1:m, Blocks = 1:r)) nblabsw <- 0 ################################################### ### code chunk number 19: sqMISE ################################################### set.seed(1000) for (mc in 1:S) { x <- rmvnormmix(n, lambda, mu, sigma) a <- npEM(x, centers, verb = FALSE, samebw = FALSE) if (a$lambda[1] > a$lambda[2]) nblabsw <- nblabsw + 1 for (j in 1:m) { for (k in 1:r) { ISE[j, k] <- ISE[j, k] + ise.npEM(a, j, k, dnorm, lower = mu[j, k] - 5, upper = mu[j, k] + 5, plots = FALSE, mean = mu[j, k], sd = sigma[j, k])$value #$ } } } MISE <- ISE/S print(sqMISE <- sqrt(MISE)) ################################################### ### code chunk number 20: summarygauss ################################################### summary(a) ################################################### ### code chunk number 21: plotgauss3rm (eval = FALSE) ################################################### ## plot(a) ################################################### ### code chunk number 22: gauss3rm ################################################### pdf("gauss3rm.pdf", paper="special", width=10, height=5) par(mfrow=c(1,3), ask=F) plot(a) dev.off() ################################################### ### code chunk number 23: true5rm ################################################### pdf("truepdf5rm_block1.pdf") par(mar=0.1+c(5,4.2,4,1.5)) x <- seq(-10, 25, len=250) plot(x, .4* dt(x, 2, 0) + .6 * dt(x, 10, 8), type="l", lwd=3, col=2, cex.axis=1.4, cex.lab=1.5, cex.main=1.5, main="Block 1", xlab="", ylab="Density") lines (x, .4*dt(x, 2, 0), lwd=4, lty=2) lines (x, .6*dt(x, 10, 8), lwd=4, lty=2) dev.off() pdf("truepdf5rm_block2.pdf") par(mar=0.1+c(5,4.2,4,1.5)) x <- seq(0, 1, len=250) plot(x, .4 + .6 * dbeta(x, 1, 5), type="l", lwd=3, col=2, cex.axis=1.4, cex.lab=1.5, cex.main=1.5, main="Block 2", xlab="", ylab="Density", ylim= c(0, 3.4)) lines (x, rep(.4, 250), lwd=4, lty=2) lines (x, .6*dbeta(x, 1, 5), lwd=4, lty=2) dev.off() ################################################### ### code chunk number 24: parameters5rm ################################################### m <- 2; r <- 5 lambda <- c(0.4, 0.6) df <- c(2, 10); ncp <- c(0, 8) sh1 <- c(1, 1) ; sh2 <- c(1, 5) ################################################### ### code chunk number 25: generate5rm ################################################### n <- 300; z <- sample(m, n, rep = TRUE, prob = lambda) r1 <- 3; z2 <- rep(z, r1) x1 <- matrix(rt(n * r1, df[z2], ncp[z2]), n, r1) r2 <- 2; z2 <- rep(z, r2) x2 <- matrix(rbeta(n * r2, sh1[z2], sh2[z2]), n, r2) x <- cbind(x1, x2) ################################################### ### code chunk number 26: npEM5rm ################################################### id <- c(rep(1, r1), rep(2, r2)) centers <- matrix(c(0, 0, 0, 1/2, 1/2, 4, 4, 4, 1/2, 1/2), m, r, byrow = TRUE) b <- npEM(x, centers, id, eps = 1e-8, verb = FALSE, samebw = FALSE) ################################################### ### code chunk number 27: plot5rm (eval = FALSE) ################################################### ## plot(b, breaks = 15) ################################################### ### code chunk number 28: plot5rmcommands ################################################### pdf("npEM5rm.pdf", width=8, height=5) par(mfrow=c(1,2)) plot(b, breaks = 15) dev.off() ################################################### ### code chunk number 29: ISEnpEM5rm (eval = FALSE) ################################################### ## par(mfrow=c(2,2)) ## for (j in 1:2){ ## ise.npEM(b, j, 1, truepdf = dt, lower = ncp[j] - 10, ## upper = ncp[j] + 10, df = df[j], ncp = ncp[j]) ## ise.npEM(b, j, 2, truepdf = dbeta, lower = -0.5, ## upper = 1.5, shape1 = sh1[j], shape2 = sh2[j]) ## } ################################################### ### code chunk number 30: plotISEnpEM5rm ################################################### options(warn=-1) pdf("ISEnpEM5rm.pdf", width=8, height=8) par(mfrow = c(2, 2)) for (j in 1:2){ ise.npEM(b, j, 1, truepdf = dt, lower = ncp[j] - 10, upper = ncp[j] + 10, df = df[j], ncp = ncp[j]) ise.npEM(b, j, 2, truepdf = dbeta, lower = -0.5, upper = 1.5, shape1 = sh1[j], shape2 = sh2[j]) } dev.off() ################################################### ### code chunk number 31: gnpdata ################################################### data("CO2data") attach(CO2data) pdf("gnpdata.pdf") par(mar=0.1+c(5,4.2,4,1.5)) plot(GNP, CO2, xlab="Gross National Product", ylab=expression(paste(CO[2]," per Capita")), cex.lab=1.5, cex.main=1.5, cex.axis=1.4, main="1996 GNP and Emissions Data") text(GNP, CO2, country, adj=c(.5,-.5)) dev.off() ################################################### ### code chunk number 32: mixtools.Rnw:1282-1284 ################################################### data("CO2data") attach(CO2data) ################################################### ### code chunk number 33: CO2reg ################################################### CO2reg <- regmixEM(CO2, GNP, lambda = c(1, 3) / 4, beta = matrix(c(8, -1, 1, 1), 2, 2), sigma = c(2, 1)) ################################################### ### code chunk number 34: summaryCO2reg ################################################### summary(CO2reg) ################################################### ### code chunk number 35: plotCO2reg (eval = FALSE) ################################################### ## plot(CO2reg, density = TRUE, alpha = 0.01, cex.main = 1.5, cex.lab = 1.5, ## cex.axis = 1.4) ################################################### ### code chunk number 36: trueplotCO2reg ################################################### for(i in 1:2){ file=paste("CO2reg", i, ".pdf", sep="") pdf(file=file, paper="special", width=6, height=6) plot(CO2reg, whichplots=i, alpha = 0.01, cex.main = 1.5, cex.lab = 1.5, cex.axis = 1.4) dev.off() cat("\\includegraphics{", file, "}\n", sep="") } ################################################### ### code chunk number 37: CO2igle ################################################### CO2igle <- regmixEM.loc(CO2, GNP, beta = CO2reg$beta, sigma = CO2reg$sigma, lambda = CO2reg$posterior, kern.l = "Beta", kernl.h = 20, kernl.g = 3) ################################################### ### code chunk number 38: CO2iglesummary ################################################### summary(CO2igle) ################################################### ### code chunk number 39: lamplot (eval = FALSE) ################################################### ## plot(GNP, CO2igle$post[,1], xlab = "GNP", cex.axis = 1.4, cex.lab = 1.5, ## ylab = "Final posterior probabilities") ## lines(sort(GNP), CO2igle$lambda[order(GNP), 1], col=2) ## abline(h = CO2igle$lambda[1], lty = 2) ################################################### ### code chunk number 40: truelamplot ################################################### pdf("lamplot.pdf") plot(GNP, CO2igle$post[,1], xlab = "GNP", cex.axis = 1.4, cex.lab = 1.5, ylab = "Final posterior probabilities") lines(sort(GNP), CO2igle$lambda[order(GNP), 1], col=2, lwd=2) abline(h = CO2igle$lambda[1], lty = 2, lwd=2) dev.off() ################################################### ### code chunk number 41: CO2boot ################################################### set.seed(123) CO2boot <- boot.se(CO2reg, B = 100) ################################################### ### code chunk number 42: bootresults ################################################### rbind(range(CO2boot$beta[1,]), range(CO2boot$beta[2,])) ################################################### ### code chunk number 43: CO2bootse ################################################### CO2boot[c("lambda.se", "beta.se", "sigma.se")] ################################################### ### code chunk number 44: modelsel ################################################### data("Waterdata") cutpts <- 10.5*(-6:6) watermult <- makemultdata(Waterdata, cuts = cutpts) set.seed(10) multmixmodel.sel(watermult, comps = 1:4, epsilon = 0.001) mixtools/inst/doc/mixtools.Rnw0000755000176200001440000021573514342153463016245 0ustar liggesusers\documentclass[nojss]{jss} \usepackage{amsmath} \usepackage{amssymb} %% need no \usepackage{Sweave.sty} %\VignetteIndexEntry{mixtools for mixture models} %% macros (Didier) \newcommand{\CF}{{\mathcal F}} \newcommand{\CN}{{\mathcal N}} \def\Bg{\mathbf{g}} \def\Bh{\mathbf{h}} \def\Bk{\mathbf{k}} \def\Bx{\mathbf{x}} \def\By{\mathbf{y}} \def\Bc{\mathbf{c}} \def\BC{\mathbf{C}} \def\Bz{\mathbf{z}} \newcommand{\argmax}{\mathop{\mbox{argmax}}} \def\bP{\mathbb{P}} % Probability \def\I{\mathbb I} % indicator function \def\bE{\mathbb{E}} % expectation \def\bR{\mathbb{R}} % real line \newcommand{\f}{{\vec\theta}} \newcommand{\lb}{{\lambda}} \def\post{{p}} \def\defn{{\stackrel{\rm def}{=}}} \def\vec#1{\mathchoice{\mbox{\boldmath$\displaystyle\bf#1$}} {\mbox{\boldmath$\textstyle\bf#1$}} {\mbox{\boldmath$\scriptstyle\bf#1$}} {\mbox{\boldmath$\scriptscriptstyle\bf#1$}}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% declarations for jss.cls %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% almost as usual \author{Tatiana Benaglia \\ Pennsylvania State University \And Didier Chauveau \\ Universit\'e d'Orl\'eans \AND David R.~Hunter \\ Pennsylvania State University \And Derek S. Young \\ Pennsylvania State University} \title{\pkg{mixtools}: An \proglang{R} Package for Analyzing Finite Mixture Models} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Tatiana Benaglia, Didier Chauveau, David R.~Hunter, Derek Young} %% comma-separated \Plaintitle{mixtools: An R Package for Analyzing Mixture Models} %% without formatting \Shorttitle{mixtools for Mixture Models} %% a short title (if necessary) %% an abstract and keywords \Abstract{ The \pkg{mixtools} package for \proglang{R} provides a set of functions for analyzing a variety of finite mixture models. These functions include both traditional methods, such as EM algorithms for univariate and multivariate normal mixtures, and newer methods that reflect some recent research in finite mixture models. In the latter category, \pkg{mixtools} provides algorithms for estimating parameters in a wide range of different mixture-of-regression contexts, in multinomial mixtures such as those arising from discretizing continuous multivariate data, in nonparametric situations where the multivariate component densities are completely unspecified, and in semiparametric situations such as a univariate location mixture of symmetric but otherwise unspecified densities. Many of the algorithms of the \pkg{mixtools} package are EM algorithms or are based on EM-like ideas, so this article includes an overview of EM algorithms for finite mixture models. } \Keywords{cutpoint, EM algorithm, mixture of regressions, model-based clustering, nonparametric mixture, semiparametric mixture, unsupervised clustering} %, keywords, comma-separated, not capitalized, \proglang{Java}} \Plainkeywords{keywords, comma-separated, not capitalized, Java} %% without formatting %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{13} %% \Issue{9} %% \Month{September} %% \Year{2004} %% \Submitdate{2004-09-29} %% \Acceptdate{2004-09-29} %% The address of (at least) one author should be given %% in the following format: \Address{ Didier Chauveau\\ Laboratoire MAPMO - UMR 7349 - F\'ed\'eration Denis Poisson\\ Universit\'e d'Orl\'eans\\ BP 6759, 45067 Orl\'eans cedex 2, FRANCE.\\ E-mail: \email{didier.chauveau@univ-orleans.fr} \\ URL: \url{http://www.univ-orleans.fr/mapmo/membres/chauveau/}\\ \\ David R.~Hunter\\ Department of Statistics\\ 326 Thomas Building\\ Pennsylvania State University\\ University Park, PA 16802\\ Telephone: +1/814-863-0979\\ Fax: +1/814-863-7114\\ E-mail: \email{dhunter@stat.psu.edu} \\ URL: \url{http://www.stat.psu.edu/~dhunter/}\\ \\ Tatiana Benaglia\\ Department of Statistics, Penn State (see above)\\ E-mail: \email{tab321@stat.psu.edu} \\ \\ Derek Young\\ Department of Statistics, Penn State (see above)\\ E-mail: \email{dsy109@psu.edu} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/1/31336-5053 %% Fax: +43/1/31336-734 %% for those who use Sweave please include the following line (with % symbols): %% need no \usepackage{Sweave.sty} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} \SweaveOpts{concordance=FALSE} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. \section[Introduction to finite mixtures and mixtools]{Introduction to finite mixtures and \pkg{mixtools}} %% Note: If there is markup in \(sub)section, then it has to be escape %% as above. \label{s:intro} Authors' note: The original version of this vignette was produced using an article that appears in the {\it Journal of Statistical Software} (URL: \url{http://www.jstatsoft.org/}); see \citet{Benaglia+Chauveau+Hunter+Young:2009}. Populations of individuals may often be divided into subgroups. Yet even when we observe characteristics of these individuals that provide information about their subgroup memberships, we may not actually observe these memberships {\em per se}. The basic goal of the tools in the \pkg{mixtools} package (version 0.4.3, as of this writing) for \proglang{R} \citep{r2009} is to examine a sample of measurements to discern and describe subgroups of individuals, even when there is no observable variable that readily indexes into which subgroup an individual properly belongs. This task is sometimes referred to as ``unsupervised clustering'' in the literature, and in fact mixture models may be generally thought of as comprising the subset of clustering methods known as ``model-based clustering''. The \pkg{mixtools} package is available from the Comprehensive \proglang{R} Archive Network at \url{http://CRAN.R-project.org/package=mixtools}. Finite mixture models may also be used in situations beyond those for which clustering of individuals is of interest. For one thing, finite mixture models give descriptions of entire subgroups, rather than assignments of individuals to those subgroups (though the latter may be accomplished using mixture models). Indeed, even the subgroups may not necessarily be of interest; sometimes finite mixture models merely provide a means for adequately describing a particular distribution, such as the distribution of residuals in a linear regression model where outliers are present. Whatever the goal of the modeler when employing mixture models, much of the theory of these models involves the assumption that the subgroups are distributed according to a particular parametric form --- and quite often this form is univariate or multivariate normal. While \pkg{mixtools} does provide tools for traditional fitting of finite mixtures of univariate and multivariate normal distributions, it goes well beyond this well-studied realm. Arising from recent research whose goal is to relax or modify the assumption of multivariate normality, \pkg{mixtools} provides computational techniques for finite mixture model analysis in which components are regressions, multinomial vectors arising from discretization of multivariate data, or even distributions that are almost completely unspecified. This is the main feature that distinguishes \pkg{mixtools} from other mixture-related \proglang{R} packages, also available from the Comprehensive \proglang{R} Archive Network at \url{http://CRAN.R-project.org/}, such as \pkg{mclust} \citep{Fraley+Raftery:2009} and \pkg{flexmix} \citep{jss:Leisch:2004, Grun+Leisch:2008}. We briefly mention these two packages in Sections~\ref{section:EMexample} and \ref{section:pdmp}, respectively. To make the mixture model framework more concrete, suppose the possibly vector-valued random variables $\vec X_1, \ldots, \vec X_n$ are a simple random sample from a finite mixture of $m>1$ arbitrary distributions, which we will call {\em components} throughout this article. The density of each $\vec X_i$ may be written \begin{equation} \label{mvmixture} g_{\f}(\vec x_i) = \sum_{j=1}^m\lambda_j\phi_j(\vec x_i), \quad \vec x_i\in\bR^r, \end{equation} where $\f=(\vec\lambda, \vec \phi) = (\lambda_1, \ldots, \lambda_m, \phi_1, \ldots, \phi_m)$ denotes the parameter and the $\lambda_m$ are positive and sum to unity. We assume that the $\phi_j$ are drawn from some family $\cal F$ of multivariate density functions absolutely continuous with respect to, say, Lebesgue measure. The representation \eqref{mvmixture} is not identifiable if no restrictions are placed on $\cal F$, where by ``identifiable'' we mean that $g_{\f}$ has a {\em unique} representation of the form \eqref{mvmixture} and we do not consider that ``label-switching'' --- i.e., reordering the $m$ pairs $(\lambda_1, \phi_1), \ldots, (\lambda_m, \phi_m)$ --- produces a distinct representation. In the next sections we will sometimes have to distinguish between {\em parametric} and more general {\em nonparametric} situations. This distinction is related to the structure of the family $\CF$ of distributions to which the component densities $\phi_j$ in model \eqref{mvmixture} belong. We say that the mixture is {\em parametric} if $\CF$ is a parametric family, $\CF = \{\phi(\cdot|\vec\xi), \vec\xi\in\bR^d\}$, indexed by a ($d$-dimensional) Euclidean parameter $\vec\xi$. A parametric family often used is the univariate Gaussian family $\CF = \{\phi(\cdot|\mu,\sigma^2)=\mbox{density of }\CN(\mu,\sigma^2), (\mu,\sigma^2)\in\bR\times\bR^+_*\}$, in which case the model parameter reduces to $\f = (\vec \lambda, (\mu_1,\sigma^2_1),\ldots,(\mu_m,\sigma^2_m))$. For the multivariate case, a possible parametric model is the {\em conditionally i.i.d.\ normal model}, for which $\CF=\{\phi(\vec x_i) = \prod_{k=1}^r f(x_{ik}), \mbox{$f(t)$ density of $\CN(\mu,\sigma^2)$}\}$ (this model is included in \pkg{mixtools}; see Section~\ref{ss:nbcomp}). An example of a (multivariate) nonparametric situation is $\CF=\{\phi(\vec x_i) = \prod_{k=1}^r f(x_{ik}), \mbox{$f(t)$ a univariate density on $\bR$}\}$, in which case $\vec\f$ consists in a Euclidean part ($\vec\lb$) and a nonparametric part $(f_1,\ldots,f_m)$. As a simple example of a dataset to which mixture models may be applied, consider the sample depicted in Figure \ref{geyser}. In the Old Faithful dataset, measurements give time in minutes between eruptions of the Old Faithful geyser in Yellowstone National Park, USA. These data are included as part of the \pkg{datasets} package in \proglang{R} \citep{r2009}; type \code{help("faithful")} in \proglang{R} for more details. <>= library(mixtools) data(faithful) attach(faithful) @ \setkeys{Gin}{width=0.6\textwidth} \begin{figure}[h] \centering <>= hist(waiting, main="Time between Old Faithful eruptions", xlab="Minutes", ylab="", cex.main=1.5, cex.lab=1.5, cex.axis=1.4) @ \caption{The Old Faithful dataset is clearly suggestive of a two-component mixture of symmetric components.} \label{geyser} \end{figure} For the Old Faithful eruption data, a two-component mixture model is clearly a reasonable model based on the bimodality evident in the histogram. This example is analyzed by \citet{hunter2007ims}, who compare a standard normal-mixture method for fitting it with a novel semiparametric approach. Both approaches are included in \pkg{mixtools}; see Sections \ref{section:EMexample} and \ref{section:SPexample} of this article. In Section~\ref{section:EM} of the current article we review the well-known class of EM algorithms for finite mixture models, a common thread that runs throughout much of the rest of the article. The remaining sections discuss various categories of functions found in the \pkg{mixtools} package, from cutpoint methods that relax distributional assumptions for multivariate data by discretizing the data (Section~\ref{section:cut}), to semi- and non-parametric methods that eliminate distributional assumptions almost entirely depending on what the identifiability of the model allows (Section~\ref{section:np}), to methods that handle various mixtures of regressions (Section~\ref{section:reg}). Finally, Section \ref{section:misc} describes several miscellaneous features of the \pkg{mixtools} package. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{EM algorithms for finite mixtures} \label{section:EM} \subsection{Missing data setup} Much of the general methodology used in \pkg{mixtools} involves the representation of the mixture problem as a particular case of maximum likelihood estimation (MLE) when the observations can be viewed as incomplete data. This setup implies consideration of two sample spaces, the sample space of the (incomplete) observations, and a sample space of some ``complete'' observations, the characterization of which being that the estimation can be performed explicitly at this level. For instance, in parametric situations, the MLE based on the complete data may exist in closed form. Among the numerous reference papers and monographs on this subject are, e.g., the original EM algorithm paper by \citet{dempster1977mli} and the finite mixture model book by \citet{mclachlan2000fmm} and references therein. We now give a brief description of this setup as it applies to finite mixture models in general. The (observed) data consist of $n$ i.i.d. observations $\vec x = (\vec x_1,\ldots,\vec x_n)$ from a density $g_\f$ given by \eqref{mvmixture}. It is common to denote the density of the sample by $\Bg_\f$, the $n$-fold product of $g_\f$, so that we write simply $\Bx\sim \Bg_\f$. In the missing data setup, $\Bg_\f$ is called the incomplete-data density, and the associated log-likelihood is $L_{\Bx}(\f) = \sum_{i=1}^n \log g_\f(\vec x_i)$. The (parametric) ML estimation problem consists in finding $\hat\f_{\Bx} = \argmax_{\f\in\Phi} L_{\Bx}(\f)$, or at least finding a local maximum --- there are certain well-known cases in which a finite mixture model likelihood is unbounded \citep{mclachlan2000fmm}, but we ignore these technical details for now. Calculating $\hat\f_{\Bx}$ even for a parametric finite mixture model is known to be a difficult problem, and considering $\Bx$ as incomplete data resulting from non-observed complete data helps. The associated complete data is denoted by $\Bc = (\vec c_1,\ldots, \vec c_n)$, with density $\Bh_\f(\Bc)=\prod_{i=1}^n h_\f(\vec c_i)$ (there exists a many-to-one mapping from $\Bc$ to $\Bx$, representing the loss of information). In the model for complete data associated with model~\eqref{mvmixture}, each random vector $\vec C_i = (\vec X_i,\vec Z_i)$, where $\vec Z_i = (Z_{ij},j=1,\ldots m)$, and $Z_{ij}\in\{0,1\}$ is a Bernoulli random variable indicating that individual $i$ comes from component $j$. Since each individual comes from exactly one component, this implies $\sum_{j=1}^m Z_{ij}=1$, and $$ \Prob(Z_{ij} = 1) = \lambda_{j},\quad (\vec X_i|Z_{ij}=1) \sim \phi_j, \quad j=1,\ldots,m. $$ The complete-data density for one observation is thus $$ h_\f(\vec c_i) = h_\f(\vec x_i,\vec z_i) = \sum_{j=1}^m \I_{z_{ij}}\lb_j \phi_j (\vec x_i), $$ In the parametric situation, i.e.\ when $\CF$ is a parametric family, it is easy to check that the complete-data MLE $\hat\f_{\Bc}$ based on maximizing $\log \Bh_\f(\Bc)$ is easy to find, provided that this is the case for the family $\CF$. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{EM algorithms} \label{sec:EM} An EM algorithm iteratively maximizes, instead of the observed log-likelihood $L_{\Bx}(\f)$, the operator $$ Q(\f | \f^{(t)}) = \E \left[\log \Bh_\f(\BC)|\Bx,\f^{(t)} \right], $$ where $\f^{(t)}$ is the current value at iteration~$t$, and the expectation is with respect to the distribution $\Bk_\f(\Bc|\Bx)$ of $\Bc$ given $\Bx$, for the value $\f^{(t)}$ of the parameter. The iteration $\f^{(t)} \to \f^{(t+1)}$ is defined in the above general setup by \begin{enumerate} \item E-step: compute $Q(\f | \f^{(t)})$ \item M-step: set $\f^{(t+1)} = \argmax_{\f\in\Phi}Q(\f | \f^{(t)})$ \end{enumerate} For finite mixture models, the E-step does not depend on the structure of $\CF$, since the missing data part is only related to the $\Bz$'s: $$ \Bk_\f(\Bc|\Bx) = \prod_{i=1}^n k_\f(\vec z_i|\vec x_i). $$ The $\Bz$ are discrete, and their distribution is given via Bayes' theorem. The M-step itself can be split in two parts, the maximization related to $\vec\lb$, which does not depend on $\CF$, and the maximization related to $\vec \phi$, which has to be handled specifically (say, parametrically, semi- or non-parametrically) for each model. Hence the EM algorithms for the models handled by the \pkg{mixtools} package share the following common features: \begin{enumerate} \item{\bf E-step:\ } Calculate the ``posterior'' probabilities (conditional on the data and $\vec\theta^{(t)}$) of component inclusion, \begin{equation}\label{posteriors} \post_{ij}^{(t)} \, \defn \, \Prob_{\vec\theta^{(t)}}(Z_{ij}=1| \vec x_i) = \frac{\lambda_j^{(t)} \phi_{j}^{(t)}(\vec x_{i})} {\sum_{j'=1}^m\lambda_{j'}^{(t)} \phi_{j'}^{(t)}(\vec x_{i})} \end{equation} for all $i=1,\ldots, n$ and $j=1, \ldots, m$. Numerically, it can be dangerous to implement equation (\ref{posteriors}) exactly as written due to the possibility of the indeterminant form $0/0$ in cases where $\vec x_i$ is so far from any of the components that all $\phi_{j'}^{(t)}(\vec x_i)$ values result in a numerical underflow to zero. Thus, many of the routines in \pkg{mixtools} actually use the equivalent expression \begin{equation}\label{altposteriors} \post_{ij}^{(t)} = \left[ 1 + \sum_{j'\ne j} \frac{ \lambda_{j'}^{(t)} \phi_{j'}^{(t)}(\vec x_{i})} {\lambda_j^{(t)} \phi_{j}^{(t)}(\vec x_{i})} \right]^{-1} \end{equation} or some variant thereof. \item{\bf M-step for $\vec\lb$:\ } Set \begin{equation}\label{lambda} \lambda_j^{(t+1)} = \frac1n\sum_{i=1}^n \post_{ij}^{(t)} , \quad\mbox{for $j=1, \ldots, m$.} \end{equation} \end{enumerate} \subsection{An EM algorithm example} \label{section:EMexample} As an example, we consider the univariate normal mixture analysis of the Old Faithful waiting data depicted in Figure \ref{geyser}. This fully parametric situation corresponds to a mixture from the univariate Gaussian family described in Section~\ref{s:intro}, where the $j$th component density $\phi_j(x)$ in \eqref{mvmixture} is normal with mean $\mu_j$ and variance $\sigma_j^2$. This is a special case of the general mixture-of-normal model that is well-studied in the literature and for which other software, such as the \pkg{mclust} \citep{Fraley+Raftery:2009} package for \proglang{R}, may also be used for parameter estimation. The M-step for the parameters $(\mu_j,\sigma^2_j)$, $j=1,\ldots,m$ of this EM algorithm for such mixtures of univariate normals is straightforward, and can be found, e.g., in \citet{mclachlan2000fmm}. The function \code{normalmixEM} implements the algorithm in \pkg{mixtools}. Code for the Old Faithful example, using most of the default values (e.g., stopping criterion, maximum number of iterations), is simply <>= wait1 <- normalmixEM(waiting, lambda = .5, mu = c(55, 80), sigma = 5) @ The code above will fit a 2-component mixture (because \code{mu} is a vector of length two) in which the standard deviations are assumed equal (because \code{sigma} is a scalar instead of a vector). See \code{help("normalmixEM")} for details about specifying starting values for this EM algorithm. <>= plot(wait1, density=TRUE, cex.axis=1.4, cex.lab=1.4, cex.main=1.8, main2="Time between Old Faithful eruptions", xlab2="Minutes") @ \setkeys{Gin}{width=0.49\textwidth} \begin{figure}[!h] \centering <>= for(i in 1:2){ file=paste("geyserEM", i, ".pdf", sep="") pdf(file=file, paper="special", width=6, height=6) plot(wait1, whichplots=i, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") dev.off() cat("\\includegraphics{", file, "}\n", sep="") } @ \caption{The Old Faithful waiting data fitted with a parametric EM algorithm in \pkg{mixtools}. Left: the sequence of log-likelihood values; Right: the fitted Gaussian components.} \label{geyserEM} \end{figure} The \code{normalmixEM} function returns an object of class \code{"mixEM"}, and the \code{plot} method for these objects delivers the two plots given in Figure \ref{geyserEM}: the sequence $t\mapsto L_{\Bx}(\f^{(t)})$ of observed log-likelihood values and the histogram of the data with the $m$ ($m=2$ here) fitted Gaussian component densities of $\CN(\hat\mu_j,\hat\sigma^2_j)$, $j=1,\ldots,m$, each scaled by the corresponding $\hat\lambda_j$, superimposed. The estimator $\hat{\vec\theta}$ can be displayed by typing, e.g., <>= wait1[c("lambda", "mu", "sigma")] @ Alternatively, the same output may be obtained using the \code{summary} method: <>= summary(wait1) @ \section{Cutpoint methods} \label{section:cut} Traditionally, most literature on finite mixture models has assumed that the density functions $\phi_j(\vec x)$ of equation (\ref{mvmixture}) come from a known parametric family. However, some authors have recently considered the problem in which $\phi_j(\vec x)$ is unspecified except for some conditions necessary to ensure the identifiability of the parameters in the model. One such set of conditions is as follows: \citet{hettmansperger2000ani}; \citet{cruzmedina2004smm}; and \citet{elmore2004ecc} treat the case in which $\phi_j(\vec x)$ equals the product $f_j(x_i)\cdots f_j(x_r)$ for some univariate density function $f_j$. Thus, conditional on knowing that $\vec X$ comes from the $j$th mixture component, the coordinates of $\vec X$ are independent and identically distributed. For this reason, this case is called the conditionally i.i.d.\ model. The authors named above have developed an estimation method for the conditionally i.i.d.\ model. This method, the {\em cutpoint approach}, discretizes the continuous measurements by replacing each $r$-dimensional observation, say $\vec X_i= (x_{i1}, \ldots, x_{ir})$, by the $p$-dimensional multinomial vector $(n_1, \ldots, n_p)$, where $p\ge2$ is chosen by the experimenter along with a set of cutpoints $-\infty = c_0 < c_1 < \cdots < c_p=\infty$, so that for $a=1, \ldots, p$, \[ n_a = \sum_{k=1}^r I\{c_{a-1} < x_{ik} \le c_a\}. \] Note that the multinomial distribution is guaranteed by the conditional i.i.d.\ assumption, and the multinomial probability of the $a$th category is equal to $\theta_a \equiv P_{}(c_{a-1}>= data("Waterdata") cutpts <- 10.5*(-6:6) watermult <- makemultdata(Waterdata, cuts = cutpts) @ Once the multinomial data have been created, we may apply the \code{multmixEM} function to estimate the multinomial parameters via an EM algorithm. <>= set.seed(15) theta4 <- matrix(runif(56), ncol = 14) theta3 <- theta4[1:3,] mult3 <- multmixEM(watermult, lambda = rep(1, 3)/3, theta = theta3) mult4 <- multmixEM (watermult, lambda = rep (1, 4) / 4, theta = theta4) @ Finally, \code{compCDF} calculates and plots the estimated distribution functions of equation (\ref{ecdf}). Figure \ref{WDcutpoint} gives plots for both a 3-component and a 4-component solution; these plots are very similar to the corresponding plots in Figures 1 and 2 of \citet{elmore2004ecc}. <>= cdf3 <- compCDF(Waterdata, mult3$posterior, lwd=2, lab=c(7, 5, 7), xlab="Angle in degrees", ylab="Component CDFs", main="Three-Component Solution") cdf4 <- compCDF(Waterdata, mult4$posterior, lwd=2, lab=c(7, 5, 7), xlab="Angle in degrees", ylab="Component CDFs", main="Four-Component Solution") @ <>= pdf(file="WDcutpoint3comp.pdf", paper="special", width=8, height=8) cdf3 <- compCDF(Waterdata, mult3$posterior, lwd=3, xlab="Angle in degrees", lab=c(7, 5, 7), ylab="Component CDFs", main="Three-Component Solution", cex.axis=1.4, cex.lab=1.5, cex.main=1.5) ltext <- paste(round(mult3$lam*100, 1), "%", sep="") legend("bottomright", legend=ltext, pch=15:17, cex=1.5, pt.cex=1.35) y <- compCDF(Waterdata, mult3$posterior, x=cutpts, makeplot=F) for(i in 1:3) points(cutpts, y[i,], pch=14+i, cex=1.35) dev.off() pdf(file="WDcutpoint4comp.pdf", paper="special", width=8, height=8) cdf4 <- compCDF(Waterdata, mult4$posterior, lwd=3, xlab="Angle in degrees", lab=c(7, 5, 7), ylab="Component CDFs", main="Four-Component Solution", cex.axis=1.4, cex.lab=1.5, cex.main=1.5) ltext <- paste(round(mult4$lam*100,1), "%", sep="") legend("bottomright", legend=ltext, pch=15:18, cex=1.5, pt.cex=1.35) y <- compCDF(Waterdata, mult4$posterior, x=cutpts, makeplot=F) for(i in 1:4) points(cutpts, y[i,], pch=14+i, cex=1.35) dev.off() @ \begin{figure}[!h] \centering \includegraphics[width=0.49\textwidth]{WDcutpoint3comp} \includegraphics[width=0.49\textwidth]{WDcutpoint4comp} \caption{Empirical cumulative distribution function (CDF) estimates for the three- and four-component multinomial cutpoint models for the water-level data; compare Figures 1 and 2 of \citet{elmore2004ecc}. The 13 cutpoints used are indicated by the points in the plots, and the estimated mixing proportions for the various components are given by the legend. } \label{WDcutpoint} \end{figure} As with the output of \code{normalmixEM} in Section~\ref{section:EM}, it is possible to summarize the output of the \code{multmixEM} function using the \code{summary} method for \code{mixEM} objects: <>= summary(mult4) @ \section{Nonparametric and semiparametric methods} \label{section:np} In this section, we consider nonparametric multivariate finite mixture models. The first algorithm presented here was introduced by \citet{benaglia2009} as a generalization of the stochastic semiparametric EM algorithm of \citet{bordes2007sas}. Both algorithms are implemented in \pkg{mixtools}. \subsection{EM-like algorithms for mixtures of unspecified densities} \label{section:EMlike} Consider the mixture model described by equation \eqref{mvmixture}. If we assume that the coordinates of the $\vec X_i$ vector are {\em conditionally independent}, i.e. they are independent conditional on the subpopulation or component ($\phi_1$ through $\phi_m$) from which $\vec X_i$ is drawn, the density in \eqref{mvmixture} can be rewritten as: \begin{equation} \label{mvmixture2} g_{\vec\theta}(\vec x_i) = \sum_{j=1}^m\lambda_j\prod_{k=1}^rf_{jk}(x_{ik}), \end{equation} where the function $f(\cdot)$, with or without subscripts, will always denote a univariate density function. Here we do not assume that $f_{jk}(\cdot)$ comes from a family of densities that may be indexed by a finite-dimensional parameter vector, and we estimate these densities using nonparametric density techniques. That is why we say that this algorithm is a fully nonparametric approach. The density in equation \eqref{mvmixture2} allows for a different distribution for each component and each coordinate of $\vec X_i$. Notice that if the density $f_{jk}(\cdot)$ does not depend on $k$, we have the case in which the $\vec X_i$ are not only conditionally independent but identically distributed as well. These are the two extreme cases. In order to encompass both the conditionally i.i.d. case and the more general case \eqref{mvmixture2} simultaneously in one model, we allow that the coordinates of $\vec X_i$ are conditionally independent and there exist {\em blocks} of coordinates that are also identically distributed. If we let $b_k$ denote the block to which the $k$th coordinate belongs, where $1\le b_k\le B$ and $B$ is the total number of such blocks, then equation \eqref{mvmixture2} is replaced by \begin{equation}\label{rmgeneral} g_{\vec\theta} (\vec x_i) = \sum_{j=1}^m \lambda_j \prod_{k=1}^r f_{j{b_k}} (x_{ik}). \end{equation} The indices $i$, $j$, $k$, and $\ell$ will always denote a generic individual, component (subpopulation), coordinate (repeated measurement), and block, respectively. Therefore, we will always have $1\le i\le n$, $1\le j\le m$, $1\le k\le r$, and $1\le\ell\le B$. The EM algorithm to estimate model \eqref{rmgeneral} has the E-step and M-step described in Section~\ref{sec:EM}. In equation (\ref{posteriors}), we have $\phi_j^{(t)}(\vec x_i) = \prod_{k=1}^r f_{jb_k}^{(t)}(x_{ik})$, where $f_{j\ell}^{(t)}(\cdot)$ is obtained by a weighted nonparametric (kernel) density estimate, given by: \begin{enumerate} \addtocounter{enumi}{2} \item{\bf Nonparametric (Kernel) density estimation step:\ } For any real $u$, define for each component $j\in\{1, \ldots, m\}$ and each block $\ell\in\{1, \ldots, B\}$ \begin{equation} \label{densest} f_{j\ell}^{t+1}(u) = \frac {1}{nh_{j\ell} C_\ell\lambda_{j}^{t+1}} \sum_{k=1}^r \sum_{i=1}^n \post_{ij}^{(t)} I\{b_k=\ell\} K\left(\frac{u-x_{ik}}{h_{j\ell}}\right), \end{equation} where $K(\cdot)$ is a kernel density function, $h_{j\ell}$ is the bandwidth for the $j$th component and $\ell$th block density estimate, and $C_\ell$ is the number of coordinates in the $\ell$th block. \end{enumerate} The function \code{npEM} implements this algorithm in \pkg{mixtools}. This function has an argument \code{samebw} which, when set to \code{TRUE} (the default), takes $h_{j\ell} = h$, for all $1 \le j \le m$ and $1\le\ell\le B$, that is, the same bandwidth for all components and blocks, while \code{samebw = FALSE} allows a different bandwidth for each component and each block, as detailed in \citet{bch:festchrift2009}. This function will, if called using \code{stochastic = TRUE}, replace the deterministic density estimation step (\ref{densest}) by a {\em stochastic} density estimation step of the type proposed by \citet{bordes2007sas}: First, generate $\vec Z^{(t)}_{i} = (Z^{(t)}_{i1}, \ldots, Z^{(t)}_{im})$ as a multivariate random vector with a single trial and success probability vector $\vec p_i^{(t)} = (p_{i1}^{(t)}, \ldots, p_{1m}^{(t)})$, then in the M-step for $\lambda_{j}^{t+1}$ in equation~(\ref{lambda}), replace $p^{(t)}_{ij}$ by $Z^{(t)}_{ij}$ and let \[ f_{j\ell}^{t+1}(u) = \frac {1}{nh_{j\ell} C_\ell\lambda_{j}^{t+1}} \sum_{k=1}^r \sum_{i=1}^n Z_{ij}^{(t)} I\{b_k=\ell\} K\left(\frac{u-x_{ik}}{h_{j\ell}}\right). \] In other words, the stochastic versions of these algorithms re-assign each observation randomly at each iteration, according to the $p_{ij}^{(t)}$ values at that iteration, to one of the $m$ components, then the density estimate for each component is based only on those observations that have been assigned to it. Because the stochastic algorithms do not converge the way a deterministic algorithm often does, the output of \code{npEM} is slightly different when \code{stochastic = TRUE} than when \code{stochastic = FALSE}, the default. See the corresponding help file for details. \citet{benaglia2009} also discuss specific cases of model (\ref{rmgeneral}) in which some of the $f_{jb_k}(\cdot)$ densities are assumed to be the same except for a location and scale change. They refer to such cases as semiparametric since estimating each $f_{jb_k}(\cdot)$ involves estimating an unknown density as well as multiple location and scale parameters. For instance, equation (17) of \citet{benaglia2009} sets \begin{equation} \label{spEM} f_{j\ell}(x) = \frac{1}{\sigma_{j\ell}}f \left( \frac{x-\mu_{j\ell}}{\sigma_{j\ell}} \right), \end{equation} where $\ell=b_k$ for a generic $k$. The \pkg{mixtools} package implements an algorithm for fitting model (\ref{spEM}) in a function called \code{spEM}. Details on the use of this function may be obtained by typing \code{help("spEM")}. Implementation of this algorithm and of that of the \code{npEM} function requires updating the values of $f_{jb_k}(x_{ik})$ for all $i$, $j$, and $k$ for use in the E-step (\ref{posteriors}). To do this, the \code{spEM} algorithm keeps track of an $n\times m$ matrix, called $\Phi$ here, where \[ \Phi_{ij} \equiv \phi_j(\vec x_i) = \prod_{k=1}^r f_{jb_k}(x_{ik}). \] The density estimation step of equation (\ref{densest}) updates the $\Phi$ matrix for the $(t+1)$th iteration based on the most recent values of all of the parameters. For instance, in the case of model (\ref{spEM}), we obtain \begin{eqnarray*} \Phi_{ij}^{t+1} &=& \prod_{\ell=1}^B\prod_{k:b_k=\ell} \frac{1}{\sigma_{j\ell}^{t+1}} f^{t+1} \left( \frac{x-\mu_{j\ell}^{t+1}}{\sigma_{j\ell}^{t+1}} \right) \\ &=& \prod_{\ell=1}^B \prod_{k:b_k=\ell} \frac{1}{\sigma_{j\ell}^{t+1}} \sum_{i'=1}^n \frac{p_{ij}^{t+1}}{hrn\lambda_j^{t+1}} \sum_{k'=1}^r K\left[ \frac{\left(\frac{x_{ik}-\mu_{j\ell}^{t+1}}{\sigma_{j\ell}^{t+1}} \right) - (x_{i'k'} - \mu_{j\ell}^{t+1})} {h\sigma_{j\ell}^{t+1}} \right]. \end{eqnarray*} \subsection{A univariate symmetric, location-shifted semiparametric example} \label{section:SPexample} Both \citet{hunter2007ims} and \citet{bordes2006set} study a particular case of model ({\ref{mvmixture}) in which $x$ is univariate and \begin{equation} \label{spmodel} g_{\vec \theta}(x) = \sum_{j=1}^m\lambda_j \phi(x-\mu_j), \end{equation} where $\phi(\cdot)$ is a density that is assumed to be completely unspecified except that it is symmetric about zero. Because each component distribution has both a nonparametric part $\phi(\cdot)$ and a parametric part $\mu_j$, we refer to this model as semiparametric. Under the additional assumption that $\phi(\cdot)$ is absolutely continuous with respect to Lebesgue measure, \citet{bordes2007sas} propose a stochastic algorithm for estimating the model parameters, namely, $(\vec\lambda, \vec\mu, \phi)$. This algorithm is implemented by the \pkg{mixtools} function \code{spEMsymloc}. This function also implements a nonstochastic version of the algorithm, which is the default and which is a special case of the general algorithm described in Section~\ref{section:EMlike}. <>= pdf(file="spsymmfig1.pdf", paper="special", width=8, height=8) par(mar=0.1+c(5,4.2,4,1.8)) plot(wait1, which = 2, cex.axis = 1.4, cex.lab = 1.5, cex.main = 1.5, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") wait2 <- spEMsymloc(waiting, mu0 = c(55, 80)) plot(wait2, lty = 2, newplot = FALSE, addlegend = FALSE) dev.off() pdf(file="spsymmfig2.pdf", paper="special", width=8, height=8) par(mar=0.1+c(5,4.2,4,1.8)) wait2a <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 1) wait2b <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 6) plot(wait2a, lty = 1, addlegend = FALSE, cex.axis = 1.4, cex.lab = 1.5, cex.main = 1.5, title = "Time between Old Faithful eruptions", xlab = "Minutes") plot(wait2b, lty = 2, newplot = FALSE, addlegend = FALSE) dev.off() @ \begin{figure}[h] \centering \includegraphics[height=3in,width=3in]{spsymmfig1} \includegraphics[height=3in,width=3in]{spsymmfig2} \caption{The Old Faithful dataset, fit using different algorithms in \pkg{mixtools}. Left: the fitted Gaussian components (solid) and a semiparametric fit assuming model (\ref{spmodel}) with the default bandwidth of $4.0$ (dashed); Right: the same model (\ref{spmodel}) using bandwidths of $1.0$ (solid) and $6.0$ (dashed).} \label{spsymmfig} \end{figure} As noted in Figure \ref{geyser}, model (\ref{spmodel}) appears to be an appropriate model for the Old Faithful waiting times dataset. Here, we provide code that applies the \code{spEMsymloc} function to these data. First, we display the normal mixture solution of Figure \ref{geyserEM} with a semiparametric solution superimposed, in Figure \ref{spsymmfig}(a): <>= plot(wait1, which = 2, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, main2 = "Time between Old Faithful eruptions", xlab2 = "Minutes") wait2 <- spEMsymloc(waiting, mu0 = c(55, 80)) plot(wait2, lty = 2, newplot = FALSE, addlegend = FALSE) @ Because the semiparametric version relies on a kernel density estimation step (\ref{densest}), it is necessary to select a bandwidth for this step. By default, \code{spEMsymloc} uses a fairly simplistic approach: It applies ``Silverman's rule of thumb'' \citep{silverman1986des} to the entire dataset using the \code{bw.nrd0} function in \proglang{R}. For the Old Faithful waiting time dataset, this bandwidth is about~$4$: <>= bw.nrd0(waiting) @ But the choice of bandwidth can make a big difference, as seen in Figure \ref{spsymmfig}(b). <>= wait2a <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 1) wait2b <- spEMsymloc(waiting, mu0 = c(55, 80), bw = 6) plot(wait2a, lty = 1, addlegend = FALSE, cex.axis = 1.4, cex.lab = 1.4, cex.main = 1.8, xlab = "Minutes", title = "Time between Old Faithful eruptions") plot(wait2b, lty = 2, newplot = FALSE, addlegend = FALSE) @ We find that with a bandwidth near $2$, the semiparametric solution looks quite close to the normal mixture solution of Figure \ref{geyserEM}. Reducing the bandwidth further results in the ``bumpiness'' exhibited by the solid line in Figure \ref{spsymmfig}(b). On the other hand, with a bandwidth of 8, the semiparametric solution completely breaks down in the sense that algorithm tries to make each component look similar to the whole mixture distribution. We encourage the reader to experiment by changing the bandwidth in the above code. \subsection{A trivariate Gaussian example} \label{ss:trigauss} As a first simple, nonparametric example, we simulate a Gaussian trivariate mixture with independent repeated measures and a shift of location between the two components in each coordinate, i.e., $m=2$, $r=3$, and $b_k=k$, $k=1,2,3$. The individual densities $f_{jk}$ are the densities of $\CN(\mu_{jk},1)$, with component means $\vec\mu_1 = (0,0,0)$ and $\vec\mu_2=(3,4,5)$. This example was introduced by \citet{hall2005nim} then later reused by \citet{benaglia2009} for comparison purposes. Note that the parameters in this model are identifiable, since \citet{hall2003nec} showed that for two components ($m=2$), identifiability holds in model~\eqref{mvmixture} is under mild assumptions as long as $r\ge3$, even in the most general case in which $b_k=k$ for all $k$. A function \code{ise.npEM} has been included in \pkg{mixtools} for numerically computing the integrated squared error (ISE) relative to a user-specified true density for a selected estimated density $\hat f_{jk}$ from \code{npEM} output. Each density $\hat f_{jk}$ is computed using equation~(\ref{densest}) together with the posterior probabilities after convergence of the algorithm, i.e., the final values of the $\post_{ij}^t$ (when \code{stochastic = FALSE}). We illustrate the usage of \code{ise.npEM} in this example by running a Monte Carlo simulation for $S$ replications, then computing the square root of the mean integrated squared error (MISE) for each density, where \[ {\rm MISE} = \frac{1}{S}\sum_{s=1}^S \int \left(\hat f_{jk}^{(s)}(u)-f_{jk}(u)\right)^2\,du,\quad j=1,2 \mbox{ and } k=1,2,3. \] For this example, we first set up the model true parameters with $S=100$ replications of $n=300$ observations each: <>= m <- 2; r <- 3; n <- 300; S <- 100 lambda <- c(0.4, 0.6) mu <- matrix(c(0, 0, 0, 3, 4, 5), m, r, byrow = TRUE) sigma <- matrix(rep(1, 6), m, r, byrow = TRUE) @ Next, we set up ``arbitrary'' initial centers, a matrix for storing sums of integrated squared errors, and an integer storing the number of suspected instances of label switching that may occur during the replications: <>= centers <- matrix(c(0, 0, 0, 4, 4, 4), 2, 3, byrow = TRUE) ISE <- matrix(0, m, r, dimnames = list(Components = 1:m, Blocks = 1:r)) nblabsw <- 0 @ Finally, we run the Monte Carlo simulation, using the \code{samebw = FALSE} option since it is more appropriate for this location-shift model: <>= set.seed(1000) for (mc in 1:S) { x <- rmvnormmix(n, lambda, mu, sigma) a <- npEM(x, centers, verb = FALSE, samebw = FALSE) if (a$lambda[1] > a$lambda[2]) nblabsw <- nblabsw + 1 for (j in 1:m) { for (k in 1:r) { ISE[j, k] <- ISE[j, k] + ise.npEM(a, j, k, dnorm, lower = mu[j, k] - 5, upper = mu[j, k] + 5, plots = FALSE, mean = mu[j, k], sd = sigma[j, k])$value #$ } } } MISE <- ISE/S print(sqMISE <- sqrt(MISE)) @ We can examine the \code{npEM} output from the last replication above using <>= summary(a) @ We can also get plots of the estimated component densities for each block (recall that in this example, block $\ell$ consists only of coordinate $\ell$) using the \code{plot} function. The resulting plots are given in Figure~\ref{fig:gausstrivariate}. <>= plot(a) @ <>= pdf("gauss3rm.pdf", paper="special", width=10, height=5) par(mfrow=c(1,3), ask=F) plot(a) dev.off() @ \begin{figure}[h] \centering \includegraphics[width=.99\textwidth]{gauss3rm} \caption{Output of the \code{npEM} algorithm for the trivariate Gaussian model with independent repeated measures.} \label{fig:gausstrivariate} \end{figure} \subsection{A more general multivariate nonparametric example} \label{sec:generalmv} In this section, we fit a more difficult example, with non-multimodal mixture densities (in block \#2), heavy-tailed distributions, and different scales among the coordinates. The model is multivariate with $r=5$ repeated measures and $m=2$ components (hence identifiability holds; cf.\ \citet{hall2003nec} as cited in Section~\ref{ss:trigauss}). The $5$ repeated measures are grouped into $B=2$ blocks, with $b_1=b_2=b_3=1$ and $b_4=b_5=2$. Block $1$ corresponds to a mixture of two noncentral Student $t$ distributions, $t'(2,0)$ and $t'(10,8)$, where the first parameter is the number of degrees of freedom, and the second is the non-centrality. Block~2 corresponds to a mixture of Beta distributions, ${\cal B}(1,1)$ (which is actually the uniform distribution over $[0,1]$) and ${\cal B}(1,5)$. The first component weight is $\lambda_1 = 0.4$. The true mixtures are depicted in Figure~\ref{fig:true5rm}. <>= pdf("truepdf5rm_block1.pdf") par(mar=0.1+c(5,4.2,4,1.5)) x <- seq(-10, 25, len=250) plot(x, .4* dt(x, 2, 0) + .6 * dt(x, 10, 8), type="l", lwd=3, col=2, cex.axis=1.4, cex.lab=1.5, cex.main=1.5, main="Block 1", xlab="", ylab="Density") lines (x, .4*dt(x, 2, 0), lwd=4, lty=2) lines (x, .6*dt(x, 10, 8), lwd=4, lty=2) dev.off() pdf("truepdf5rm_block2.pdf") par(mar=0.1+c(5,4.2,4,1.5)) x <- seq(0, 1, len=250) plot(x, .4 + .6 * dbeta(x, 1, 5), type="l", lwd=3, col=2, cex.axis=1.4, cex.lab=1.5, cex.main=1.5, main="Block 2", xlab="", ylab="Density", ylim= c(0, 3.4)) lines (x, rep(.4, 250), lwd=4, lty=2) lines (x, .6*dbeta(x, 1, 5), lwd=4, lty=2) dev.off() @ \begin{figure}[h] \centering \includegraphics[height=2.5in,width=2.5in]{truepdf5rm_block1} \includegraphics[height=2.5in,width=2.5in]{truepdf5rm_block2} \caption{True densities for the mixture of Section~\ref{sec:generalmv}, with individual component densities (scaled by $\lambda_j$) in dotted lines and mixture densities in solid lines. The noncentral $t$ mixture of coordinates 1 through 3 is on the left, the beta mixture of coordinates 4 and 5 on the right.} \label{fig:true5rm} \end{figure} To fit this model in \pkg{mixtools}, we first set up the model parameters: <>= m <- 2; r <- 5 lambda <- c(0.4, 0.6) df <- c(2, 10); ncp <- c(0, 8) sh1 <- c(1, 1) ; sh2 <- c(1, 5) @ Then we generate a pseudo-random sample of size $n=300$ from this model: <>= n <- 300; z <- sample(m, n, rep = TRUE, prob = lambda) r1 <- 3; z2 <- rep(z, r1) x1 <- matrix(rt(n * r1, df[z2], ncp[z2]), n, r1) r2 <- 2; z2 <- rep(z, r2) x2 <- matrix(rbeta(n * r2, sh1[z2], sh2[z2]), n, r2) x <- cbind(x1, x2) @ For this example in which the coordinate densities are on different scales, it is obvious that the bandwidth in \code{npEM} should depend on the blocks and components. We set up the block structure and some initial centers, then run the algorithm with the option \code{samebw = FALSE}: <>= id <- c(rep(1, r1), rep(2, r2)) centers <- matrix(c(0, 0, 0, 1/2, 1/2, 4, 4, 4, 1/2, 1/2), m, r, byrow = TRUE) b <- npEM(x, centers, id, eps = 1e-8, verb = FALSE, samebw = FALSE) @ Figure~\ref{fig:npEM5rm} shows the resulting density estimates, which may be obtained using the plotting function included in \pkg{mixtools}: <>= plot(b, breaks = 15) @ % plot(b, breaks = 15, cex.main = 1.5, cex.lab = 1.5, cex.axis = 1.4, % cex.legend = 1.5) <>= pdf("npEM5rm.pdf", width=8, height=5) par(mfrow=c(1,2)) plot(b, breaks = 15) dev.off() @ \begin{figure}[h] \centering \includegraphics[width=.95\textwidth]{npEM5rm} \caption{Result of plotting \code{npEM} output for the example of Section~\ref{sec:generalmv}. Since $n=300$, the histogram on the left includes 900 observations and the one on the right includes 600.} \label{fig:npEM5rm} \end{figure} Finally, we can compute the ISE of the estimated density relative to the truth for each block and component. The corresponding output is depicted in Figure \ref{fig:ISEnpEM5rm}. <>= par(mfrow=c(2,2)) for (j in 1:2){ ise.npEM(b, j, 1, truepdf = dt, lower = ncp[j] - 10, upper = ncp[j] + 10, df = df[j], ncp = ncp[j]) ise.npEM(b, j, 2, truepdf = dbeta, lower = -0.5, upper = 1.5, shape1 = sh1[j], shape2 = sh2[j]) } @ <>= options(warn=-1) pdf("ISEnpEM5rm.pdf", width=8, height=8) par(mfrow = c(2, 2)) for (j in 1:2){ ise.npEM(b, j, 1, truepdf = dt, lower = ncp[j] - 10, upper = ncp[j] + 10, df = df[j], ncp = ncp[j]) ise.npEM(b, j, 2, truepdf = dbeta, lower = -0.5, upper = 1.5, shape1 = sh1[j], shape2 = sh2[j]) } dev.off() @ \begin{figure}[h] \centering \includegraphics[height=5in,width=6in]{ISEnpEM5rm} \caption{\code{ise.npEM} output for the 5-repeated measures example; the true densities are $f_{11}\equiv t'(2,0)$, $f_{21}\equiv t'(10,8)$, $f_{12}\equiv {\cal U}_{(0,1)}$, $f_{22}\equiv {\cal B}(1,5)$.} \label{fig:ISEnpEM5rm} \end{figure} \section{Mixtures of regressions} \label{section:reg} \subsection{Mixtures of linear regressions} Consider a mixture setting where we now assume $\textbf{X}_{i}$ is a vector of covariates observed with a response $Y_{i}$. The goal of mixtures of regressions is to describe the conditional distribution of $Y_{i}|\textbf{X}_{i}$. Mixtures of regressions have been extensively studied in the econometrics literature and were first introduced by \citet{quandt1972sr} as the \textit{switching regimes} (or \textit{switching regressions}) problem. A switching regimes system is often compared to \textit{structural change} in a system \citep{quandtram1978sr}. A structural change assumes the system depends deterministically on some observable variables, but switching regimes implies one is unaware of what causes the switch between regimes. In the case where it is assumed there are two heterogeneous classes, \citet{quandt1972sr} characterized the switching regimes problem ``by assuming that nature chooses between regimes with probabilities $\lambda$ and $1-\lambda$''. Suppose we have $n$ independent univariate observations, $y_{1},\ldots,y_{n}$, each with a corresponding vector of predictors, $\textbf{x}_{1},\ldots,\textbf{x}_{n}$, with $\textbf{x}_{i}=(x_{i,1},\ldots,x_{i,p})^\top$ for $i=1,\ldots,n$. We often set $x_{i,1}=1$ to allow for an intercept term. Let $\textbf{y}=(y_{1},\ldots,y_{n})^\top$ and let $\underline{\textbf{X}}$ be the $n\times p$ matrix consisting of the predictor vectors. Suppose further that each observation $(y_{i}, \vec x_i)$ belongs to one of $m$ classes. Conditional on membership in the $j$th component, the relationship between $y_{i}$ and $\textbf{x}_{i}$ is the normal regression model \begin{equation}\label{regmodel} y_{i}=\textbf{x}_{i}^\top\vec{\beta}_{j}+\epsilon_{i}, \end{equation} where $\epsilon_{i}\thicksim \CN(0,\sigma^{2}_{j})$ and $\vec{\beta}_{j}$ and $\sigma_{j}^{2}$ are the $p$-dimensional vector of regression coefficients and the error variance for component $j$, respectively. Accounting for the mixture structure, the conditional density of $y_{i}|\vec x_i$ is \begin{equation}\label{mor} g_{\vec\theta}(y_{i}|\textbf{x}_{i})=\sum_{j=1}^{m}\lambda_{j} \phi(y_{i} | \textbf{x}_{i}^\top\vec{\beta}_{j},\sigma^{2}_{j}), \end{equation} where $\phi(\cdot|\textbf{x}^\top\vec{\beta}_{j},\sigma^{2}_{j})$ is the normal density with mean $\textbf{x}^\top\vec\beta$ and variance $\sigma^2$. Notice that the model parameter for this setting is $\vec\theta=(\vec\lambda,(\vec{\beta}_{1},\sigma^2_{1}),\ldots,(\vec{\beta}_{m},\sigma^2_{m}))$. The mixture of regressions model (\ref{mor}) differs from the well-known mixture of multivariate normals model $(Y_{i},\textbf{X}_{i}^\top)^\top\thicksim \sum_{j=1}^{m}\lambda_{j}\CN_{p+1}(\vec{\mu}_{j},\Sigma_{j})$ because model (\ref{mor}) makes no assertion about the marginal distribution of $\textbf{X}_{i}$, whereas the mixture of multivariate normals specifies that $\textbf{X}_{i}$ itself has a mixture of multivariate normals distribution. <>= data("CO2data") attach(CO2data) pdf("gnpdata.pdf") par(mar=0.1+c(5,4.2,4,1.5)) plot(GNP, CO2, xlab="Gross National Product", ylab=expression(paste(CO[2]," per Capita")), cex.lab=1.5, cex.main=1.5, cex.axis=1.4, main="1996 GNP and Emissions Data") text(GNP, CO2, country, adj=c(.5,-.5)) dev.off() @ \begin{figure}[h] \centering \includegraphics[height=3in,width=3in]{gnpdata.pdf} \caption{1996 data on gross national product (GNP) per capita and estimated carbon dioxide ($\textrm{CO}_{2}$) emissions per capita. Note that ``CH'' stands for Switzerland, not China.} \label{gnpdata} \end{figure} As a simple example of a dataset to which a mixture of regressions models may be applied, consider the sample depicted in Figure \ref{gnpdata}. In this dataset, the measurements of carbon dioxide ($\textrm{CO}_{2}$) emissions are plotted versus the gross national product (GNP) for $n=28$ countries. These data are included \pkg{mixtools}; type \code{help("CO2data")} in \proglang{R} for more details. \citet{hurn} analyzed these data using a mixture of regressions from the Bayesian perspective, pointing out that ``there do seem to be several groups for which a linear model would be a reasonable approximation.'' They further point out that identification of such groups could clarify potential development paths of lower GNP countries. \subsection{EM algorithms for mixtures of regressions} A standard EM algorithm, as described in Section~\ref{section:EM}, may be used to find a local maximum of the likelihood surface. \citet{deveaux1989} describes EM algorithms for mixtures of regressions in more detail, including proposing a method for choosing a starting point in the parameter space. The E-step is the same as for any finite mixture model EM algorithm; i.e., the $p_{ij}^{(t)}$ values are updated according to equation (\ref{posteriors})---or, in reality, equation (\ref{altposteriors})---where each $\phi_j^{(t)}(\vec x_i)$ is replaced in the regression context by $\phi(y_i | \vec x_i^\top\vec\beta_j, \sigma_j^2)$: \begin{equation}\label{regposteriors} \post_{ij}^{(t)} = \left[ 1 + \sum_{j'\ne j} \frac{ \lambda_{j'}^{(t)} \phi(y_i | \vec x_i^\top\vec\beta_{j'}, \sigma_{j'}^2)}{\lambda_j^{(t)} \phi(y_i | \vec x_i^\top\vec\beta_j, \sigma_j^2)} \right]^{-1} \end{equation} The update to the $\lambda$ parameters in the M-step, equation (\ref{lambda}), is also the same. Letting $\textbf{W}_{j}^{(t)}=\textrm{diag}(\post_{1j}^{(t)},\ldots,\post_{nj}^{(t)})$, the additional M-step updates to the $\vec\beta$ and $\sigma$ parameters are given by \begin{eqnarray}\label{betaEM} \vec{\beta}_{j}^{(t+1)} &=& (\underline{\textbf{X}}^\top\textbf{W}_{j}^{(t)}\underline{\textbf{X}})^{-1}\underline{\textbf{X}}^\top \textbf{W}_{j}^{(t)}\textbf{y} \quad \mbox{and} \\ \label{sigma} \sigma_{j}^{2(t+1)} &=& \frac{\biggl\|\textbf{W}_{j}^{1/2(t)}(\textbf{y}-\underline{\textbf{X}}^\top\vec{\beta}_{j}^{(t+1)})\biggr\|^{2}}{\mbox{tr}(\textbf{W}_{j}^{(t)})}, \end{eqnarray} where $\|\textbf{A}\|^{2}=\textbf{A}^\top\textbf{A}$ and $\mbox{tr}(\textbf{A})$ means the trace of the matrix $\textbf{A}$. Notice that equation (\ref{betaEM}) is a weighted least squares (WLS) estimate of $\vec{\beta}_{j}$ and equation (\ref{sigma}) resembles the variance estimate used in WLS. Allowing each component to have its own error variance $\sigma_j^2$ results in the likelihood surface having no maximizer, since the likelihood may be driven to infinity if one component gives a regression surface passing through one or more points exactly and the variance for that component is allowed to go to zero. A similar phenomenon is well-known in the finite mixture-of-normals model where the component variances are allowed to be distinct \citep{mclachlan2000fmm}. However, in practice we observe this behavior infrequently, and the \pkg{mixtools} functions automatically force their EM algorithms to restart at randomly chosen parameter values when it occurs. A local maximum of the likelihood function, a consistent version of which is guaranteed to exist by the asymptotic theory as long as the model is correct and all $\lambda_j$ are positive, usually results without any restarts. The function \code{regmixEM} implements the EM algorithm for mixtures of regressions in \pkg{mixtools}. This function has arguments that control options such as adding an intercept term, \code{addintercept = TRUE}; forcing all $\vec\beta_j$ estimates to be the same, \code{arbmean = FALSE} (for instance, to model outlying observations as having a separate error variance from the non-outliers); and forcing all $\sigma_j^2$ estimates to be the same, \code{arbvar = FALSE}. For additional details, type \code{help("regmixEM")}. As an example, we fit a 2-component model to the GNP data shown in Figure \ref{gnpdata}. \citet{hurn} and \citet{youngphd} selected 2 components for this dataset using model selection criteria, Bayesian approaches to selecting the number of components, and a bootstrapping approach. The function \code{regmixEM} will be used for fitting a 2-component mixture of regressions by an EM algorithm: <>= data("CO2data") attach(CO2data) @ <>= CO2reg <- regmixEM(CO2, GNP, lambda = c(1, 3) / 4, beta = matrix(c(8, -1, 1, 1), 2, 2), sigma = c(2, 1)) @ We can then pull out the final observed log-likelihood as well as estimates for the 2-component fit, which include $\hat{\lambda}$, $\hat{\vec{\beta}}_{1}$, $\hat{\vec{\beta}}_{2}$, $\hat{\sigma}_{1}$, and $\hat{\sigma}_{2}$: <>= summary(CO2reg) @ The reader is encouraged to alter the starting values or let the internal algorithm generate random starting values. However, this fit seems appropriate and the solution is displayed in Figure \ref{co2EM} along with 99\% Working-Hotelling Confidence Bands, which are constructed automatically by the \code{plot} method in this case by assigning each point to its most probable component and then fitting two separate linear regressions: <>= plot(CO2reg, density = TRUE, alpha = 0.01, cex.main = 1.5, cex.lab = 1.5, cex.axis = 1.4) @ \setkeys{Gin}{width=0.49\textwidth} \begin{figure}[!h] \centering <>= for(i in 1:2){ file=paste("CO2reg", i, ".pdf", sep="") pdf(file=file, paper="special", width=6, height=6) plot(CO2reg, whichplots=i, alpha = 0.01, cex.main = 1.5, cex.lab = 1.5, cex.axis = 1.4) dev.off() cat("\\includegraphics{", file, "}\n", sep="") } @ \caption{The GNP data fitted with a 2-component parametric EM algorithm in \pkg{mixtools}. Left: the sequence of log-likelihood values, $L_{\Bx}(\f^{(t)})$; Right: the fitted regression lines with 99\% Working-Hotelling Confidence Bands.} \label{co2EM} \end{figure} \subsection{Predictor-dependent mixing proportions} \label{section:pdmp} Suppose that in model (\ref{mor}), we replace $\lambda_j$ by $\lambda_{j}(\textbf{x}_{i})$ and assume that the mixing proportions vary as a function of the predictors $\textbf{x}_{i}$. Allowing this type of flexibility in the model might be useful for a number of reasons. For instance, sometimes it is the proportions $\lambda_j$ that are of primary scientific interest, and in a regression setting it may be helpful to know whether these proportions appear to vary with the predictors. As another example, consider a \code{regmixEM} model using \code{arbmean = FALSE} in which the mixture structure only concerns the error variance: In this case, $\lambda_j(\vec x)$ would give some sense of the proportion of outliers in various regions of the predictor space. One may assume that $\lambda_{j}(\textbf{x})$ has a particular parametric form, such as a logistic function, which introduces new parameters requiring estimation. This is the idea of the \textit{hierarchical mixtures of experts} (HME) procedure \citep{jacobsall}, which is commonly used in neural networks and which is implemented, for example, in the \pkg{flexmix} package for \proglang{R} \citep{jss:Leisch:2004, Grun+Leisch:2008}. However, a parametric form of $\lambda_{j}(\textbf{x})$ may be too restrictive; in particular, the logistic function is monotone, which may not realistically capture the pattern of change of $\lambda_j$ as a function of $\vec x$. As an alternative, \citet{young2009mor} propose a nonparametric estimate of $\lambda_{j}(\textbf{x}_{i})$ that uses ideas from kernel density estimation. The intuition behind the approach of \citet{young2009mor} is as follows: The M-step estimate (\ref{lambda}) of $\lambda_j$ at each iteration of a finite mixture model EM algorithm is simply an average of the ``posterior'' probabilities $p_{ij}=\E(Z_{ij}|\mbox{data})$. As a substitute, the nonparametric approach uses local linear regression to approximate the $\lambda_j(\textbf{x})$ function. Considering the case of univariate $x$ for simplicity, we set $\lambda_j(x) = \hat\alpha_{0j}(x)$, where \begin{equation}\label{lambdax} (\hat\alpha_{0j}(x), \hat\alpha_{1j}(x))= \arg\min_{(\alpha_0, \alpha_1)} \sum_{i=1}^n K_h(x-x_i) \left[ p_{ij} - \alpha_0 - \alpha_1(x-x_i) \right]^2 \end{equation} and $K_h(\cdot)$ is a kernel density function with scale parameter (i.e., bandwidth) $h$. It is straightforward to generalize equation (\ref{lambdax}) to the case of vector-valued $\vec x$ by using a multivariate kernel function. \citet{young2009mor} give an iterative algorithm for estimating mixture of regression parameters that replaces the standard $\lambda_j$ updates (\ref{lambda}) by the kernel-weighted version (\ref{lambdax}). The algorithm is otherwise similar to a standard EM; thus, like the algorithm in Section~\ref{section:EMlike} of this article, the resulting algorithm is an EM-like algorithm. Because only the $\lambda_j$ parameters depend on $\vec x$ (and are thus ``locally estimated''), whereas the other parameters (the $\vec\beta_j$ and $\sigma_j$) can be considered to be globally estimated, \citet{young2009mor} call this algorithm an iterative global/local estimation (IGLE) algorithm. Naturally, it replaces the usual E-step (\ref{regposteriors}) by a modified version in which each $\lambda_j$ is replaced by $\lambda_j(x_i)$. The function \code{regmixEM.loc} implements the IGLE algorithm in \pkg{mixtools}. Like the \code{regmixEM} function, \code{regmixEM.loc} has the flexibility to include an intercept term by using \code{addintercept = TRUE}. Moreover, this function has the argument \code{kern.l} to specify the kernel used in the local estimation of the $\lambda_{j}(\textbf{x}_{i})$. Kernels the user may specify include \code{"Gaussian"}, \code{"Beta"}, \code{"Triangle"}, \code{"Cosinus"}, and \code{"Optcosinus"}. Further numeric arguments relating to the chosen kernel include \code{kernl.g} to specify the shape parameter for when \code{kern.l = "Beta"} and \code{kernl.h} to specify the bandwidth which controls the size of the window used in the local estimation of the mixing proportions. See the corresponding help file for additional details. For the GNP and emissions dataset, Figure \ref{co2EM} indicates that the assumption of constant weights for the component regressions across all values of the covariate space may not be appropriate. The countries with higher GNP values appear to have a greater probability of belonging to the first component (i.e., the red line in Figure \ref{co2EM}). We will therefore apply the IGLE algorithm to this dataset. We will use the triweight kernel in equation (\ref{lambdax}), which is given by setting $\gamma=3$ in \begin{equation}\label{beta} K_{h}(x)=\frac{1}{hB(1/2,\gamma+1)}\left(1-\frac{x^2}{h^2}\right)^{\gamma}_{+}, \end{equation} where $B(x,y)=\Gamma(x)\Gamma(y)/\Gamma(x+y)$ is the beta function. For the triweight, $B(1/2, 4)$ is exactly $32/35$. This kernel may be specified in \code{regmixEM.loc} with \code{kern.l = "Beta"} and \code{kernl.g = 3}. The bandwidth we selected was $h=20$, which we specify with \code{kernl.h = 20}. For this implementation of the IGLE algorithm, we set the parameter estimates and posterior probability estimates obtained from the mixture of regressions EM algorithm as starting values for $\hat{\vec{\beta}}_{1}$, $\hat{\vec{\beta}}_{2}$, $\hat{\sigma}_{1}$, $\hat{\sigma}_{2}$, and $\lambda(x_{i})$. <>= CO2igle <- regmixEM.loc(CO2, GNP, beta = CO2reg$beta, sigma = CO2reg$sigma, lambda = CO2reg$posterior, kern.l = "Beta", kernl.h = 20, kernl.g = 3) @ We can view the estimates for $\hat{\vec{\beta}}_{1}$, $\hat{\vec{\beta}}_{2}$, $\hat{\sigma}_{1}$, and $\hat{\sigma}_{2}$. Notice that the estimates are comparable to those obtained for the mixture of regressions EM output and the log-likelihood value is slightly higher. <>= summary(CO2igle) @ Next, we can plot the estimates of $\lambda(x_{i})$ from the IGLE algorithm. <>= plot(GNP, CO2igle$post[,1], xlab = "GNP", cex.axis = 1.4, cex.lab = 1.5, ylab = "Final posterior probabilities") lines(sort(GNP), CO2igle$lambda[order(GNP), 1], col=2) abline(h = CO2igle$lambda[1], lty = 2) @ <>= pdf("lamplot.pdf") plot(GNP, CO2igle$post[,1], xlab = "GNP", cex.axis = 1.4, cex.lab = 1.5, ylab = "Final posterior probabilities") lines(sort(GNP), CO2igle$lambda[order(GNP), 1], col=2, lwd=2) abline(h = CO2igle$lambda[1], lty = 2, lwd=2) dev.off() @ This plot is given in Figure \ref{lamplot}. Notice the curvature provided by the estimates from the IGLE fit. These fits indicate an upward trend in the posteriors. The predictor-dependent mixing proportions model provides a viable way to reveal this trend since the regular mixture of regressions fit simply provides the same estimate of $\lambda$ for all $x_{i}$. \begin{figure}[h] \centering \includegraphics[height=3in,width=3in]{lamplot.pdf} \caption{Posterior membership probabilities $p_{i1}$ for component one versus the predictor GNP along with estimates of $\lambda_1(x)$ from the IGLE algorithm (the solid red curve) and $\lambda_1$ from the mixture of linear regressions EM algorithm (the dashed black line).} \label{lamplot} \end{figure} \subsection{Parametric bootstrapping for standard errors} With likelihood methods for estimation in mixture models, it is possible to obtain standard error estimates by using the inverse of the observed information matrix when implementing a Newton-type method. However, this may be computationally burdensome. An alternative way to report standard errors in the likelihood setting is by implementing a parametric bootstrap. \citet{eftib} claim that the parametric bootstrap should provide similar standard error estimates to the traditional method involving the information matrix. In a mixture-of-regressions context, a parametric bootstrap scheme may be outlined as follows: \begin{enumerate} \item Use \code{regmixEM} to find a local maximizer $\hat{\vec\theta}$ of the likelihood. \item For each $\textbf{x}_{i}$, simulate a response value $y_{i}^{*}$ from the mixture density $g_{\hat{\vec\theta}}(\cdot|\textbf{x}_{i})$. \item Find a parameter estimate $\tilde{\vec{\theta}}$ for the bootstrap sample using \code{regmixEM}. \item Use some type of check to determine whether label-switching appears to have occurred, and if so, correct it. \item Repeat steps 2 through 4 $B$ times to simulate the bootstrap sampling distribution of $\hat{\vec\theta}$. \item Use the sample covariance matrix of the bootstrap sample as an approximation to the covariance matrix of $\hat{\vec\theta}$. \end{enumerate} Note that step 3, which is not part of a standard parametric bootstrap, can be especially important in a mixture setting. The \pkg{mixtools} package implements a parametric bootstrap algorithm in the \code{boot.se} function. We may apply it to the regression example of this section, which assumes the same estimate of $\lambda$ for all $x_{i}$, as follows: <>= set.seed(123) CO2boot <- boot.se(CO2reg, B = 100) @ This output consists of both the standard error estimates and the parameter estimates obtained at each bootstrap replicate. An examination of the slope and intercept parameter estimates of the 500 bootstrap replicates reveals that no label-switching is likely to have occurred. For instance, the intercept terms of component one range from 4 to 11, whereas the intercept terms of component two are all tightly clumped around 0: <>= rbind(range(CO2boot$beta[1,]), range(CO2boot$beta[2,])) @ We may examine the bootstrap standard error estimates by themselves as follows: <>= CO2boot[c("lambda.se", "beta.se", "sigma.se")] @ \section[Additional capabilities of mixtools]{Additional capabilities of \pkg{mixtools}} \label{section:misc} \subsection{Selecting the number of components} \label{ss:nbcomp} Determining the number of components $k$ is still a major contemporary issue in mixture modeling. Two commonly employed techniques are information criterion and parametric bootstrapping of the likelihood ratio test statistic values for testing \begin{eqnarray}\label{mixturetest} \nonumber H_{0}&:& k = k_{0} \\ H_{1}&:& k = k_{0}+1 \end{eqnarray} for some positive integer $k_{0}$ \citep{mclach}. The \pkg{mixtools} package has functions to employ each of these methods using EM output from various mixture models. The information criterion functions calculate An Information Criterion (AIC) of \citet{aic}, the Bayesian Information Criterion (BIC) of \citet{schw}, the Integrated Completed Likelihood (ICL) of \citet{biern}, and the consistent AIC (CAIC) of \citet{boz}. The functions for performing parametric bootstrapping of the likelihood ratio test statistics sequentially test $k=k_{0}$ versus $k=k_{0}+1$ for $k_0=1, 2, \ldots$, terminating after the bootstrapped $p$-value for one of these tests exceeds a specified significance level. Currently, \pkg{mixtools} has functions for calculating information criteria for mixtures of multinomials (\code{multmixmodel.sel}), mixtures of multivariate normals under the conditionally i.i.d.\ assumption (\code{repnormmixmodel.sel}), and mixtures of regressions (\code{regmixmodel.sel}). Output from various mixture model fits available in \pkg{mixtools} can also be passed to the function \code{boot.comp} for the parametric bootstrapping approach. The parameter estimates from these EM fits are used to simulate data from the null distribution for the test given in (\ref{mixturetest}). For example, the following application of the \code{multmixmodel.sel} function to the water-level multinomial data from Section~\ref{section:cut} indicates that either 3 or 4 components seems like the best option (no more than 4 are allowed here since there are only 8 multinomial trials per observation and the mixture of multinomials requires $2m \le r+1$ for identifiability): <>= <> set.seed(10) multmixmodel.sel(watermult, comps = 1:4, epsilon = 0.001) @ \citet{youngphd} gives more applications of these functions to real datasets. \subsection{Bayesian methods} Currently, there are only two \pkg{mixtools} functions relating to Bayesian methodology and they both pertain to analyzing mixtures of regressions as described in \citet{hurn}. The \code{regmixMH} function performs a Metropolis-Hastings algorithm for fitting a mixture of regressions model where a proper prior has been assumed. The sampler output from \code{regmixMH} can then be passed to \code{regcr} in order to construct credible regions of the regression lines. Type \code{help("regmixMH")} and \code{help("regcr")} for details and an illustrative example. \section*{Acknowledgments} This research is partially supported by NSF Award SES-0518772. DRH received additional funding from Le Studium, an agency of the Centre National de la Recherche Scientifique of France. \bibliography{mixtools} \end{document} mixtools/inst/CITATION0000755000176200001440000000152414343144555014257 0ustar liggesuserscitHeader("To cite mixtools in publications use:") citEntry(entry = "Article", title = "{mixtools}: An {R} Package for Analyzing Finite Mixture Models", author = personList(as.person("Tatiana Benaglia"), as.person("Didier Chauveau"), as.person("David R. Hunter"), as.person("Derek Young")), journal = "Journal of Statistical Software", year = "2009", volume = "32", number = "6", pages = "1--29", url = "https://www.jstatsoft.org/v32/i06/", textVersion = paste("Tatiana Benaglia, Didier Chauveau, David R. Hunter, Derek Young (2009).", "mixtools: An R Package for Analyzing Finite Mixture Models.", "Journal of Statistical Software, 32(6), 1-29.", "URL https://www.jstatsoft.org/v32/i06/.") )