sn/0000755000176200001440000000000012620601735010674 5ustar liggesuserssn/inst/0000755000176200001440000000000012620166635011656 5ustar liggesuserssn/inst/CITATION0000644000176200001440000000153012620166635013012 0ustar liggesuserscitHeader("To cite the 'sn' package in publications use:") if(!exists("meta") || is.null(meta)) meta <- packageDescription("sn") citEntry(entry="manual", title = paste("The {R} package \\texttt{sn}: ", "The Skew-Normal and Skew-$t$ distributions (version ", meta$Version, ")", sep=""), author = personList(as.person("A. Azzalini")), address = "Universit\\`a di Padova, Italia", year = substr(meta$Date, 1, 4), url = "http://azzalini.stat.unipd.it/SN", textVersion = paste("Azzalini, A. (", substr(meta$Date, 1, 4), "). ", "The R package 'sn': The Skew-Normal and Skew-t distributions", " (version ", meta$Version, "). ", "URL http://azzalini.stat.unipd.it/SN", sep="") ) sn/inst/doc/0000755000176200001440000000000012576764640012435 5ustar liggesuserssn/inst/doc/how_to_sample.pdf0000644000176200001440000034523612607745277016005 0ustar liggesusers%PDF-1.5 % 3 0 obj << /Length 2174 /Filter /FlateDecode >> stream xڍXM۶W3B$AƇqizH<;CC$daL ?4tۋ, x'P2Mv]лDgj{W&Ɩ=woaH~m* cfx?XD$S6"n24kp=w_WیJ}cg6nhAÞtjR@"MI) $n4eV.O־;׻:4Ԣ%myIFSJqQE2u,RA)8u;fcT,R %} Utaih2jcV8\<-@Ζ_@-YŅC% @Dtϴ~v4"?(u'0GkTyq4|ܘ['uԵ5;* y–SƇ ^Z_-edʣ_?l<#xC1)ٲ>U=4W,/^CCtE(Uă0%qxvV.H~K=ioi>p|ź&e.'XBAxȆzM4cj*4pV"͒]<0340{TV!яS}3a"VO",> stream xڭXK۸W|TYX3VWj=sHH͇BP̿O7H=|Fh|6o~W5b G''G5!G0.Ry`+@L2d '@M$ƫ4V #_V¤`"1׿1HA:!*wUh_\P7'bUBa oL틼耐w].GZձT)k"2 xq+3:&Tρlzjq+ΎZ=Ӯ xmLJ{1ƾf\2HCTN4 ,sHs"/H0W44}f~it]+q Xm/Za!K*K&_GB!ꔷhK6,9e:@ˠwa}Q KXYA} >+sçbHbYfYl)i;k\><.<:(V;4[<+8 mL";ƫmBF6 !O4n} zjE?[!B5SP3oO7YZbl$h5QXA߇ p%qÚ̮D0qfx8y=T2a7y Ng޼Y_bRF!3<'0Rn qNӗ%"f.*:d[l[R*1FLҮ^@Le+}SsVf.LtBl_Bp (_+hź5 т<`G]m*jY4b@wT8K{#TV/7omܼ6=:T< '_w-S*,ePA 5ͥ$ I$ysڠ2Od5x?st?O) ( l҃ endstream endobj 20 0 obj << /Length 2538 /Filter /FlateDecode >> stream xYYܸ~haWL3uǙ7"F<:@8]+JsקE%;CX<Ҝ.|9ݔ_BhyyI Gɧ@ƹ׉^r=(MEA K}Gʻ %;JmKٴ7yc eQI֯5-,W,O>`IBn-8 wUӱN7pgaQNݵp#L3O)E_oF0RXf`0eSHymю]ث޵=A3"M <Qlrs˞%u'*TXCӕ/u#nd܉ZUWoqm=/Yz@Fܷl slc3!-9hНZVrB L&0cqe [;"%67Ly7bSnN^[!Q1/CnA (MK qIE,AU5qR[ "|0l*UA^(EsJ a[g"TS#%qZl?C=v`َV(k Ua 1gܟhEOw^z r,z_ R3Sr=߅xa&H}r9Q*:_@e~_ĉ$DU٥?P7QFYdHt#B Q閨$ рicind8IO\HoDda']B$:lM8Bؚ=^@G=AؐkIP6ߓ likyW.;+*dn`C€'TGeUiQw48:O ZtO}脈> ;ٴmk, <{Z=nX~_:fI2ne+ x `ƠZsLY]lod,2Yq,¤FF!qP~}#@ 3LPah\0Ӊte 79om\`JB==zy1؇!H0P줉@ G Axw y0kYFclFD5"FfRdyv [Oz,Yz@@!OE͸͊ss6 BF=U K{Rpn0x|LBm[NPHp % -~a(14rVwPw46FMΎ:D~z8H+>ۺEY: *d0!*5@*;p}o;hX9 .|^Pp,L.WN"$u9#eYJL#|eLntDimq|2i2VKrj Ma.]n\_3~QZ,3;y0M|mP ssi%?Cr+ ܣ2{z9pXvhlo%:s}Az[ΊK_f V+~4p5AqގXvQ5 ړԷ,LYYYEJmhW(,#$!˴:ho1A3.x1%gD1KO.@֙T%I'VVsbˢ;6 M}&d'Cr^X,g;)[9Y.$#q$Eh' &fz0O_ O0ƆwD*ط#0TCANCo읷'*Qtrp!ez?}^M$P%' 2yg,Ȧ'wm ƕw]\6u-8H HS3ȝ %6'E;ZeS (o[zL 168'+K&3T?~n p}#[j+LH!1 mv|;2}})ݶԫ4G$)ypi.2uNxQxk^>o.'^"r岢-p9)7{&T!|72ͩ endstream endobj 23 0 obj << /Length 925 /Filter /FlateDecode >> stream xuUKo6W{ˇPm/X-Qr% H+ |-XDNY,Q!Ģ-&q)/?kYݪB-cŜ̗h(CFŌfk0g)lsIӤ%KbwĐPl׍/OE; bӊYRBDH2vgNӍLUΦmmE)KՇ}@sHFU.f6mJ_iR[wnrlg]4c(]:!N]{A83Pޟ/eëv^A:l؛)1TVen} 5I>"*S=XCT7Ёb)͸*h/WNfX.۵C0m]?x9SG2oᒫ^5UۘRgjsn"-D i_"v~S }G^kQ 0d~f|Ak4c0D % T9/<}2nLFaߴ$jPll788I`qXxz(͏8}&ĂD]95̍(E6aL҄Md="/ţ5iΧt˹%g@)r. p= 0I\~"+'5Eҳ&L!ɽExr@z<\#,wJy@;4dFhLvxE)Kʐmj\$|G;hgۻ(`6DPk  kF>8~tШ"SBv[D9ƒ[:}| _vvw3m.?t4W|'{|  endstream endobj 35 0 obj << /Length1 1456 /Length2 7657 /Length3 0 /Length 8646 /Filter /FlateDecode >> stream xڝvuXm>ݍ -%t*,", ! !)]!-% ]w{5393u,Habp#%huGW?OO+"Ȁ08~c46P.0p8X؃a +[G,`+@M $mo@A0db A`= utAp w."@K +Z]MN]ZNKKk%Em--9Z Q5@ZD`cpt` =O+PfisA"jۂ (QoXHQ$  C!:֎P' @ ks>.>>!N^%+Us tb[[t=ψ~*a38Z1xÉ@/EXVi&ȅY+?~ -Pn !:Nm^~g - xxcf8@Dm08Afr"&Q&B ;+A"# !_uq^'VbYp;X?n]ՁC2Vtۻ/wR$ A _G`< d [sA# g_8yyDfC,B rG'sn-Eue%-;ÿ4`ύ`zW" `ËpD|d7R9b= V:WP/{' PL!5A d3;hɦHrSrJ|GUZXSu_ۇ;HY.ikX×ùZۇtCyNЁ {^iRB8rI3炛b#_>jFePgך%i<}[BUTh(VZݡ4g>T T-Du7vri0rc'G@Zf,ƨt?z5b ̾S ݹdbFW'°M:O(;j"{,Oi]@Y+ zV|G(׾,yns9Q ҄UTHf%Qw%BpMJ4ٿ Z,J#5\[? )!rU /Ii%gWnӱ3Xg3>tGݧ2W/fLJ+DNr؟y}|wHM߲pvWPۿ7alr[ӳ1a]dIjJ+%~?duݵfAO3V`A]A0jۖ3Vyd,q.e~iHwdF:{CD_6,X6G"/~yﺯ^ .?&xH$Ds CՐ峖򩞅 )! DvNϒ#yD$ K"@XShыk4v̀ds1c 7>,TTC[(ط^W |p^dƦR1jFV4M3Ly*R'aRBPI WK}G-x(UYߧn_ټ=S9ȟ&i'Y?A2eoQ%qfOwWAztTSC5cS24Tcoq mͥ^2`אXWWiFz_7F9p\ARd"z5rz=B8T*;:l6R6->ֵ$0qJ :ܖ@HEmv$4Ub~AnO"EoQGrV,ۗj,+88Jm&T3Q<˳n~e|KGͽvf-FL(X'NIaNnCbX%!D-˕$)kS:w۞do-{GEz_?mQDEaIf%]ȏCuu֛dU^촪{?Nvy?E%UVF< l3b:WoS ;T|k񿒢/WT$?zzmM Ͼޑk_]bXKعg$@qzza^K[X;|B"%#KBuk&E2# i)L|>E4$gT\q}7^)zJqkuXZ鳑~!d!cP5#Fe qje?ԾEL@h`u8j.][,2蔿#$\Oe¯Bެ){g84YMkJʹ{Ag l;9~7tSZ9M>ΣƗ]"$ L8IT?L'vtۉP=c !77i9}7,uQT{Č'fZKh&m_ۡ&kxi͛/{Kd f{J΄&.F q>L psCSA˄KIUr .*rX՞~O UŻHh8)Ce5dp}Z'&Z[R 4^r$W 'ۿw|{m,įq>]-nT˒p҃%dW+n#-wsB}#TُɄj'E*l(7s*y mI;ve5Ez=F矱DԺ?ؐh^=~\ۨu(y-Zp\yrP3yL3 fsnq߰uFY10:ޤ~+Lw6e4˃҇g=7>  hpsw?gaI $[_m9I,'v#!OKBp"ǿ~Yn.Ů¥uȄ&AgZD‹DkT@]a%q1+,e[P߭!AxPNݨ`|["'>{O[75 N=;B짎RBq:x*X'E&<K1ﮨ2 \^>^..ȈbFuJk7-guYڑˢ_|I1w~ژ$XJ2Mدa%z%gݚPC褶dS'&]D bmΗ9 {9=NAfoh7hh"! j(`t[>֮fV 8}Ib-V}aqtJnN/V1(_'Y[Xy[WtEF -cW)'uDk &igK/#brYR'< Fyx'0JY(4U.b9ZRhSY'{v.]E:2t(ݤo,1eP#jvgz<@MAGYg<VNǜ/ gx BKp;y.T'RjhE!M6 M~zd09SVG B.;+B7U8l"bNɕfN[ߙ˰I2]f00e\{|Po}VXhZ{tl85\,*/ζYxW(زB4HiN]w(lRs?mN]Y09H({"4(N#꛴6}u[fJ7%Z\w"7\V厴RƯ<+ax'æ.@gQW:H)`T;/~ 4 ذ%/V]ڣުm?e*-[weHN:锅Z>_stbo.\GC /'jیӔ7td>iGo[X(]%lWTo3OM0wȉhGܓswЧuOɗZ3SmЎsd,ǷH>z$':k޹9G8S'G:R UG|uos+3&q;L39ow9ݮ=JEio &x}o&7|x8Ԓ?48ݭy&^._: ^Oxkҫ5H{RAe')$?G%jv:N4h./ àa,/~OIpq7R&▘ AM4 .,s.=˖ 4W"`DȁC{/Vdx%W*`2"g#UPD r~9̤5[OѨ7ˏޙuO7Mi&.D.Buи |2vңH 'l}^Bg)D2e׋QmG8]A:is7}cקK0[3׶A`_.5Y.^6B,9+p@H7qg<-+\f*Cx9vDze+sh} J[_xwE;NgQ8ًM=ܪa $5+yLoP&C >ͩ߅Ծ` xekK|ic(x,e[! ͽ&$I:(ת5 8=<Z>Ӂ Y:o+?I {<?ۊej[U! "ah+ 8$ث*s=K-ܳ~ˬ-}gd!$aF% wj LTPi\Ui>k<ϱZ{/lQ<=Q?64*9j,, Oд@k.Wrbu!'wuf#H^3qPxZSޯ):HO xtYBp%n" " EN:EFQm]DQvu'22&䌛؀)*-;4W8?Tc'a%H=';/]:&^?V@.Ok}:ULU@ R3ߪ%qʜﮣ_Y }ZOXIߕy^3TVeZ.t\:TF'FT聻pIւLv7)۷`&o*PjJaCiMHƯd4M.CJL7:9Ke&YuA\kHaD䓌wf{Po0ޭ@'2(}Y1.y<^$R9lX)QULhyOػh}J9umTdr ,/>Cc/2;ʟ#B.xt^87W0j -!8UjawakQ$S;Koe(NmZ E:QrnZ׃ŝddRz6?|rN/1 Vem%i{Oռ4tM]pRgY66o?(vu)x.Ѓ>LB6"^SG,Tm-;MTȞu_mNc%.$<⬾}_A(ch8mf.~Eh b<>So<~`:AE2jEMI1yBl?'銹eRh|hN:[g>JGJwDcLc fy*Wd.ƹK '* @aaǘ]51}ck.D4=F30}8-e|usw<1}?$騍4EA7!@lbBuL-{otEKA1UAddװf(t 5JDS,߽EMEqĭdy]N *0qd6͘ìm%#3l&݂hXhH->JdCe8Sy)KEJniOI\ÉRһ,tickg*m6#?++9v5զi*y>]G Ɇlժ0sn1 %U=TRv9eDi\p# g~D=1TC[ª[]M)昨JSn$%2\^uu; 5Ycbr=|_EdG^X0~[_?{^N^TLyZ~ / /T=4"tt8 H~Cp=/6hr>sin? .{iH=4"_f.mn/*n4*2M*?bґY:*N^o S[6M,7{_Zg%%.;7q(zSmCboL`2榄6CEaNQ8IlJkRC7{i(Jb_H؛φT߯ι'\OuA4g='wC#NH܌6jgTohtԘcVU31MRyYonET(ɨd3s^"~D!-e{9"jGjY`!{¼u)K?afѪ|:!7*OQ( 5sF9,!Ek7l+pߥ5~IKlR?q 8 >f<[ij,Y)$7fUk?Yo:5T+3Tlת;Z4ꎣXe$Lh3l8QO~P]1JgKx~e?r3NYrZb4<OMi鹄ԧ_Hz\_~[4;;?O'̜sBka4zU1 (7|s>bKԫDFIE9n^u .pc$r'kֹ> stream xڝePm-[pwנu]'Xsxo޽:55S}uZ-瑱$UR*lfosȌ@I)4vۉyN y\]>}mj@  ] dao`lpsp59[N)#@ dfd 3~" Er8Nn@3 Af@;' t1vg:*#@RQC\EA^\A ""-&.PRSQ9]܍̍M@>GOA.'#@d`2{'fK @ dgY?ή&VO?tq 9g do'20pF a;+#++Wn)-+o9.NRsϟJ2؛kS_O$)@1deaͿ\^H͏8;1۹~uNt?O, @t YY27~6t'SrXX>9Ow;t.mgnAO@.VF։`4G`Rwn_72J(~ro(QKcϪWc[GgM(;USHvJb+hr1|{u;3 d wY0ss+MMOGS7w&- 59 WO 1,o~]fFffO<Sx hd.+g_Y8,,ln6e9Y|6}",ۛITF<Ҹ;| (C ௮m25kIU Z4_n;FawlD*갅'q])< gH"vQD_)Fi;e|mArDs6,K*\E-uKyj$a|Ԁ>B>5_ˍL`Tse05fWqV-\ǥGl/߰qS(51>ءn{"7| .H|MжdഇVNgTº~ظu$aTM@`N>\p7҄Hb#akUaVAH.%8v^K⵿ɘx[1R3K&<& J_P ^49p+Ļ8BuOg Q&u8`H!T >4,|&34.…^H00Cdxp̾3̎4 dWY~3ϥ]B5TVj%hK(F(J$Z|P#c14 `)Q2*]%A[K\G:Q3Vž/6< HtJrfjK_Pސn` j#{'awqp:~^/as*Pv@b(؛w 8B&o*EFQxJXl=}e ͡,0v w\42J[tG#lhUG]qD_Qt!wYP檞ž`:.M,f:C?epL60-|[x 8B8&;Q9.FhvLE3a 5Wzo 7J 7R!]/!أ5,R@bQgh&v r|@ mB_ۑxs#CqȬh˱; f鵶2 LՕ~goEc)fջ+tap`ȕdغ(DY,s98*wq'x4a~TF~χ `Jo+VL 5| ~ʔs>_HPIk-.Xijc.V^|7#^vDP?bHI[Y~"&NsCf5NX]RG^5HݓaL L%8.Z!>,_D)OX-  mw-bQ.4.V[;1hVew %CptuB ݽ ^׆Uŀn4TɎ?Ή1",KBڇ3;wT~Oz>}WxX6 ʱ>F},  rϲ)Σ%oD۷aCcf̰^<^ga\Lsm7w5*FwihLekƬmq=D<ŮGRD8+hCG\2$mJA)q"?{Y&L^H `^$Q(NtlbgE%܎ ^GϜiػ^_0L6t髝զ}Ɗ~r] l=N-;MHc!-U`\I3RFBw% 9a{v_=kW'wvGLdTNTA2$I`yMtI8Q *p T =|A.=kos\-lsk %5E+XF{bڕ:ĕkkH)2S}jȐiW'ǫ֟~# i䛡;"C]TK㵛rGm򄻸ې%%(%GȄ!E)M@ թX6zм1D91yXj _qgDpxUo{4_X:(p@\(FUmdw.'"Q)Ҷ[AO+)c졽!阔l='ё3ך=X}Pw-ŹNÕXm\?.JaxP3d>w%<3{-w &8~XŦl%O_re:誉4]rX$"qf=5fZ$Q/b j%yV?8 *"ZLQZPg^Y5zx)Գب8AwkW$Ij|d|@~#O8CzΆryvtVL۷]긾~(\6_⾁J]D>؀ N$Ngz\S[%;Kh0E4 !pNa\3l{nz+L)[QM9J{:Zpp7\<]2e"Qש'㆚RP<1LY!rBu9|v5OLoA GƄ/oZHJΡǪUċ^*k6O)A:)'Ѳ2߷L!qH_ْ ;K:svCE$PoSmϫ|U!7,߷uSY|mf/Ё@0M.v#AulE/OOU.rxt4(pYu9PxvB=y1{JCűBSD;8tHgW(.ށ"3hG\Aչ=Fgk%rO?o{WрyٙP5xiAD1135<y݁"wq*vj<7hxewF7@=tAk@qi1F݋xՒ'lŷ2 g+,C6BIۏFȖ,+ P*T76ؔ>J2AWS).kĔjH}aq\>)`!*|~g]`_, ܣ0^k_f+]_ 7$&!H`؏ _0h?jڧ$IZD\j9TG{:6]W=qܢ6'X4_u5ffWL0<,g&CfwZvJ͟`i?1.ק^ni9N qeT݃:vVXgW-2 ?!@u\$ZZ~pr>YAVMXAмnw|QN F'UNM3Г>S gp La*hl V\k{Ut<+|E[aU2?hGE8J;sQ郯P_}ˣ k\1).*'!n\N]V򞨵,tO)/Q$>l\ dYtu'&c{D1 .vSv`Gf59G}5ĨE; F2V u ՞G71m 7l8◘ Ch'EO؏g©HeTӦ "H)?飝T}(o WNTLs|dI7PW+1tÜ#$܃+7X6 I1B[32$R*3Dj1տ/֕\D)GD%{drePV0w6 q 0ɑDIc(1@/@R)W/ir57:+M} NςߜDL8miT3 /dW YVjމ>\K.ED\!~S/wp͵cl$1XXɉbSIŕ"v&G\;r]lȌ6<Ė3iꂼ>eP2hɴbCzt[tUria;&QfyT'|a>'IJl pIM!9JW,ojݏgAE(Gn'zfqn3O_'XAtٱCn6w\sWBYPӍs_gד`vC׽ٛnPNŝWAV[O$#knF!ߠseS^֚4UI-R_M&Bv6ă.z69X+dݥyTQ,!RT(8kĤM3,g6HR x<!>R>E)}ͬR\~dZk{DD5+INk)6 mpabjԡ""ViI ץ%Ir`uv[Ң՞}WaꟈOcN+(" k'MbMgn7Cg<[Y22 8 !pb z<^D N[xz+1ꞧLˉ|,/΃?nJM$!FRvIcJ|Ҏ[E~ϟf }U"‘n%}8EC/'!#.D4Fb[ѕA?sk6Vr7-@$A\>!PSy[ 2h#0|SR'q9"R=grd$f6CqT"pTKARo{?$ FSH: Bw>(Һc0S!Z g%xYe:3+~L`&V`Yh0]ļF6xWAe+kЙGkz1Ld$ t 8 P'(\]p}̔%TB.g>jM>tMCk$g"Efc"^+#{Li]>C ])co3.9gG?R4ol)JU1;ax?}q"-!ڷZȭ ,R,nYZٕhBsYC̱x& J\Ņ{!a1bf:>WC gQ63ۈedtm_{cۻb\F!qũ#"N- _BV,u h+9+tO0i23D{נ0 TEcڐ@lkn5%S8ɏyPAHp{}b%,C6lvz_Ag3׭+%Aȡv8:cE9پ*;/U.Ѭ  NDPDr퇡Ez'2TopQ#=7)5m ƚ^\A\ y703(_k~*WlG [2 Տfہ׸ #^#56abUٖS5h=e@&`ڛtQ-ޅV0f[] { uc Ogؚ}+H&lгD=s>"q-uj~lʊ#]8%=h<C-cI{~W>n&?RF: {P~ kWs5$yF?@^3*NjJxGWQ(HI/xMՋ˂r4O&~؂_8BqO 3*dnӋj(gKR !ryI4'f/9r)Ŋ\F"<+l7ug +E]Ӌj z?)} `GC%T𞞺J+BB{E+*$2z@}/nׁdcj>QIL8G֯y^Y{:x~*;~|X0>~;xDLsνpFelugѯ<7K{eFxOH4dLJ3d]LŚqs,Pw`2ʈ]/+}uLR WunаB'%~ e_؏Ib_ޡr0z"M+>y!jRz1,B+딿[Q!"'zUo`8uQH*+$ovb tޔZ\J2CcR& SG_.3F!.u==p^U d/)Q:5'!ZJCڱŁ=[TLq@CW-SBP]Pw EnCLDc/\qd"s' ثM _}1w@qt<HP} >3^TYk[yF @ - Vzc+,Z!LN5@κ.=WX)PGRo3oȲ釻%{' K-6u%O`u{͟XA|flsVZmE_l4 i9jP&,PſOvbbtu2ي2(ɋ<pGxI,a39"k>{w#?:pϭFGt‡T.Mg$Gq% $sXܭA=ݍga*1BR Kq5q-k O ~SKc Iq:WHzGm]'7Ƥys&:ԁlKx>ҽ/ֻ3=xq ";;]4m@ߖy*ٚX}FJo[)!,*"ht<`( %tU)@oc7%N~CԀ0"[2賣Fֹ2_UL) VG-$G-@`y+&n 8}UHHG8<;Gܳoֱuqtߡ.5HzDg㚸:Xw1((NGSjItN+fpBqe࢖8\`(}0 XQEQu ϊDŽ:R4$ZnRV.="ӃRtn0I ikHUR)nv0.Kľ4}i#v-TOVr _V̖%VۃF',V\AZL!-3#ZBXωv*l4mPNePV*iKCzp 8"˽ɞw!*ׄ]b0!x|@]; ~ ꃜʰZbnJqpooުkwZOFy$8B_oXz &3(t-aGѻA[=κ Ӎ_*c v_iL" !%$KaClJ[/aT5Z/1y^gf#E&#O\{w-'h-"2݀C^eg` 1=_zK8$8^<$6.qOW  3k.2ۤ,yF84 x餘Q(m(Πިx&tkwu1x|i LE69`6qn 2j@CSLtdXnx/.@F9Ăx( 0ob&wKamuޓպA 'Ϯ|r/: o0h+QA<ZA g1գj IF%yÙSzɉ[djx P2pNٹTS,i+J>&Ҽ f5ElI?5`i&N~~[xk~g`G2&UL׷#}Wͮ8WafE%yS)K[rK>O V-L>e1k홧LHsn"d.d~mËRBցPf&c ύ_y}R`5E\sh3a|듎(vx~Y܎h&UEov,\=?J2L ú? ;N2s]L9u;hg?=UY:R1Tfq~X ճk,lfOT+U# oHo٣Tʾtt̶P :ӄS`r ~ˑAq"߲F{CɖW2/[7ϸ~Pswj.Â_cف_2AɁsߜ"rMϥLzG)Dou!u0Oy"Uɫ}{#/N0r_Kw/HB?ŒsLT327<r8,ꂅSwTʭAߩ`_cvGyO/1i Dj VIiR YuMnq+!+>,^L]I_qޓ3E3Xhx[m߸N Ķ/~ ]*Sgev1 wMokkJ5)\>{s٢?"#"sb[$#}7yt$v{@;Jk w(!~mfW[NHoW*#;KUxh8 WnMx'WbFW=p;`%`cB9E'3D]a3rk^蔩m9JhͼTr}ĖeQ/QmF E)VD(ߴf)Js|Uũqy/Xd25 Gⱥ [Kђ:UAVrgƢc⛕ߗP΢-+N^hj3dvw2L7̆z3^j5P[:{ <>㭎jOd|;^,t@[+Ș506]sdz[F loQyֽ9bIKK:U]]s5PVYF:ѭ))R *+sVfHP<0y8r6}<Fձ2%R'KO"8&Ƚcs6R-jnmhz};>Mt-8c҅Z|bEF9_PO q=|B0Hx$P:=)czcasF` 4ھwJۂLAWNCXLe#@)tڼ2;L; \s{LεA=mǖvq {,L^HL%M5.Vr"jihH9H7[E=xS?Ok\Gc~rE|\rӖF^w 3koH(-A blrDkOފ%l^Xr3?Q"x\F1Cd K(A1Y'U6/ fz4">9\/ayyRP$ tHP-RXs3mx>GFf8}AG^Vsި7+ԮF)A67, ڥ$.X!俿D\ d)I`xP.,"qoƛ C/xLXDgr_2\B`OQ 8 !@clږkoՄ:~ǙȢo9M}rg3p0KMÅ3%tavL}Sׂ6lqO@prwW@i:mW!b~jSB: D%Zԇl@˝b>oW d"]e(uUC%u'cgRPp@izqomhwpzRn+'}~2u0g8^cu%&Q\dmi:V@N|/B\GE"?"{iƥɴU?7?Wr0qnxdGi9ھGg|[C ֬wR_LZ{wᙦN¿:dȮsWpZ .ˤοBۨQ1:;7йC5!*xa? ,~}aC4 qn09:ta#XsDSe/jAeJO5H#!zї2rRWiujBR=sWj+jYMn>δ,X Y'tbՆCEQ`֥\#•rb?䏼Jh dڶJa{qMn3Mt3p,{I(F}x4ˉco-Dۼz8Z1+ 'ua HY?'}l/ꖰH0Y\!"V= ߏ֬DQxA|v{( }ԟx-,,OvjمjNQ0^uǕLf*\`ࣴ>4m$r'& Ϳ {@̫-_1ZO J1W aZl~hc6ֽ 6Ԯ6w5ϭ|Y՜{x[Xl2O()~tHf@uS_'l`[xa nwZaՍ~w:w1v>=#C`d킅SzWfMLf<i3SBH%c6oL[b=)B$|44wز^Yn10 kp8ǜڜZJ|mEjvrnTIb,S*]ލ%k((~b݀2&flD!P.bߓ~@+yb4zKo9tUHwt-A6 eAb?L[5SڛRGCC7yq;w;oLpɾ lFOҩs- ѕP_\_-ɦaF}lU? k6duWb\!y5 /WUAN Xck2$DVEָkNcON]ϗ}Іo0bnNGjE>2FlwB&ߤ.rB 5xnYߘcE9˼W"njz@-AYF<+{͖Vӗ9k[._&tx!f믑뇌7F+BSgq,њUy1B篰~&F lVԹ PP)Ҡ=\ vI \)s!J\tG}q6Ltkp:uJU*w 'loPW_)I8"vTSYas4l#9EB+P xN}[m)A+䠛:nsM7Ճ\2M#R_m"'[F|7tׂ>5XNԫ-03+^1̂<_:'0f;Bt|tjcgʨaj3zqRXJLbX~^ľyêF~Vy)W @QÜ}O.EEO n <&s–ό_|;5\pjkE3U%]tU )2d;"Y`P N 3-'EstagSznN =I;-@{﨣(f0l?lSU5/ldN),_ZDtTi%aU.lW8:Z! j*}`v[${Fy{=#baMDhnM:EnO FSk|B/on+q Gp^hϹ0[a8hkZ!ç=j%|d| ê8xQLX pnn>Ibn:T{wr#9xCg~/S 4(RPsN[ 1K6Ȟ略!ݓ'_޵d_0/@ڌŞ鱶5 Cǔqf&KzC\;map?X# r?nteJBCx# PQZde^1>6I-!9ey3)r kɷ/"k\u pr$< SQF@ CzE%Cgdʰ xz g5Jw(xcyiS^paN0q\b_3@X! w>Ҫ۫s"SYB:`%K[i{ P#U=Tü X7 /Í(rםn ٔ7ml±H# $FAQx:6;Vp ?щmX!A'R/[ HO)[_1#Cj+퀠Hz7''X"jwpD/ kMb8:jCJ6$CBt#Y@=8%Ϳ&:* hmDi;A?/0N endstream endobj 39 0 obj << /Length1 1468 /Length2 10276 /Length3 0 /Length 11268 /Filter /FlateDecode >> stream xڝuXT6 ]J 8tHww 10t)!]ҍtII7HH=癹f?k^4Y-A2+'&=$!R@H T\NA!n!^  -O'uvIG'O(7t!W=d pw=?@ 6$ HH.(uY%X-AhǶ8A`  fdȪHk(Kh454%rZp- 02+ 7/0`hXHN`8B` {GW8*\3utA!p`]\mApxp0(O ^9 `!c @!nrqqr -\2Г~?ۀ uOGF)U.pp$#(# /g#۟ @ #q7/O1/Ȁ.0&c\<\l6p ` o&O$\?&=xkL?s.r6/]\l։ Nt{,AV*0x ldqW:9JÀvGl. FGC //ET,lV@{$=׆X`HwsX99akG-]C[FNEҗbWNrS!O/+0 w GK0>uB-$$=ެ\\|V.n>xYy>e ;w $\sx#GxMa4\-I:{AEqnW١Q*Q֝Ư1;0r,jId2$7ja_Ivekz67Q-!2}s&PbNJhZc8vpOmEo1b^ϖxX>Yjm`>(|n<L<|}X1!%o첸wEF"e[S2(a%0J)n{͉_[n-r9]L/y txSwr鞣,DUq.5PwޚwRw}Rt(R>m N$!*^34c_ryS> 38웪o2 bƞ9n,l& ۱||* w*`w|qJ^x '& /ؠDDJ>W#^\󙣇 ({'v<%W \Q^eʼhJ6fïUK,/_C6+m?d` AJ( $qdƨOp0滞B:y-yMYf*N,%p )qkšO6*  c.3HAv;n-$3HFH]xesE;?{ 6?Ji'S݉AC<mb&2V]j{`m )r5##4'9ҢR{7nDnٕ/Ber+z׼sTZkth]ыjz7Zev7< H),;PKd1,0Wj^ybt)Q8,FY;|}1$ iAeTJ ǜtTk4^ (=} ]DR xʶ ourAm{u%JnqT8;x[5F(J6zrmg'EqC1Mn*/"Kφnx]F]HeB2HqHTrC>Iq`D1LZHݙ3W ! nc [.6e{]ؗX3ҩܹ|~R-%_R H7E|H4=&*YFNzEÃwX e6iv%a^1~\Iܤs|Vkj`@ K}K_jo%G+ ~~GQ˹yTH+.P%Bl!\,FsԊwN,'ihm:/$7{Cr7Q:3tɄT!9Ы}xÀn=LgCWL4 /1b#ʟ#(b#d[Cxd#=lvNdjmuEJv~ugW`x >|o COFvc.`O [6$شXHdNxVFȣ!fb) Q@mXV_tUN_X_@ΜSy2d!EJkYmzXbL\O࣫5C*OJ)#^4|wIInRׂ,cJ"m6r Un0ҍ tYj £}@Z*w-?([/Oez?;JFnvF{})7>HLW%~#s"Xeމwk'wqrRf:!'2tlNWz۰E3,[ {fK>ONY%:QXKb>e_ɧ8}S +1t>KPZf{Oc{oT<P=DUJu;ѯjPY )vNQ5W:$ CR+BO$坕ie-zDŶ -4YΔ&pOЋ@3\,D=gF rw;\yx-M$DT/"*;yXP1OWgE2cW^EA(}y3+i [7`Q!zVj>~ڻ b`{C3vm1YRwz9>0ޑjmpz\ 9ݯt.p=+ͧ.s4'bmET(j~Je:hf7FCy" ^DyA~Z}uD²_ m<< SBշJB0sٹrZ|Q!J0MM2|2zeN&_}6{t2c*x"JrBxp"]7mzC 6RrF 3aѡHaRhN1~2ayÅ ᨑ}U׋7g'|DEfaNIĶe8^ƩDPlj%/#qÏuH*N4,EyM2J~M9ݞ ppT~4 NV"{AB׉&q>ُ,D-5@-|ttQdp5# ³j'DFf,-\;$I`wpѢȝmms襧J:MW_d3+j/78tʃNr ˧شo%]2Ej?y*!7^Iv YɪUW:ƄaE"r(=;F }8P6X֊HQDۨv*⚸}c(Idؽzw<'4Ł%#2lI(HSa=-QlC !ZߥS-CGTѹ;-N{Z+ctY G:[ڃʟ[x+-ҟ(5oϔ$y!pe;|ԤՅMR*U6ӒU>ZV6}*m2 : G@2nCYw[,syz)1n%l/qY,UbR/jZ9Y;C| cT?R-'"yE%Ab>6H 4DHTq45A%o|xŴ+'@a8 ݆P}SN m l4&94E3-t~e&ȤG)>վ8&-cϦ*z_iJ'|a#qn3,ȩ}<9؝S7)Rkjȇc]Ƽ]qʙ21|^SFpN P]4-3XvP@SuNc\,wَX5{ob4kWțّX1(J ?Aڣ󙆁Kiw"DފQ# a$$+~݀'9C]gx<ۈZY7闻(U7hM7>wui䉴!K19M)ek4?3<58!:vodVׄ\kHʍC|-V\19W*+p"3|-8Q=\="9?JFN$[1f@;j[h/-:a(a:V|SBUb vmj6㴔g{SYATmiQn`9:ytUKoE,gRx.!U:b6.?kR/} !WCR]# Ӱ`}]̴U呻KN]Q~h#sBHUYuh5wإs~vyڹfYd(T'cӌD0nt7IL^~t.t?^~3K8h652J.7Ӥ*ÈK>;l#@f^ʋ_1%^E/2[CLd)ƌ,}\ΩS4_J:t)}ҕ 2z}';gdsǂ6#RhdχbL,AHnp,I|<߱ XxD0gnMC.@3_#,r.45ʝͽ?|e>ssE{MPU'ЧQz;΄!)ir/L~o<uY=إEc?lʙ߶;=GhǐM1HNuSW &GLҦjy 'g52@ؚr4l}#:OI=zK48+z/:8eM6Y?٬5C;wrV;'yo87$KmM$YUXFs6[QBgMwr+I/|P_GTX0OIdI/쭤sI!:@S]:yĒkK M'ի{{C'^v~F2a4R~e[7@jV}GJlCqYs2 @y. 3ժ󣪥4CDӦ_W5DKWGRH{YBC qf`jc.%ú>#Fa61uItK>#N;@XÆh#E}q+ۍĶICq{̎tDJP1r%N_XpbΆ>b3AKBgAvAY/V2>F}̘stlN5orGcaqy5~Sd~ixWFKM1bOp/`4s:\gQy,dCw[/f`uC/OFnuS6deuލNr{ܺZ1T\X(SHu G+G7YGc2b$ Ϗ> stream x}VycpRo0#I< ki(2 a폅** V/jG$ KQ"s}pM@ Eǡ~Qڀ?(]@- `$ O8?`Vd|pN~=C(I!UUktյ-x3Ad2HHD}𬵂`0ߓc}.ӳOhhO]=fqOĆÇ~{-PEByxMBNp\{}pZ޹+ L(*qƙEu-~c9R/9+FMz=K c!yoNw}ZIe)i.ÊY vOjvib#w/IDY: JZxg%Ў\zQSjtsT"P{cs\tRTh4yk&,ydF.{/d.4<,D~.uڎ=^5li3>Zܫ]%q5r3*(z 5WxT#jPA~Giʑ7olnTs[[_]P4R͕=pRXs]QF<~_w\YeF bJ-_푾3!V}~c /1MjIDZtՆi++vI-&1Tsa嵽Y%ꝍ5˫;#« Nfj8쏩}i3 y~rTcjDxZlY3_?=d"<30AGO/4f)2^ +٤c`$p/g]_,*N4zla֜^t;BC:wL΃h4F4}avW/tB>|p&Cc-%hbwS^>}c9nreD яgr.'?ú>JH|pB!絜}S݅+ GʏO+Enu?(?/YKCUհ٩Uɿۜ^ g |.,Q_4<: 0Eؒ|3rL 8OtrޕNyE\z~q@5!h&@kQ9PLNRNǣ8>Ywhr7٭#OD,4+& e0JVg!!O(dmNcS"Y'' I^ 7}tUΎ;Eo=$P u>]\7B<`v۷)T>5Ż9g|mbnFFNBG٩ώUxXaM ;ňyf* |iě@4&-gt.hɲ6PiZ$|6EJ*Rksw ەaTg谲3HX5+e7="aFL`^I2lx kKcmnH.s ^tx G4Uy1\[SAmL+5Fc+bQQ5H?)(*s#.=2uv K ==X˷ wC37C)#ox).;jTʇk3´c%lsN_k6h5)w/ᢠ@0#MNUN_f|d&ϕУ7fn Q`Ƣ.S 2=X}vkD]_6+ xaY}#l(hg<2>"Һ21> stream xڍRyTSg3cEʪY q(a% 2Њ,LBAq&P) :eb[z(E<`zztcw{w`!P ED v 0"/O$rҒTH$<ًI3I4@!h8/%8$ V DPF+mYd.R;a2pos4 1}/*pBS0X(_iA/+IޮڥJw6?|/D "²]Era"2h FD&(+3KU*5" O#{#H'r(@bIt.c+`wMY|G@՘{K`%H$|ozވ0*A:у :/gƛT Da|yBI.[Tt'P&[Szcv=qqy[}cSZ Mkl?rg3Μj6H>nŢaںх }r:>:MOW9CyeG^/,wpƜ u OeE(h;t}d0V_r5lj1ۡn`NՉi̴kVr؀l;yx%MX?ns>/LN8Zu8G3L!^('I8yiLQYzD/xBsj S5[sxSཛ߃ؐRy[_XPwm[: T~R_mgstӲ Ǔ;yo/`iWWf!TM MNm}?%v~v1c4^gʹ;[tsDD$XszKJ_56>54SV7jr4vN58uK~҉QΖ#qʾ%7`if1Kw%- ޛIgbw@U5=I6(fF޷lϴ'=bTh۔n?rO2ʿǽ:sw|>E/۰:xET?wt X5xhIu4y J;(GVXg#u l1>Q3c7yȧRr|Z|*txHW:Nsu5d.x-mҮ0a[?>hrNPԡv~❳ -&'G GFhu4/zts<]Sq~/:$$zl6~Q%QC &i }թRAcY-sss}4c!d͉|Eoa> stream x}weT\-8i\Cpw'4h5X 4x< \B{s<k5U5k~~,VF}Y+ '4D @-H!ꃀ#֜-Ĺ&@}w$ vA yez%P_T܁P3䱥18):C@7l?08G>:݁ 豆=]mP O bC@{$UBz @AxJNNZGU_ 0'O1TYdvNP ?.jCZm!Nɝ`p;%Gf A6q tMLkxK60_w lwX# |\_E y8o |>>>_8ɹx yu Hk G1u'xUAa1$?t0ZWL_WnŅj.d3g r K8(_+Py qC,ϖ(ֶ =\{a彝XU#d\+Qea0OjCz#64ۼ3W r؍5bjٻ~QD {-?zB4 >!̶ YF#L/|R !6jXwb>D.MaۻCJI>FDIRr,5]}irʜ&)c3l:f%4ْRƝL: 0~_mN(qb~ ^I)%C1ghdyٱ1nHh{KqnV /WD=xu:E?;"PlIMw,aOA2]n[pXORyOuBBKO. ^WbR*:l RwHُx"XAˢ!Z.:$p܆W3_J .Lٸϔ M Mbǒ.6}c] ۛrn*yW5j g,iOE5v?Px9BehxGܡ62,҂+ T#6NFW֦e`5CCJ CWHMYp9M"#)&dC{S8VU+FΒUW"03Wv4=dmF1[[ ṇ`qwҥ;;Fm=]> DKC.7Tig!*tY9fL պMr%UO'@4צ M#E%r<69#}msO&}^f0sny9_$~!47G#n>ot/Nqۂ_kJV9eOf?|NgdvWڡ>LD|9Sbkz)'>}M`=k|O] {~-պ;a ph8Oiݧ TdQ,#s`I_Xp^j:~\Yv ޚ,s>S#M&E5R4'p;^1]2NdnaaV}8d6ǸgfsGg^A* E s| AŗOK6j# 2FIwX]i8nZ]ڜz2[cuZHhl8tddl%ѻ$S #>bx)o4#FW+k!mO4nIiB7'7JeT.;JDP<>"*ZW>R]&޺x:d͞ 'sYŽ!(Fݚh.aB1_nͼ*F *0i<˨=x&58ě~@=y(4> 7-+*XK^gDsX=_wB:2FbZ8Q퉽,Vk&y&Bgb3'9 i"',^Nm9QHܓ#Zmd|ؑ;I馌)ꗾ='1u)1{}e˕搕e¡{f&e:h4EH)}你YJuw1Hl^ۛݑsi&wk[u:+C1W!}nWԠC8(dhh8Oҩ)+^ 7 ;|TRcz xPK\4:pMz%um(edGl,~C,> eҰB>k&DSɾbA -ۗ"Oa ЇMm0P<0U4X*NN}W0?HR JWr+oY<?2Ya%kcr?U:>e5>%!w^ȓ T .S{_ebh:9m!KhliXX=v9I[ʹN:jìٞt2~:bx3kT,0^fs~'0[@EՙAy+&(8񾀢!q6XLzƇWho[m$c/1M(Szb_OJUH=EY1{1D uz&{ [ۊ&b~' ]!V=&}j1oyCR(j֍#5 @9c+a/~YA] /Z?ky5Z•7g|0 o"Mծ 3!͍W]_&ƞ/B$?y5ZozISY[ fy91ة}|c`a8̇C<^sm5^AhQC{xZuޕ̕WXүBDih# NwجF +04mӥլJ*U 8-J`J3w90~?2"mИ6AH.ÄxP)Hϸf[j6'9[*{~z8(__VU+t؝5W?=FJCv+, 2^ ԔH".5fuY#[:G#?V#ou}_~‡27?Hq"嗌7~&L>;υ܁%OAxPRrxiLw0sڹp&ԅZ@l/aq{DsjB*nT6xkElsulE*Z%0nZ :q1G7B:"A-](qg⿑u/);+ D??:QP*`?P;b={t>p[{0 z5^lȏI,T.FgzZ0u PB/n%Gb\ZKdytϯXUj4T}<⹓,8D,SosSkM+HLb%ω_1qFvQ?'@Oϻ}S#KTosfLDϕJ6_o*& 1-cznStV&~&=y"~O ~hr/yrfZ5 |ʉ,X& DzX𳬇*,204?;wjtDiɬKe~qڙT S4e]8cn{܂SaV/T\y,k+)a0f]Z&'Lzzh\A}W-|~Yn̏M[ E9Gs.9ꥍ'Oy$Qnxv{5;O't/U(ZϘ3d_FdJ&)ZD:NyClb_c^dv|M/G$ "OD"\ޗ<]|'y/ԝY<6_|-vЇQ,m2q&Ml=Q6&F#NnzOwS.hJf@r^|.6*ine%U.~p ! 8Բk9?{ͯT#rq C7a'C"مhlݳp= Ϻz[зz셬;8|}9 6fnܠ˰m\nuȳ"p^6OT{9?#̸{I(VՌQbJ1:rԈ#tI2];9əUXLp]S 4a{>#LбkV]?NQaPxTU{gg1Zxq 5(sFu 6pY 0 ):wT1,KwU۳ .n:E(*bf^1|? :mu}Կc$dszn!j$YHz&vG}Okut5}JrN #k;ર [4}V\C޸5=&/HE5vlz_-ps u @C, 1rhoAJPpGF[?g1%Hբ$!*w ?(Xu>a&v%p@zk͠; `kڌO${D1b̺H{S92Rpyٹ)mo$ǥ\}5j2zfjf:s gF9;r?@ ^n#8Y{b^'G'L8=D̨~g}6r 2{(,g7W;ëڷCqC~tIz~ZF7};"=3l&0=p󅲷jq*ۨgbtl4b+,^쎁Q,/xKuN^=A.{y좿Kcv[x50=~w;ȌGu )7Ů;-=zJt1BnL.91C(sKZ;HF i 9k-bbF4_F&HY(Sc]M: OgIqvV=_޲&]nZ+ 2E!լӯ@#JTOMqUIg1Jءm,a]*{t9rNY[Ne\1”@"`vO =s}5y+5'c.Hu=;{WQ{vi>T5=u̍R Ĭ58,Iپ+I|S) ;vDiIΈ̾f2"cn䤶{'.[?w}l@V"\O$Ȏ4DWi-`C\ 6F8b4gh%0W־K>po#%0lA]b2D7:7$Z~>_:K؋PjuNDvWs2|(๸u D2bt %&!q>ei5QuJߴ]@dĜy{vVk"M$=s,5䐈v;RxOQpi&HOgl-q>$ҵfꟷþ^fke:bD~E6Ps?] / S`@ tI}q6$`SW`:8|6 VMtJ7NY(,l}L꾫xSF!A@sXS' Xezs7"{yf|?d1#`I)2=2ف 7pmxJ!_2l#,+E?dAJ.8@é-Gs"4n$x0)fj'h 4n_k™ (($IV VH,ue=F3|T%rWҞG|¹B6@2)MJ4vQS*yE 1\vO,/VhǍlJ)yq_?pŪ@apY;N{e|xk œ|KZWk8l,Q"LKK{by> stream x}SiXSgV *P? >,/B7@2uas,U>,E쎲s uZyɟ߹>p`љv E( Q`2)ɢ:K8%#llX6ek;%se%,&˒fXy>"!!՛J;c(@>ፓ`⌋TJ)5\PX$w"t!t("1bHD΁T JRHJԦ$E`8T's?IbW$P()C(T8o4USfQ|Bn$rC!$)c0Hΐ(j韚& }7q#Paԟ2~P |[GL vDn">( |:(8Š.F箔*a2?p j>1S _g?o>W̽ p ?"E12 J󏞊GťN 8̹ÿ! ,XMigVƖ#&OB#هRB(<ڣ8>1xV&YTmu_g3{"nz7yO.XlW3*:5#Z]EwMꟲ,Ru,&)N^֞ҟΥ}o*-&Nn;u-ol>lX2Ln~tg޸hb~C x,8]rPL<[]fu49dޯWj|#%mNޗڲB$evu7yt%k:Zʱ+WѠ\~W^w42. L֔1U٭_ YvWSQXbGUW) ş>'kiIW~Ŧ_YO꬯Y jAS]FFR^l`1m?WNz2B Q7takIӣ&w}]`]j:Ubz Α9q6P|xn$ yird$~X2{eg}p>:-ҽdEVOR7"sCޞ=yʕoKZ4𔜳}t#+S&֠K_-?zCyjZ}r-|QH?Ck %FתM9m[ 'S]绳n8U/⡪iAaSCiᢁ~_n4r{hԨr'ALg51tg.}{|wrA#mzkohVŨߜ gJ}e"STM}[&I.!o@Ya%+tZPZv .m~@e^dVK*ݮڱDzs>GC\UxymycYu[Hco_=+Na//k#` 3irpoOh$?qWj<ݮ2ic_A9=((|woIxm_{m*ױeJs_+eU' ZEFk8* 2=Lden$M_owNR!vg[}>$i{7x,0йD+ x7V <$aarMfSkFi8Z /t[us75j_M Q} endstream endobj 49 0 obj << /Length1 725 /Length2 31586 /Length3 0 /Length 32154 /Filter /FlateDecode >> stream xlxceݲmVkm۶e]mVwm۶.}q#^?9G9rXULPPScff01‘:]Ō]<M@`f011ÑD,,]TfVvV [w+SK?E@ 0D$T I=fbke 2ڻfVo@g;;Մ%⢌jc{3?.<?D&O?33`cofnM#}<a*Tvn@g/=AK5/C3-?'L]݀5yyʁxϫ9zi1Ki;-no`feoPuOcgV2W' ƮV]&ӿF%"Cg`03X|\S7ggM=L@'nm7:-Ox vvHvteFj ^ `&ЄrG8p<1CZJZeW\ap cgqy皹D3ɖw^'TΏ*cTe;au^Z-K O[2kZtm"^pCchYTxSxe-4)#_Gl+b۽3np3Hu*cCxP懲qx*Oqs;@P@:gCO=*~뉟7pwoZSS)*uR[f^.Cgn'o]vUiCg{clUx6p:WTYѻ J놙G=ĆY~ i_2I DAL񖂉H 7iBVTJQQ+֬avAs5&r _UT EDʴHϳ{FFEy_A`2m~>fIlBwʀ&)Ɒ;w㻯IaXA e3&뜐;ScJԪb0Yn3}L z ޼v14,Vh7{HK^a W3I$i@nLVwOJtNqYaOڜ0^M)8G#]ՈXh䭆lyj΅{N5vB;)2m8mڽ [G$;!+Nq5qg12k3)Nc` N gոw@n^]X~k[Bi>Yr3j{($}LWelLh}E.OٛY^/yWǞSAc 4P rcf$k<ᜤntYKzWQ蒭_>yr6uڒv1 U2@.˧0w;UvءՄQ"Y=l:km}NO"Rjڕ\dۋvAti6 'g::ZJUTD`&r<o4XyR,vP(i頲]b5P~رUX8'-ov1^q+nQUjQ=f<IܿNL;)7XUck^+- I̕bk߼n%Itrn퇈"hV^ 8jgv2E̐?U0L-k\xGVf9Qmf_>˒l)`'@9tq2s7|`-}@5Q><|p*^oJWIa؂25KRRAbԱ|p3Ju+JS9i2\w m?>ƨ1jݶ\N~vE6qRaD(m|=%-""Kҳϰr\~f((fⵧ .Km]xE3)wW0=tpC/Ka }**uO8":ڔ@qpЩ [A%!T.|-U\w3dt#>АlJٱG K 􇠬K} Ebk*xVy dj I݈?d"6Xt(I~<%$R j:B{uIbR~Q #o +sk?5#-_EҮE@|ԈSRj-ϗ Z0y^:+7MSR`rمHi]s9ˌ]4QEfm7h^ 1"2#z 6{'1m20uJucS W߆ |&s1Lc.nCx^MH'~Ka4:i#.!e=@k8xbӖ  cER1!ofm'ӟM垹M_zYlDYHs0o$(7ѷ_>G>dž:**jtVΪ WFvL}nU$Fk f<.N ~ ou}ŏtA\4jHm]߇f+DAz%;bu;N452 Q}D\ U7Q߀ޭ0{,*ǘn ^r ,S}` _"#+KdD-Xř:JF8JP_8ҿ>o&;b S`>koU0v*ěB+,EJI@fqKR`uoۖژ!c΍>Zкs+k՚gy -֨q4A}{P~NUm/u!qCE,sPŴޒص(蒙M1_)=|PFas!Fx,k tC)':֑\&)|)}p[I9W96w j;Dui^\1r]Uj=\i|tW!R9u+wmeǓySFn`Lìn^˧}z#[v3gAZPԯ}áFFCsT7׀[qmZ_姸c9 C{0nt߁ɘZةbf"g6Qmꈀ8jY!DPDH'.,-g.2g2  G/݂uByl=^PBUt)b'ϾKiwK}wO<(7$ftяљ0!  ;8,M+rgƷ#e06?j ,㲛"9"g}ҩ;()f&Jp4_B6 ?u}͓A UiuWX^h;g +1=Km,}-m}Cur&݄Q{yl8с&a" :SMYjp.F =xb C}ǫ"16 x:OBAgޠ'9b(pB9b$u2 ]kB,F&1읬u /-gC!K$wZtB217ٱYP|)YJj'{JQYwpO^m1$^%X l9cno!ʙ " D< ׮npXܰLiIcqV` ʊ-#b"g;36(_{nb\Nӏ3&| ^- 1шYu& ܃B?^.DHvM;4+`<0uiFu.W~Zd܄f*d)~}  b *'p sHGf:Pgi^+Ȇpu%v7~jX `LAЂn:?e[XtdtY9 ' \uh&zcx\!Y0;Gp۠:V憀]:M>_o!jVGCd.+cK r%b'5RqD0#M=2z;¤f8ywh:Hph% hGF^M>ўt .Rg(n e -:P}6Gv!W$Ҫ!- 97MM;J G,Ͳ߲iʬg2z_t2eSk_܈̠9z򷾕P_ JDO|tŁV?8+'X_=--k u}AԐN^鲲dfצBRoT76)s s7># B3jdqTuҎ7}G5Q4 QƀBP7z7k;k/0U$|Uς}uk e4쥒=S6^p &P6 !6w>#ŗJQve MkӺpTJיVi-HIw>8o\(YOm~3`k\.uO^SEU ˯BVi'm8\_Uǿ x 5<"C/=S%I 9vJ/}Rr33( E7z_ rgdtg7f~t/XQ >T}Wtlbzu=6Uq`9xN_k½RL7h&F?a'-ș HTϠݜ;gLIu\'K|1 ~1eo:#K sJ؁a`tD`Q #M 'O:x5o;1 oap3d}7d GaHٖ}h9<&]܊F43rËэb?"!5ANc/RW06p/F.o֕ΊգUt^ש{/,旝SxxM}FܱGƲ22a?Vޟz.Ү q*P^/X۷,C.!Mg <:dۗ=4Qe-WegJ(OHukl{\ďI Ue0i]@qA+y* 5Mx1 ۚg i̭#9AnRfГ!^M&ev Jl0X;0+1{ W-!ýI ~yƧÏ0kM?fѭZ;&168[%B n>K)7'M洈*'g`mZ񫟽>eaw)JFu~@!Jѹ0IT'E^LP M!CAm9|S"+4F3X"E݊^$ X"_$C#|wS-*^¹oW[qBkuPJ`"hRewsoe>Czu2lxsq r Y Z+2tZSsx{Rw*=)<*=y,qk'Oc?﯑:Nmy8bX+b3cv|%P"iH.j"n2Ci{,[tdY⚜'WdJ;bP[Gn5Z0UмI?Qi?()A.w`p'y%syIiMkc\6j0ga:BMh7/bEpvɇ/A!o&nxǸt@2z 惯B']DIK&Rŕjݐ+6G OU*RΖCld[ . "9p鵱OqԂ\pYTB!-}qqpl<ƏM.se{v^ma[qo *mH%{L<>Ns̋X}TANN`W" du58c1K?| xL]%O`Hn̶Ԡ8e2i,'&9{^oIrUbY9z dWzM md"D?:X_jp%9O5A}.e.{_TÕ[7nH#̊ߑqbu3ՎΠ5wE;|K,t;w0/πzj^$P=:.A/p!j6.qGNos n9 fVcujo>d.Q3y>WnkZd|vCf-Ʉ׬mrW[Cc-c2 Jsv`y# .JgDwzgGK3y*4#FQ.b4`Un 7@F> f"ui[LÍw܅sp<4փ6y&Bq"8jAI7"'{D**I8Js,Wo.|ׄ??7_$v3dV!P-ƳqIg8q }`;8b]Soɟ˖?cQێ0$6ZD+Drj㕻¥و#**̎ڡ♵.sRٽ @a pB,/VMQyo75k5 \8OiOZc Y:eiB .ZY>>_HB={ȁA /3P"-&,CEͯ6Y99KG$ ՚!o8,2B>/BtE1.ID3>J\ {aa 8׍l>rM; c0#zo*glwyADJAns[DcGj`J9cv ,^6PZvmٍ-,ZI,7a>>HylԤTcqZ>C=X&b~,VyjJLsTcs@'q$y.uz\.2y^[( A|GHBW[Թ-v֐"#Px s5k&fx)+%5 #Ǡ rsGTx6uV(5%HO!WWWó\ιolLH%th-Ȉol~i'K7!JYo/_{TBi2\{.0N52lys;By-#74a igo[@a6x#JeخS7m!#dVTSt/Jw5OmKIJ{ `"09T,9sK}wY^ߪ6Y>ӳbN|2lOB9WST'd?% \|C+(Wbj2C{EV:: iWqbv7Vn,DدxF.:&^J7 B5d@V9^A Ƥo5]((VAK$DDrEH'qNy뷚`;R}C .Jg?Y"=O*R&n+=5Ű?Kv3ě ûkVҺnt[Y[wZ՟om0&Eʑzm7CƎ}b_Yp4ܝE1vBH]WHNFn5ia-oP| Iαz4ĸQs.m*_rck]k@f-KnAz[41V_av^|=ɶ=N 15Z8Wm.u'g ߡD!!NYɞ./ۯ ek&YV|M#*`:hCRn#r^&[Zmﯸ+3cku{F.3`#F؂ZN,"Z%uuzRllT&͚Lmssvp0(8ɳ _T3˾7kg!$)qvGb49! \ $&;wͱ>B[: 7OqWS4{4ʠ1eW<վӳ#ri`}ϜŪKuj||Q#exSfLz_gC$ 8..iVy"ex\S pYaa3cr+h!dr<}3ϭs, :sg኷Ю Ӳ?>!-9Ʈ;L8ESաri^- :6bmU^N{nGy g|X$ZkОXH˫d#D5?XFb("7xZjGɥ8U~RԓJE{hX2@`Up+0gfv3:c8ߗ1OJ4A;ouK ru=52X/ɬ1<5 K &R{0`HKߝk%s-S)u!88 gciO::>sos/3B{dVg/Fwo۵r\ ~'{ܧY Я2,V-ZX^*C?&.JG0A~݇.تWZ 9= jJ!c,1x_NMA'fm8\t7j(Z睢;! rolq*9"$:(}鈒k<_m\ܶ=3^`"DIm(3Rɨr0c9zz[(0+M62nMA^_t֯^潵{g2kDP=8q7CggBHBf$!y\&9+zO-Wb h_]e&k[hfgz&zkN+%\t/|70;]lqRZ #T$5J7VW P`|ĪD?!˶#UaVL@v$i5X$Uf2si%T~cjU#'L[ <ɩ-T/GZMnj^$dg7~`J hfUh٨i64^֟RjQE7H]xAϧ뤓z4"^+:]2X*iɋ{&]Οt胀P/*=*itCPՉYO<WpnB!ѷ i糐K?GtZ)7й%c^x{ڦb)P]^w}IsD:a5NV_DɐFJ%).ݼQ` A˿lMj=G]jj;UK^\f`3 ]̛ H'wJ[9B۫C ]:Wn>Wqi sbhƮb 5ΤP)K8r=ImpI/`O,ex W$\+vSHdbq@7lig FVsNoNg[?#\*Zan@]),i53E˗"b* `?y 7~ e䞇8_S~#zֈM9V4k. b9՛]j!{r@iE:U .9c7s}8>V?z筙+ .#N[?e?P,55ot@ ,xBSҮY'/uV֒bVOWzn%n~%Z.~62=g1@V@dx K L/S%挶թA^ cZ}^lXLP߲jzi6^hNu*XIEﮋR SVpM9@ .,!6Q}}*+o"1Ǚ} [k2F?p&(/o9A\K̻6ƇAY&}gj WF;[&\zhBԀRV*Α  ]IGPf2~QM=,0&m!jq_Wq DNA،'3\B O?:r}#1YJJ-+]i+u[TzL)I!,!]8 4X.r7 EJc1%רԗ uM-qw84KnD' }w<D i7p;z4:,]BY]Q˜WЄ'_O rk䝋` eO~1Aac۷|BBu-[YXR ~ʻ<3)=?#x7!8wӒg-v}z1.iU"'O1Oe?p=7D8 :iIIc'dʞyL&@xdWB[HG%;X YR;}|elktҘrU-ť=ϫ>ꗷׄ̕\)q%0-1($fbR76E+q/\mJ|ߣI&~ӪC=&"Ya6+H/S2ZK:eS]݃J՚ebi^2hs੪Ynv-.EgF5:!?Yw 8i&a_ɭȸ>̪g_V@~%~WpIZwoV^Y[nb`8DWK/2τW1U㬶qMYO9ݙB`xl1-$Wchw4MVi"WZjdPg[j-U0sވP{0B'TrK"8!:㘙"s=;6k!$[\:q˴$~5j潘Oל 1DH2TAa%5Re1jE)S(6AJ %I}V80E,}aK#£ģ MAf [M˙9^%eFRAbuSG_i]!FW/r-cwú4ќ][3 g_X/V_IGTt~/f^YĦuGjs-k<̩kd*˘g~8KDG~1Ah9I˕/w~w[@3mWҮcQE{r7mqPw+>G/ACOzװ! 6 l6_}6>h'2?5=P0jji#bY1N)#Kt)Lz#W'.9#΃ʌŞ_+&"mwPuG,p`6 b8j;"DrXhFj?Fm<vvTE}p!Iӫ Tg S8wXi+JZ0,~{iW{c !c)]×Qri"4c r㜞:gh'4d{*0I VvET`:}_ʷz,"dfx$^o= ߉h7a+*8rYyfϠdm<}{Kآ) !=蠕=.pvGL==z"8yFY{ o: 5C\1œvT8KF 6^G4aB"Q"X_x5c]:.h`mS߰3Cl_ѶY9+X}ޟ\mܟx~DRVHs`~ݱVPu#䎒#ݗz f:ʩi?L Q֪k{]g D PA#&ܤ̒l)UhQ: b4`37)XXl5>g{c}jʶ"8Վ/9RKN@uV@zTZʣjoצkv$!sR؀Tqni.Ɩ&kS.xI˵9p|Nد=X^,H9njJsI3pz}ls]10]GR>NZ<DJϚFnP1S—jLe> sUL\6;pyju+mV#U \%H9؍Aq y˭^Thvsҏ/0X,`V'ǻ_;a zkI7%HժyqilQ^aF,MmXc+"t?[NM )Aϛkd4@@.DL!⪌.wMQp7^Ը bq ɘ<Aw%sڟg ̕~6',,):oOުh}uWӻe-{~T_k{h*T!׃ߊ⛤#ָ>66}9SRgNڊ%1+PuP K~-{ӊqZ1@yI6H[MCC0`HOOc>r)B8y B\?D< /vEx>`c?y`#]?XЕW=%«9ҾE1V/2ZAr/` eoe~iu2C~?ҭÉWM{负Ah0`Ch$6Vs4"/Vt ]hXcBH? 7L]!(Mi&FDFуjCa_M|7PZ>بS 6d=/fb]џ d<h!ls q`5|PQP%lj/)}.A€gzŠ@ Qf+r|f(tJ|&N".9 9XFÔ`WDk瀂b L%.OK?v"kCifbڇFf}xT( Jp8A"jWQj&"z{.J[3 ̫]?k$;sjqz"Sʮ x69 4k3~_kɥ36}fϜ~%y;Oh.^S:6~$ F.fj* +Գbv0˸d '2:Eq̱ީȺk');J]8o%k(ԾZ dnN`ͦoFVaBVBu_iY:&Utn^z+ŏ1E\ؾ@ kvWK| _0ƶÀuF-3-$~|pNOɇE'{SKubm&,+ۼ<+$#O≰dܣÊ 1ґ(f&W7"'?9E'~jXl)ҵ6P~. DdV 32|ۑ/Md/JIZ['?KqFܥ |.zyO$ $QɃO5IMC_>1cPWEyC18j45N5krrjO?K%]'0?|wQ`23svjDpDQɃXQ5-/UxbT͒^t/1Wr\dBAn;UyȇiZ6*k03A*Ӊ‡NLk}$䘦)y2z)K X&!GG— Ov[`ɦ3MVMwsysy|E45o!2z*T2ކ'o2BueUVz;4zzۻ]qd˦#ˀA?>*0J֌1yyVja~EBK 6txDDsARyjhNs3K$_O͐cLOdUTOcH1'Q ,? E櫓rᨀv+! l|ZG-)& O)쵮%}el5HDfk.ܑ?.!(s>ݕ@o:~jTu,4-\ۢօ#=&:cg(Ri5unq7OfTt3L\́zCEk"4p`1 ]:(1 ,{U 5 (K~2G6SL g WiW3tL·kp"\06كH췁3|0[Bi4gphsO,vJL>,MV`dRmIؚnov1x>M\ k뷣:拢o3Tԩ_/[TN݄G$$LgsnjMjuo R oGّ$ޥI@$!_c/,֕2RJ[3 p K#5.. uc*{ϔꩥ\ H;с)'EʌzFS7\VR޼|&j#JAä8gR|pLt%5 MgvDӝ0 \Br Q2'|ȸaxjU#8JE 2__o@ک8)iD^sfAQ4X]NO:E@I. k0z??#}XCC'MnCU7{mV eQa[͓K"L 0ˁRFK^[|˜KeqKX*$KI2S$bV-Ǭq5\;4՘ \;{s]XwTezwءN{ܟS4u1|N8Hlbө_hؗW50( X ŹUG{VLh.G8HGGOCۨAiȝ-V{aqaW^NXg[$z rd) lw~XJR!@ ayb5z}O %%dO8OHptC3tL5 *q"ݝk Mǚm%t$~'`v'\Lvj`QxGUuuCǬ=0w) "b+ql,0hw5adc׎s O>Pt83W`^efR|FŐN9\擣{U/E%r芇]`{e1OJ [:]ZBLHUhcT  gQ4li8z"s˩K-v6PSyhȻ;dLk-GXݶ@=H/L;I_C۱qN<5}vyujfdy`6_Rs0T>J&nj0u/tgdq.0&{\ XSh,M9L _^u}w)ԙ+ڳυγ>GDu!E~ve9@[=Q+>%j.6Ţ_>]Tbt%<=1UWg}p0L@<[l޶\tap#d+r9ǟ@Wc|fT@.~nvwV{>R*U4E>$A?1I0Z22f tH4k~I>J1u9O;0P= BQW!u*V(1St'<8 6Jz~=:6rbl7A]Sq1pM:f%v{k&I.-ľ/mamif%6.}9*&au,N0ui*\@68?a=,Z -ţPf[א; RtBy:LҼѳk.v\0iѝV̼_駛Pl{=jM!&LseY^GvE*s =]5q0< h` 7G]y":y(Į_ńgՋ[q\اr' a, &v)у% (l3󕙞M 6cDD L&J7]b9,I5lSDX2tn :DʼnJC6tYt@a7 l.juݲ[:yhVbt',gVi/3 &9r>tkH gk[O@o&{@iJ5B7X(E9e܏IF\\<9mfZ*Ysз^oئPwFF9a%A=7i#"}Zw1 "X: ўU=#V-oUW?[i9FѼ|^4 yGr-n3&UQE El x)ܯ40H- (,oVB rKkw ;聐7ҖLA Zѥ$)<_&C[Wq Еے41cfdSPH4: 0P\սc2EEu\ksS+MװO y, vϙF1 8Pt!3{% O**pxLt$̒R^19{ %pQo6.icDoZx8W:3(Bk:n' jwA&L RSu3*Bs=#~*P׈7K-vcH ʅ#Ќ.9,$Lh/|Fba"^jM&=maDʍٚj̋t?;xmW=(u7kEZ,1r =7)F<[#Sv7S3|"g &RKw\o;"(F퐎<ƚߩ8V^M/'ՕvnNh TD]ݹM t\]?4T 45|5ҡj(AV٨_!˾ n?jNufgG޾vŗ9$2Y U/wh0:M M:K[aG`]Y)nwG{5D9:8g(‚~ B+RqZ{n9_Rc_7G|UP u˃Sςq>.&|uxee2ԑB~g)ZZcUXo"N: OG57Ť?L0JULFg7m~KV"J~ lKlw NG bcC%sf_1᮹C{F~h!8E6pnRT })Է 00_v!i0q#7__YbTɄ)R+@U$?AyXT sf87* mZc[ G>5>LPK:\lhߕi'a4_`KH8 јZQ(hQ&7  iS ‘L,t ?$nNq ^x+Je)1ŀ Gg 2}D&4{]EAc[&VM4^o`S.-odhP!~%'t+(IN TVHq^"DmWRD݌BAas[RlRq)VsNGCP2E̸[Xs;¬ 56UE~If~~Cß}47l]b/pҜl2ڰvثn)%~ CKGkb|^$|jf4 ^j" 4x~WG׽zic |z-dNW̓ljoMFOQʱXGt78>Ѿf"Dۃɰ-JrSmʥl]0l@d ƥ<=632qe KSv"CpiW' ;"b-#^f|Xj-sCr{Zl"F~y(A嶎zl4g\% #9ː(J經읭Ɇٯ涍LQ UR'(}'zc.sW^q/ɣ@YdDCxOz@1G | cB*G{922Hs@F"nAyZ&-h|׼[Qƭǹ޻X~Jܴ'7^;9/cM?g]?bT[ǎ̭bM 8QԾ= M*}kY(8R Om%Aκ "s?IFk{Br|fe"i7l17nz7\~Y D6 z%-a{(%Xe:pe|+ňK#v/ c§qFW9R{-98pK[L= x:Щh޹R~):`NuìJ$W )VLn@AŚ#߹[F`\U+;d.sR*Bi,j=hl'G+H>zBx|ua="PR9VOQ1Щ9(Pܣf7}iPZ|H=rRbB ʒMnHZ"h쒾 \Wu0iS{@N Hâ@^ @ӆo$.tM\R. _"/Ԑ̄T˺Ռ& SR~]S4υ5ܑqM~r9ؽ,܌k34J#@V4 61یU:"-2צա]*d+`ól/+`BQ7t52S#OYB$J1lV@zU%'~x-7/.Ә'Wrc_#W-}X =r b.,VE>yX +ܪ f*h᝴t1t68Ic Ά?&=Uj}(9mCtu꜋$*~7 ƕmE}'x %S:^ ̦+1zf 1L7$'v`= 2-"32kb064-Fhj#Kkwwd+$@I=뺍|v DSF"b?yY|s=h^ҁk!JTੲ:|A984u qf8XiDk OLgv\^)r=2x/h(ЁA-ev6s٣ePrmEQ+F]mkD*G hMJ T37ק%Q>W6GPBPJlNdާ_p;VpXK1G<ݐh4>Wz1bȵJ]/o8Fهo/ǣAR<=X&Wf (A3`H|lanzR\Ԅ!Ӵ[OXx_.{DGEhƒdt25ɢd8}Z^~6M7]mGeI%^m+RzA &̨P}+l6Iefo9&?34. X*jv1_+}1Bkg&8cV5)ԯ;M;};<9حmV4ȷ+3=|ŒlX`#QtdR&ss_^jwBr-A{0[9N(,ls$ G`4Z1PX y EXxz3/\6﷒/sWG!ȋT$~ƕv<9;kT sA*elq[HOE놪hVIȋ*0+#\RB;(KCfX"27>Їm"#ce2,&.@K7rgT#c-RH spʞ!>XWSVAFC9דgn&%[bPj(x򹃅ϫ[tdYxS<~-k7uM#c(l~oq $B,z9 xJz:4 ƻ9+ ݮm(j'iCN3Ю#{~c53\D+M2rP?1,n4Mi8zhW7Uץu:KXF9%odGK`!KE馳@D.Cr, ʃ&CS{~b[Vo5qD67OŅa4WHҺXkVXOW ‚^,,~~j 7 ܄ `ٛ[W0!htDޜr&@Eި ޙ&Hs | V\'@4-b({wō9gӧO˃?m>NsIRRKdVReدmJQaք)sϜ mPkTc|GѼ-SC*+=uh^* df@={PJOHI3Lڵ WՒ6SI7X4dN >C7 \gI?;{9wr8 zSIԭBAO8?PB sը&K{\޴pDU6m.fBz]YxI Ѐ~Tsy uNO⬿rit9ޒS_gnDiXԤ'Ш𺲶>0kL-ȡ ip g2x]IL,d 7m:``s]c'rYX3;EeYǸfv1}d]驯[q1&Bd!NXa@5$fb[vSH`:j4qK*o PU3:Gt7i˿̻F6WkUrBT{܅6 %216װu fS-gLŌRt&*~F|[4NU AT&VcE},U2P-ʦ}{GfqRmYrM#gJ&Ue1Nl\w6Q @ld{ǘgJKEFA5ّآE` 7|=FRL6 .4.#OZ³gkbUr&EnE2q\}!b޼ #vFP/è"ʟڴpr4UV@כ{L03>ma P ꃪp\u ̦]~}!-=/ Hi oW^m'C8e.6'>(XY;X~#!%Ӆœj )xe^5nPg4e4wV$,[ftj VX7Bx0Gὡ_- ֜ + +$Bm`8~ rB UP!^(qImK'^Yʿiќ '; t)^no Zg0s} yc?B)uvdٌo)TY1s3Iз׹ACފ]m UTZw&Ҙ7?t@9D{|(yXm:`,OЖ$R}%+կO7aHuf5ydT5 X>|,#u*Z9ɪ ITX؉J$bZ!x "ڗ7*0vR pէ&Oሢu;%M {1"ux0^QE u'9q:\, ƧݡHPBaT/}zo4[ [}`QKBU0Hc\0%+gW u;bo04/4!lʱʨv拓-hl,j+:|%s] 3X|M.e١L7CC4 LO{l -RCվ@=ЬgiKe3C+H; && I/-hˊ+PjDvNLiY i[M!B6RSM MĝF@Vi#T1Ui X뼞"]?rA# DӲ9ص(Qc&R#6m/CK`uꁞ8tZb.fq}D: .uAn-9,^kׯ`ߜp󣪍c*]*@6m'-s|}F2/^H$( >#`nUoՄ7|Q>OcfglGYWNF}F-&T6^?r(lx,&'&Fh-}[mJ|O^T[>LLP@Cc/]p>Mt%xjbSᣘtwэfk} Zga<3o ԥ 2[qp"aJ&cS,."3iv;' ,Ku{_ @SA 8уa7 Ƀ)dd7/,:_>6".xEK g2;2YZbq]Ek!_ZWͯ#\]/ 0Ђ&ce( '*l6]$b_#+JC6 m }\m e{v;12D#l,!1 XQӁ&7E1gPc5vژ*eyY$F+jhٻZ/p^q9QfIY}1"N{nV5$>q &3xoTу|E`@Bdt3;S endstream endobj 51 0 obj << /Length1 725 /Length2 20096 /Length3 0 /Length 20653 /Filter /FlateDecode >> stream xlchM,l۶mk/۶m۶m˶mqorDeeYUbv&t \JbʌL  tPŽ&v"&\j&J&L@H =-̝ (($P60p$Ps02'quupurstHĄ܄ڄ@XN^CBY?&&.FF&N&vql-ɉl]M!fhgC #,(&'L *L,L``kL -O?h#g͎-k ߬,:(FFc #gC3 [(&akjGSr?Rv51!wq6q$36q%nD 5B1m?! '1 wcy vvt1OX?k#cblbr4gUl=g襕$ 535#PrGOG ;-o`/ve - " k--3#3 #Eߢ3n&w#;#`˴ _ѢJP}F[-D!scke|7C޽]"8ɩhpJ3pUL#Yۈ{猍@y)܋ZI2^?;kO(uȑ25`LkC o ׁ`nI1 +4 :OQp]@ih*Z񪒴N;GծT]ᇡ*DuIn4ҫ lֲvMSǵ$;Y#۩tHMIA9ز? }P"kll̄g;rPBP[i1kB~8z}-8DhN;gX NLH'x!~i nMy|%dt QuBky/c+PSjZrxLVr&3vYEo*-L rf7*R'56}(V'f;؁~L싃TD]p/kP anYOMZKG t<\3{G.ednP˨'jBuFam^3BWq!^MFSq 1RnJr_b[q+ m[&[[ay>!j7U0E.5$#Wo/iǔLkTĿD% +xk,Xjp݊yŗ|0."b"kr";jljAz!D}nn!v߾lUܫbTg#ԫkY+{XdO{̗Sg& \ʨ7E+-P1Ʊa>|۷V+xplO]uAGپj \nUp*ƙjK>íPX),LbeZLyӄj <rXTO4-&:6E&BpdS"0 JkSĉ+:t|Nէ+6M~N\g8l= Ƀ!_B\^ƪH)VhF3ณp Gj| 6z|V)LŞ2\f[q/49=v5aSc[IB`nC(gOœH3+CBʲkS}B xC4ZFL5Kza5G'iOΆ'V)~Un}&qVkp,M5Q@%FRS4m :~d~4Rgu)~;lJ+:4q. >d,,>uj)W{!k}w1씎4_*/ECՓȌ,TL/v5hmFt6Hn!T QM>M`H-RnXvp>Fi-TU4zpDp[ɦ:]c锠gcS=}d."O5D "MQ$ AuO1dqDĎw+OI:Oet!πO9r͞NVEPQ|#z{H &X k]IXDyjJ72a)2Gb V(wF#JqplڐMwsӁ:'o^k Wb /%{yzRo% suXxa5K*8(y<ªh# sfg0 1 r}c/T%aOeGsh@M}--sq9<"G{pt${RC`ٳVl\> IMtZ^th~ÃB\}"Bs!цrnGTenFQ1a͜,tMIJx+0دz#8i]EFt!=uc[xf)_QCP4nA~1#ϳ4t#.xc @I3؄oƏJH3Gt9A)tTLZ$jKҘtlOS'{ זSc;+"-jm^@1TmkI۶`pJrJu19#-~$+hǼmS}^7^N*G~ͧ06fӇL$5  R^RBh 4vk%?bA^w4p0(hRiqx8;!S9Sy!dd ]a/^/֕M#ÌCtsQ)0m>]yZPS*2Wk" Ц|Zfbh hh 3I x}I@ ^z$GLc5>[LUy ;4X%.J3\}5:-KG&ƽ1a V:I~Q撁\hҎU '>b{] YJ@J>0e[[؈Bh{rΝоcm`> 釐{ 4I2KVlY}!f)`zZ(%ZJV/fnCX #6mz6QϘ~>uzd1OGTM!`8{#TUsUIۭ0ph.W/32QD,5&2d`C` 4ln|ɣ.|ze}j -p]Dِ}*Z:o6wF27ZN"N6?Zpl-BwXÄ]wnV%[sC$|Hl[l1+U(bH )/plm2@FɮxM{A;( \C!~]q&`qյTWh?Gj^h׸;LҮkFuPPB {V\Zl!:&b*% TqK>79ovq 8=8qBs ڐ>YŸxg4C,G!O9qqnd{+j9/G'9]cҪESI}rl`U 1Dߐ9uA>@x3["$ tㄤ<}w?kL&v̥ 0}Dx޴kAU\^!;J]!(o?'pI}^߸`Vŏ ${f dnc1V%i;HRX_ N!h֘4 9WOD/n)?`F%1>{*dwLq˶6Їw0H fd ?-ƽrW!\.Uy*OEW|Fcvt\wɟ 2nZڇOB7>= ?Y i8a縵wz.jDx>Ď"=U D-l9V3D *)VI),Y'z@t4TJL[E$?(ֶqR_SdP Mͼ5Vˆ?«]{.r g8R욺.˨_\kD^Z∷ g sr3V~S,5 /C}/籼BFtvmK2LχdrU,mJFl0=]8$܋[1DFo$k(],3O9ؼuM506z31}pHvy0nn/4Y }ý@ΞxR:< N AY)oa?u4`ol IUVg4bUy7ds[ W)Y*Js[+C3Q|1bb%j_XT2V7ə{c m~xLp=G8O+6XEȷ?Lsl\=`EkOhz GƁ +Û]9<r`Fj8ꔐɧ bԪ lFաxӓTJl1*WnbP]AI#K W66\7ȅ?GnYGKH fId$@}}`jzŃu݊nmY}a2Cۆov_ڪiۊ]* 3̊ph9*/`D&A_?.Bv0`gFOPz^QKhN 厧je{Y:r-)r˰$KL̮0~Gu4Sڊ,-R2pزF.Œo5Eܺ^ezj)ry$]B .$lVjŊ󘷉l1gO uqVfkdpMtXe!`[bpZ"Kn 7!m8o[2|[T #e*v2 *V7IL`y,#$o[)*_T8؂+!;[!5n} ik;")s{6h"FxS̅R*FYiXۓ$g}xV'Rk% u )C6*y#6P'm?A0!3m|;}|Oyݴϼ7QL\Ԁܬd[xvB.r&ro,Y~k=~ nidtl@p]̕U"~,Irͽ)p{s_|;2c(z=  9Zb{r!q#[} Q7c[BQ׍d.9 ,Tm":sոdG8%+ՙ.7FÒ&C]<,lRFMrmцؚJ^DYFN D i8|XȧX/vo=>e b!~iٍ>^_k3,fJ[E_ ˴95iΡYOcRtb<FT@[ fdXۡ LL9grق?k%H(ix^b&O{S"]t94t`jÖbLI=V&㾓1T`h곒btK--pm-a-,&|p|&vՑ86(N<{}7J Ȭ88VpBݣ1'fp+ļiWmH 1x{>>cǜч#쥍߯!+]KK_h.R& 0F'x=;Fx&\l&Ϟ.V:tFQ=6H>0WB~P?[[t:Ym=LM*'T9e0ϻ ͟# )03yG,VI;#59\-vKk+س3޴>SPj,A{Bs30Nvz&t OF,Me̥X Pa(BbV~ZFĸvYc׋К>W巔po"Ŝ΅n{5UY=#pչ3\ɿ'N|ϗpich=o*dH?fr2VݏғR6zu| L P1,S)a)9 yM^`} l 1_Cla!`Tur r2;E}z@Q\SJngz[[Kf93 =lsQ!^J`6I\:qN4tk$ ]/7&ǃ< ȝ|nSi^يc0d;"52;O[(r7H1?4 {@.} ԰ܶGaGgN oT=6ДR鞽Xq4{* S(` " ;=a'bR]E)& Z[>z wb@Н$"|N)Hŵy2wjA"b2[v5[6}%Dy}@hz^Gc:(臯x#\2k=ǚX@EFih }sR䁵\+ybZFeA W] 'z{OG@B}8u~w1Vs2lu}gk&%=X8!WucSCyA.ѓ|7t>N%06> c#V [Bj]9{)P洩^xe]_.-Ѱ5KY}霒ZHh繏&NG-4_Хjӽr~Sb)/[?2=D#Q $Z&w^,'=UvPfq6ګEx"pm}0Qr̃? hqҧ\V >~??8̸Mc{XrrPC!Orŀq]$;NS /IŽXw?06Um*+>l ټJ9IqI'̭xbG'/4R n4MiKHz[%9\Z|SwjmŮX=C:;~ }Xj=?^>`8(N`T8t"t }CKi-7j\lF$#SQaYtl  [WbWmva-ҽUHM!Ounl{;z1h$^8~r <ջOd蝫pTBx! xt|`(jCg,$(Vq1'e5=zNAOpGN QMDQ ֕"8. [ K.SpS_1dsm*V83]Q1d3-'b ގ1'W~ݨ9 Ņ\ZLۭCssH!rY p zcmd0WsEMl˛ М!- H- *a 89V nײ{(WN&.6#(2Qn gfJq_ wNzx%]L㹯PL\|@= {w'vī?)rmh{mxϛnm,D˨_J-o0eY'ܟ.uE7#}o6ϾicRjac.]8 WyxZrEz0Vv{vc8X-AӄBM|[g&u5r+LwSj;uh2|@rSkZ7"MD_"jx!R&,Vp麥Oۘ7<co`˹2.DxR0ZU珧细;Z5v.~ҒyRJa#ִxaН=C|Ws)80WT}D8(CAaikC)g>]"w/[I LeQs|$Q tx:4K {< Z|wذz`Hxtm%3ȳ)NB83قˮg=%0Dj:wtplG`<^ [f#@t.a3 RTzM#c,lRfEK$4|]cFtjlzh)2)X2Q$ٱqJ3E, .f푙l;]aZ*g26/TKk"ǬrOD uu)xZl4_?}qb#o%T?i+C-Ǭ}2fO w' 57׿xA8J:HyPgpU7K{LUK[ZTx&Œʠ.Ԟ>>Z>l 0ӌDCTOg~1m`DZ9388,+\\2mq{-kέ4I%fiZ%;b:]zլ `0MZ's3$ӫZ|%%Ð̺~! _H=M.K |GlQ S};)c} 8l_C6ߍ.0t"h91m L9 2c5:'Q+4ƫʁ!+%l@/A2'@K(ZTow=BtYb*KF)BL${48gu# m`q [g3mq2qlmƉ~NЫ/`9:;')@w/Yz&Ĵ0 + IF$FU7v>@t/gT atFv-JO48HöPdX׻=4K}^8HwWE;YൊO#WǏLD.J[x]=ystZn:qPe\hu'lêlZ15*[(d l3x':>3/"rAU^Nҳ2C)_zdldu!ğ݂a˯%+ӽ*wަ,&Za=5S;I`ےdE`bfLWԬ8-2z"$k r5xk ]H١w+a⑼ҽu-p^~:U7Ϯ,<=mcҺEkuEd|Q}>k-D6Qء*CqUcJvUa83?tƿ/ˑR^9j^ ΐwj]kgZMJ}Ŕ2!(l e -Ӷ*6 ;mYe UOYu2m"h/34&6+h{9jlܸ/Źl Vcml#tݿ9zkoɑM]!,|Hz{ h@⒩4=#Ꚛ.Pӽ{%5==vu y#O G|&߀dUz9i: 7&S^\Fx/!z4p1:hu1}jq2MJqxh0Q.AҗD,B*f./G9fFL7 ̓0".21O#NPf5k2B&Rd~ء :!8J(Sv \*fq3arۍ裿xC+|Iғ- ݘa~N*e8.Ω6rKͫ{[3orK BU؍ T +fAUbNtM|_1l+h61Zy&}rgTzCk+g?L"^bu)21U9h:yŊNGT1aZu7]I()mYExۻ@ ~ߺe>!j?FƥA__!s!ꋲ Rmb !׮3C7ACY 6mmč<*E9t?-0h~</x;Q+Yp+_nG Fۃ.{_rMXue}22ێJRjYb;b{N$ϸ]5g{đ9ճOl[09s~ 2_;W(-_.<>?#:bWI< /̚㔣udJfp>k=|I7w6ze-JI+y{&W ~VkTZSхKZ! Q·o^ZE4]j:MԤ죥ߌ)y1w~-eaڵ#h^^-(`:T:n`t,-6DV^r=IS!iXa~IALs7R~sì7 Y:qlzgjV _y̑AQ*E :FߐAG.9A** 2z[AcT+rοKwBtWE|۩o"RNHHOjd  E䢔+$d.N.(cC|nf|&bO瞮y{\Ekpt ٲ7oP,‰B5$߶DT3__ cfx &lWVb'd\) :gjt;V󣠅e "a &2,w@c+$?,0+Ja,zI{AI. \sdJzծzNVPLq/'W 1gՒy~Lj?0C4(#Vw!2^Lͬ?=.戰r{ FOn`䴔 ½c9Z8TېA(ct;;|!D̂/ uYUd#eZnvpOPChCvmrG_P(FT%cE0v;eަV4,6phZ&Qݦ˛[ hܼ5 ǐSzXw+`C[߅:4([(}mę l!th'mأe.ۑuwnAr8By/KU j`{ʼn΂SaThh{.edUQIn{,^ʨKW<:S\\z{޶u)X!zy'` &7=r'Ɯx}.5eƫ5YڍA\! ih^ }#fAzTGl-aIxIϞnslcpz6=BkeFdy,qIvb; 1 .7<[ Y1@5MƍO((I5b`sc%TEOa ~UÇ=L2ј9VTZF4 W1|d+R߷uCt'(q^M>3,9a-rT0h:3uYD,%fbK*@uw Z@4vBɡ|5im8$W¦}odع\{;aMS[mUTM 2(04hZz,܁M)0jrVovG$$#Kj-%X_Do?CtI}s{7? VԢ96ZF'z8 ~M/'v T`۾Qߪ$Iz2~Ryn~ 8~m"jg&=RthPZij%tFZ%U8xclY#K Dri习!^s/Zލ+J«*ˆ.#u@so?nbO\zG: B;3RıdG33VDtͷcHG])'6jCgmW9;"5ڡr=௜[Lf*6f*9uN<*C>`M ./FIgc8ItSzäꇴVv)ئf#en, ¢W[jQ}J>ػR[!Rz]ĩ=Yr'mnXt6'7s1c\~}]|yUrɼ(Σ*UgY+!lt=jG[~7nfge>ӄ]0.l cJ w$J,Ty1(WtԭEPh},%ס20Dqﳺe6KT%*"8sڅ VI'pʍ2< k>@w(+6"gAfQ\˅Syi*JϨ,m.[&:ͪ@P^[~]U4m SPSjwua7.ЂC`;|h:W0qzߏn_UːN w$EeNhd~a#ׂ' $]<(BNvISj*Ĩ1c\U KL;?Ѽxֺ4;I摄ZQ"v@AKZ$P's[7ޠZg7ٳeUO kp"!MN1oҫo|'HF(IAԉ7l9=ٴ*VseY*o/G K{fIhG5,m3ZwJ4UH``,WR?;E|@D,;`&'Z< PR/_V1؏NJŒ-E(v i"><`!_:0j/X[yU&|rqx(śdJ>P׸ Dbh.ɨݐOWw[jhd #ߦB(DG}? sulͮf+ʞ&^0{x7xv rѕ tD5"6?^se<033'11j)=.ږEg. iV,wƞZ%op@H)&ff[{ |ݕ :CЏ%⬯vZ EWs'A4Ԧ,3!‰/x깊CӪr P/T5&wKP`j b_N)~ȶ)8F|XX4(=TTo<5jI olŮ[o%cm:Q3T1mҽߌR& > ? _.ڜ?wI%W1gN`JmVO[z>%{Ys9Vʿ{ dhHlPz,F8`)rWc "JraЃ("Lȗ h>`UN[d$1As(!rڕH?봛Y8S.PjEke},hq3Э4 ^ ~(G,&1sG#+wƸocD\Ĕ>[z) }rR1 qB4,Ea#b'IM|@ XtpJȒL*<+`ľM-G@;hu:p> ldH[rr%-@&hI&o2fR v)Up*aMp\fjVw3_B4^}DAi撗R 8,k Q\cC|ACuT 0̠17 Y_Hz޷cظ1F&hgYDP! !Di!zȿDg&2S+0-Aur1>{3X%o !%l[]#Z%cQDӒLrdEEu$hԎuY<_t6hm jd{QI[>Kv<>\Mz.SJdϫGu] g+tORp,X}M,xc۰koy]&oԪRv-zFqtnF_zf)8QvqG6{Z'Vqk&lDAVh2)EZFJN Njj[Gp/?F'93Ĩ,֚[ .!mOb[Eژ=/IAaGՊu9"('cDlpT ߫ c-y<m\/$1vf@l`'[Gs ԓrLT=һEsw3+S6}Mۇ$DnBx1KV66[[t^C~sCixĺ oH=xk] ZRP/O<Va/Bu(ҏM -_G.<`- [CL fdvdZ´·5Β~$Ovտa㙡E$17k j&`〜b ^8\,.-V^gR*5Y so;B;̈́4W S>^@!@kmvĉם:qE_U2sA*W?6CaToE&'EY_zNYHތm%ikCƄ[U 9I{s۽Upe@1ki:x0lm63YbeoR3́ jv6T}?9h4Sw %\(Hr=翅QaӲ6::coĵٔ<ثLCQ!(xד;ڏr̖gX8+<˜WDa lmhܛBZJȣOd4}ȱF9qjNC< έc7`ZK>qiKaRQݰ0[B@bebpBl FS_gjKz,U\8Q G颟=˝Uf@ګi!)T"{hl/eseyǶG24!j5y<2k@D)R //a%sG(9-VXҙp[! ؈PRJfkb) U v(Bl\جiѵuAko7C>w Kw-Fњ"s<60R6,AJö%EJv(':,oB3JpTgʒdcz?z/?c$z$ql[lQf܋{@/Ӭ^z朒8'R(x-XnG9N33BE~&QLJ`NRh|qw-$?"~CT<l݃?!f)8] ee{an:-b!9>r3a(<R'hE*v"+'C>M(}loJ:g5 KvUm'a|\4kt |hz*Kڐ:ߕpI2Tئ?hQ:6[bl?[ !yJaK+~51 ӈ;+m1*+Ⱦܞ $ KiO#}'on{oTh-QJ_&/]pWev &gh.l6P`7;&ϰZew_;#d[}WMA@:sob-cl{ uK~ wDN@A֗+U$.PkHnpH=h}t> endobj 12 0 obj << /Type /ObjStm /N 39 /First 292 /Length 2278 /Filter /FlateDecode >> stream xYnH}W.m=YchXYr$:Tx>,EKթ9բbIy&-S*c03w& ,y2,XǔcR:Q4cI,&0Bq4ޠ ]w8u8ό`F 1㱾a \wd2[df̲Fਘ3riLV gΛ#q5g^X,4k*qyÄIA+h"$(^tY22#1p̂%5rG3jXE)lP.r!H` OkaQZ {AhDa!Hb,Le18&mL rIb 6q2ܴfqE^E_> !̰q f| `ҖtA`%elK~|XFƼ0/-I(ŝ7֟D8Ж!Qحt_Zuz75K0IR[?.Α&B]F9'-rRF߃s$9GxtY+9j3M}IL k%FZ,韏>ИH0@&!IG鄍A!iM:ᢿhɶ)H:( 2 "FE@IKQ1wtVת'-=yw/oYU݃x|4gy+ᮄ]ڽJA_Q% D]߽-MNѽRUz= &:*nȧ 2=r }_!/5/ w!9xu3+ ^1+gmĢڦ|6K`Oo.\dDXڸ`WD SXT k~w=@:DN`X~ `d|81/nx%dow7}R%U}6s6¿Ī_Uųk^ܖa+ ƿlڊ+zoOIkREKmDH4@Jd+];&~u&ɷ?myI&ǿޝ!e1MCQʀAD8"&5TR/` nr>)UG#jxr:owd\dN ZI{v ;g|\-> ~ɛ]w~v$I: YڧNao;igjrQq# 5H*~|^wn Z?ټu7fNbjU;5ºY*ʥU <57CAE3AA1D14FCF8BDFA19B09431BA2D>] /Length 166 /Filter /FlateDecode >> stream x%;askaƛx *DDT Fa  ܛ|uzb Ƣ/b(b-ODJ8HdDw6ˉ,=Hx"/ Q%v[&U̬qJue ^G&^Xڪ-y :j endstream endobj startxref 116989 %%EOF sn/NAMESPACE0000644000176200001440000000402312620566753012124 0ustar liggesusers importFrom("stats", ".getXlevels", "as.formula", "contrasts", "cov2cor", "dcauchy", "dchisq", "dnorm", "dt", "integrate", "is.empty.model", "lm.wfit", "model.matrix", "model.offset", "model.response", "model.weights", "optimize", "pf", "pnorm", "printCoefmat", "pt", "qchisq", "qf", "qnorm", "qt", "quantile", "rchisq", "resid", "rnorm", "runif", "uniroot", "var", "residuals", "fitted", "weights", "optim", "nlminb", "splinefun") importFrom("graphics", "plot", "Axis", "abline", "axis", "box", "boxplot", "contour", "hist", "lines", "mtext", "panel.smooth", "par", "points", "rug", "strheight", "text", "title") importFrom("grDevices", "dev.interactive", "devAskNewPage", "extendrange", "contourLines") importFrom("utils", "packageDescription") importFrom("mnormt", pmnorm, dmt, pmt, pd.solve) importFrom("numDeriv", grad, hessian) import("methods") import("stats4") S3method(weights, selm) S3method(weights, mselm) S3method(coef, selm) S3method(coef, mselm) S3method(plot, selm) S3method(plot, mselm) S3method(fitted, selm) S3method(fitted, mselm) S3method(residuals, selm) S3method(residuals, mselm) S3method(profile, selm) S3method(sd, default) export( T.Owen, zeta, sn.cumulants, st.cumulants, dsn, psn, qsn, rsn, dst, pst, qst, rst, dsc, psc, qsc, rsc, dmsn, pmsn, rmsn, dmst, pmst, rmst, dmsc, pmsc, rmsc, makeSECdistr, modeSECdistr, marginalSECdistr, affineTransSECdistr, conditionalSECdistr, dp2cp, cp2dp, dp2op, op2dp, sn.infoUv, sn.infoMv, st.infoUv, st.infoMv, selm, MPpenalty, Qpenalty, extractSECdistr, selm.fit, sn.mple, st.mple, msn.mle, msn.mple, mst.mple, vech, vech2mat, duplicationMatrix, coef.selm, plot.selm, residuals.selm, fitted.selm, profile.selm, coef.mselm, plot.mselm, residuals.mselm, fitted.mselm, sd.default, sd ) exportMethods("show", "plot", "summary", "coef", "logLik", "residuals", "fitted", "mean", "vcov", "sd") exportClasses("SECdistrUv", "SECdistrMv", "summary.SECdistrUv", "summary.SECdistrMv", "selm", "mselm", "summary.selm", "summary.mselm") sn/NEWS0000644000176200001440000001066112620566003011375 0ustar liggesusersR package 'sn' NEWS (ChangeLog) file ------------------------------------ Version 1.3-0 (2015-11-11) Method profile.selm is introduced. The object returned by plot.SECdistrMv now includes the coordinates of the contour levels. Fixes a bug affecting rmsn when called using dp= and dp[[1]] is named beta instead of xi. Version 1.2-5 (2015-09-25) Not released Version 1.2-4 (2015-08-25) Output of plot.SECdistr is better structured and documented. In pmst, handling of case nu=Inf required a fix. Corrected a bug of internal function msn.dp2dp when called with aux=TRUE and d=1; this affected rmsn and rmst if d=1. Version 1.2-3 (2015-07-14) Fixed a bug in evaluation of the feasible CP parameter space of univariate ST. Fixed a bug which crashed pmst when called with fractional degrees of freedom. Functions dmsn, pmsn and dmst now expand a single value supplied as 'xi' into a vector or matrix of suitable dimension. Version 1.2-2 (2015-06-05) Fixed a bug in extractSECdistr from mselm-class objects. Fixed a bug that prevented calling low level fitting functions with non-null 'penalty' argument. Improved documentation of selm.fit and related functions. Version 1.2-1 (2015-04-28) Optimization parameters are now passed from selm to sn.mple and st.mple as indicated in the documentation. Plotting of selm-class and mselm-class objects avoids clash of par('cex') parameters. Computation of sn.infoMv now takes into account whether method="MPLE" was used at the estimation stage. Version 1.2-0 (2015-03-24) Created new functions extractSECdistr and modeSECdistr; new methods mean and sd for class SECdistrUv and new methods mean and vcov for class SECdistrMv. Computation of qst switches to qsn if nu>1e4, instead of nu=Inf as before. Fixed a bug in st.pdev.hessian (correction in args sequence). Improved detection of singular distributions in selm output. Improved handling of component names of SECdistr. Version 1.1-2 (2014-11-30) Fixed a bug affecting plotting of mselm-class objects under certain circumstances. Fixed a bug affecting function selm when the weights argument contained some 0's. Improved coding in some functions. More functions are exported and their documentation added. Version 1.1-1 (2014-10-30) Function qsn has an additional argument 'solver'. Functions pmsn and pmst can now be called with argument 'xi' of matrix type. More functions are now exported in NAMESPACE. Fixed a bug about selm.control argument of selm.fit. Improved documentation of various functions. Version 1.1-0 (2014-08-06) Main few feature is the possibility to set the constraint alpha=0 in function selm and in lower level fitting functions. Other additions or changes are: introduction of OP parameterization; fix a bug in qst; more efficient coding of dmsn and dmst; pmsn can now be called with argument 'x' of matrix type; in pst and qst, new argument method allows to select the algorithm employed. More detailed documentation of pst and other functions and methods. Version 1.0-0 (2014-01-06) This is a major upgrade of the package, with much of the code completely new or largely re-written, leading to changes in the syntax and the user interface. The key new functions are selm and makeSECdistr, with various related functions and methods. S4 methods are adopted. Many existing functions are updated, a few are dropped; see help(SN) for more information. (Development of "version 1" is started in June 2007.) ------------------------------------------------------------------------------ Version 0.4-1 to 0.4-18 (2007-2013) Various minor adjustments, many of them to fulfill CRAN programming standards Version 0.4-0 (2006-04-11) Several changes and additions are included: - many routines allow use of composite parameter 'dp' - multivariate normal and t probabilities are now computed by 'mnormt' - use of NAMESPACE introduced - some more routines introduced, eg. st.cumulants.inversion - various fixes/improvements in documentation Version 0.3x (2003--2005) Added some new functions (these include msn.affine, sn.mmle, sn.Einfo, sn.mle.grouped), fix various errors, and other improvements (eg. improved pst) Version 0.30 (2002-06-15) The main change is the addition of routines for (multivariate) skew-t distribution; also some other routines, e.g. mle for grouped data Version 0.22.2 (2002-01-05) Fix error in sn.dev.gh, improved qsn Version 0.22.1 (2001-05-17) Version 0.20 (Oct.1998): This is the first public release and distribution via WWW sn/data/0000755000176200001440000000000012620566762011617 5ustar liggesuserssn/data/frontier.rda0000644000176200001440000000072012620566762014136 0ustar liggesusers r0b```b`fbb`b2Y# 'H++L-~[o.'߷e?{ƁYTՍ{km^_WBs.N{yׁ#mLg}뾲[,#vNYgjb`5 Ohʷm5S }JwW*RD3k+?Dߌӊ7QTϽ *kZA. ?J߉'beb:eW]QQxPT.yK{(*ωӲ+ ܠ?eZ_F> _cK>F }<(_]/rK$wJK+{/ת}+*exJ(.7C~T6* GT"[vA+Θo^H+ e@oƟz} y+JgR*)exԓ^gS'\5M|kE77g OuS=)_^^/ϕǵgz]y;KS4>7O>gYgg ѿJgO~Wc 7~ )r΄|wucNxww]huo3M{O7ڧ LWD?7-$gw:[K;gꓪjpJne4jL8ZXo7]OGM'Kqθ\c[|!)Hߏ鷈^/\'z@yb]{Iߤtk}ɽHzhXµH)mq\uLޥo18cBUcg|S[4bqx\~q 6tJ7&Un{L@~{\Ieo,ksAO\8}حYr,]GC/ȃx7 w3~ ?=vZ>["byl~ rg/KE~Ԋ}U=.,4=XziQjM?d/WBE/ZnVRʋޒö7k6G+Eg)UUjg7K6m-e'oU5p13wFxyIuP忐~ KY=}+\?s+x% x(?Z ~>s^ϲG) <d/~}.B<'>IyA~I??D^__~W*^#ݵ.>U@Nɟ?hPCB^,Q1E(Wy=ᒻ@ȕ٢+}Џ!('~)9JGʎhl$tC4R/D@iɟGuBޏ^CL͒FgG~ɾ]ğ4D?7i/>\_ >~_%9h$)Jx"7/Uޗ? UKi7 3>YkC:M;ViW=XY`oGgz Sd/\e\]7i dWI'%;Dٌ? vc<}P̑e5+Tt(=z>[-?g.4J;wߑGyzYN(ꩿvr+Q8q]r i+gJ?Lz_-<#P8Ug<1ܭzߏpC[ 7iןN%?ȯH%n:joIߴOsZyͫ>T}FxW~'ѿZ]_^.x3)>3[rO}g?\Yy>8㴳4 @.;޿7r=7Qzg{{ONɏvH/zs/`qqqv9+>g=8]7v=h'5d>w^'>d>M2N+Kh>ixa\6L;yc)d\PWχ1k < 'ƳG0ô^}^kB5 xr[ ~Cn~Hѓ/A=}IϚWD.yˇ?vg}3GN_z?\%0@EwD.9~ 9,G9OSye/a藿!}L*կ%9N9:i7+͹<ӽ~s:Unw;}9jsvĭ?p"gYs5W+?GdH~}KtXXA'9l'@8?{9ԣy*揈ZПVWsNt>_Nyo:<٢_$ C%~ߧz3VUؿmʿSC-qGiG~k ~=4{"=nMa9_܁٣IÒH 9cS?9Xilp~{ />a~)~v`^%~IG?_ƎVu߳t8?Xz']Z7~v< ʍu+l~C'˜mT9ΫBoPG>N`ᚫJqY)L".V"c8xhﴏfelW km-Kܺ^'Y.v:R.Wx6hvnwǷٱysMnrxP>ufs|{.uzkivr`&ο[[lr 6~;r74%nhOW8anͷ^N^o˜|~%>+]גF=ߪuKEvMtSOKjV?jo|%['sZϽzg oۀgϫ~yEڪ[>zAxT|PNtξ~+z`1w6h{L9V/?)߫O'[Wz&/>n_O\m]6zI-E'zTUpu[~=Zr>@rn^Юd zoqЏ܋Am>E{λ{ogg+-9hW\O6GOl_z,-OWGJ'mݓ}>v[+`'ϼm&7.N`ºihp n~:qGv{> uEvҗ6Wn[wtEy̭Y8<8Á| ~jwg"e3`ݵ*cu~~><5Ͻ_{7QGg_7>3ϭsfg7Mnɭcv7/~o? |;j&'4:]pNX?mtuj?3q>.k+Dz_ĭ'~atobA_Pc]:cpaG\@;L;\'D=᲋#A!poS> ~yh J9ǽpnXiO\4tG8W}=Η/q/T=s2?{_ݹq{Gs# N#r.{zO;iw{i[ï==>)ȿh_9}z7>\?΅D#&ne_v\hߴ1p6UýpY&v&y?w9esRy2n$_;wvyphuΪ?z_~Ľ__^/=ǓR),r/skq}H<wJ =doUopCW' }I\C9!}HI|~*9H)x/E:?|?Yz/j?z'~v+~{CGG7rPy)_ŗr^n;Pn{'Uz =ʁG/c@9Q~ Qt'A. ^tht|']{/=P<=Ÿ~WsRc!UÏ]ћR zx@y}'/)wD3N3B\0]¸zş8kDWO sKx8a}G'n 6Jz|W]ʳ2tx6!nw?,]ϱe>Auv!Kv~G;ï~W@wC笃ׯ=zS?a=9X1/RK6^C\.>gJy+".O!DWm\qXٝ<|~5O&Nl !.o⠅ 9iW|AOH_!?ŏaIo0?$n<<ú#q/B-ێB n$?úJpO\.3A/N4K\ }CO/߭OwXߤ`4z?^Szq2ް$8f=a'ջCr~kG,!r\lY (Ol}`?1wx[>-{ Ey9z q\|T옰(<}?bO%*_+|} ];7G;HEXk}L:YcR*7E;{tH$J Mt/B6W_z8> q^qq&[Y tGc \K<'^N"q¾3SK|\I G~蓆q\N>xwι)|-D/ǀ]Ow[XG@y$8]za{v*SăO~)^.uF0o83EcCqK9p0nG{򋰏-~g|Ž trqB\?O=}:5=Q.>V.ebRO̯4b~@<|͟r]|ćҸŸJOwxXa 43 qЛ{y#w;qL毜c,p^$Ɵ9g~^+88`~-'4iOp0.q)|_w(4}6>ű]7cwLS!6qo>޶;qxAp'%|aKpރᅵp꓆xnNw># # }.Xwl;tozqqē~zT~$?9T|cRG"8-vMthđ/xn(G]3.߱BXW}1]n~x;NBMQ>a7]C8&Hbm\,՞&\S=h~qz?Qzc?{}E8;ND[apM|DEoLR{ƟqC;v;H2{U_yG'Wě#>>zoy8YGmEvn C=g׶Gt*վb;tuUΣm-}_mttw_S7a[~_)>ܗxO ~mV. ^w ^!z;w*{>v+ne-wN-ەwtX/X{U=wŏ菸gT8;7ޓ.%:#ZErX d]Խm㯽Z_~hKOP?+?`oW9{T~Wо {T.GG;+^7h킧.떿QQjoh^أ~w?F料[M>=W\Ozt]z%54nO*ȏW<ţAq.~9ۃ]j'yOq7#Y\'C[+v7; "~8zxѫy@(񀇃N'*}ߍ7~^ tC? NCs #ϻ#}G֜WW?D?+ vP/=K:=Wh?^aOC9L!펤W7a װ!> x}'<o.!GvS?*^qWz_\^zJOqF1F#z "{{DrE2~1{ {a4nF1'_n'ȏ߸HG_ƹ7T.J_ŷS܍ &ě驪 pgKWS#T\S9t _$$rY|'h1pJ?U īRk=3 x1E~LW~/D_xoW|Cx^`O_ N!d첼e?t~i3. .C=.poӴ?#;?;/^~xa~S[3aq%1S /܀gL7JZz"=dogqۖg>T:^2K*i^ysGZ:Hݵt^ҳZyKASg#/S~b- ZwQ[Z8п_{VKr'KOΓC"/{t৕4kNzq9~xki]mrKq.9ҹgvӔ~W.4Ͷt9Ow[i?+oΊp+ͯ e-7;Wg//;_Jy(7 _ +/~E_tŃ?ҳإxiibZCxH*yW8K}\iY=+.^ڟW"_qU/<1Y?qq6189w}? 'uEyC+w>W~>9b/pZȻvw9v"/ɿ9rg/iǞ2w}y'?"pMNetv `OE ξ4uze7ܯF{6'^.܇ o~웋rA>Mc^sOPOAN"s)*7!3C씓En}3 ќk? !;7p!GsO:~:"ʼnc<tПrح^@qYxؑ<8/#=D}oy']Wnagwoy},Cig 'Ân͇ Dqp>ßxCW_[#=[]xM4!v+<q#=`g/:+Z<%9BTc~\ ]k_ANk_89x]b>XwrKz_ }n u)^@ 5ҋZG{'8OR\.AM\538/:31x־YQ]pyO~Z>ޙ'D߳o}?Ap1j Oj^O{DYw3_<{=ݻ磺O-;F;7h~$uoKq?RoyCu,x5i~}T>x"os_CN_t 3'sco:}е{uEf~ý7ZҮܬC'cW{8-dXӾX_k>@ Y/Eu~E9m=ĺ_}֭2 >4,| ^\7Ye3@ n8&z<yo֕}grNer=轟~Gh ;Yg<zduQe0Cs"k]vg=!w7't?:vbnJv~7%}7lߵo7e>1zj~gon^^pv >2̃ÎҾWA .9 _A򊏣!棣đP_{a}=>eS3o3qizb:^gyMK=ef.u1Os'ouhuES,e=6~yW>'?rSuB ;ަ#$2aQ/e޷LN?._szOu2>Q?{q~|'&a#Ύ vrkg]vr9Ǿ)Û8 .?7q淩_wN2^eΟw3N|MrNL/5]?/y]y;ɷcAږϒ&Ng(|Ӛrs)kXZr`Fɞ&}zCqT 糔svأvs6_ A\NJRWss|W W ؿWHJ\\Ij9woW&zޖ8hɿWWC*v5浚ځ_%n*[g_T#WzmB|ԉ:a2J אWeT5dG^OM?x~ICc'xZըyjU9' փ ~vT,~DȟRܼ>k'=fuxGv3ȭ*OGy4]uG1Z ku " {) sEl߁gnζL1&d|EiOGx. 9߆;r[`6YgQ͑)d{^SttfTYz \Aәǡ$٘ٹ-/aG\'d'zH+RXnчyxӬց/ 9ϐ|H ?㑏/02N׹?vziMyz}~/Ϻ >171ߋ2}ο}1f4}c8Y1&%a^y; ;1?d|>muiP)%';L9̿Bf϶d߈"uVpRՄ !MmK81GKܮ! ZjX|P.Cj\O8T?B~ZSq`=6w|?UReoAmȹw.{QPռsCY y]'Rd}?OVQ:VQ`W gzA7_g2oyo3Ln*e66grQ6fav3꾪A8pG5z4zX{_i3k-?}켏 jA?Ճ_Ǩ"tɏ�aM^G]QW/<>n2YiyԭN.<!8vGo<ӥ.|ݧ#?aš|OfUW;~|35}-MދO+VfGK@3}ьWӉD2Hc|rsz|9A_l4j^Y@w}7Ҳ_-<ét6tKl/LQ['sn/R/0000755000176200001440000000000012620566034011077 5ustar liggesuserssn/R/sn-funct.R0000644000176200001440000056515112620065374012775 0ustar liggesusers# file sn/R/sn-funct.R (various functions) # This file is a component of the package 'sn' for R # copyright (C) 1997-2015 Adelchi Azzalini # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 or 3 of the License # (at your option). # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # http://www.r-project.org/Licenses/ #--------- dsn <- function(x, xi=0, omega=1, alpha=0, tau=0, dp=NULL, log=FALSE) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi <- dp[1] omega <- dp[2] alpha <- dp[3] tau <- if(length(dp)>3) dp[4] else 0 } z <- (x-xi)/omega logN <- (-log(sqrt(2*pi)) -logb(omega) -z^2/2) if(abs(alpha) < Inf) logS <- pnorm(tau * sqrt(1+alpha^2) + alpha*z, log.p=TRUE) else logS <- log(as.numeric(sign(alpha)*z + tau > 0)) logPDF <- as.numeric(logN + logS - pnorm(tau, log.p=TRUE)) replace(logPDF, omega<= 0, NaN) if(log) logPDF else exp(logPDF) } psn <- function(x, xi=0, omega=1, alpha=0, tau=0, dp=NULL, engine, ...) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi <- dp[1] omega <- dp[2] alpha <- dp[3] tau <- if(length(dp)>3) dp[4] else 0L } z <- as.numeric((x-xi)/omega) nz <- length(z) na <- length(alpha) if(missing(engine)) engine <- if(na == 1 & nz > 3 & all(alpha*z > -5) & (tau == 0L)) "T.Owen" else "biv.nt.prob" if(engine == "T.Owen") { if(tau != 0 | na > 1) stop("engine='T.Owen' not compatible with other arguments") p <- pnorm(z) - 2 * T.Owen(z, alpha, ...) } else{ # engine="biv.nt.prob" p <- numeric(nz) alpha <- cbind(z, alpha)[,2] delta <- delta.etc(alpha) p.tau <- pnorm(tau) for(k in seq_len(nz)) { if(abs(alpha[k]) == Inf){ p[k] <- if(alpha[k] > 0) (pnorm(pmax(z[k],-tau)) - pnorm(-tau))/p.tau else 1- (pnorm(tau) - pnorm(pmin(z[k], tau)))/p.tau } else { # SNbook: formula (2.48), p.40 R <- matrix(c(1, -delta[k], -delta[k], 1), 2, 2) p[k]<- mnormt::biv.nt.prob(0, rep(-Inf,2), c(z[k], tau), c(0, 0), R)/p.tau } }} p <- pmin(1, pmax(0, as.numeric(p))) replace(p, omega <= 0, NaN) } # qsn <- function(p, xi = 0, omega = 1, alpha = 0, tau=0, dp=NULL, tol = 1e-08, solver="NR", ...) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi <- dp[1] omega <- dp[2] alpha <- dp[3] tau <- if(length(dp) > 3) dp[4] else 0 } max.q <- sqrt(qchisq(p,1)) + tau min.q <- -sqrt(qchisq(1-p,1)) + tau if(tau == 0) { if(alpha == Inf) return(as.numeric(xi + omega * max.q)) if(alpha == -Inf) return(as.numeric(xi + omega * min.q)) } na <- is.na(p) | (p < 0) | (p > 1) zero <- (p == 0) one <- (p == 1) p <- replace(p, (na | zero | one), 0.5) dp0 <- c(0, 1, alpha, tau) if(solver == "NR") { dp0 <- c(0, 1, alpha, tau) cum <- sn.cumulants(dp=dp0, n=4) g1 <- cum[3]/cum[2]^(3/2) g2 <- cum[4]/cum[2]^2 x <- qnorm(p) x <- (x + (x^2 - 1) * g1/6 + x * (x^2 - 3) * g2/24 - x * (2 * x^2 - 5) * g1^2/36) x <- cum[1] + sqrt(cum[2]) * x px <- psn(x, dp=dp0, ...) max.err <- 1 while (max.err > tol) { # cat("qsn:", x, "\n") # cat('x, px:', format(c(x,px)),"\n") x1 <- x - (px - p)/dsn(x, dp=dp0) # x1 <- pmin(x1,max.q) # x1 <- pmax(x1,min.q) x <- x1 px <- psn(x, dp=dp0, ...) max.err <- max(abs(px-p)) if(is.na(max.err)) stop('failed convergence, try with solver="RFB"') } x <- replace(x, na, NA) x <- replace(x, zero, -Inf) x <- replace(x, one, Inf) q <- as.numeric(xi + omega * x) } else { if(solver == "RFB") { abs.alpha <- abs(alpha) if(alpha < 0) p <- (1-p) x <- xa <- xb <- xc <- fa <- fb <- fc <- rep(NA, length(p)) nc <- rep(TRUE, length(p)) # not converged (yet) nc[(na| zero| one)] <- FALSE fc[!nc] <- 0 xa[nc] <- qnorm(p[nc]) xb[nc] <- sqrt(qchisq(p[nc], 1)) + abs(tau) fa[nc] <- psn(xa[nc], 0, 1, abs.alpha, tau, ...) - p[nc] fb[nc] <- psn(xb[nc], 0, 1, abs.alpha, tau, ...) - p[nc] regula.falsi <- FALSE while (sum(nc) > 0) { # alternate regula falsi/bisection xc[nc] <- if(regula.falsi) xb[nc] - fb[nc] * (xb[nc] - xa[nc])/(fb[nc] - fa[nc]) else (xb[nc] + xa[nc])/2 fc[nc] <- psn(xc[nc], 0, 1, abs.alpha, tau, ...) - p[nc] pos <- (fc[nc] > 0) xa[nc][!pos] <- xc[nc][!pos] fa[nc][!pos] <- fc[nc][!pos] xb[nc][pos] <- xc[nc][pos] fb[nc][pos] <- fc[nc][pos] x[nc] <- xc[nc] nc[(abs(fc) < tol)] <- FALSE regula.falsi <- !regula.falsi } # x <- replace(x, na, NA) x <- replace(x, zero, -Inf) x <- replace(x, one, Inf) Sign <- function(x) sign(x) + as.numeric(x==0) q <- as.numeric(xi + omega * Sign(alpha)* x) } else stop("unknown solver")} names(q) <- names(p) return(q) } # rsn <- function(n=1, xi=0, omega=1, alpha=0, tau=0, dp=NULL) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi <- dp[1] omega <- dp[2] alpha <- dp[3] tau <- if(length(dp)>3) dp[4] else 0 } if(tau == 0) { u1 <- rnorm(n) u2 <- rnorm(n) id <- (u2 > alpha*u1) u1[id] <- (-u1[id]) z <- u1 } else { # for ESN use transformation method delta <- alpha/sqrt(1+alpha^2) truncN <- qnorm(runif(n, min=pnorm(-tau), max=1)) z <- delta * truncN + sqrt(1-delta^2) * rnorm(n) } y <- xi+omega*z attr(y, "family") <- "SN" attr(y, "parameters") <- c(xi,omega,alpha,tau) return(y) } dmsn <- function(x, xi=rep(0,length(alpha)), Omega, alpha, tau=0, dp=NULL, log=FALSE) { if(!(missing(alpha) & missing(Omega)) && !is.null(dp)) stop("You cannot set both component parameters and dp") if(!is.null(dp)){ if(length(dp) < 3) stop("wrong length of non-null 'dp'") xi <- drop(dp[[1]]) Omega <- dp[[2]] alpha <- dp[[3]] tau <- if(length(dp) == 4) dp[[4]] else 0 } if(any(abs(alpha) == Inf)) stop("Inf's in alpha are not allowed") d <- length(alpha) Omega <- matrix(Omega,d,d) invOmega <- pd.solve(Omega, silent=TRUE, log.det=TRUE) if (is.null(invOmega)) stop("Omega matrix is not positive definite") logDet <- attr(invOmega, "log.det") x <- if(is.vector(x)) matrix(x, 1, d) else data.matrix(x) if (is.vector(xi)) xi <- outer(rep(1, nrow(x)), as.vector(matrix(xi,1,d))) if(tau == 0){ log.const <- logb(2) alpha0 <- 0 } else { log.const <- -pnorm(tau, log.p=TRUE) O.alpha <- cov2cor(Omega) %*% alpha alpha0 <- tau*sqrt(1+sum(alpha* O.alpha)) } X <- t(x - xi) # Q <- apply((invOmega %*% X) * X, 2, sum) Q <- colSums((invOmega %*% X) * X) L <- alpha0 + as.vector(t(X/sqrt(diag(Omega))) %*% as.matrix(alpha)) logPDF <- (log.const - 0.5 * Q + pnorm(L, log.p = TRUE) - 0.5 * (d * logb(2 * pi) + logDet)) if (log) logPDF else exp(logPDF) } pmsn <- function(x, xi=rep(0,length(alpha)), Omega, alpha, tau=0, dp=NULL, ...) { if(!(missing(alpha) & missing(Omega)) && !is.null(dp)) stop("You cannot set both component parameters and dp") if(!is.null(dp)){ xi <- dp$xi Omega <- dp$Omega alpha <- dp$alpha tau <- if(is.null(dp$tau)) 0 else dp$tau } if(any(abs(alpha) == Inf)) stop("Inf's in alpha are not allowed") d <- length(alpha) Omega <- matrix(Omega, d, d) omega <- sqrt(diag(Omega)) delta_etc <- delta.etc(alpha, Omega) delta <- delta_etc$delta Ocor <- delta_etc$Omega.cor Obig <- matrix(rbind(c(1,-delta), cbind(-delta,Ocor)), d+1, d+1) x <- if (is.vector(x)) matrix(x, 1, d) else data.matrix(x) if (is.vector(xi)) xi <- outer(rep(1, nrow(x)), as.vector(matrix(xi,1,d))) z0 <- cbind(tau, t(t(x - xi))/omega) mnormt::pmnorm(z0, mean=rep(0,d+1), varcov=Obig, ...)/pnorm(tau) } rmsn <- function(n=1, xi=rep(0,length(alpha)), Omega, alpha, tau=0, dp=NULL) {# generates SN_d(..) variates using the additive (=transformation) method # if(!(missing(alpha) & missing(Omega) & !is.null(dp))) # stop("You cannot set both component parameters and dp") if(!is.null(dp)) { dp0 <- dp dp0$nu <- NULL if(is.null(dp0$tau)) dp0$tau <- 0 if(names(dp)[1] == "beta") { dp0[[1]] <- as.vector(dp[[1]]) names(dp0)[1] <- "xi" } } else dp0 <- list(xi=xi, Omega=Omega, alpha=alpha, tau=tau) if(any(abs(dp0$alpha) == Inf)) stop("Inf's in alpha are not allowed") lot <- dp2cpMv(dp=dp0, family="SN", aux=TRUE) d <- length(dp0$alpha) y <- matrix(rnorm(n*d), n, d) %*% chol(lot$aux$Psi) # each row is N_d(0,Psi) if(dp0$tau == 0) truncN <- abs(rnorm(n)) else truncN <- qnorm(runif(n, min=pnorm(-dp0$tau), max=1)) truncN <- matrix(rep(truncN, d), ncol=d) delta <- lot$aux$delta z <- delta * t(truncN) + sqrt(1-delta^2) * t(y) y <- t(dp0$xi + lot$aux$omega * z) attr(y, "family") <- "SN" attr(y, "parameters") <- dp0 return(y) } # dst <- function (x, xi=0, omega=1, alpha=0, nu=Inf, dp=NULL, log=FALSE) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both component parameters and dp") xi <- dp[1] omega <- dp[2] alpha <- dp[3] nu <- dp[4] } if (nu == Inf) return(dsn(x, xi, omega, alpha, log=log)) if (nu == 1) return(dsc(x, xi, omega, alpha, log=log)) z <- (x - xi)/omega pdf <- dt(z, df=nu, log=log) cdf <- pt(alpha*z*sqrt((nu+1)/(z^2+nu)), df=nu+1, log.p=log) if(log) logb(2) + pdf + cdf -logb(omega) else 2 * pdf * cdf / omega } rst <- function (n=1, xi = 0, omega = 1, alpha = 0, nu=Inf, dp=NULL) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both component parameters and dp") xi <- dp[1] omega <- dp[2] alpha <- dp[3] nu <- dp[4] } z <- rsn(n, 0, omega, alpha) if(nu < Inf) { v <- rchisq(n,nu)/nu y <- z/sqrt(v) + xi } else y <- z+xi attr(y, "family") <- "ST" attr(y, "parameters") <- c(xi,omega,alpha,nu) return(y) } pst <- function (x, xi=0, omega=1, alpha=0, nu=Inf, dp=NULL, method=0, ...) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both component parameters and dp") xi <- dp[1] omega <- dp[2] alpha <- dp[3] nu <- dp[4] } if(length(alpha) > 1) stop("'alpha' must be a single value") if(length(nu) > 1) stop("'nu' must be a single value") if (nu <= 0) stop("nu must be non-negative") if (nu == Inf) return(psn(x, xi, omega, alpha)) if (nu == 1) return(psc(x, xi, omega, alpha)) int.nu <- (round(nu) == nu) if((method == 1 | method ==4) & !int.nu) stop("selected method does not work for non-integer nu") ok <- !(is.na(x) | (x==Inf) | (x==-Inf)) z <- ((x-xi)/omega)[ok] if(abs(alpha) == Inf) { z0 <- replace(z, alpha*z < 0, 0) p <- pf(z0^2, 1, nu) return(if(alpha>0) p else (1-p)) } fp <- function(v, alpha, nu, t.value) psn(sqrt(v) * t.value, 0, 1, alpha) * dchisq(v * nu, nu) * nu if(method == 4 || (method ==0 && int.nu && (nu < (8.2 + 3.55* log(log(length(z)+1)))))) p <- pst_int(z, 0, 1, alpha, nu) # "method 4" else { p <- numeric(length(z)) for (i in seq_len(length(z))) { if(abs(z[i]) == Inf) p[i] <- (1+sign(z[i]))/2 else { if(method==1 | method == 0) p[i] <- pmst(z[i], 0, matrix(1,1,1), alpha, nu, ...) # method 1 else { # upper <- if(absalpha> 1) 5/absalpha + 25/(absalpha*nu) else 5+25/nu upper <- 10 + 50/nu if(method==2 || (method==0 & (z[i] < upper) )) p[i] <- integrate(dst, -Inf, z[i], dp=c(0,1,alpha, nu), ...)$value # method 2 else p[i] <- integrate(fp, 0, Inf, alpha, nu, z[i], ...)$value # method 3 }} }} pr <- rep(NA, length(x)) pr[x==Inf] <- 1 pr[x==-Inf] <- 0 pr[ok] <- p return(pmax(0,pmin(1,pr))) } pst_int <- function (x, xi=0, omega=1, alpha=0, nu=Inf) {# Jamalizadeh, A. and Khosravi, M. and Balakrishnan, N. (2009) if(nu != round(nu) | nu < 1) stop("nu not integer or not positive") z <- (x-xi)/omega if(nu == 1) atan(z)/pi + acos(alpha/sqrt((1+alpha^2)*(1+z^2)))/pi else { if(nu==2) 0.5 - atan(alpha)/pi + (0.5 + atan(z*alpha/sqrt(2+z^2))/pi)*z/sqrt(2+z^2) else (pst_int(sqrt((nu-2)/nu)*z, 0, 1, alpha, nu-2) + pst_int(sqrt(nu-1)*alpha*z/sqrt(nu+z^2), 0, 1, 0, nu-1) * z * exp(lgamma((nu-1)/2) +(nu/2-1)*log(nu)-0.5*log(pi)-lgamma(nu/2) -0.5*(nu-1)*log(nu+z^2))) } } qst <- function (p, xi = 0, omega = 1, alpha = 0, nu=Inf, tol = 1e-8, dp = NULL, method=0, ...) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both component parameters and dp") xi <- dp[1] omega <- dp[2] alpha <- dp[3] nu <- dp[4] } if(length(alpha) > 1) stop("'alpha' must be a single value") if(length(nu) > 1) stop("'nu' must be a single value") if (nu <= 0) stop("nu must be non-negative") if (nu > 1e4) return(qsn(p, xi, omega, alpha)) if (nu == 1) return(qsc(p, xi, omega, alpha)) if (alpha == Inf) return(xi + omega * sqrt(qf(p, 1, nu))) if (alpha == -Inf) return(xi - omega * sqrt(qf(1 - p, 1, nu))) na <- is.na(p) | (p < 0) | (p > 1) abs.alpha <- abs(alpha) if(alpha < 0) p <- (1-p) zero <- (p == 0) one <- (p == 1) x <- xa <- xb <- xc <- fa <- fb <- fc <- rep(NA, length(p)) nc <- rep(TRUE, length(p)) # not converged (yet) nc[(na| zero| one)] <- FALSE fc[!nc] <- 0 xa[nc] <- qt(p[nc], nu) xb[nc] <- sqrt(qf(p[nc], 1, nu)) fa[nc] <- pst(xa[nc], 0, 1, abs.alpha, nu, method=method, ...) - p[nc] fb[nc] <- pst(xb[nc], 0, 1, abs.alpha, nu, method=method, ...) - p[nc] regula.falsi <- FALSE while (sum(nc) > 0) { # alternate regula falsi/bisection xc[nc] <- if(regula.falsi) xb[nc] - fb[nc] * (xb[nc] - xa[nc])/(fb[nc] - fa[nc]) else (xb[nc] + xa[nc])/2 fc[nc] <- pst(xc[nc], 0, 1, abs.alpha, nu, method=method, ...) - p[nc] pos <- (fc[nc] > 0) xa[nc][!pos] <- xc[nc][!pos] fa[nc][!pos] <- fc[nc][!pos] xb[nc][pos] <- xc[nc][pos] fb[nc][pos] <- fc[nc][pos] x[nc] <- xc[nc] nc[(abs(fc) < tol)] <- FALSE regula.falsi <- !regula.falsi } # x <- replace(x, na, NA) x <- replace(x, zero, -Inf) x <- replace(x, one, Inf) Sign <- function(x) sign(x) + as.numeric(x==0) q <- as.numeric(xi + omega * Sign(alpha)* x) names(q) <- names(p) return(q) } dmst <- function(x, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, dp=NULL, log = FALSE) { if(!(missing(alpha) & missing(Omega)) && !is.null(dp)) stop("You cannot set both component parameters and dp") if(!is.null(dp)) { if(length(dp) != 4) stop("wrong length of non-null 'dp'") xi <- drop(dp[[1]]) Omega <- dp[[2]] alpha <- dp[[3]] nu <- dp[[4]] } if(any(abs(alpha) == Inf)) stop("Inf's in alpha are not allowed") if (nu == Inf) return(dmsn(x, xi, Omega, alpha, log = log)) d <- length(alpha) Omega <- matrix(Omega, d, d) if(!all(Omega - t(Omega) == 0)) return(NA) # stop("Omega not a symmetric matrix") invOmega <- pd.solve(Omega, silent=TRUE, log.det=TRUE) if(is.null(invOmega)) return(NA) # stop("Omega matrix is not positive definite") logDet <- attr(invOmega, "log.det") x <- if(is.vector(x)) matrix(x, 1, d) else data.matrix(x) if (is.vector(xi)) xi <- outer(rep(1, nrow(x)), as.vector(matrix(xi,1,d))) X <- t(x - xi) # Q <- apply((invOmega %*% X) * X, 2, sum) Q <- colSums((invOmega %*% X) * X) L <- as.vector(t(X/sqrt(diag(Omega))) %*% as.matrix(alpha)) if(nu < 1e4) { log.const <- lgamma((nu + d)/2)- lgamma(nu/2)-0.5*d*logb(nu) log1Q <- logb(1+Q/nu) } else { log.const <- (-0.5*d*logb(2)+ log1p((d/2)*(d/2-1)/nu)) log1Q <- log1p(Q/nu) } log.dmt <- log.const - 0.5*(d * logb(pi) + logDet + (nu + d)* log1Q) log.pt <- pt(L * sqrt((nu + d)/(Q + nu)), df = nu + d, log.p = TRUE) logPDF <- logb(2) + log.dmt + log.pt if (log) logPDF else exp(logPDF) } rmst <- function(n=1, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, dp=NULL) { if(!(missing(alpha) & missing(Omega)) && !is.null(dp)) stop("You cannot set both component parameters and dp") if(!is.null(dp)){ if(!is.null(dp$xi)) xi <- dp$xi else if(!is.null(dp$beta)) xi <- as.vector(dp$beta) Omega <- dp$Omega alpha <- dp$alpha nu <- dp$nu } if(any(abs(alpha) == Inf)) stop("Inf's in alpha are not allowed") d <- length(alpha) x <- if(nu==Inf) 1 else rchisq(n,nu)/nu z <- rmsn(n, rep(0,d), Omega, alpha) y <- t(xi+ t(z/sqrt(x))) attr(y, "family") <- "ST" attr(y, "parameters") <- list(xi=xi, Omega=Omega, alpha=alpha, nu=nu) return(y) } pmst <- function(x, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, dp=NULL, ...) { if(!(missing(alpha) & missing(Omega)) && !is.null(dp)) stop("You cannot set both component parameters and dp") if(!is.null(dp)){ if(!is.null(dp$xi)) xi <- dp$xi else if(!is.null(dp$beta)) xi <- as.vector(dp$beta) Omega <- dp$Omega alpha <- dp$alpha nu <- dp$nu } if(!is.vector(x)) stop("x must be a vector") if(any(abs(alpha) == Inf)) stop("Inf's in alpha are not allowed") if(nu == Inf) return(pmsn(x, xi, Omega, alpha)) d <- length(alpha) Omega<- matrix(Omega,d,d) omega<- sqrt(diag(Omega)) Ocor <- cov2cor(Omega) O.alpha <- as.vector(Ocor %*% alpha) delta <- O.alpha/sqrt(1 + sum(alpha*O.alpha)) Obig <- matrix(rbind(c(1, -delta), cbind(-delta, Ocor)), d+1, d+1) if(nu == as.integer(nu)) { z0 <- c(0,(x-xi)/omega) if(nu < .Machine$integer.max) p <- 2 * mnormt::pmt(z0, mean=rep(0,d+1), S=Obig, df=nu, ...) else p <- 2 * mnormt::pmnorm(z0, mean=rep(0,d+1), varcov=Obig, ...) } else {# for fractional nu, use formula in Azzalini & Capitanio (2003), # full-length paper, last paragraph of Section 4.2[Distr.function]) z <- (x-xi)/omega fp <- function(v, Ocor, alpha, nu, t.value) { pv <- numeric(length(v)) for(k in seq_len(length(v))) pv[k] <- (dchisq(v[k] * nu, nu) * nu * pmsn(sqrt(v[k]) * t.value, rep(0,d), Ocor, alpha) ) pv} p <- integrate(fp, 0, Inf, Ocor, alpha, nu, z, ...)$value } p } dmsc <- function(x, xi=rep(0,length(alpha)), Omega, alpha, dp=NULL, log = FALSE) { if(is.null(dp)) dp <- list(xi=xi, Omega=Omega, alpha=alpha, nu=1) else dp$nu <- 1 dmst(x, dp=dp, log = log) } pmsc <- function(x, xi=rep(0,length(alpha)), Omega, alpha, dp=NULL, ...) { if(is.null(dp)) dp <- list(xi=xi, Omega=Omega, alpha=alpha, nu=1) else dp$nu <- 1 pmst(x, dp=dp, ...) } rmsc <- function(n=1, xi=rep(0,length(alpha)), Omega, alpha, dp=NULL) { if(is.null(dp)) dp <- list(xi=xi, Omega=Omega, alpha=alpha, nu=1) else dp$nu <- 1 y <- rmst(n, dp=dp) attr(y, "family") <- "SC" attr(y, "parameters") <- dp[-4] return(y) } dsc <- function(x, xi=0, omega=1, alpha=0, dp=NULL, log = FALSE) { # log.pt2 <- function(x) log1p(x/sqrt(2+x^2)) - log(2) if(!is.null(dp)){ if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi <- dp[1] omega <- dp[2] alpha <- dp[3] } z <- (x-xi)/omega logPDF <- (dcauchy(x, xi, omega, log=TRUE) + log1p(alpha*z/sqrt(1+z^2*(1+alpha^2)))) if(log) logPDF else exp(logPDF) } psc <- function(x, xi=0, omega=1, alpha=0, dp=NULL) {# Behboodian et al. / Stat. & Prob. Letters 76 (2006) p.1490, line 2 if(!is.null(dp)){ if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi <- dp[1] omega <- dp[2] alpha <- dp[3] } z <- (x-xi)/omega delta <- if(abs(alpha)==Inf) sign(alpha) else alpha/sqrt(1+alpha^2) atan(z)/pi + acos(delta/sqrt(1+z^2))/pi } qsc <- function(p, xi=0, omega=1, alpha=0, dp=NULL) {# Behboodian et al. / Stat. & Prob. Letters 76 (2006) p.1490, formula (4) if(!is.null(dp)){ if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi<- dp[1] omega <- dp[2] alpha <- dp[3] } na <- is.na(p) | (p < 0) | (p > 1) zero <- (p == 0) one <- (p == 1) p <- replace(p, (na | zero | one), 0.5) u <- (p - 0.5) * pi delta <- if(abs(alpha) == Inf) sign(alpha) else alpha/sqrt(1+alpha^2) z <- delta/cos(u) + tan(u) z <- replace(z, na, NA) z <- replace(z, zero, -Inf) z <- replace(z, one, Inf) q <- (xi + omega*z) names(q) <- names(p) return(q) } rsc <- function(n=1, xi=0, omega=1, alpha=0, dp=NULL) { if(!is.null(dp)){ if(!missing(alpha)) stop("You cannot set both 'dp' and component parameters") xi <- dp[1] omega <- dp[2] alpha <- dp[3] } y <- xi + rsn(n, 0, omega, alpha)/abs(rnorm(n)) attr(y, "family") <- "SC" attr(y, "parameters") <- c(xi, omega, alpha) return(y) } sn.cumulants <- function(xi = 0, omega = 1, alpha = 0, tau=0, dp=NULL, n=4) { cumulants.half.norm <- function(n=4){ n <- max(n,2) n <- as.integer(2*ceiling(n/2)) half.n <- as.integer(n/2) m <- 0:(half.n-1) a <- sqrt(2/pi)/(gamma(m+1)*2^m*(2*m+1)) signs <- rep(c(1, -1), half.n)[seq_len(half.n)] a <- as.vector(rbind(signs*a, rep(0,half.n))) coeff <- rep(a[1],n) for (k in 2:n) { ind <- seq_len(k-1) coeff[k] <- a[k] - sum(ind*coeff[ind]*a[rev(ind)]/k) } kappa <- coeff*gamma(seq_len(n)+1) kappa[2] <- 1 + kappa[2] return(kappa) } if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both component parameters and dp") dp <- c(dp,0)[1:4] dp <- matrix(dp, 1, ncol=length(dp)) } else dp <- cbind(xi,omega,alpha,tau) delta <- ifelse(abs(dp[,3])n) kv <- kv[-(n+1)] kv[2] <- kv[2] - 1 kappa <- outer(delta,1:n,"^") * matrix(rep(kv,nrow(dp)),ncol=n,byrow=TRUE) } else{ # ESN if(n>4){ warning("n>4 not allowed with ESN distribution") n <- min(n, 4) } kappa <- matrix(0, nrow=length(delta), ncol=0) for (k in 1:n) kappa <- cbind(kappa, zeta(k,tau)*delta^k) } kappa[,2] <- kappa[,2] + 1 kappa <- kappa * outer(dp[,2],(1:n),"^") kappa[,1] <- kappa[,1] + dp[,1] kappa[,,drop=TRUE] } zeta <- function(k, x) { # k integer in (0,5) if(k<0 | k>5 | k != round(k)) return(NULL) na <- is.na(x) x <- replace(x,na,0) x2 <- x^2 z <- switch(k+1, pnorm(x, log.p=TRUE) + log(2), ifelse(x>(-50), exp(dnorm(x, log=TRUE) - pnorm(x, log.p=TRUE)), -x/(1 -1/(x2+2) +1/((x2+2)*(x2+4)) -5/((x2+2)*(x2+4)*(x2+6)) +9/((x2+2)*(x2+4)*(x2+6)*(x2+8)) -129/((x2+2)*(x2+4)*(x2+6)*(x2+8)*(x2+10)) )), (-zeta(1,x)*(x+zeta(1,x))), (-zeta(2,x)*(x+zeta(1,x)) - zeta(1,x)*(1+zeta(2,x))), (-zeta(3,x)*(x+2*zeta(1,x)) - 2*zeta(2,x)*(1+zeta(2,x))), (-zeta(4,x)*(x+2*zeta(1,x)) -zeta(3,x)*(3+4*zeta(2,x)) -2*zeta(2,x)*zeta(3,x)), NULL) neg.inf <- (x == -Inf) if(any(neg.inf)) z <- switch(k+1, z, replace(z, neg.inf, Inf), replace(z, neg.inf, -1), replace(z, neg.inf, 0), replace(z, neg.inf, 0), replace(z, neg.inf, 0), NULL) if(k>1) z<- replace(z, x==Inf, 0) replace(z, na, NA) } st.cumulants <- function(xi=0, omega=1, alpha=0, nu=Inf, dp=NULL, n=4) { if(!is.null(dp)) { if(!missing(alpha)) stop("You cannot set both component parameters and dp") xi <- dp[1] omega <- dp[2] alpha <- dp[3] nu <- dp[4] } if(nu == Inf) return(sn.cumulants(xi, omega, alpha, n=n)) n <- min(as.integer(n),4) # if(nu <= n) stop("need nu>n") par <- cbind(xi,omega,alpha) delta <- par[,3]/sqrt(1+par[,3]^2) cum<- matrix(NA, nrow=nrow(par), ncol=n) cum[,1]<- mu <- b(nu)*delta # if(n>1) cum[,2] <- nu/(nu-2) - mu^2 # if(n>2) cum[,3] <- mu*(nu*(3-delta^2)/(nu-3) - 3*nu/(nu-2)+2*mu^2) # if(n>3) cum[,4] <- (3*nu^2/((nu-2)*(nu-4)) - 4*mu^2*nu*(3-delta^2)/(nu-3) # + 6*mu^2*nu/(nu-2)-3*mu^4)- 3*cum[,2]^2 r <- function(nu, k1, k2) 1/(1-k2/nu) - k1/(nu-k2) # (nu-k1)/(nu-k2) if(n>1 & nu>2) cum[,2] <- r(nu,0,2) - mu^2 if(n>2 & nu>3) cum[,3] <- mu*((3-delta^2)*r(nu,0,3) - 3*r(nu,0,2) + 2*mu^2) if(n>3 & nu>4) cum[,4] <- (3*r(nu,0,2)*r(nu,0,4) - 4*mu^2*(3-delta^2)*r(nu,0,3) + 6*mu^2*r(nu,0,2)-3*mu^4) - 3*cum[,2]^2 cum <- cum*outer(par[,2],1:n,"^") cum[,1] <- cum[,1]+par[,1] cum[,,drop=TRUE] } T.Owen <- function(h, a, jmax=50, cut.point=8) { T.int <-function(h, a, jmax, cut.point) { fui <- function(h,i) (h^(2*i))/((2^i)*gamma(i+1)) seriesL <- seriesH <- NULL i <- 0:jmax low<- (h <= cut.point) hL <- h[low] hH <- h[!low] L <- length(hL) if (L > 0) { b <- outer(hL, i, fui) cumb <- apply(b, 1, cumsum) b1 <- exp(-0.5*hL^2) * t(cumb) matr <- matrix(1, jmax+1, L) - t(b1) jk <- rep(c(1,-1), jmax)[1:(jmax+1)]/(2*i+1) matr <- t(matr*jk) %*% a^(2*i+1) seriesL <- (atan(a) - as.vector(matr))/(2*pi) } if (length(hH) > 0) seriesH <- atan(a)*exp(-0.5*(hH^2)*a/atan(a)) * (1+0.00868*(hH*a)^4)/(2*pi) series <- c(seriesL, seriesH) id <- c((1:length(h))[low],(1:length(h))[!low]) series[id] <- series # re-sets in original order series } if(!is.vector(a) | length(a)>1) stop("'a' must be a vector of length 1") if(!is.vector(h)) stop("'h' must be a vector") aa <- abs(a) ah <- abs(h) if(is.na(aa)) stop("parameter 'a' is NA") if(aa==Inf) return(sign(a)*0.5*pnorm(-ah)) # sign(a): 16.07.2007 if(aa==0) return(rep(0,length(h))) na <- is.na(h) inf <- (ah == Inf) ah <- replace(ah,(na|inf),0) if(aa <= 1) owen <- T.int(ah,aa,jmax,cut.point) else owen<- (0.5*pnorm(ah) + pnorm(aa*ah)*(0.5-pnorm(ah)) - T.int(aa*ah,(1/aa),jmax,cut.point)) owen <- replace(owen,na,NA) owen <- replace(owen,inf,0) return(owen*sign(a)) } #========================================================================= makeSECdistr <- function(dp, family, name, compNames) { ndp <- switch(tolower(family), "sn" = 3, "esn" = 4, "st" = 4, "sc" = 3, NULL) if(is.null(ndp)) stop(gettextf("unknown family '%s'", family)) family <- toupper(family) if(length(dp) != ndp) stop(gettextf("wrong number of dp components for family '%s'", family)) if(family == "ST") { nu <- as.numeric(dp[4]) if(nu <= 0) stop("'nu' for ST family must be positive") if(nu == Inf) { warning("ST family with 'nu==Inf' is changed to SN family") family <- "SN" dp <- dp[-4] }} if(is.numeric(dp)){ # univariate distribution if(dp[2] <= 0) stop("omega parameter must be positive") fourth <- switch(family, "SN"=NULL, "ESN"="tau", "SC"=NULL, "ST"="nu") names(dp) <- c("xi","omega","alpha",fourth) name <- if(!missing(name)) as.character(name)[1] else paste("Unnamed-", toupper(family), sep="") obj <- new("SECdistrUv", dp=dp, family=family, name=name) } else {if(is.list(dp)) {# multivariate distribution names(dp) <- rep(NULL,ndp) d <- length(dp[[3]]) if(any(abs(dp[[3]]) == Inf)) stop("Inf in alpha not allowed") if(length(dp[[1]]) != d) stop("mismatch of parameters size") Omega <- matrix(dp[[2]],d,d) if(any(Omega != t(Omega))) stop("Omega matrix must be symmetric") if(min(eigen(Omega, symmetric=TRUE, only.values=TRUE)$values) <= 0) stop("Omega matrix must be positive definite") dp0 <- list(xi=as.vector(dp[[1]]), Omega=Omega, alpha=dp[[3]]) name <- if(!missing(name)) as.character(name)[1] else paste("Unnamed-", toupper(family), "[d=", as.character(d), "]", sep="") if(family=="ST") dp0$nu <- nu if(family=="ESN") dp0$tau <- dp[[4]] if(d == 1) warning(paste( "A multivariate distribution with dimension=1 is a near-oxymoron.", "\nConsider using a 'dp' vector to define a univariate distribution.", "\nHowever, I still build a multivariate distribution for you.")) if(missing(compNames)) { compNames <- if(length(names(dp[[1]])) == d) names(dp[[1]]) else as.vector(outer("V",as.character(1:d),paste,sep="")) } else { if(length(compNames) != d) stop("Wrong length of 'compNames'") compNames <- as.character(as.vector(compNames)) } names(dp0$alpha) <- names(dp0$xi) <- compNames dimnames(dp0$Omega) <- list(compNames, compNames) obj <- new("SECdistrMv", dp=dp0, family=family, name=name, compNames=compNames) } else stop("'dp' must be either a numeric vector or a list")} obj } summary.SECdistrUv <- function(object, cp.type="auto", probs) { cp.type <- match.arg(tolower(cp.type), c("proper", "pseudo", "auto")) family <- slot(object,"family") lc.family <- tolower(family) name <- slot(object,"name") dp <- slot(object,"dp") # op <- dp2op(dp, family) if(family=="ST" || family=="SC") { if(cp.type=="auto") cp.type <- if(family == "SC" | dp[4] <= 4) "pseudo" else "proper" } if(family=="SN" || family=="ESN") cp.type <- "proper" cp <- dp2cpUv(dp, family, cp.type) if(is.null(cp)) stop('Stop. Consider using cp.type=="pseudo"') if(missing(probs)) probs <- c(0.05, 0.25, 0.50, 0.75, 0.95) if(lc.family == "esn") lc.family <- "sn" q.fn <- get(paste("q",lc.family, sep=""), inherits = TRUE) q <- q.fn(probs, dp=dp) names(q) <- format(probs) cum <- switch(lc.family, "sn" = sn.cumulants(dp=dp, n=4), "st" = st.cumulants(dp=dp, n=4), rep(NA,4) ) std.cum <- c(gamma1=cum[3]/cum[2]^1.5, gamma2=cum[4]/cum[2]^2) oct <- q.fn(p=(1:7)/8, dp=dp) mode <- modeSECdistrUv(dp, family) alpha<- as.numeric(dp[3]) delta <- delta.etc(alpha) q.measures <- c(bowley=(oct[6]-2*oct[4]+oct[2])/(oct[6]-oct[2]), moors=(oct[7]-oct[5]+oct[3]-oct[1])/(oct[6]-oct[2])) aux <- list(delta=delta, mode=mode, quantiles=q, std.cum=std.cum, q.measures=q.measures) new("summary.SECdistrUv", dp=dp, family=family, name=name, cp=cp, cp.type=cp.type, aux=aux) } modeSECdistr <- function(dp, family, object=NULL) { if(!is.null(object)) { if(!missing(dp)) stop("you cannot set both arguments dp and obj") obj.class <- class(object) if(!(obj.class %in% c("SECdistrUv", "SECdistrMv"))) stop(gettextf("wrong object class: '%s'", obj.class), domain = NA) family <- slot(object, "family") dp <- slot(object, "dp") } else { if(missing(family)) stop("family required") family <- toupper(family) if(!(family %in% c("SN", "ESN", "ST","SC"))) stop(gettextf("family '%s' is not supported", family), domain = NA) } if(is.list(dp)) modeSECdistrMv(dp, family) else modeSECdistrUv(dp, family) } modeSECdistrUv <- function(dp, family) { if(abs(dp[3]) < .Machine$double.eps) return(as.numeric(dp[1])) cp <- dp2cpUv(dp, family, cp.type="auto", upto=1) lc.family <- tolower(family) if(lc.family == "esn") lc.family <- "sn" d.fn <- get(paste("d", lc.family, sep=""), inherits = TRUE) int <- c(dp[1], cp[1]) if(abs(diff(int)) < .Machine$double.eps) return(mean(int)) opt <- optimize(d.fn, lower=min(int), upper=max(int), maximum=TRUE, dp=dp) as.numeric(opt$maximum) } modeSECdistrMv <- function(dp, family) { Omega <- dp[[2]] alpha <- dp[[3]] delta_etc <- delta.etc(alpha, Omega) alpha.star <- delta_etc$alpha.star if(alpha.star < .Machine$double.eps) return(dp[[1]]) lc.family <- tolower(family) if(lc.family == "esn") lc.family <- "sn" direct <- sqrt(diag(Omega)) * (delta_etc$delta/delta_etc$delta.star) if(lc.family == "sn") {# case SN: book (5.49), +ESN dp1 <- c(xi=0, omega=1, alpha=alpha.star, dp$tau) mode.can <- modeSECdistrUv(dp1, family) mode <- as.numeric(dp[[1]] + mode.can * direct) } else { # ST, SC: book Prop. 6.2 d.fn <- get(paste("dm", lc.family, sep=""), inherits = TRUE) f <- function(u, dp, direct) -d.fn(dp[[1]]+ u*direct, dp=dp, log=TRUE) maxM <- max(dp2cpMv(dp, family, "auto", upto=1)[[1]] - dp[[1]]/direct) opt <- optimize(f, lower=0, upper=maxM, dp=dp, direct=direct) mode <- as.numeric(dp[[1]]+ opt$minimum * direct) } return(mode) } summary.SECdistrMv <- function(object, cp.type="auto") { cp.type <- match.arg(tolower(cp.type), c("proper", "pseudo", "auto")) family <- slot(object,"family") name <- slot(object,"name") dp <- slot(object,"dp") # op <- dp2op(dp, family) if(family == "SN" || family == "ESN") cp.type <- "proper" if(family=="ST" || family=="SC") { if(cp.type=="auto") cp.type <- if(family == "SC" || dp$nu <= 4) "pseudo" else "proper"} cp <- dp2cpMv(dp, family, cp.type, aux=TRUE) aux <- cp$aux if(family=="SN" | family=="SC") cp <- cp[1:3] cp[["aux"]] <- NULL mode <- modeSECdistrMv(dp, family) aux0 <- list(mode=mode, delta=aux$delta, alpha.star=aux$alpha.star, delta.star=aux$delta.star, mardia=aux$mardia) new("summary.SECdistrMv", dp=dp, family=family, name=object@name, compNames=object@compNames, cp=cp, cp.type=cp.type, aux=aux0) } dp2cp <- function(dp, family, object=NULL, cp.type="proper", upto=NULL) { if(!is.null(object)){ if(!missing(dp)) stop("you cannot set both arguments dp and object") obj.class <- class(object) if(!(obj.class %in% c("SECdistrUv", "SECdistrMv"))) stop(gettextf("wrong object class: '%s'", obj.class), domain = NA) family <- slot(object, "family") dp <- slot(object,"dp") multiv <- (obj.class == "SECdistrMv") } else{ if(missing(family)) stop("family required") family <- toupper(family) if(!(family %in% c("SN", "ESN", "ST","SC"))) stop(gettextf("family '%s' is not supported", family), domain = NA) multiv <- is.list(dp) } if(!is.null(upto)) if(upto<0 | upto>4 | upto != round(upto)) { warning("unsuitable value of argument 'upto', reset to NULL") upto <- NULL} if(multiv) dp2cpMv(dp, family, cp.type, upto=upto) else dp2cpUv(dp, family, cp.type, upto=upto) } dp2cpUv <- function(dp, family, cp.type="proper", upto=NULL) { # internal function; works also with regression parameters included cp.type <- match.arg(tolower(cp.type), c("proper", "pseudo", "auto")) family <- toupper(family) if(!(family %in% c("SN", "ESN", "ST", "SC"))) stop(gettextf("family = '%s' is not supported", family), domain = NA) if(family %in% c("SN","ESN")){ if(cp.type == "pseudo") warning("'cp.type=pseudo' makes no sense for SN and ESN families") p <- length(dp)-2-as.numeric(family=="ESN") omega <- dp[p+1] if(omega <= 0) stop("scale parameter 'omega' must be positive") alpha <- dp[p+2] tau <- if(family=="ESN") as.numeric(dp[p+3]) else 0 delta <- if(abs(alpha) < Inf) alpha/sqrt(1+alpha^2) else sign(alpha) mu.Z <- zeta(1,tau)*delta s.Z <- sqrt(1+zeta(2,tau)*delta^2) gamma1 <- zeta(3,tau)*(delta/s.Z)^3 sigma <- omega*s.Z mu <- dp[1:p] mu[1] <- dp[1]+sigma*mu.Z/s.Z beta1 <- if(p>1) mu[2:p] else NULL cp <- c(mu, sigma, gamma1, if(family=="ESN") tau else NULL) names(cp) <- param.names("CP", family, p, x.names=names(beta1)) if(!is.null(upto)) cp <- cp[1:(upto+p-1)] } if(family=="ST" || family=="SC") { if(cp.type=="auto") cp.type <- if(family == "SC" || dp[4] <= 4) "pseudo" else "proper" } if(family %in% c("SC", "ST")) { fixed.nu <- if(family=="SC") 1 else NULL cp <- st.dp2cp(dp, cp.type, fixed.nu, jacobian=FALSE, upto=upto) if(is.null(cp)) {warning("no CP could be found"); return(invisible())} # param.type <- switch(cp.type, proper="CP", pseudo="pseudo-CP") # names(cp) <- param.names(param.type, family) } return(cp) } dp2cpMv <- function(dp, family, cp.type="proper", fixed.nu=NULL, aux=FALSE, upto=NULL) {# internal. NB: name of cp[1] must change according to dp[1] cp.type <- match.arg(cp.type, c("proper", "pseudo", "auto")) family <- toupper(family) if(!(family %in% c("SN", "ESN", "ST","SC"))) stop(gettextf("family '%s' is not supported", family), domain = NA) if(family %in% c("SN","ESN")){ if(cp.type == "pseudo") warning("'cp.type=pseudo' makes no sense for SN and ESN families") cp <- msn.dp2cp(dp, aux=aux) if(!is.null(upto)) cp <- cp[1:upto] } if(family %in% c("SC","ST")){ if(cp.type=="auto") cp.type <- if(family == "SC" || dp$nu <= 4) "pseudo" else "proper" if(family == "SC") fixed.nu <- 1 cp <- mst.dp2cp(dp, cp.type=cp.type, fixed.nu=fixed.nu, aux=aux, upto=upto) if(is.null(cp)) {warning("no CP could be found"); return(invisible())} } return(cp) } msn.dp2cp <- function(dp, aux=FALSE) {# dp2cp for multivariate SN and ESN alpha <- dp$alpha d <- length(alpha) Omega <- matrix(dp$Omega, d, d) omega <- sqrt(diag(Omega)) lot <- delta.etc(alpha, Omega) delta <- lot$delta delta.star <- lot$delta.star alpha.star <- lot$alpha.star names(delta) <- names(dp$alpha) tau <- if(is.null(dp$tau)) 0 else dp$tau mu.z <- zeta(1, tau) * delta sd.z <- sqrt(1 + zeta(2, tau) * delta^2) Sigma <- Omega + zeta(2,tau) * outer(omega*delta, omega*delta) gamma1 <- zeta(3, tau) * (delta/sd.z)^3 if(is.vector(dp[[1]])) { cp <- list(mean=dp[[1]] + mu.z*omega, var.cov=Sigma, gamma1=gamma1) } else { beta <- dp[[1]] beta[1,] <- beta[1,] + mu.z*omega cp <- list(beta=beta, var.cov=Sigma, gamma1=gamma1) } if(!is.null(dp$tau)) cp$tau <- tau if(aux){ lambda <- delta/sqrt(1-delta^2) D <- diag(sqrt(1+lambda^2), d, d) Ocor <- lot$Omega.cor Psi <- D %*% (Ocor-outer(delta,delta)) %*% D Psi <- (Psi + t(Psi))/2 O.inv <- pd.solve(Omega) O.pcor <- -cov2cor(O.inv) O.pcor[cbind(1:d, 1:d)] <- 1 R <- force.symmetry(Ocor + zeta(2,tau)*outer(delta,delta)) ratio2 <- delta.star^2/(1+zeta(2,tau)*delta.star^2) mardia <- c(gamma1M=zeta(3,tau)^2*ratio2^3, gamma2M=zeta(4,tau)*ratio2^2) # book: (5.74), (5.75) on p.153 cp$aux <- list(omega=omega, cor=R, Omega.inv=O.inv, Omega.cor=Ocor, Omega.pcor=O.pcor, lambda=lambda, Psi=Psi, delta=delta, lambda=lambda, delta.star=delta.star, alpha.star=alpha.star, mardia=mardia) } return(cp) } mst.dp2cp <- function(dp, cp.type="proper", fixed.nu=NULL, symmetr=FALSE, aux=FALSE, upto=NULL) {# dp2cp for multivariate ST, returns NULL if CP not found (implicitly silent) nu <- if(is.null(fixed.nu)) dp$nu else fixed.nu if(is.null(upto)) upto <- 4L if((round(upto) != upto)||(upto < 1)) stop("'upto' must be positive integer") if(nu <= upto && (cp.type =="proper")) return(NULL) if(cp.type == "proper") { if(nu <= upto) # stop(gettextf("d.f. '%s' too small, CP is undefined", nu), domain = NA) return(NULL) a <- rep(0, upto) tilde <- NULL } else { a <- (1:upto) tilde <- rep("~", upto) } Omega <- dp$Omega d <- ncol(Omega) comp.names <- colnames(dp$Omega) alpha <- if(symmetr) rep(0, d) else dp$alpha omega <- sqrt(diag(Omega)) lot <- delta.etc(alpha, Omega) delta <- lot$delta delta.star <- lot$delta.star alpha.star <- lot$alpha.star comp.names <- colnames(dp$Omega) names(delta) <- comp.names mu0 <- b(nu+a[1]) * delta * omega names(mu0) <- comp.names mu.2 <- b(nu+a[2]) * delta * omega if(is.vector(dp[[1]])) cp <- list(mean=dp[[1]] + mu0) else { beta <- dp[[1]] beta[1,] <- beta[1,] + mu0 cp <- list(beta=beta) } if(upto > 1) { Sigma <- Omega * (nu+a[2])/(nu+a[2]-2) - outer(mu.2, mu.2) dimnames(Sigma) <- list(comp.names, comp.names) cp$var.cov <- Sigma } cp$gamma1 <- if(upto > 2 & !symmetr) st.gamma1(delta, nu+a[3]) else NULL cp$gamma2M <- if(upto > 3 & is.null(fixed.nu)) mst.gamma2M(delta.star^2, nu+a[4], d) else NULL names(cp) <- paste(names(cp), tilde[1:length(cp)], sep="") # cp <- cp[1:length(dp1)] if(aux){ mardia <- mst.mardia(delta.star^2, nu, d) cp$aux <- list(fixed.nu=fixed.nu, omega=omega, Omega.cor=lot$Omega.cor, delta=delta, delta.star=delta.star, alpha.star=alpha.star, mardia=mardia) } return(cp) } mst.gamma2M <- function(delta.sq, nu, d) { # Mardia's index of kurtosis gamma_2 for ST-d if(delta.sq < 0 | delta.sq >1 ) stop("delta.sq not in (0,1)") ifelse(nu>4, {R <- b(nu)^2 * delta.sq * (nu-2)/nu R1R <- R/(1-R) (2*d*(d+2)/(nu-4) + (R/(1-R)^2)*8/((nu-3)*(nu-4)) +2*R1R^2*(-(nu^2-4*nu+1)/((nu-3)*(nu-4))+2*(nu/((nu-3)*b(nu)^2)-1)) +4*d*R1R/((nu-3)*(nu-4))) }, Inf) } mst.mardia <- function(delta.sq, nu, d) {# Mardia's gamma1 and gamam2 for MST; book: (6.31), (6.32), p.178 if(delta.sq < 0 | delta.sq > 1) stop("delta.sq not in (0,1)") if(d < 1) stop("d < 1") cum <- st.cumulants(0, 1, sqrt(delta.sq/(1-delta.sq)), nu) mu <- cum[1] sigma <- sqrt(cum[2]) gamma1 <- cum[3]/sigma^3 gamma2 <- cum[4]/sigma^4 gamma1M <- if(nu > 3) (gamma1^2 + 3*(d-1)*mu^2/((nu-3)*sigma^2)) else Inf r <- function(nu, k1, k2) 1/(1 - k2/nu) - k1/(nu - k2) # (nu-k1)/(nu-k2) gamma2M <- if(nu > 4) (gamma2 + 3 +(d^2-1)*r(nu,2,4) +2*(d-1)*(r(nu,0,4) -mu^2*r(nu,1,3))/sigma^2 - d*(d+2)) else Inf return(c(gamma1M=gamma1M, gamma2M=gamma2M)) } cp2dp <- function(cp, family){ family <- toupper(family) if(!(family %in% c("SN", "ESN", "ST","SC"))) stop(gettextf("family '%s' is not supported", family), domain = NA) dp <- if(is.list(cp)) cp2dpMv(cp, family) else cp2dpUv(cp, family) if(anyNA(dp)) dp <- NULL return(dp) } cp2dpUv <- function(cp, family, silent=FALSE, tol=1e-8) { # internal function; works also with regression parameters included family <- toupper(family) if(family=="ESN") stop("cp2dp for ESN not yet implemented") if(family == "SN") { p <- length(cp)-2-as.numeric(family=="ESN") beta1 <- if (p>1) cp[2:p] else NULL b <- sqrt(2/pi) sigma <- cp[p+1] excess <- max(0, -sigma) gamma1 <- cp[p+2] tau <- if(family=="ESN") as.numeric(cp[p+3]) else 0 max.gamma1 <- 0.5*(4-pi)*(2/(pi-2))^1.5 if (abs(gamma1) >= max.gamma1) { if (silent) excess <- excess + (abs(gamma1) - max.gamma1) else {message("gamma1 outside admissible range"); return(invisible())}} if(excess > 0) { out <- NA attr(out, "excess") <- excess return(out) } r <- sign(gamma1)*(2*abs(gamma1)/(4-pi))^(1/3) delta <- r/(b*sqrt(1+r^2)) alpha <- delta/sqrt(1-delta^2) mu.z <- b*delta sd.z <- sqrt(1-mu.z^2) beta <- cp[1:p] omega <- cp[p+1]/sd.z beta[1] <- cp[1] - omega*mu.z dp <- as.numeric(c(beta, omega, alpha)) names(dp) <- param.names("DP", family, p, x.names=names(beta1)) return(dp) } if(family == "ST") return(st.cp2dp(cp, silent=silent, tol=tol)) if(family == "SC") stop("this makes no sense for SC family") warning(gettextf("family = '%s' is not supported", family), domain = NA) invisible(NULL) } cp2dpMv <- function(cp, family, silent=FALSE, tol=1e-8) { # internal function if(family == "SN") dp <- msn.cp2dp(cp, silent) else if(family == "ESN") stop("cp2dp for ESN not yet implemented") else if(family == "ST") dp <- mst.cp2dp(cp, silent, tol=tol) else if(family == "SC") stop("this makes no sense for SC family") else warning(gettextf("family = '%s' is not supported", family), domain = NA) return(dp) } msn.cp2dp <- function(cp, silent=FALSE) { beta <- cp[[1]] Sigma <- cp[[2]] gamma1 <- cp[[3]] d <- length(gamma1) b <- sqrt(2/pi) max.gamma1 <- 0.5*(4-pi)*(2/(pi-2))^1.5 if(any(abs(gamma1) >= max.gamma1)) {if(silent) return(NULL) else stop("non-admissible CP")} R <- sign(gamma1)*(2*abs(gamma1)/(4-pi))^(1/3) delta <- R/(b*sqrt(1+R^2)) mu.z <- b*delta omega <- sqrt(diag(Sigma)/(1-mu.z^2)) Omega <- Sigma + outer(mu.z*omega, mu.z*omega) Omega.bar <- cov2cor(Omega) Obar.inv <- pd.solve(Omega.bar, silent=silent) if(is.null(Obar.inv)) {if(silent) return(NULL) else stop("non-admissible CP")} Obar.inv.delta <- as.vector(Obar.inv %*% delta) delta.sq <- sum(delta * Obar.inv.delta) if(delta.sq >= 1) {if(silent) return(NULL) else stop("non-admissible CP")} alpha <- Obar.inv.delta/sqrt(1-delta.sq) if(is.vector(beta)) { beta <- beta - omega*mu.z dp <- list(beta=beta, Omega=Omega, alpha=alpha) } else { beta[1,] <- beta[1,] - omega*mu.z dp <- list(beta=beta, Omega=Omega, alpha=alpha) } attr(dp, "delta.star") <- sqrt(delta.sq) return(dp) } st.dp2cp <- function(dp, cp.type="proper", fixed.nu=NULL, jacobian=FALSE, upto=NULL) { if(any(is.na(dp))) stop("NA's in argument 'dp'") if(!(cp.type %in% c("proper", "pseudo"))) stop("invalid cp.type") nu <- if(is.null(fixed.nu)) dp[length(dp)] else fixed.nu if(is.null(upto)) upto <- 4L if((round(upto) != upto)||(upto < 1)) stop("'upto' must be positive integer") if(nu <= upto && (cp.type =="proper")) return(NULL) p <- length(dp) - 2 - is.null(fixed.nu) beta1 <- if(p>1) dp[2:p] else NULL dp <- c(dp[1], dp[p+1], dp[p+2], nu) a <- if(cp.type == "proper") rep(0,upto) else (1:upto) omega <- dp[2] alpha <- dp[3] delta <- delta.etc(alpha) mu.z <- function(delta, nu) delta*b(nu) mu <- dp[1] + dp[2]* mu.z(delta, nu+a[1]) cp <- c(mu, beta1) if(upto > 1) { kappa2 <- function(delta,nu) nu/(nu-2) - mu.z(delta,nu)^2 sigma <- omega * sqrt(kappa2(delta, nu+a[2])) cp <- c(cp, sigma) } if(upto > 2) { g1 <- st.gamma1(delta, nu+a[3]) cp <- c(cp, g1) } if(upto > 3) { g2 <- st.gamma2(delta, nu+a[4]) cp <- c(cp, g2)} rv.comp <- c(rep(TRUE,upto-1), rep(FALSE, 4-upto)) param.type <- switch(cp.type, proper="CP", pseudo="pseudo-CP") names(cp) <- param.names(param.type, "ST", p, x.names=names(beta1), rv.comp) if(!is.null(fixed.nu) && upto==4) cp <- cp[-length(cp)] if(jacobian && (nu+a[3] > 3)) { u <- function(nu) 0.5*(1/nu + digamma((nu-1)/2) - digamma(nu/2)) Ddelta <- 1/(1+alpha^2)^1.5 Dkappa2.nu <- function(delta,nu) (-2)*(1/(nu-2)^2 + mu.z(delta,nu)^2 * u(nu)) Dg1.delta <- function(delta,nu) { # derivative di gamma1 wrt delta k2 <- kappa2(delta,nu) tmp <- nu/(nu-2)-delta^2*(nu-2*b(nu)^2*(nu-2)) (3*b(nu) *nu *tmp)/(k2^2.5 * (nu-2)*(nu-3)) } Dg1.nu <- function(delta,nu) {# derivative di gamma1 wrt nu k1 <- mu.z(delta,nu) k2 <- kappa2(delta,nu) Dk2.nu <- Dkappa2.nu(delta,nu) (g1*u(nu) + k1/k2^1.5*(-3*(3-delta^2)/(nu-3)^2 + 6/(nu-2)^2 + 4*k1^2*u(nu)) -3*g1*Dk2.nu/(2*k2)) } Dg2.delta <- function(delta,nu) {# derivative di gamma2 wrt delta k1 <- mu.z(delta, nu) k2 <- kappa2(delta,nu) 4*b(nu)^2*delta/k2 * (g2 + 3 -(2*(3-2*delta^2)*nu/(nu-3) -3*nu/(nu-2)+3*k1^2)/k2) } Dg2.nu <- function (delta, nu) {# derivative di gamma2 wrt nu k1 <- mu.z(delta, nu) k2 <- kappa2(delta,nu) b. <- b(nu) u. <- u(nu) k4 <- (3 * nu^2/((nu - 2) * (nu - 4)) -6*(delta*b.)^2 * nu*(nu-1)/((nu-2)*(nu-3)) + delta^4 * b.^2* (4*nu/(nu-3)-3*b.^2)) Dk4.nu <- (-6*nu*(3*nu-8)/((nu-2)*(nu-4))^2 -4*k1^2*(3-delta^2)*((2*u.*nu+1)*(nu-3)-nu)/(nu-3)^2 +6*k1^2*((2*u(nu)*nu+1)*(nu-2)-nu)/(nu-2)^2 -12*k1^4*u.) Dk2.nu <- Dkappa2.nu(delta,nu) Dk4.nu/k2^2 - 2*k4*Dk2.nu/k2^3 } Dcp.dp <- if(is.null(fixed.nu)) diag(1, p+3) else diag(1, p+2) Dcp.dp[1, p+1] <- mu.z(delta, nu+a[1]) Dcp.dp[1, p+2] <- omega * Ddelta * b(nu+a[1]) sigma.z <- sqrt(kappa2(delta, nu+a[2])) Dcp.dp[p+1,p+1] <- sigma.z Dcp.dp[p+1,p+2] <- -omega *delta *b(nu+a[2])^2 *Ddelta/sigma.z Dcp.dp[p+2,p+2] <- Dg1.delta(delta, nu+a[3]) * Ddelta if(is.null(fixed.nu) && (nu+a[4] > 4)) { Dcp.dp[1, p+3] <- omega * mu.z(delta, nu+a[1]) * u(nu+a[1]) Dcp.dp[p+1,p+3] <- omega * Dkappa2.nu(delta, nu+a[2])/(2 * sigma.z) Dcp.dp[p+2,p+3] <- Dg1.nu(delta, nu+a[3]) Dcp.dp[p+3,p+2] <- Dg2.delta(delta, nu+a[4]) * Ddelta Dcp.dp[p+3,p+3] <- Dg2.nu(delta, nu+a[4]) } attr(cp, "jacobian") <- Dcp.dp } return(cp) } # b <- function (nu) ifelse(nu>1, ifelse(nu < 1e8, # sqrt(nu/pi)*exp(lgamma((nu-1)/2)-lgamma(nu/2)), sqrt(2/pi)), NA) b <- function(nu){ out <- rep(NA, length(nu)) big.nu <- 1e4 big <- (nu > big.nu) ok <- ((nu > 1) & (!big) & (!is.na(nu))) out[big] <- sqrt(2/pi) * (1 + 0.75/nu[big] + 0.78125/nu[big]^2) out[ok] <- sqrt(nu[ok]/pi) * exp(lgamma((nu[ok]-1)/2) - lgamma(nu[ok]/2)) out} # st.gamma1 <- function(delta, nu) {# this function is vectorized for delta, works with a single value of nu if(nu > 1e6) { mu <- delta*sqrt(2/pi) return(0.5*(4-pi)*mu^3/(1-mu^2)^1.5) } if(nu > 3) { mu <- delta*b(nu) k2 <- nu/(nu-2)- mu^2 k3 <- mu * (nu * (3 - delta^2)/(nu-3) -3 * nu/(nu - 2) + 2 * mu^2) gamma1 <- k3/sqrt(k2)^3 } else gamma1<- Inf*sign(delta) gamma1 } # st.gamma2 <- function(delta, nu) {# this function is vectorized for delta, works a single value of nu # if(nu > 1e6) { mu <- delta*sqrt(2/pi) return(2*(pi-3)*mu^4/(1-mu^2)^2) } if(nu > 4) { mu <- delta*b(nu) k2 <- nu/(nu-2)- mu^2 k4 <- (3 * nu^2/((nu - 2) * (nu - 4)) - 4 * mu^2 * nu * (3 - delta^2)/(nu - 3) + 6 * mu^2 * nu/(nu - 2) -3*mu^4) gamma2 <- k4/k2^2 - 3 } else gamma2 <- Inf gamma2 } # st.cp2dp <- function(cp, silent=FALSE, tol=1e-8, trace=FALSE) { fn0 <- function(log.nu, g1) st.gamma1(1, exp(log.nu)) - g1 if(any(is.na(cp))) stop("NA's in argument 'cp'") p <- length(cp)-3 x.names <- if(p>1) names(cp[2:p]) else NULL gamma1 <- cp[p+2] abs.g1 <- abs(gamma1) gamma2 <- cp[p+3] if(abs.g1 <= 0.5*(4-pi)*(2/(pi-2))^1.5) { # book: (2.29)+(3.20) feasible <- (gamma2 > 2*(pi-3)*(2*abs.g1/(4-pi))^(4/3)) excess <- max(0, 2*(pi-3)*(2*abs.g1/(4-pi))^(4/3) - gamma2) } else { if(abs.g1 >= 4) { feasible <- FALSE; excess <- Inf } else { r0 <- uniroot(fn0, interval=c(log(4), 1000), tol=tol, g1=abs.g1) nu0 <- exp(r0$root) feasible <- (gamma2 >= st.gamma2(1,nu0)) excess <- max(0, st.gamma2(1,nu0) - gamma2) } } if(!feasible) { if(silent) { out <- NA attr(out, "excess") <- excess return(out)} else stop("CP outside feasible region")} delta <- 0.75 * sign(gamma1) old <- c(delta, Inf) step <- Inf fn1 <- function(delta, g1, nu) st.gamma1(delta, nu) - g1 fn2 <- function(log.nu, g2, delta) st.gamma2(delta, exp(log.nu)) - g2 out <- NULL while(step > tol){ fn21 <- fn2(log(4 + sqrt(.Machine$double.eps)), gamma2, delta) fn22 <- fn2(log(1e4), gamma2, delta) if(any(is.na(c(fn21, fn22)))) stop("parameter inversion failed") if(fn21 * fn22 > 0) { out <- NA attr(out, "excess") <- fn21*fn22 break} r2 <- uniroot(fn2, interval=c(log(4 + sqrt(.Machine$double.eps)), 100), tol=tol, g2=gamma2, delta=delta) nu <- exp(r2$root) if(fn1(-1, gamma1, nu) * fn1(1, gamma1, nu)> 0) { out <- NA attr(out, "excess") <- fn1(-1, gamma1, nu) * fn1(1, gamma1, nu) break} r1 <- uniroot(fn1, interval=c(-1,1), tol=tol, g1=gamma1, nu=nu) delta <- r1$root new <- c(delta, nu) step <- abs(old-new)[1] + abs(log(old[2])- log(new[2])) if(trace) cat("delta, nu, log(step):", format(c(delta, nu, log(step))),"\n") old <- new } if(anyNA(out)) return(out) mu.z <- delta * b(nu) omega <- cp[p+1]/sqrt(nu/(nu-2) - mu.z^2) if(omega < 0) { if(silent) { out <- NA attr(out, "excess") <- abs(omega) return(out)} else stop("CP outside feasible region")} alpha <- delta/sqrt(1-delta^2) dp <- c(cp[1] - omega*mu.z, if(p>1) cp[2:p] else NULL, omega, alpha, nu) names(dp) <- param.names("DP", "ST", p, x.names=x.names) return(dp) } mst.cp2dp <- function(cp, silent=FALSE, tol=1e-8, trace=FALSE) { mu <- drop(cp[[1]]) Sigma <- cp[[2]] gamma1 <- cp[[3]] gamma2M <- cp[[4]] d <- length(gamma1) # fn1 <- function(delta, g1, nu) st.gamma1(delta, nu) - g1 # fn2 <- function(log.nu, g2, delta.sq, d) # mst.gamma2M(delta.sq, exp(log.nu), d) - g2 if(any(abs(gamma1) >= 4)) {if(silent) return(NULL) else stop("cp$gamma1 not admissible")} dp.marg <- matrix(NA, d, 4) for(j in 1:d) { dp <- st.cp2dp(c(0,1,gamma1[j], gamma2M), silent=silent) if(is.null(dp)) {if(silent) return(NULL) else stop("no CP could be found")} dp.marg[j,] <- dp } if(trace) {cat("starting dp:\n"); print(dp.marg)} fn <- function(par, Sigma, gamma1, gamma2M, trace=FALSE){ if(trace) cat("[mst.cp2dp[fn]] par:", format(par), "\n") nu <- exp(par[1])+4 delta <- par[-1]/sqrt(1+par[-1]^2) d <- length(delta) mu.z <- delta*b(nu) omega <- sqrt(diag(Sigma)/(nu/(nu-2)-mu.z^2)) Omega.bar <- (diag(1/omega, d, d) %*% Sigma %*% diag(1/omega, d, d) + outer(mu.z, mu.z)) * (nu-2)/nu Obar.inv <- pd.solve(force.symmetry(Omega.bar)) delta.sq <- sum(delta * as.vector(Obar.inv %*% delta)) if(delta.sq >= 1) return(delta.sq*10^10) L1 <- sum((st.gamma1(delta, nu) - gamma1)^2) L2 <- (mst.gamma2M(delta.sq, nu, d) - gamma2M)^2 # if(trace){ ecat(c(nu,delta,L1,L2))} # ; readline("")} L1 + L2 } nu <- min(dp.marg[,4]) par <- c(log(nu-4), dp.marg[,3]) if(trace) cat("[mst.cp2dp] par:", format(par), "\n") opt <- nlminb(par, fn, Sigma=Sigma, gamma1=gamma1, gamma2M=gamma2M, trace=trace) if(trace) cat("[mst.cp2dp]\nopt$convergence:", opt$convergence, "\nopt$message", opt$message, "\n") if(opt$convergence != 0) { if(silent) return(NULL) else stop ("no CP could be found") } par <- opt$par nu <- exp(par[1])+4 delta <- par[-1]/sqrt(1+par[-1]^2) if(trace) { cat("[mst.cp2dp]min opt$fn:", format(opt$obj),"\n") print(c(nu,delta)) } mu.z <- delta*b(nu) omega<- sqrt(diag(Sigma)/(nu/(nu-2)-mu.z^2)) Omega.bar <- (diag(1/omega, d, d) %*% Sigma %*% diag(1/omega, d, d) + outer(mu.z,mu.z)) * (nu-2)/nu Obar.inv <- pd.solve(Omega.bar) delta.sq <- sum(delta * as.vector(Obar.inv %*% delta)) alpha <- as.vector(Obar.inv %*% delta)/sqrt(1-delta.sq) if(is.matrix(mu)) { xi <- mu xi[1,] <- mu[1,] - omega*mu.z } else xi <- mu - omega*mu.z Omega <- diag(omega) %*% Omega.bar %*% diag(omega) return(list(xi=xi, Omega=Omega, alpha=alpha, nu=nu)) } affineTransSECdistr <- function(object, a, A, name, compNames, drop=TRUE) {# object is of class SECdistrMv # computes distribution of affine transformation of SEC variable T=a+t(A)Y if(class(object) != "SECdistrMv") stop("wrong object class") dp <- slot(object, "dp") alpha <- dp$alpha d <- length(alpha) if(!is.matrix(A) || nrow(A) != d) stop("A is not a matrix or wrong nrow(A)") h <- ncol(A) if(length(a) != h) stop("size mismatch of arguments 'a' and 'A'") if(missing(name)) name<- paste(deparse(substitute(a)), " + t(", deparse(substitute(A)), ") %*% (", deparse(substitute(object)),")", sep="") else name <- as.character(name)[1] compNames <- if(missing(compNames)) as.vector(outer("V",as.character(1:h),paste,sep="")) else as.character(as.vector(compNames)[1:h]) family <- object@family xi.X <- as.vector(a + t(A) %*% matrix(dp$xi, ncol=1)) Omega <- dp$Omega omega <- sqrt(diag(Omega)) Omega.X <- as.matrix(t(A) %*% Omega %*% A) invOmega.X <- pd.solve(Omega.X, silent=TRUE) if (is.null(invOmega.X)) stop("not full-rank transformation") omega.X <- sqrt(diag(Omega.X)) omega.delta <- omega * delta.etc(alpha, Omega)$delta m <- as.vector(invOmega.X %*% t(A) %*% matrix(omega.delta, ncol=1)) u <- sum(omega.delta * as.vector(A %*% matrix(m, ncol=1))) alpha.X <- (omega.X * m)/sqrt(1 - u) dp.X <- list(xi=xi.X, Omega=Omega.X, alpha=alpha.X) if(family == "ESN") dp.X$tau <- dp$tau if(family == "ST") dp.X$nu <- dp$nu if(h==1 & drop) { dp1 <- unlist(dp.X) dp1[2] <- sqrt(dp1[2]) names(dp1) <- names(dp.X) names(dp1)[2] <- tolower(names(dp)[2]) # new.obj <- new("SECdistrUv", dp=dp1, family=family, name=name) #?? new.obj <- makeSECdistr(dp=dp1, family=family, name=name) } else new.obj <- makeSECdistr(dp.X, family, name, compNames) # new.obj <- new("SECdistrMv", dp.X, family, name, compNames) #?? return(new.obj) } marginalSECdistr <- function(object, comp, name, drop=TRUE) {# marginals of SECdistrMv obj; 2nd version, computing marginal delta's family <- slot(object,"family") if(missing(name)) { basename <- if(object@name != "") object@name else deparse(substitute(object)) name<- paste(basename, ".components=(", paste(as.character(comp),collapse=","), ")", sep="") } else name <- as.character(name)[1] dp <- slot(object,"dp") xi <- dp$xi Omega <- dp$Omega alpha <- dp$alpha compNames <- slot(object,"compNames") d <- length(alpha) comp <- as.integer(comp) Omega11 <- Omega[comp,comp,drop=FALSE] if(length(comp) < d){ if(any(comp>d | comp<1)) stop("comp makes no sense") delta_etc <- delta.etc(alpha, Omega) delta1 <- delta_etc$delta[comp] R11 <- delta_etc$Omega.cor[comp, comp, drop=FALSE] iR11.delta1 <- as.vector(pd.solve(R11, silent=TRUE) %*% delta1) diRd <- sum(delta1*iR11.delta1) alpha1_2 <- if(diRd < 1) iR11.delta1/sqrt(1 - diRd) else sign(delta1)*Inf dp0 <- list(xi=xi[comp], Omega=Omega11, alpha=alpha1_2) } else { if(any(sort(comp) != (1:d))) stop("comp makes no sense") dp0 <- list(xi=xi[comp], Omega=Omega11, alpha=alpha[comp]) } if(family=="ESN") dp0$tau <- dp$tau if(family=="ST") dp0$nu <- dp$nu new.obj <- new("SECdistrMv", dp=dp0, family=family, name=name, compNames=compNames[comp]) if(length(comp)==1 & drop) {# new.obj <- as(new.obj, "SECdistrUv") # non va.. dp <- unlist(dp0) names(dp) <- names(dp0) dp[2] <- sqrt(dp[2]) names(dp)[2] <- "omega" new.obj <- new("SECdistrUv", dp=dp, family=family, name=compNames[comp]) } new.obj } conditionalSECdistr <- function(object, fixed.comp, fixed.values, name, drop=TRUE) { # conditional distribution of SN/ESN object family <- slot(object,"family") if(!(family %in% c("SN", "ESN"))) stop("family must be either SN or ESN") dp <- slot(object,"dp") xi <- dp$xi Omega <- dp$Omega alpha <- dp$alpha tau <- if(family=="SN") 0 else dp$tau d <- length(alpha) fix <- fixed.comp h <- length(fix) if(any(fix != round(fix)) | !all(fix %in% 1:d) | h == d) stop("fixed.comp makes no sense") if(length(fixed.values) != h) stop("length(fixed.comp) != lenght(fixed.values)") compNames <- slot(object,"compNames") if(missing(name)) { basename <- if(object@name != "") object@name else deparse(substitute(object)) name<- paste(basename,"|(", paste(compNames[fix],collapse=","), ")=(", paste(format(fixed.values),collapse=","), ")", sep="") } else name <- as.character(name)[1] # free.fix <- setdiff(1:d, fix) omega <- sqrt(diag(Omega)) omega1 <- omega[fix] omega2 <- omega[-fix] R <- cov2cor(Omega) R11 <- R[fix,fix, drop=FALSE] R12 <- R[fix,-fix, drop=FALSE] R21 <- R[-fix,fix, drop=FALSE] R22 <- R[-fix,-fix, drop=FALSE] alpha1 <- matrix(alpha[fix], ncol=1) alpha2 <- matrix(alpha[-fix], ncol=1) iR11 <- pd.solve(R11) R22.1 <- R22 - R21 %*% iR11 %*% R12 a.sum <- as.vector(t(alpha2) %*% R22.1 %*% alpha2) alpha1_2 <- as.vector(alpha1 + iR11 %*% R12 %*% alpha2)/sqrt(1+a.sum) tau2.1 <- (tau * sqrt(1 + sum(alpha1_2 * as.vector(iR11 %*% alpha1_2))) + sum(alpha1_2 * (fixed.values-xi[fix])/omega1)) O11 <- Omega[fix,fix, drop=FALSE] O12 <- Omega[fix,-fix, drop=FALSE] O21 <- Omega[-fix,fix, drop=FALSE] O22 <- Omega[-fix,-fix, drop=FALSE] iO11<- (1/omega1) * iR11 * rep(1/omega1, each=h) # solve(O11) reg <- O21 %*% iO11 xi2.1 <- as.vector(xi[-fix]+ reg %*% (fixed.values - xi[fix])) O22.1 <- O22 - reg %*% O12 omega22.1 <- sqrt(diag(O22.1)) alpha2.1 <- as.vector((omega22.1/omega2)*alpha2) dp2.1 <- list(xi=xi2.1, Omega=O22.1, alpha=alpha2.1, tau=tau2.1) obj <- if((d-h)==1 & drop) { dp2.1 <- unlist(dp2.1) dp2.1[2] <- sqrt(dp2.1[2]) names(dp2.1) <- c("xi","omega","alpha","tau") new("SECdistrUv", dp=dp2.1, family="ESN", name=name) } else new("SECdistrMv", dp=dp2.1, family="ESN", name=name, compNames=compNames[-fix]) return(obj) } delta.etc <- function(alpha, Omega=NULL) { inf <- which(abs(alpha) == Inf) if(is.null(Omega)){ # case d=1 delta <- alpha/sqrt(1+alpha^2) delta[inf] <- sign(alpha[inf]) return(delta) } else { # d>1 if(any(dim(Omega) != rep(length(alpha),2))) stop("dimension mismatch") Ocor <- cov2cor(Omega) if(length(inf) == 0) { # d>1, standard case Ocor.alpha <- as.vector(Ocor %*% alpha) alpha.sq <- sum(alpha * Ocor.alpha) delta <- Ocor.alpha/sqrt(1+alpha.sq) alpha. <- sqrt(alpha.sq) delta. <- sqrt(alpha.sq/(1+alpha.sq)) } else { # d>1, case with some abs(alpha)=Inf if(length(inf) > 1) warning("Several abs(alpha)==Inf, I handle them as 'equal-rate Inf'") k <- rep(0,length(alpha)) k[inf] <- sign(alpha[inf]) Ocor.k <- as.vector(Ocor %*% k) delta <- Ocor.k/sqrt(sum(k * Ocor.k)) delta. <- 1 alpha. <- Inf } return( list(delta=delta, alpha.star=alpha., delta.star=delta., Omega.cor=Ocor)) } } selm <- function (formula, family="SN", data, weights, subset, na.action, start=NULL, fixed.param=list(), method="MLE", penalty=NULL, offset, model=TRUE, x = FALSE, y = FALSE, ...) { ret.x <- x ret.y <- y cl <- match.call() formula <- as.formula(formula) if (length(formula) < 3) stop("formula must be a two-sided formula") mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "subset", "weights", "na.action", "offset"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- as.name("model.frame") mf <- eval(mf, parent.frame()) method <- toupper(method) if(!(method %in% c("MLE", "MPLE"))) { warning(gettextf("method = '%s' is not supported, replaced by 'MLE'", method), domain = NA) method <- "MLE"} penalty.name <- if(method == "MPLE") { if(is.null(penalty)) "Qpenalty" else penalty } else NULL contr <- list(penalty=penalty.name, trace=FALSE, info.type="observed", opt.method="nlminb", opt.control=list()) control <- list(...) contr[(namc <- names(control))] <- control if (length(noNms <- namc[!namc %in% names(contr)])) warning( "unknown names in control: ", paste(noNms, collapse = ", ")) mt <- attr(mf, "terms") y <- model.response(mf, "numeric") w <- as.vector(model.weights(mf)) if(is.null(w)) w <- rep(1, NROW(y)) if(any(w != round(w)) | all(w == 0)) stop("weights must be non-negative integers (=frequencies), not all 0") offset <- as.vector(model.offset(mf)) if (!is.null(offset)) { if (length(offset) == 1) offset <- rep(offset, NROW(y)) else if (length(offset) != NROW(y)) stop(gettextf( "number of offsets is %d, should equal %d (number of observations)", length(offset), NROW(y)), domain = NA) } if(length(fixed.param) > 0) { if(!all(names(fixed.param) %in% c("nu", "alpha"))) stop("Not admissible component of 'fixed.param'") if(!is.null(fixed.param$alpha)) { if(fixed.param$alpha != 0) stop("'alpha' can only be fixed at 0") if(method == "MPLE") stop('method MPLE not allowed when alpha=0') } } if (is.empty.model(mt)) stop("empty model") else { x <- model.matrix(mt, mf, contrasts) xt <- pd.solve(t(x) %*% (w*x), silent=TRUE) if(is.null(xt)) stop("design matrix appears to be of non-full rank") z <- selm.fit(x, y, family=family, start, w=w, fixed.param=fixed.param, offset=offset, selm.control=contr) } class(z) <- c(if (is.matrix(y)) "mselm", "selm") z$na.action <- attr(mf, "na.action") z$offset <- offset z$contrasts <- attr(x, "contrasts") z$xlevels <- .getXlevels(mt, mf) z$call <- cl z$terms <- mt input <- list() if (model) input$model <- mf if (ret.x) input$x <- x if (ret.y) input$y <- y # input$weights <- as.vector(model.weights(mf)) # input$offset <- as.vector(model.offset(mf)) # cl.obj <- if(is.matrix(y)) "mselm" else "selm" obj <- new(class(z), call=cl, family=toupper(family), logL=z$logL, method=c(method, contr$penalty), param=z$param, param.var=z$param.var, size=z$size, residuals.dp=z$resid.dp, fitted.values.dp=z$fitted.dp, control=control, input=input, opt.method=z$opt.method) return(obj) } # #selm.control <- function(method="MLE", info.type="observed", # trace=FALSE, algorithm="nlminb", opt.control=list()) #{ # if(algorithm !="nlminb") stop("only algorithm='nlminb' handled so far") # if(info.type !="observed") stop("only info.type='observed' handled so far") # list(method=method, info.type=info.type, trace=trace, # algorithm=algorithm, opt.control=opt.control) #} #------------------------------------------------------ selm.fit <- function (x, y, family="SN", start=NULL, w, fixed.param=list(), offset = NULL, selm.control) { if (!(toupper(family) %in% c("SN", "ST", "SC"))) stop(gettextf("I do not know family '%s'", family), domain = NA) family <- toupper(family) if (is.null(n <- nrow(x))) stop("'x' must be a matrix") if (n == 0L) stop("0 (non-NA) cases") if(NROW(y) != n) stop("'x' and 'y' have non-compatible dimensions") p <- ncol(x) if ((p == 0L) || !(all(data.matrix(x)[,1] == 1))) stop("first column of model matrix is not all 1's") y <- drop(y) d <- NCOL(y) if(d>1 && is.null(colnames(y))) colnames(y) <- paste("V", 1:d, sep="") if(is.null(colnames(x))) colnames(x) <- paste("x", 0L:(p-1), sep=".") if (!is.null(offset)) y <- (y - offset) if (NROW(y) != n) stop("incompatible dimensions") if (missing(w) || is.null(w)) w <- rep(1, n) nw <- sum(w) n.obs <- NROW(y) contr <- list(method="MLE", penalty=NULL, trace=FALSE, info.type="observed", opt.method="nlminb", opt.control=list()) control <- selm.control contr[(namc <- names(control))] <- control symmetr <- FALSE if(length(fixed.param) > 0) { if(!all(names(fixed.param) %in% c("nu", "alpha"))) stop("Not admissible component of 'fixed.param'") if(!is.null(fixed.param$alpha)) { if( fixed.param$alpha != 0 ) stop("'alpha' can only be fixed at 0") else symmetr <- TRUE } } zero.weights <- any(w == 0) if(zero.weights) { save.r <- y save.f <- y save.w <- w ok <- (w != 0) nok <- !ok w <- w[ok] x0 <- x[!ok, , drop = FALSE] x <- x[ok, , drop = FALSE] n <- nrow(x) y0 <- if (d > 1L) y[!ok, , drop = FALSE] else y[!ok] y <- if (d > 1L) y[ok, , drop = FALSE] else y[ok] } storage.mode(x) <- "double" storage.mode(y) <- "double" info.type <- contr$info.type # so far, only "observed" yInfo <- if(contr$info.type == "observed") y else NULL penalty <- contr$penalty # either NULL or a char string penalty.fn <- if(is.null(penalty)) NULL else get(penalty, inherits=TRUE) trace <- contr$trace if(d == 1) { y <- as.vector(y) if(family == "SN") { npar <- p + 2 - as.numeric(symmetr) if(symmetr) { # SN with alpha=0 is Gaussian case ls <- lm.wfit(x, y, w) # note: offset already subtracted if any res <- residuals(ls) s2 <- sum(w*res^2)/nw param <- c(coef(ls), sqrt(s2)) j <- rbind(cbind(t(x) %*% (w*x)/s2, 0), c(rep(0,p), 2*nw/s2)) j.inv <- solve(j) se <- sqrt(diag(j.inv)) info <- list(dp=param, cp=param, info.dp=j, info.cp=j, asyvar.dp=j.inv, asyvar.cp=j.inv, se.dp=se, se.cp=se, aux=NULL) logL <- (-0.5*nw)*(log(2*pi*s2) +1) fit <- list(cp=param, dp=param, dp.complete=c(param,0), opt.method=list(ls$qr), logL=logL) boundary <- FALSE fit$opt.method <- list(method="least_squares", called.by= "lm.wfit") mu0 <- 0 } else { # proper SN case cp <- if(is.null(start)) NULL else dp2cpUv(start, "SN") fit <- sn.mple(x, y, cp, w, penalty, trace, contr$opt.method, contr$control) fit$dp <- cp2dpUv(cp=fit$cp, family="SN") boundary <- fit$boundary mu0 <- fit$cp[1] - fit$dp[1] info <- if(boundary) NULL else sn.infoUv(dp=fit$dp, x=x, y=yInfo, w=w, penalty=penalty) }} if(family == "ST") { fixed.nu <- fixed.param$nu npar <- p + 2 + as.numeric(is.null(fixed.nu)) - as.numeric(symmetr) fit <- st.mple(x, y, dp=start, w, fixed.nu, symmetr, penalty, trace, contr$opt.method, contr$control) dp <- fit$dp cp <- st.dp2cp(dp, cp.type="proper", fixed.nu=fixed.nu, upto=4-as.numeric(!is.null(fixed.nu))) p_cp<- st.dp2cp(dp, cp.type="pseudo", fixed.nu=fixed.nu, jacobian=TRUE) fit$cp <- cp[1:npar] fit$p_cp <- p_cp[1:npar] Dpseudocp.dp <- attr(p_cp, "jacobian")[1:npar, 1:npar] attr(p_cp, "jacobian") <- NULL boundary <- fit$boundary nu <- if(is.null(fixed.nu)) dp[npar] else fixed.nu mu0 <- if(nu <= 1) NA else st.dp2cp(dp, fixed.nu=fixed.nu, upto=1)[1] - dp[1] info <- if(boundary) NULL else st.infoUv(dp=fit$dp, NULL, x, yInfo, w, fixed.nu, symmetr, penalty) } if(family == "SC") { npar <- p + 2 - as.numeric(symmetr) fit <- st.mple(x, y, dp=start, w, fixed.nu=1, symmetr, penalty, trace, contr$opt.method, contr$control) fit$cp <- NULL p_cp0 <- st.dp2cp(fit$dp, cp.type="pseudo", fixed.nu=1, jacobian=TRUE) fit$p_cp <- p_cp0[1:npar] Dpseudocp.dp <- attr(p_cp0, "jacobian")[1:npar, 1:npar] attr(p_cp0, "jacobian") <- NULL boundary <- fit$boundary mu0 <- NA info <- if(boundary) NULL else st.infoUv(dp=fit$dp, x=x, y=yInfo, w=w, fixed.nu=1, symmetr=symmetr) } if(!boundary && family %in% c("ST","SC")) info$asyvar.p_cp <- Dpseudocp.dp %*% info$asyvar.dp %*% t(Dpseudocp.dp) beta.dp <- fit$dp[1:p] dp <- fit$dp cp <- fit$cp } else { # d>1 npar0 <- p*d + d*(d+1)/2 if(family == "SN") { if(symmetr) { # SN with alpha=0 is Gaussian case npar <- npar0 ls <- lm.wfit(x, y, w) # note: offset already subtracted if any beta <- coef(ls) res <- residuals(ls) s2 <- t(res) %*% (w*res)/nw dp <- dp. <- list(beta=beta, Omega=s2) dp.$alpha <- rep(0,d) param <- c(beta, vech(s2)) conc <- solve(s2) betaBlock <- conc %x% (t(x) %*% (w*x)) D <- duplicationMatrix(d) varBlock <- (n/2) * t(D) %*% (conc %x% conc) %*% D m0 <- matrix(0, p*d, d*(d+1)/2) j <- rbind(cbind(betaBlock, m0), cbind(t(m0), varBlock)) # use (10) in section 15.8 of Magnus & Neudecker (1988/1999, p.321) j.inv <- rbind(cbind(solve(betaBlock), m0), cbind(t(m0), solve(varBlock))) diags.dp <- sqrt(diag(j.inv)) se.beta <- matrix(diags.dp[1:(p*d)], p, d) se.diagOmega <- diags.dp[p*d + d*(d+1)/2 +1 -rev(cumsum(1:d))] se <- list(beta=se.beta, diagOmega=se.diagOmega) info <- list(dp=param, cp=param, info.dp=j, info.cp=j, asyvar.dp=j.inv, asyvar.cp=j.inv, se.dp=se, se.cp=se, aux=NULL) logL <- (-0.5*nw)*(determinant(2*pi*s2, logarithm=TRUE)$modulus + d) # see (6.2.7) of Mardia, Kent & Bibby (1979) fit <- list(dp=dp, cp=dp, dp.complete=dp., logL=logL) fit$opt.method <- list(method="lm.wfit") boundary <- FALSE mu0 <- rep(0, d) } else { # proper SN case npar <- npar0 + d if(is.null(penalty)) { # MLE fit <- msn.mle(x, y, start, w, trace=trace, opt.method=contr$opt.method, control=contr$opt.control) boundary <- ((1 - fit$aux$delta.star) < .Machine$double.eps^(1/4)) if(!boundary) info <- sn.infoMv(fit$dp, x=x, y=yInfo, w=w) } else { # MPLE fit <- msn.mple(x, y, start, w, penalty, trace=trace, opt.method=contr$opt.method, control=contr$opt.control) boundary <- FALSE info <- sn.infoMv(fit$dp, x=x, y=y, w=w, penalty=penalty) } fit$cp <- msn.dp2cp(fit$dp) mu0 <- as.vector(fit$cp[[1]][1,] - fit$dp[[1]][1,]) }} if(family == "ST"){ fixed.nu <- fixed.param$nu npar <- npar0 + d*as.numeric(!symmetr) + as.numeric(is.null(fixed.nu)) fit <- mst.mple(x, y, start, w, fixed.nu=fixed.nu, symmetr=symmetr, penalty=penalty, trace=trace, opt.method=contr$opt.method, control=contr$opt.control) fit$opt.method$called.by <- "mst.mple" boundary <- fit$boundary dp <- fit$dp nu <- if(is.null(fixed.nu)) dp$nu else fixed.nu mu0 <- if(nu <= 1) NA else as.vector(mst.dp2cp(dp, fixed.nu=fixed.nu, symmetr=symmetr, upto=1)[[1]][1,] - dp[[1]][1,]) fit$cp <- mst.dp2cp(dp, cp.type="proper", fixed.nu, symmetr) fit$p_cp <- mst.dp2cp(dp, cp.type="pseudo", fixed.nu, symmetr) if(!boundary) info <- st.infoMv(dp, x=x, y=yInfo, w, fixed.nu, symmetr, penalty) } if(family == "SC") { npar <- npar0 + d*as.numeric(!symmetr) if(is.null(start)) { fit.sn <- msn.mle(x, y, NULL, w, control=list(rel.tol=1e-4)) start <- fit.sn$dp } fit <- mst.mple(x, y, start, w, fixed.nu=1, symmetr=symmetr, penalty=penalty, trace=trace, opt.method=contr$opt.method, control=contr$opt.control) fit$opt.method$called.by <- "mst.mple" npar <- p*d + d*(d+1)/2 + d*as.numeric(!symmetr) boundary <- fit$boundary mu0 <- NA fit$cp <- NULL fit$p_cp <- mst.dp2cp(fit$dp, "pseudo", fixed.nu=1) if(!boundary) info <- st.infoMv(fit$dp, x=x, y=yInfo, w, fixed.nu=1, symmetr, penalty) } beta.dp <- fit$dp[[1]] } param <- list(dp=fit$dp, cp=fit$cp, "pseudo-cp"=fit$p_cp, boundary=boundary, mu0=mu0) if(!boundary && !is.null(info)) { asyvar.dp <- info$asyvar.dp[1:npar, 1:npar] asyvar.cp <- info$asyvar.cp[1:npar, 1:npar] asyvar.p_cp <- info$asyvar.p_cp[1:npar, 1:npar] param.var <- list(info.type=info.type, dp=asyvar.dp, cp=asyvar.cp, "pseudo-cp"=asyvar.p_cp) } else param.var <- list() dn <- colnames(x) fv <- drop(x %*% beta.dp) if(is.matrix(fv)) colnames(fv) <- colnames(y) size <- c(d=d, p=p, n.param=npar, n.obs=n.obs, nw.obs=sum(w)) z <- list(call=match.call(), logL=fit$logL, param=param, param.var=param.var, fitted.dp=fv, resid.dp=y-fv, size=size, selm.control=contr, opt.method=fit$opt.method) r1 <- y - z$resid.dp z$weights <- w if (zero.weights) { # coef[is.na(coef)] <- 0 f0 <- x0 %*% beta.dp if (d > 1) { save.r[ok, ] <- z$resid.dp save.r[nok, ] <- y0 - f0 save.f[ok, ] <- z$fitted.dp save.f[nok, ] <- f0 } else { save.r[ok] <- z$resid.dp save.r[nok] <- y0 - f0 save.f[ok] <- z$fitted.dp save.f[nok] <- f0 } z$resid.dp <- save.r z$fitted.dp <- save.f z$weights <- save.w } if(!is.null(offset)) { z$fitted.dp <- z$fitted.dp + offset r1 <- r1 + offset } # z$fitted.dp <- r1 if(length(fixed.param) > 0) { z$param$fixed <- fixed.param z$param$dp.complete <- fit$dp.complete } else z$param$fixed <- z$param$dp.complete<- list() return(z) } #--------------------------------------------------- summary.selm <- function(object, param.type="CP", cov=FALSE, cor=FALSE) { fixed <- slot(object, "param")$fixed if(length(fixed$alpha==0)>0 && fixed$alpha==0) { param.type <- "DP" note <- "param.type=DP has been set because of constraint alpha=0" } else note <- "" lc.param.type <- tolower(param.type) if(!(lc.param.type %in% c("cp", "op", "dp", "pseudo-cp"))) stop(gettextf("unknown param.type '%s'", param.type), domain = NA) param.type <- switch(lc.param.type, "dp"="DP", "op"="OP", "cp"="CP", "pseudo-cp"="pseudo-CP") family <- slot(object,"family") if(param.type=="pseudo-CP" && !(family %in% c("ST", "SC"))) stop("pseudo-CP makes sense only for ST and SC families") if (!(family %in% c("SN","ST","SC"))) stop(gettextf("family '%s' not (yet) handled", family), domain = NA) param <- slot(object, "param")[[lc.param.type]] if(param.type=="CP" && is.null(param)) { if(family %in% c("ST", "SC")) { {message("CP does not exist. Consider param.type='DP' or 'pseudo-CP'") return(invisible())}}} param.var <- slot(object, "param.var")[[lc.param.type]] if(is.null(param.var)) param.var <- diag(NA, length(param)) se <- sqrt(diag(param.var)) z <- param/se param.table <- cbind(param, se, z, 2*pnorm(-abs(z))) dimnames(param.table) <- list(names(param), c("estimate","std.err","z-ratio", "Pr{>|z|}")) resid <- residuals(object, lc.param.type) aux <- list() aux$param.cov <- if(cov) param.var else NULL aux$param.cor <- if(cor) cov2cor(param.var) else NULL out <- new("summary.selm", call=slot(object,"call"), family = slot(object, "family"), logL = slot(object, "logL"), method=slot(object, "method"), resid = resid, param.type = param.type, param.table = param.table, param.fixed = fixed, control = slot(object, "control"), aux = aux, boundary=slot(object, "param")$boundary, size=object@size, note=note) out } residuals.selm <- function(object, param.type="CP", ...){ param.type <- tolower(param.type) if(!(param.type %in% c("cp", "dp", "pseudo-cp"))) stop("param.type must be either 'CP' or 'DP' or 'pseudo-CP'") # param <- slot(object, "param")[[param.type]] p <- object@size["p"] n <- object@size["n.obs"] r <- slot(object, "residuals.dp") dp <- slot(object, "param")$dp pseudo.mu0 <- (slot(object, "param")$"pseudo-cp"[1] - dp[1]) resid <- switch(param.type, 'dp' = r, 'cp' = r - rep(slot(object,"param")$mu0, n), 'pseudo-cp' = r - rep(pseudo.mu0, n)) # resid <- resid/param[p+1] # AA: standardize resid? w <- slot(object,"input")$weights if(!is.null(w)) attr(resid,"weights") <- w return(resid) } fitted.selm <- function(object, param.type="CP", ...) { param.type <- tolower(param.type) if(!(param.type %in% c("cp", "dp", "pseudo-cp"))) stop("param.type must be either 'CP' or 'DP' or 'pseudo-CP'") # param <- slot(object, "param")[[param.type]] n <- object@size["n.obs"] dp <- slot(object, "param")$dp fit.dp <- slot(object,"fitted.values.dp") pseudo.mu0 <- (slot(object, "param")$"pseudo-cp"[1] - dp[1]) fitted <- switch(param.type, 'dp' = fit.dp, 'cp' = fit.dp + rep(slot(object,"param")$mu0, n), 'pseudo-cp' = fit.dp + rep(pseudo.mu0, n)) w <- slot(object, "input")$weights if(!is.null(w)) attr(fitted,"weights") <- w return(fitted) } weights.selm <- function(object, ...) slot(object, "input")$weights summary.mselm <- function(object, param.type="CP", cov=FALSE, cor=FALSE) { fixed <- slot(object, "param")$fixed if(length(fixed$alpha==0)>0 && fixed$alpha==0) { param.type <- "DP" note <- "param.type=DP has been set because of constraint alpha=0" } else note <- "" lc.param.type <- tolower(param.type) if(!(lc.param.type %in% c("dp", "op", "cp", "pseudo-cp"))) stop(gettextf("unknown param.type '%s'", param.type), domain = NA) param.type <- switch(lc.param.type, "dp"="DP", "op"="DP", "cp"="CP", "pseudo-cp"="pseudo-CP") # OP not yet implemented, so far re-directed to DP family <- slot(object, "family") method <- slot(object, "method") if(param.type=="pseudo-CP" & !(family %in% c("ST","SC"))) stop("pseudo-CP makes sense only for ST and SC families") p <- object@size["p"] d <- object@size["d"] npar <- object@size["n.param"] param <- object@param[[lc.param.type]] if(is.null(param) && family %in% c("ST", "SC")) { message("CP does not exist. Consider param.type='DP' or 'pseudo-CP'") return(invisible())} beta <- param[[1]] param.var <- slot(object, "param.var")[[lc.param.type]] if(object@param$boundary | is.null(param.var)) param.var <- matrix(NA, npar, npar) coef.tables <- list() par.names <- param.names(param.type, family, p, x.names=rownames(beta)[-1]) for(j in 1:d) { beta.j <- beta[,j] var.j <- param.var[((j-1)*p+1):(j*p), ((j-1)*p+1):(j*p), drop=FALSE] se.j <- sqrt(diag(var.j)) z <- beta.j/se.j coef.table <- cbind(beta.j, se.j, z, 2*pnorm(-abs(z))) dimnames(coef.table) <- list(par.names[1:p], c("estimate","std.err","z-ratio", "Pr{>|z|}")) coef.tables[[j]] <- coef.table } scatter <- list(matrix=param[[2]], name=names(param)[2]) resid <- residuals.mselm(object, param.type) # resid <- t(t(resid)/sqrt(diag(scatter$matrix))) # for normalized/std resid if(is.null(fixed$alpha)) { se.slant <- sqrt(diag(param.var)[(p*d+d*(d+1)/2+1):(p*d+d*(d+1)/2+d)]) slant <- list(param=param[[3]], se=se.slant, name=names(param)[3])} else { if(fixed$alpha == 0) slant <- list() else stop('cannot have fixed alpha at non-zero value, please report')} tail <- if(family== "ST" & is.null(fixed$nu) ) list(param=param[[length(param)]], se=sqrt(diag(param.var)[npar]), name=names(param)[length(param)]) else list() aux <- list() aux$param.cov <- if(cov) param.var else NULL aux$param.cor <- if(cor) cov2cor(param.var) else NULL out <- new("summary.mselm", call=slot(object,"call"), family = family, logL = slot(object, "logL"), method=slot(object, "method"), resid = resid, param.type=param.type, coef.tables = coef.tables, param.fixed = fixed, scatter = scatter, slant = slant, tail = tail, control = slot(object, "control"), aux = aux, boundary=slot(object, "param")$boundary, size=slot(object, "size")) out } residuals.mselm <- function(object, param.type="CP", ...){ param.type <- tolower(param.type) if(!(param.type %in% c("cp", "dp", "pseudo-cp"))) stop("param.type must be either 'CP' or 'DP' or 'pseudo-CP'") # param <- slot(object, "param")[[param.type]] # beta <- param[[1]] n <- object@size["n.obs"] r <- slot(object,"residuals.dp") param <- slot(object, "param") pseudo.mu0 <- as.vector(param$"pseudo-cp"[[1]][1,] - param$dp[[1]][1, ]) resid <- switch(param.type, 'dp' = r, 'cp' = r - outer(rep(1,n), param$mu0), 'pseudo-cp' = r - outer(rep(1,n), pseudo.mu0)) w <- slot(object, "input")$weights if(!is.null(w)) attr(resid,"weights") <- w return(resid) } fitted.mselm <- function(object, param.type="CP", ...) { param.type <- tolower(param.type) if(!(param.type %in% c("cp", "dp", "pseudo-cp"))) stop("param.type must be either 'CP' or 'DP' or 'pseudo-CP'") n <- object@size["n.obs"] fit.dp <- slot(object, "fitted.values.dp") param <- slot(object, "param") pseudo.mu0 <- as.vector(param$"pseudo-cp"[[1]][1,] - param$dp[[1]][1, ]) fitted <- switch(param.type, 'dp' = fit.dp, 'cp' = fit.dp + outer(rep(1,n), param$mu0), 'pseudo-cp' = fit.dp + outer(rep(1,n), pseudo.mu0)) w <- slot(object, "input")$weights if(!is.null(w)) attr(fitted,"weights") <- w return(fitted) } weights.mselm <- function(object, ...) slot(object, "input")$weights #------------------------------------------------------------ # # sn.info<- function(dp=NULL, cp=NULL, x=NULL, y=NULL, w, penalty=NULL, # type="observed", norm2.tol=1e-6) { # if(any(is.list(dp), is.list(cp))) { # if(is.null(dp)) stop("in the multivariate case, 'dp' must be non-NULL") # info <- sn.infoMv(dp=dp, x=x, y=y, w=w, type=type, norm2.tol=norm2.tol) # } else { # if(any(is.numeric(dp), is.numeric(cp))) # info <- sn.infoUv(dp=dp, cp=cp, x=x, y=y, w=w, penalty=penalty, # type=type, norm2.tol = norm2.tol) # else stop("invalid input") # } # return(info) # } sn.infoUv <- function(dp=NULL, cp=NULL, x=NULL, y, w, penalty=NULL, norm2.tol=1e-6) {# computes observed/expected Fisher information for univariate SN variates if(missing(y)) {y <- NULL; type <- "expected"} else type <- "observed" if(type == "observed") {if(!is.numeric(y)) stop("y is non-numeric")} if(is.null(dp) & is.null(cp)) stop("either dp or cp must be set") if(!is.null(dp) & !is.null(cp)) stop("cannot set both dp and cp") if(missing(w)) w <- rep(1, max(NROW(cbind(x,y)),1)) if(any(w != round(w)) | any(w<0)) stop("weights must be non-negative integers") n <- length(w) nw <- sum(w) if(is.null(x)) { p <- 1 wx <- w xx <- sum.x <- nw x <- matrix(1, nrow=n, ncol=1) } else { p <- NCOL(x) # x <- matrix(x, n, p) wx <- w*x xx <- t(x) %*% (wx) sum.x <- matrix(colSums(wx)) } x.names <- if(length(colnames(x)) == p) colnames(x)[2:p] else { if(p==1) NULL else paste("x", 1L:(p-1), sep=".")} if(is.null(cp)) { if(length(dp) != (p+2)) stop("length(dp) must be equal to ncol(x)+2") if(is.null(names(dp))) names(dp) <- param.names("DP", "SN", p, x.names) cp <- dp2cpUv(dp, "SN") } if(is.null(dp)) { if(length(cp) != (p+2)) stop("length(cp) must be equal to ncol(x)+2") if(is.null(names(cp))) names(cp) <- param.names("CP", "SN", p, x.names) dp <- cp2dpUv(cp, "SN") } penalty.fn <- if(is.null(penalty)) NULL else get(penalty, inherits=TRUE) omega <- dp[p+1] alpha <- dp[p+2] mu.z <- sqrt(2/pi)*alpha/sqrt(1+alpha^2) sd.z <- sqrt(1-mu.z^2) sigma <- cp[p+1] gamma1 <- cp[p+2] R <- mu.z/sd.z T <- sqrt(2/pi-(1-2/pi)*R^2) Da.Dg <- 2*(T/(T*R)^2+(1-2/pi)/T^3)/(3*(4-pi)) Dmu.z <- sqrt(2/pi)/(1+alpha^2)^1.5 Dsd.z <- (-mu.z/sd.z)*Dmu.z Ddp.cp <- diag(p+2) Ddp.cp[1,p+1] <- (-R) Ddp.cp[1,p+2] <- (-sigma*R)/(3*gamma1) Ddp.cp[p+1,p+1] <- 1/sd.z Ddp.cp[p+1,p+2] <- (-sigma)* Dsd.z* Da.Dg/sd.z^2 Ddp.cp[p+2,p+2] <- Da.Dg I.dp <- I.cp <- matrix(NA,p+2,p+2) if(type == "observed"){ score <- sn.pdev.gh(cp, x, y, w, penalty.fn, trace=FALSE, hessian=TRUE)/(-2) I.cp <- attr(score, "hessian")/2 attr(score,"hessian") <- NULL Dcp.dp <- solve(Ddp.cp) I.dp <- force.symmetry(t(Dcp.dp) %*% I.cp %*% Dcp.dp) a.coef <- NULL asyvar.cp <- pd.solve(I.cp, silent=TRUE) if(is.null(asyvar.cp)) { asyvar.dp <- NULL not.mle <- TRUE} else { not.mle <- (abs(sum(score * as.vector(asyvar.cp %*% score))) > norm2.tol) asyvar.dp <- pd.solve(I.dp, silent=TRUE) } if(not.mle) warning("parameters do not seem at MLE") #--Iinfo.dp 2nd form I2 <- matrix(NA,p+2,p+2) z <- (y - as.vector(x%*% dp[1:p]))/omega z1 <- zeta(1, alpha*z) z2 <- zeta(2, alpha*z) I2[1:p,1:p] <- t(wx) %*% ((1 - alpha^2*z2)*x)/omega^2 I2[1:p,p+1] <- t(wx) %*% (2*z - alpha*z1 - alpha^2*z2*z)/omega^2 I2[p+1,1:p] <- t(I2[1:p,p+1]) I2[1:p,p+2] <- t(wx) %*% (z1 + alpha*z2*z)/omega I2[p+2,1:p] <- t(I2[1:p,p+2]) I2[p+1,p+1] <- (-nw + 3*sum(w*z^2) -2*alpha*sum(w*z1*z) -alpha^2*sum(w*z2*z^2))/omega^2 I2[p+1,p+2] <- I2[p+2,p+1] <- (sum(w*z*z1) + alpha*sum(w*z2*z^2))/omega I2[p+2,p+2] <- sum(-w*z2*z^2) } else { # type == "expected" I2 <- NULL if(abs(alpha) < 200) { f.a <- function(x, alpha, k) x^k * dsn(x,0,1,alpha) * zeta(1,alpha*x)^2 err <- .Machine$double.eps^0.5 a0 <- integrate(f.a, -Inf, Inf, alpha=alpha, k=0, rel.tol=err)$value a1 <- integrate(f.a, -Inf, Inf, alpha=alpha, k=1, rel.tol=err)$value a2 <- integrate(f.a, -Inf, Inf, alpha=alpha, k=2, rel.tol=err)$value } else {# approx of Bayes & Branco (2007) with multiplicative adjustment u <- 1 + 8*(alpha/pi)^2 b <- sqrt(2/pi) a0 <- 1.019149098 * b^2/sqrt(u) a1 <- 1.020466516 * (-alpha * b^3/sqrt(u^3*(1+alpha^2/u))) a2 <- 1.009258704 * b^2/sqrt(u)^3 } a.coef <- c(a0, a1, a2) I.dp[1:p,1:p] <- xx * (1+alpha^2*a0)/omega^2 I.dp[p+1,p+1] <- nw * (2+alpha^2*a2)/omega^2 I.dp[p+2,p+2] <- nw * a2 I.dp[1:p,p+1] <- sum.x * (mu.z*(1+mu.z^2*pi/2)+alpha^2*a1)/omega^2 I.dp[p+1,1:p] <- t(I.dp[1:p,p+1]) I.dp[1:p,p+2] <- sum.x * (sqrt(2/pi)/(1+alpha^2)^1.5-alpha*a1)/omega I.dp[p+2,1:p] <- t(I.dp[1:p,p+2]) I.dp[p+1,p+2] <- I.dp[p+2,p+1] <- nw*(-alpha*a2)/omega eps <- 0.005 if(abs(alpha) > eps) I.cp <- force.symmetry(t(Ddp.cp) %*% I.dp %*% Ddp.cp) else{ if(alpha == 0) I.cp <- diag(c(1/omega^2, 2/omega^2, 1/6)) else { add <- c(rep(0,p+1), 3*eps) i1 <- sn.infoUv(dp=dp+add, x=x, w=w) i2 <- sn.infoUv(dp=dp-add, x=x, w=w) I.cp <- (i1$info.cp + i2$info.cp)/2 } } score <- NULL asyvar.dp <- pd.solve(I.dp, silent=TRUE) asyvar.cp <- pd.solve(I.cp, silent=TRUE) } dimnames(I.dp) <- list(names(dp), names(dp)) if(!is.null(I.cp)) dimnames(I.cp) <- list(names(cp), names(cp)) aux <- list(Ddp.cp=Ddp.cp, a.coef=a.coef, score.cp=score) list(dp=dp, cp=cp, type=type, info.dp=I.dp, info.cp=I.cp, asyvar.dp=asyvar.dp, asyvar.cp=asyvar.cp, aux=aux) } sn.infoMv <- function(dp, x=NULL, y, w, penalty=NULL, norm2.tol=1e-6) {# computes observed/expected Fisher information matrix for multiv.SN variates # using results in Arellano-Valle & Azzalini (JMVA, 2008+erratum) type <- if(missing(y)) "expected" else "observed" if(type == "observed") {if(!is.matrix(y)) stop("y is not a matrix")} cp <- dp2cpMv(dp, "SN") d <- length(dp$alpha) d2 <- d*(d+1)/2 if(missing(w)) w <- rep(1, max(NROW(cbind(x,y)),1)) if(any(w != round(w)) | any(w<0)) stop("weights must be non-negative integers") n <- length(w) nw <- sum(w) if(is.null(x)) { p <- 1 xx <- sum.x <- nw x <- matrix(1, nrow=n, ncol=1) } else { p <- NCOL(x) # x <- matrix(x, n, p) xx <- drop(t(x) %*% (w*x)) sum.x <- drop(matrix(colSums(w*x))) } beta <- as.matrix(dp[[1]],p,d) Omega <- dp$Omega omega <- sqrt(diag(Omega)) alpha <- dp$alpha eta <- alpha/omega # vOmega <- Omega[lower.tri(Omega,TRUE)] Obar <- cov2cor(Omega) Obar.alpha <- as.vector(Obar %*% alpha) alpha.star <- sqrt(sum(alpha * Obar.alpha)) if(alpha.star < 1e-4) { warning("information matrix of multivariate SN not computed near alpha=0") return(NULL) } # delta.star <- alpha.star/sqrt(1+alpha.star^2) c1 <- sqrt(2/pi)/sqrt(1+alpha.star^2) c2 <- 1/(pi*sqrt(1+2*alpha.star^2)) # theta <- c(beta,vOmega,eta) D <- duplicationMatrix(d) i1 <- 1:prod(dim(beta)) i2 <- max(i1) + 1:(d*(d+1)/2) i3 <- max(i2) + 1:d # ind <- list(i1=i1, i2=i2, i3=i3) O.inv <- pd.solve(Omega, silent=TRUE) if(type == "observed"){ y0 <- y - x %*% beta S0 <- t(y0) %*% (w*y0) / nw y0.eta <- as.vector(y0 %*% eta) z1 <- zeta(1, y0.eta) * w z2 <- (-zeta(2, y0.eta) * w) # Z2 <- diag(z2, n) S1 <- (O.inv %x% t(x)) %*% as.vector(w*y0)- (eta %x% t(x)) %*% z1 S2 <- (nw/2) * t(D) %*% ((O.inv %x% O.inv) %*% as.vector(S0-Omega)) S3 <- t(y0) %*% z1 score <- c(S1,S2,S3) u <- t(x) %*% z1 U <- t(x) %*% (z2 * y0) V <- O.inv %*% (2*S0-Omega) %*% O.inv # terms as given in the last but one matrix of p.16 j11 <- O.inv %x% xx + outer(eta,eta) %x% (t(x) %*% (z2 *x) ) j12 <- (O.inv %x% (t(x) %*% (w*y0) %*% O.inv)) %*% D j13 <- diag(d) %x% u - eta %x% U j22 <- (nw/2) * t(D) %*% (O.inv %x% V) %*% D j23 <- matrix(0, d*(d+1)/2, d) j33 <- t(y0) %*% (z2 * y0) uaA.coef <- NULL } else { # expected information Omega.eta <- omega * Obar.alpha mu.c <- Omega.eta/alpha.star^2 Omega.c <- Omega - outer(Omega.eta, Omega.eta)/alpha.star^2 alpha.bar <- alpha.star/sqrt(1+2*alpha.star^2) ginvMills <- function(x, m=0, s=1) # generalized inverse Mills ratio: \phi(x; m, s^2)/\Phi(x) exp(-0.5*((x-m)^2/s^2-x^2)+log(zeta(1,x))-log(s)) fn.u <- function(x, sd, k) x^k * ginvMills(x,0,sd) if(alpha.bar > 0) { err<- .Machine$double.eps^0.5 u0 <- integrate(fn.u, -Inf, Inf, sd=alpha.bar, k=0, rel.tol=err)$value u1 <- integrate(fn.u, -Inf, Inf, sd=alpha.bar, k=1, rel.tol=err)$value u2 <- integrate(fn.u, -Inf, Inf, sd=alpha.bar, k=2, rel.tol=err)$value } else {u0 <- 2; u1<- u2 <- 0} a0 <- u0 a1 <- u1 * mu.c A2 <- u2 * outer(mu.c, mu.c) + u0 * Omega.c # cfr (19) A1 <- (c1*(diag(d)-outer(eta,eta) %*% Omega/(1+alpha.star^2)) - c2*outer(eta, a1)) # cfr line after (12) # terms as given in the last matrix of p.16 j11 <- (O.inv + c2*a0*outer(eta,eta)) %x% xx j12 <- c1*(O.inv %x% outer(sum.x, eta)) %*% D j13 <- A1 %x% sum.x j22 <- 0.5*nw *t(D) %*% (O.inv %x% O.inv) %*% D j23 <- matrix(0, d*(d+1)/2, d) j33 <- nw *c2 * A2 uaA.coef <- list(u0=u0, u1=u1, u2=u2, a1=a1, A1=A1, A2=A2) score <- NULL } I.theta <-rbind(cbind( j11, j12, j13), cbind(t(j12), j22, j23), cbind(t(j13), t(j23), j33)) if(!is.null(penalty)) { # penalization depends on blocks (2,3) of the parameter set only penalty.fn <- if(is.null(penalty)) NULL else get(penalty, inherits=TRUE) penalty.theta <- function(theta23, penalty, d) { vOmega <- theta23[1:(d*(d+1)/2)] eta <- theta23[(d*(d+1)/2) + (1:d)] Omega <- vech2mat(vOmega) alpha <- eta *sqrt(diag(Omega)) penalty(list(alpha=alpha, Omega=Omega)) } i23 <- c(i2,i3) theta23 <- c(Omega[lower.tri(Omega,TRUE)], eta) # beta does not enter here score[i23] <- (score[i23] - numDeriv::grad(penalty.theta, theta23, penalty=penalty.fn, d=d)) jQ <- numDeriv::hessian(penalty.theta, theta23, penalty=penalty.fn, d=d) I.theta[i23, i23] <- I.theta[i23, i23] + jQ } I.theta <- force.symmetry(I.theta, tol=1e3) inv_I.theta <- pd.solve(I.theta, silent=TRUE) if(is.null(inv_I.theta)) { warning("numerically unstable information matrix") return(NULL) } if(type == "observed" ) { score.norm2 <- sum(score * as.vector(inv_I.theta %*% score)) if(score.norm2/d > norm2.tol) stop("'dp' does not seem to be at MLE") } D32 <- matrix(0,d, d2) tmp32 <- matrix(0,d^2,d^2) for(i in 1:d){ Eii <- matrix(0,d,d) Eii[i,i] <- 1 tmp32 <- tmp32 + Eii %x% Eii } D32 <- (-0.5)* (t(eta) %x% diag(1/omega^2, d,d)) %*% tmp32 %*% D # here we use the expression given in the notes, not in the paper Dlow <- cbind(matrix(0,d,d*p), D32, diag(1/omega,d,d)) Dtheta.dp <- rbind(cbind(diag(d*p+d2), matrix(0,d*p+d2,d)), Dlow) I.dp <- t(Dtheta.dp) %*% I.theta %*% Dtheta.dp # cfr (14) I.dp <- force.symmetry(I.dp, tol=1e3) # # psi<- c(mu, vSigma, mu0) Sigma <- cp$var.cov sigma <- sqrt(diag(Sigma)) Sigma.inv <- pd.solve(Sigma) mu0 <- c1* omega * Obar.alpha beta0.sq <- as.vector(t(mu0) %*% Sigma.inv %*% mu0) beta0 <- sqrt(beta0.sq) q1 <- 1/(c1*(1+beta0.sq)) q2 <- 0.5*q1*(2*c1-q1) Dplus <- pd.solve(t(D) %*% D) %*% t(D) D23 <- Dplus %*% (diag(d) %x% mu0 + mu0 %x% diag(d)) a <- as.vector(Sigma.inv %*% mu0) D32 <- t(-a) %x% (q1 * Sigma.inv - q1*q2*outer(a,a)) %*% D D33 <- q1 * Sigma.inv - 2*q1*q2*outer(a,a) one00 <- c(1,rep(0,p-1)) Dtheta.psi <- rbind( cbind(diag(p*d), matrix(0,p*d,d2), -diag(d) %x% one00), cbind(matrix(0,d2,p*d), diag(d2), D23), cbind(matrix(0,d,p*d), D32, D33)) # cfr (22a) mu0. <- mu0/(sigma*beta0) # \bar{\mu}_0 D32. <- matrix(0, d, d2) # \tilde{D}_{32} for(i in 1:d) { Eii <- matrix(0,d,d) Eii[i,i] <- 1 D32. <- D32. + (1/sigma[i])*((t(mu0.) %*% Eii) %x% Eii) %*% D } D32. <- 0.5* beta0 * D32. D33. <- (2/(4-pi)) * diag(sigma/mu0.^2, d, d)/(3*beta0.sq) Dpsi.cp <- rbind(cbind(diag(p*d+d2), matrix(0,p*d+d2,d)), cbind(matrix(0,d,p*d), D32., D33.)) # cfr (22b) jacob <- Dtheta.psi %*% Dpsi.cp I.cp <- t(jacob) %*% I.theta %*% jacob # cfr (17) I.cp <- if(any(is.na(I.cp))) NULL else force.symmetry(I.cp) asyvar.dp <- pd.solve(I.dp, silent=TRUE) if(is.null(asyvar.dp)) se.dp <- list(NULL) else { diags.dp <- sqrt(diag(asyvar.dp)) se.beta <- matrix(diags.dp[1:(p*d)], p, d) se.diagOmega <- diags.dp[p*d + d2 +1 -rev(cumsum(1:d))] # se.omega <- se.Omega/(2*omega) se.alpha <- diags.dp[p*d +d2 +(1:d)] se.dp <- list(beta=se.beta, diagOmega=se.diagOmega, alpha=se.alpha) } asyvar.cp <- pd.solve(I.cp, silent=TRUE) if(is.null(asyvar.cp)) se.cp <- list(NULL) else { diags.cp <- sqrt(diag(asyvar.cp)) se.beta <- matrix(diags.cp[1:(p*d)], p, d) se.diagSigma <- diags.cp[p*d + d2 +1 -rev(cumsum(1:d))] # se.sigma <- se.Sigma/(2*sigma) se.gamma1 <- diags.cp[p*d + d2 +(1:d)] se.cp <- list(beta=se.beta, var=se.diagSigma, gamma1=se.gamma1) } aux <- list(info.theta=I.theta, score.theta=score, Dtheta.dp=Dtheta.dp, Dpsi.cp=Dpsi.cp, Dtheta.psi=Dtheta.psi, uaA.coef=uaA.coef) list(dp=dp, cp=cp, type=type, info.dp=I.dp, info.cp=I.cp, asyvar.dp=asyvar.dp, asyvar.cp=asyvar.cp, se.dp=se.dp, se.cp=se.cp, aux=aux) } msn.mle <- function(x, y, start=NULL, w, trace=FALSE, opt.method=c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control=list() ) { y <- data.matrix(y) if(missing(x)) x <- rep(1,nrow(y)) else {if(!is.numeric(x)) stop("x must be numeric")} if(missing(w)) w <- rep(1,nrow(y)) opt.method <- match.arg(opt.method) x <- data.matrix(x) d <- ncol(y) n <- sum(w) p <- ncol(x) y.names <- dimnames(y)[[2]] x.names <- dimnames(x)[[2]] if(is.null(start)) { fit0 <- lm.wfit(x, y, w, method="qr") beta <- as.matrix(coef(fit0)) res <- resid(fit0) a <- msn.moment.fit(res) Omega <- a$Omega omega <- a$omega alpha <- a$alpha if(!a$admissible) alpha<-alpha/(1+max(abs(alpha))) beta[1,] <- beta[1,]-omega*a$delta*sqrt(2/pi) } else{ beta <- start[[1]] # start$beta Omega <- start$Omega alpha <- start$alpha omega <- sqrt(diag(Omega)) } eta <-alpha/omega if(trace){ cat("Initial parameters:\n") print(cbind(t(beta),eta,Omega)) } param <- c(beta,eta) dev <- msn.dev(param, x, y, w) if(opt.method == "nlminb") { opt <- nlminb(param, msn.dev, msn.dev.grad, control=control, x=x, y=y, w=w, trace=trace) opt$value <- opt$objective } else opt <- optim(param, fn=msn.dev, gr=msn.dev.grad, method=opt.method, control=control, x=x, y=y, w=w, trace=trace) if(trace) { cat("Message from function", opt.method, ":", opt$message,"\n") cat("Output parameters " , format(opt$par), "\n") } logL <- opt$value/(-2) beta <- matrix(opt$par[1:(p*d)],p,d) dimnames(beta)[2] <- list(y.names) dimnames(beta)[1] <- list(x.names) eta <- opt$par[(p*d+1):(p*d+d)] xi <- x %*% beta Omega <- t(y-xi) %*% (w*(y-xi))/n omega <- sqrt(diag(Omega)) alpha <- eta*omega # param <- cbind(omega,alpha) dimnames(Omega) <- list(y.names,y.names) names(alpha) <- y.names alpha2 <- sum(eta * as.vector(Omega %*% eta)) delta.star <- sqrt(alpha2/(1+alpha2)) # dimnames(param)[1] <- list(y.names) dp <- list(beta=beta, Omega=Omega, alpha=alpha) opt$method <- opt.method opt$called.by <- "msn.mle" aux <- list(alpha.star=sqrt(alpha2), delta.star=delta.star) list(call=match.call(), dp=dp, logL=logL, aux=aux, opt.method=opt) } msn.dev <- function(param, x, y, w, trace=FALSE) { d <- ncol(y) if(missing(w)) w <- rep(1,nrow(y)) n <- sum(w) p <- ncol(x) beta <- matrix(param[1:(p*d)],p,d) eta <- param[(p*d+1):(p*d+d)] y0 <- y-x %*% beta Omega <- (t(y0) %*% (y0*w))/n D <- diag(qr(2*pi*Omega)[[1]]) logDet <- sum(log(abs(D))) dev <- n*logDet - 2*sum(zeta(0, y0 %*% eta) * w) + n*d if(trace) { cat("\nmsn.dev:",dev,"\n","parameters:"); print(rbind(beta,eta)) } dev } msn.dev.grad <- function(param, x, y, w, trace=FALSE) { d <- ncol(y) if(missing(w)) w <- rep(1,nrow(y)) n <- sum(w) p <- ncol(x) beta <- matrix(param[1:(p*d)],p,d) eta <- param[(p*d+1):(p*d+d)] y0 <- y-x %*% beta Omega <- (t(y0) %*% (w*y0))/n p1 <- zeta(1,as.vector(y0 %*% eta)) * w Omega.inv <- pd.solve(Omega, silent=TRUE) if(is.null(Omega.inv)) return(rep(NA, p*d+d)) Dbeta <- (t(x) %*% (y0*w) %*% Omega.inv - outer(as.vector(t(x) %*% p1), eta)) Deta <- as.vector(t(y0) %*% p1) if(trace){ cat("gradient:\n") print(rbind(Dbeta,Deta))} -2*c(Dbeta,Deta) } msn.moment.fit <- function(y) {# 31-12-1997: simple fit of MSN distribution usign moments y <- as.matrix(y) k <- ncol(y) m.y <- apply(y, 2, mean) var.y <- var(y) y0 <- (t(y) - m.y)/sqrt(diag(var.y)) gamma1<- apply(y0^3, 1, mean) out <- (abs(gamma1) > 0.99527) gamma1[out] <- sign(gamma1[out])*0.995 a <- sign(gamma1)*(2*abs(gamma1)/(4-pi))^0.33333 delta <- sqrt(pi/2)*a/sqrt(1+a^2) m.z <- delta * sqrt(2/pi) omega <- sqrt(diag(var.y)/(1-m.z^2)) Omega <- var.y + outer(omega*m.z, omega*m.z) xi <- m.y-omega*m.z O.cor <- cov2cor(Omega) O.inv <- pd.solve(O.cor) tmp <- as.vector(1 - t(delta) %*% O.inv %*% delta) if(tmp<=0) {tmp <- 0.0001; admissible <- FALSE} else admissible <- TRUE alpha <- as.vector(O.inv %*% delta)/sqrt(tmp) list(xi=xi, Omega=Omega, alpha=alpha, Omega.cor=O.cor, omega=omega, delta=delta, skewness=gamma1, admissible=admissible) } st.mple <- function(x, y, dp=NULL, w, fixed.nu=NULL, symmetr=FALSE, penalty=NULL, trace=FALSE, opt.method=c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control=list()) { # MLE of DP for univariate ST distribution, allowing case symmetr[ic]=TRUE if(missing(y)) stop("required argument y is missing") if(!is.vector(y) | !is.numeric(y)) stop("argument y must be a numeric vector") x <- if(missing(x)) matrix(rep(1, length(y)), ncol = 1) else data.matrix(x) if(!is.matrix(x)) stop("argument x must be a matrix") y.name <- deparse(substitute(y)) x.name <- deparse(substitute(x)) if(any(x[,1] != 1)) stop("first column of x must have all 1's") if(symmetr && !is.null(penalty)) stop("Penalized log-likelihood not allowed with constraint alpha=0") n <- length(y) p <- ncol(x) if(missing(w)) w <- rep(1,n) nw <- sum(w) if(is.null(dp)) { ls <- lm.wfit(x, y, w) res <- ls$residuals s <- sqrt(sum(w*res^2)/nw) gamma1 <- sum(w*res^3)/(nw*s^3) gamma2 <- sum(res^4)/(nw*s^4) - 3 cp <- c(ls$coef, s, gamma1, gamma2) dp <- st.cp2dp(cp, silent=TRUE) if(is.null(dp)) dp <- rep(NA,length(cp)) if(any(is.na(dp))) dp <- c(cp[1:(p+1)], 0, 10) if(!is.null(fixed.nu)) dp <- dp[-length(dp)] if(symmetr) dp <- dp[-length(dp)] } else{ if(length(dp) != (p+2-as.numeric(symmetr)+as.numeric(is.null(fixed.nu)))) stop("arg 'dp' has wrong length")} if(trace) cat("dp (starting values) =", format(dp), "\n") tiny <- (.Machine$double.eps)^(0.25) low.dp <- c(rep(-Inf, p), tiny, if(symmetr) NULL else -Inf, if(is.null(fixed.nu)) tiny) high.dp <- c(rep(Inf, length(dp))) opt.method <- match.arg(opt.method) penalty.fn <- if(is.null(penalty)) NULL else get(penalty, inherits=TRUE) if(opt.method == "nlminb") { opt <- nlminb(dp, objective=st.pdev, gradient=st.pdev.gh, # do NOT set: hessian=st.dev.hessian, lower=low.dp, upper=high.dp, control=control, x=x, y=y, w=w, fixed.nu=fixed.nu, symmetr=symmetr, penalty=penalty.fn, trace=trace) opt$value <- opt$objective } else { opt <- optim(dp, fn=st.pdev, gr=st.pdev.gh, method = opt.method, # arguments lower & upper not used to allow all opt.method control = control, x=x, y=y, w=w, fixed.nu=fixed.nu, symmetr=symmetr, penalty=penalty.fn, trace=trace) } dp <- opt$par opt$method <- opt.method opt$called.by <- "st.mple" dp. <- if(is.null(fixed.nu)) dp else c(dp, fixed.nu) if(symmetr) dp. <- c(dp.[1:(p+1)], 0, dp.[length(dp.)]) rv.comp <- c(TRUE, !symmetr, is.null(fixed.nu)) names(dp) <- param.names("DP", "ST", p=p, x.names=colnames(x)[-1], rv.comp) names(dp.) <- param.names("DP", "ST", p=p, x.names=colnames(x)[-1]) logL <- (-opt$value)/2 boundary <- FALSE if(!symmetr) boundary <- as.logical(abs(dp[p+2]) > 1000) if(is.null(fixed.nu)) boundary <- (boundary | dp[length(dp)] > 1e3) # AA, must improve this rule if(trace) { cat("Message from function", opt.method, ": ", opt$message, "\n") cat("estimates (dp):", dp, "\n") cat("log-likelihood:", logL, "\n") } list(call=match.call(), dp=dp, fixed.nu=fixed.nu, logL=logL, dp.complete=dp., boundary=boundary, opt.method=opt) } st.pdev <- function(dp, x, y, w, fixed.nu=NULL, symmetr=FALSE, penalty=NULL, trace=FALSE) { # computes "penalized deviance"=-2*(logL-Q) for ST p <- ncol(x) xi <- as.vector(x %*% matrix(dp[1:p],p,1)) alpha <- if(symmetr) 0 else dp[p+2] nu <- if(is.null(fixed.nu)) dp[p+3-as.numeric(symmetr)] else fixed.nu if(dp[p+1] <= 0 | nu <= 0) return(NA) logL <- sum(w * dst(y, xi, dp[p+1], alpha, nu, log=TRUE)) Q <- if(is.null(penalty)) 0 else penalty(dp[p+2], nu, der=0) if(trace) cat("st.pdev: (dp,pdev) =", format(c(dp, -2*(logL-Q))),"\n") return(-2 * (logL - Q)) } st.pdev.gh <- function(dp, x, y, w, fixed.nu=NULL, symmetr=FALSE, penalty=NULL, trace=FALSE, hessian=FALSE) { # computes gradient and hessian of (penalized) deviance for ST p <- ncol(x) n <- nrow(x) beta <- dp[1:p] omega <- dp[p+1] alpha <- if(symmetr) 0 else dp[p+2] j.nu <- p + 2 + as.numeric(!symmetr) nu <- if(is.null(fixed.nu)) dp[j.nu] else fixed.nu npar <- p + 1 + as.numeric(!symmetr) + as.numeric(is.null(fixed.nu)) score <- numeric(npar) xi <- as.vector(x %*% beta) z <- (y - xi)/omega nuz2 <- (nu + z^2) loro.tau <- sqrt((nu+1)/nuz2) zt <- z * loro.tau log.pdf <- dt(alpha*zt, nu+1, log=TRUE) log.cdf <- pt(alpha*zt, nu+1, log.p=TRUE) cdf <- exp(log.cdf) loro.w <- exp(log.pdf - log.cdf) tw <- loro.tau * loro.w zwz2 <- z*(z^2-1)*loro.w/loro.tau wi.beta <- z*loro.tau^2 - nu*alpha*tw/(nu+z^2) score[1:p] <- colSums(w*x*wi.beta)/omega score[p+1] <- sum(w * (-1 + zt^2 -alpha*nu*z*tw/(nu+z^2)))/omega if(!symmetr) score[p+2] <- sum(w*z*tw) if(is.null(fixed.nu)){ fun.g <- function(x, nu1) dt(x,nu1) * (((nu1+1)*x^2)/(nu1*(nu1+x^2)) - log1p(x^2/nu1)) int.g <- numeric(n) for (i in 1:n) int.g[i] <- integrate(fun.g, -Inf, alpha*zt[i], nu1=nu+1)$value score[j.nu] <- 0.5 * sum(w * (digamma(1+nu/2) -digamma(nu/2) - (2*nu+1)/(nu*(nu+1)) -log1p(z^2/nu) + zt^2/nu + alpha*zwz2/(nu+z^2)^2 + int.g/cdf)) } if(is.null(penalty)) { Q <- 0 attr(Q, "der1") <- rep(0,2) attr(Q, "der2") <- matrix(rep(0,4), 2, 2) } else { if(symmetr) stop("Penalized logL not allowed with constraint alpha=0") Q <- penalty(alpha, nu, der=1+as.numeric(hessian)) } score[(p+2):(p+3)] <- score[(p+2):(p+3)] - attr(Q, "der1") score <- score[1:npar] gradient <- (-2)*score if(hessian){ info <- matrix(NA, npar, npar) w.z <- (-nu*(nu+2)*alpha^2*z*loro.w/((nu+z^2*(1+alpha^2))*nuz2) -nu*alpha*loro.tau*loro.w^2/nuz2) w.alpha <- (-(nu+2)* alpha*z^2*loro.w/(nu+z^2*(1+alpha^2)) -zt*loro.w^2) S.z <- (-z*loro.tau^2 + alpha*nu*tw/nuz2) S.zz <- (2*zt^2/nuz2 - loro.tau^2 -3*alpha*nu*z*tw/nuz2^2 +alpha*nu*loro.tau*w.z/nuz2) info[1:p,1:p] <- t(-S.zz *x) %*% (w*x)/omega^2 info[1:p,p+1] <- info[p+1,1:p] <- colSums(-w*(S.zz*z + S.z)*x)/omega^2 info[p+1,p+1] <- -sum(w*(1 + z^2*S.zz + 2*z*S.z))/omega^2 S.za <- nu*loro.tau*(loro.w +alpha*w.alpha)/nuz2 if(!symmetr) { info[1:p,p+2] <- info[p+2,1:p] <- colSums(w*S.za*x)/omega info[p+1,p+2] <- info[p+2,p+1] <- sum(w*z*S.za)/omega info[p+2,p+2] <- sum(-w*zt*w.alpha) + attr(Q,"der2")[1,1] } if(is.null(fixed.nu)) { w.nu <- (0.5*loro.w*((nu+2)*(alpha*z)^2/((nu+z^2*(1+alpha^2))*nuz2) - log1p((alpha*z)^2/nuz2) - int.g/cdf) - 0.5*alpha*zwz2*loro.w/nuz2^2) S.znu <- (z*(1-z^2)/nuz2^2 + alpha*nu*loro.tau*w.nu/nuz2 + alpha*(nu*(3*z^2-1)+2*z^2)*loro.w/(2*loro.tau*nuz2^3)) info[1:p,j.nu] <- info[j.nu,1:p] <- colSums(w* S.znu*x)/omega info[p+1,j.nu] <- info[j.nu,p+1] <- sum(w*z*S.znu)/omega fun.b <- function(x, nu1) dt(x,nu1) * (((nu1+1)*x^2)/(nu1*(nu1+x^2)) - log1p(x^2/nu1))^2 fun.d <- function(x, nu1) dt(x,nu1) * x^2*((nu1-1)*x^2-2*nu1)/(nu1^2*(nu1+x^2)^2) int.b <- int.d <- numeric(n) for (i in 1:n) { int.b[i] <- integrate(fun.b, -Inf, alpha*zt[i], nu1=nu+1)$value int.d[i] <- integrate(fun.d, -Inf, alpha*zt[i], nu1=nu+1)$value } info[j.nu,j.nu] <- -sum(w*( (trigamma(nu/2+1) - trigamma(nu/2))/4 + (2*nu^2+2*nu+1)/(2*(nu*(nu+1))^2) + z^2/(2*nu*nuz2) - z^2*(nu^2+2*nu+z^2)/(2*nu^2*nuz2^2) - alpha*zwz2*(z^2+4*nu+3)/(4*(nu+1)*nuz2^3) + alpha*z*(1-loro.tau^2)*w.nu/(2*loro.tau*nuz2) - (int.g/(2*cdf))^2 - alpha*zwz2*int.g/(4*cdf*nuz2^2) + (2*int.d + int.b)/(4*cdf) + (alpha*zwz2/(4*nuz2^2))* ((nu+2)*alpha^2*z^2/((nu+1)*(nu+z^2*(1+alpha^2))) - log1p((alpha*z)^2/nuz2)) )) info[j.nu,j.nu] <- info[j.nu,j.nu] + attr(Q,"der2")[2,2] if(!symmetr) { info[p+2,p+3] <- info[p+3,p+2] <- -sum(w*(0.5*zwz2/nuz2^2 + zt*w.nu)) info[p+2,p+3] <- info[p+2,p+3] + attr(Q,"der2")[1,2] info[p+3,p+2] <- info[p+3,p+2] + attr(Q,"der2")[2,1] } } attr(gradient,"hessian") <- force.symmetry(2*info) if(trace) cat("Hessian matrix has been computed\n") } if(trace) cat("st.pdev.gh: gradient = ", format(gradient),"\n") return(gradient) } st.pdev.hessian <- function(dp, x, y, w, fixed.nu=NULL, symmetr=FALSE, penalty = NULL, trace=FALSE) attr(st.pdev.gh(dp, x, y, w, fixed.nu, symmetr, penalty, trace, hessian=TRUE), "hessian") st.infoUv <- function(dp=NULL, cp=NULL, x=NULL, y, w, fixed.nu=NULL, symmetr=FALSE, penalty=NULL, norm2.tol=1e-06) {# computes observed Fisher information matrix for univariate ST variates if(missing(y)) stop("y is missing") if(!is.numeric(y)) stop("y is non-numeric") type <- "observed" if(is.null(dp) & is.null(cp)) stop("either dp or cp must be set") if(!is.null(dp) & !is.null(cp)) stop("cannot set both dp and cp") # if(is.null(cp)) cp <- st.dp2cp(c(dp, fixed.nu)) # completa DP se necessario if(is.null(dp)) dp <- st.cp2dp(cp) # AA, CP deve essere comunque completo if(missing(w)) w <- rep(1, max(nrow(cbind(x, y)), 1)) if(any(w != round(w)) | any(w<0)) stop("weights must be non-negative integers") npar <- length(dp) n <- length(w) nw <- sum(w) nu <- if(is.null(fixed.nu)) dp[npar] else fixed.nu if(is.null(x)) { n <- if(is.null(y)) 1 else NROW(y) p <- 1 xx <- sum.x <- nw x <- matrix(1, nrow=n, ncol=1) } else { p <- NCOL(x) # x <- matrix(x, n, p) xx <- t(x) %*% (w * x) sum.x <- matrix(colSums(x)) } penalty.fn <- if(is.null(penalty)) NULL else get(penalty, inherits=TRUE) score <- st.pdev.gh(dp, x, y, w, fixed.nu, symmetr, penalty.fn, trace=FALSE, hessian=TRUE) I.dp <- attr(score, "hessian")/2 if((d2 <- sum(score * as.vector(solve(I.dp) %*% score))) > norm2.tol*npar) { warning("'dp' does not seem to be at MLE; score not quite 0") cat("score(dp): ", score, "\n") cat("norm(score)^2:", d2,"\n") } attr(score, "hessian") <- NULL dimnames(I.dp) <- list(names(dp), names(dp)) asyvar.dp <- pd.solve(I.dp, silent=TRUE) aux <- list(score.dp=score) if(nu > 4) { dp0 <- c(dp[1:(p+1)], if(symmetr) 0 else dp[p+2], if(is.null(fixed.nu)) nu) cp <- st.dp2cp(dp=dp0, cp.type="proper", fixed.nu=fixed.nu, upto=if(is.null(fixed.nu)) 4 else 3, jacobian=TRUE) Dcp.dp <- attr(cp, "jacobian") attr(cp, "jacobian") <- NULL ind <- c(1:(p+1), if(symmetr) NULL else (p+2), if(is.null(fixed.nu)) p+3) Dcp.dp <- Dcp.dp[ind, ind] cp <- cp[ind] Ddp.cp <- solve(Dcp.dp) I.cp <- force.symmetry(t(Ddp.cp) %*% I.dp %*% Ddp.cp) dimnames(I.cp) <- list(names(cp), names(cp)) asyvar.cp <- pd.solve(I.cp) aux$Dcp.dp <- Dcp.dp aux$Ddp.cp <- Ddp.cp } else { I.cp <- NULL asyvar.cp <- NULL aux <- NULL } list(dp=dp, cp=cp, type=type, info.dp=I.dp, info.cp=I.cp, asyvar.dp=asyvar.dp, asyvar.cp=asyvar.cp, aux=aux) } param.names <- function(param.type, family="SN", p=1, x.names=NULL, rv.comp) {# NB: x.names= names of covariates except intercept, having length (p-1); # rv.comp=random variable components (those not part of the linear predictor) if(!(param.type %in% c("DP","CP","pseudo-CP"))) stop("invalid param.type") if(!(family %in% c("SN", "ESN", "ST", "SC"))) stop("unknown family") if(p > 1 && (length(x.names) < (p-1))) x.names <- outer("x", as.character(1L:(p-1)), paste, sep=".") if(param.type == "DP"){ name0 <- if(p > 1) "(Intercept.DP)" else "xi" par.names <- c(name0, x.names, "omega", "alpha") if(family == "ESN") par.names <- c(par.names, "tau") if(family == "ST") par.names <- c(par.names, "nu") } if(param.type == "CP"){ name0 <- if(p > 1) "(Intercept.CP)" else "mean" par.names <- c(name0, x.names, "s.d.", "gamma1") if(family == "ESN") par.names <- c(par.names, "tau") if(family == "ST") par.names <- c(par.names, "gamma2") } if(param.type == "pseudo-CP"){ if(!(family %in% c("ST", "SC"))) stop("pseudo-CP makes sense only for ST and SC families") name0 <- if(p > 1) "(Intercept.CP~)" else "mean~" par.names <- c(name0, x.names, "s.d.~", "gamma1~") if(family == "ST") par.names <- c(par.names, "gamma2~") } if(missing(rv.comp)) rv.comp <- rep(TRUE, length(par.names)-p) par.names[c(rep(TRUE,p), rv.comp)] } mst.mple <- function (x, y, start=NULL, w, fixed.nu = NULL, symmetr=FALSE, penalty=NULL, trace = FALSE, opt.method = c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control = list()) { opt.method <- match.arg(opt.method) if(missing(y)) stop("required argument y is missing") if(!is.matrix(y) | !is.numeric(y)) stop("argument y must be a numeric matrix") y.name <- deparse(substitute(y)) y.names <- dimnames(y)[[2]] n <- nrow(y) x <- if (missing(x)) matrix(rep(1, n), ncol = 1) else data.matrix(x) if (missing(w)) w <- rep(1, n) nw <- sum(w) x.names <- dimnames(x)[[2]] d <- ncol(y) p <- ncol(x) if (is.null(start)) { ls <- lm.wfit(x, y, w, singular.ok=FALSE) beta <- coef(ls) Omega <- var(resid(ls)) omega <- sqrt(diag(Omega)) alpha <- rep(0, d) nu <- if(is.null(fixed.nu)) 8 else fixed.nu if (trace) cat("mst.mple: starting dp = (", c(beta, Omega[!upper.tri(Omega)], alpha, nu), ")\n") } else { if (!is.null(fixed.nu)) start$nu <- fixed.nu if (all(names(start)[2:4] == c("Omega", "alpha", "nu"))) { beta <- start[[1]] # was start$beta Omega <- start$Omega alpha <- start$alpha nu <- start$nu } else stop("argument 'start' is not in the form that I expected") } if(symmetr) alpha <- rep(0,d) param <- dplist2optpar(list(beta=beta, Omega=Omega, alpha=alpha)) if(symmetr) param <- param[-(p*d + d*(d+1)/2 + (1:d))] if(is.null(fixed.nu)) param <- c(param, log(nu)) if(!is.null(penalty)) penalty <- get(penalty, inherits=TRUE) opt.method <- match.arg(opt.method) if(opt.method == "nlminb") { opt <- nlminb(param, objective = mst.pdev, gradient = mst.pdev.grad, control = control, x = x, y = y, w = w, fixed.nu = fixed.nu, symmetr=symmetr, penalty=penalty, trace = trace) # info <- num.deriv2(opt$par, FUN="mst.dev.grad", X=X, y=y, # w=w, fixed.nu = fixed.nu)/2 opt$value <- opt$objective } else { opt <- optim(param, fn = mst.pdev, gr = mst.pdev.grad, method = opt.method, control = control, hessian = TRUE, x = x, y = y, w = w, fixed.nu = fixed.nu, symmetr=symmetr, penalty=penalty, trace = trace) # info <- opt$hessian/2 } dev <- opt$value param <- opt$par opt$method <- opt.method opt$called.by <- "mst.mple" if (trace) { cat("Message from optimization routine:", opt$message, "\n") cat("(penalized) deviance:", dev, "\n") } par <- opt$par npar0 <- (p*d + d*(d+1)/2) vp <- par[1:npar0] dp.comp <- (1:2) if(symmetr) vp <- c(vp, rep(0,d)) else { vp <- c(vp, par[npar0 + (1:d)]); dp.comp <- (1:3)} if(is.null(fixed.nu)) { vp <- c(vp, par[length(par)]) dp.comp <- c(dp.comp,4)} dp.list <- optpar2dplist(vp, d, p, x.names, y.names) dp <- dp.complete <- dp.list$dp if(symmetr) dp.complete$alpha <- rep(0, d) if(!is.null(fixed.nu)) dp.complete$nu <- fixed.nu alpha2 <- sum(dp$alpha * as.vector(cov2cor(dp$Omega) %*% dp$alpha)) delta.star <- sqrt(alpha2/(1+alpha2)) dp <- dp[dp.comp] aux <- list(fixed.nu=fixed.nu, symmetr=symmetr, alpha.star=sqrt(alpha2), delta.star=delta.star) boundary <- ((1 - delta.star) < .Machine$double.eps^(1/4)) if(is.null(fixed.nu)) boundary <- (boundary | dp$nu > 1e3) list(call=match.call(), dp=dp, dp.complete=dp.complete, logL=dev/(-2), boundary=boundary, aux=aux, opt.method = opt) } mst.pdev <- function(param, x, y, w, fixed.nu=NULL, symmetr=FALSE, penalty=NULL, trace=FALSE) { if(missing(w)) w <- rep(1,nrow(y)) d <- ncol(y) p <- ncol(x) npar0 <- (p*d + d*(d+1)/2) param1 <- c(param[1:npar0], if(symmetr) rep(0, d) else param[npar0+(1:d)], if(is.null(fixed.nu)) param[length(param)]) dp.list <- optpar2dplist(param1, d, p) dp <- dp.list$dp nu <- if(is.null(fixed.nu)) dp$nu else fixed.nu logL <- sum(w * dmst(y, x %*% dp$beta, dp$Omega, dp$alpha, nu, log=TRUE)) Q <- if(is.null(penalty)) 0 else penalty(list(alpha=dp$alpha, Omega.bar=cov2cor(dp$Omega)), nu, der=0) pdev <- (-2) * (logL - Q) if(trace) cat("mst.pdev: ", pdev, "\nparam:", format(param), "\n") pdev } mst.pdev.grad <- function(param, x, y, w, fixed.nu=NULL, symmetr=FALSE, penalty=NULL, trace=FALSE) { # based on Appendix B of Azzalini & Capitanio (2003, arXiv-0911.2342) # except for a few quite patent typos (transposed matrices, etc) d <- ncol(y) p <- ncol(x) beta<- matrix(param[1:(p*d)],p,d) D <- exp(-2*param[(p*d+1):(p*d+d)]) A <- diag(d) i0 <- p*d + d*(d+1)/2 if(d>1) A[!lower.tri(A,diag=TRUE)] <- param[(p*d+d+1):i0] eta <- if(symmetr) rep(0,d) else param[(i0+1):(i0+d)] nu <- if(is.null(fixed.nu)) exp(param[length(param)]) else fixed.nu Oinv <- t(A) %*% diag(D,d,d) %*% A u <- y - x %*% beta u.w <- u * w Q <- as.vector(rowSums((u %*% Oinv) * u.w)) L <- as.vector(u.w %*% eta) sf <- if(nu < 1e4) sqrt((nu+d)/(nu+Q)) else sqrt((1+d/nu)/(1+Q/nu)) t. <- L*sf # t(L,Q,nu) in \S 5.1 # dlogft<- (-0.5)*(1+d/nu)/(1+Q/nu) # \tilde{g}_Q dlogft <- (-0.5)*sf^2 # \tilde{g}_Q, again dt.dL <- sf # \dot{t}_L dt.dQ <- (-0.5)*L*sf/(Q+nu) # \dot{t}_Q logT. <- pt(t., nu+d, log.p=TRUE) dlogT.<- exp(dt(t., nu+d, log=TRUE) - logT.) # \tilde{T}_1 Dbeta <- (-2* t(x) %*% (u.w*dlogft) %*% Oinv - outer(as.vector(t(x) %*% (dlogT. * dt.dL* w)), eta) - 2* t(x) %*% (dlogT.* dt.dQ * u.w) %*% Oinv ) Deta <- colSums(dlogT.*sf*u.w) if(d>1) { M <- 2*( diag(D,d,d) %*% A %*% t(u * dlogft + u * dlogT. * dt.dQ) %*% u.w) DA <- M[!lower.tri(M,diag=TRUE)] } else DA<- NULL M <- (A %*% t(u*dlogft + u*dlogT.*dt.dQ) %*% u.w %*% t(A)) if(d>1) DD <- diag(M) + 0.5*sum(w)/D else DD <- as.vector(M + 0.5*sum(w)/D) grad <- (-2) * c(Dbeta, DD*(-2*D), DA, if(!symmetr) Deta) if(is.null(fixed.nu)) { df0 <- min(nu, 1e8) if(df0 < 10000){ diff.digamma <- digamma((df0+d)/2) - digamma(df0/2) log1Q<- log(1+Q/df0) } else { diff.digamma <- log1p(d/df0) log1Q <- log1p(Q/df0) } dlogft.ddf <- 0.5 * (diff.digamma - d/df0 + (1+d/df0)*Q/((1+Q/df0)*df0) - log1Q) eps <- 1.0e-4 df1 <- df0 + eps sf1 <- if(df0 < 1e4) sqrt((df1+d)/(Q+df1)) else sqrt((1+d/df1)/(1+Q/df1)) logT.eps <- pt(L*sf1, df1+d, log.p=TRUE) dlogT.ddf <- (logT.eps-logT.)/eps Ddf <- sum((dlogft.ddf + dlogT.ddf)*w) grad <- c(grad, -2*Ddf*df0) } if(!is.null(penalty)) { if(symmetr) stop("penalized log-likelihood not allowed when alpha=0") Ainv <- backsolve(A, diag(d)) Omega <- Ainv %*% diag(1/D,d,d) %*% t(Ainv) omega <- diag(Omega) alpha <- eta*omega Q <- Qpenalty(list(alpha, cov2cor(Omega)), nu, der=1) comp <- 1:(length(alpha)+is.null(fixed.nu)) Qder <- attr(Q, "der1") * c(1/omega, 1)[comp] # gradient for transformed variable (alpha --> eta) grad <- grad + 2*c(rep(0, p*d + d*(d+1)/2), Qder) } if(trace) cat("mst.pdev.grad: norm is ", format(sqrt(sum(grad^2))), "\n") return(grad) } mst.theta.jacobian <- function(theta, p, d, cp.type="proper") { # jacobian matrices associated to transformations from # theta=c(beta, vech(Omega), eta, nu) to DP, CP and other parameterizations cp.type <- match.arg(cp.type, c("proper", "pseudo")) k1 <- p * d k2 <- k1 + d*(d+1)/2 k3 <- k2 + d k4 <- k3 + 1 if(length(theta) != k4) stop("mismatch in the arguments") block1 <- 1:k1 block2 <- (k1+1):k2 block3 <- (k2+1):k3 block4 <- k4 beta <- matrix(theta[block1], p, d) Omega <- vech2mat(theta[block2]) Omega.inv <- pd.solve(Omega) eta <- theta[block3] nu <- theta[block4] a.incr <- if(cp.type=="proper") rep(0,4) else 1:4 omega <- sqrt(diag(Omega)) alpha <- eta*omega # delta <- delta.etc(alpha, Omega)$delta D <- duplicationMatrix(d) P <- matrix(0, d^2, d^2) for (i in 1:d) { Eii <- matrix(0,d,d) Eii[i,i] <- 1 P <- P + Eii %x% Eii } omega <- sqrt(diag(Omega)) d <- length(omega) delta.plus <- delta.etc(alpha, Omega) delta <- delta.plus$delta delta.sq <- (delta.plus$delta.star)^2 alpha.sq <- (delta.plus$alpha.star)^2 a <- function(nu) nu/(nu-2) u <- function(nu) 0.5*(1/nu + digamma((nu-1)/2) - digamma(nu/2)) c1 <- function(nu) b(nu)/sqrt(1 + alpha.sq) q1 <- function(nu) a(nu)/(c1(nu)*(1 + beta0.sq(nu))) q2 <- function(nu) q1(nu)*(2*c1(nu) - q1(nu))/(2*a(nu)) beta0.sq <- function(nu) # beta0.sq = sum(mu0 * Sigma.inv_mu0) = b(nu)^2 * alpha.sq/(a(nu)+(a(nu)-b(nu)^2)*alpha.sq) #-- Dtheta.dp = D_{DP}\theta Dtheta.dp <- diag(k4) diag(Dtheta.dp)[block3] <- 1/omega Deta.vOmega <- (-0.5)* (t(eta) %x% diag(1/omega^2, d, d)) %*% P %*% D Dtheta.dp[block3, block2] <- Deta.vOmega # mu0 <- function(nu) omega * b(nu) * delta Sigma.etc <- function(nu) { mu0. <- mu0(nu) Omega.inv_mu0 <- as.vector(Omega.inv %*% mu0.) Sigma <- a(nu)*Omega - outer(mu0., mu0.) sigma <- sqrt(diag(Sigma)) tmp <- a(nu) - sum(mu0. *Omega.inv_mu0) Sigma.inv_mu0 <- Omega.inv_mu0/tmp Sigma.inv <- (Omega.inv + outer(Omega.inv_mu0, Omega.inv_mu0)/tmp)/a(nu) list(Sigma=Sigma, Sigma.inv=Sigma.inv, Sigma.inv_mu0=Sigma.inv_mu0, sigma=sigma) } Dq1.nu <- function(nu){ beta0_sq <- beta0.sq(nu) (-2/(nu-2)^2 -a(nu)*(b(nu)^2*u(nu)+beta0_sq/((nu-2)^2*(1+beta0_sq))) /c1(nu)^2)/(c1(nu)*(1+beta0_sq)) } # blocks for D_{\Psi}\theta Dplus <- solve(t(D)%*% D) %*% t(D) DvOmega.vSigma <- function(nu) diag(d*(d+1)/2)/a(nu) DvOmega.mu0 <- function(nu) Dplus %*% (diag(d) %x% mu0(nu) + mu0(nu) %x% diag(d))/a(nu) DvOmega.nu <- function(nu){ s <- Sigma.etc(nu) 2*vech(s$Sigma + outer(mu0(nu), mu0(nu)))/nu^2 } Deta.vSigma <- function(nu) { S <- Sigma.etc(nu) t(-S$Sigma.inv_mu0) %x% (q1(nu)* S$Sigma.inv - q1(nu) * q2(nu) *outer(S$Sigma.inv_mu0, S$Sigma.inv_mu0)) %*% D } Deta.mu0 <- function(nu) { S <- Sigma.etc(nu) q1(nu) * (S$Sigma.inv - 2*q2(nu)*outer(S$Sigma.inv_mu0, S$Sigma.inv_mu0)) } Deta.nu <- function(nu) Dq1.nu(nu) * Sigma.etc(nu)$Sigma.inv_mu0 #-- Dtheta.phi(phi)= D_{\Psi}\theta one00 <- c(1,rep(0,p-1)) Dtheta.phi <- diag(k4) Dtheta.phi[block1, block3] <- -diag(d) %x% one00 Dtheta.phi[block2, block2] <- DvOmega.vSigma(nu+a.incr[2]) Dtheta.phi[block2, block3] <- DvOmega.mu0(nu+a.incr[2]) Dtheta.phi[block2, block4] <- DvOmega.nu(nu+a.incr[2]) Dtheta.phi[block3, block2] <- Deta.vSigma(nu+a.incr[2]) Dtheta.phi[block3, block3] <- Deta.mu0(nu+a.incr[2]) Dtheta.phi[block3, block4] <- Deta.nu(nu +a.incr[2]) # # blocks for D_{\Psi}CP Dgamma2M.misc <- function(nu){ beta0_sq <- beta0.sq(nu) s <- Sigma.etc(nu) nu.34 <- (nu-3)*(nu-4) tmp2 <- ( (d+2)/nu.34 + beta0_sq * (2*nu/((nu-3)*b(nu)^2) - (3*(nu-3)^2-6)/nu.34 )) Dgamma2M.mu0 <- as.vector(8 * tmp2 * t(s$Sigma.inv_mu0)) Dgamma2M.vSigma <- (-4 * tmp2) * as.vector(( t(s$Sigma.inv_mu0) %x% t(s$Sigma.inv_mu0)) %*% D) R <- b(nu)^2*delta.sq*(nu-2)/nu R1R <- R/(1-R) PDgamma2.nu <- (-2*d*(d+2)/(nu-4)^2 -4*((2*nu-7)/nu.34^2) *R1R*(2/(1-R)+d) +2*(2*((nu-3)-nu*(1+2*(nu-3)*u(nu)))/((nu-3)*b(nu))^2 +(3*nu^2-22*nu+41)/nu.34^2)*R1R^2) #\ref{f:partial_gamma2.nu} list(Dgamma2M.vSigma=Dgamma2M.vSigma, Dgamma2M.mu0=Dgamma2M.mu0, PDgamma2.nu=PDgamma2.nu) } Dgamma1.misc <- function(nu) { sigma <- Sigma.etc(nu)$sigma lambda <- mu0(nu)/sigma g.nu <- 3/(nu-3) h.nu <- 1 + nu*(1-1/b(nu)^2)/(nu-3) Q <- g.nu*diag(d) + 3*h.nu*diag(lambda^2) Dgamma1.vOmega <- (t(-lambda/2) %x% (Q %*% diag(1/sigma^2,d))) %*% P %*% D Dgamma1.mu0 <- Q %*% diag(1/sigma,d) # K_{33} Dgamma1.nu <- (-3*lambda/(nu-3)^2 + (-3*(1-1/b(nu)^2)/(nu-3)^2 + 2*nu*u(nu)/((nu-3)*b(nu)^2))*lambda^3) # K_{34} list(Dgamma1.vOmega=Dgamma1.vOmega, Dgamma1.mu0=Dgamma1.mu0, Dgamma1.nu=Dgamma1.nu) } # #-- # Dcp.phi(phi) = D_{\Psi}(CP) [in the notes] = D_{\phi}\bar\rho [paper] # Dcp.phi <- diag(k4) K3 <- Dgamma1.misc(nu+a.incr[3]) K4 <- Dgamma2M.misc(nu+a.incr[4]) Dcp.phi[block3,block2] <- K3$Dgamma1.vOmega Dcp.phi[block3,block3] <- K3$Dgamma1.mu0 Dcp.phi[block3,block4] <- K3$Dgamma1.nu Dcp.phi[block4,block2] <- K4$Dgamma2M.vSigma Dcp.phi[block4,block3] <- K4$Dgamma2M.mu0 Dcp.phi[block4,block4] <- K4$PDgamma2.nu # # Dtheta.cp <- Dtheta.phi %*% solve(Dcp.phi) list(Dtheta.dp=Dtheta.dp, Dtheta.cp= Dtheta.phi %*% solve(Dcp.phi), Dtheta.phi=Dtheta.phi, Dcp.phi=Dcp.phi) } # mst.vdp2vcp <- function(vdp, p, d, cp.type="proper") { # vdp = c(betaDP, vech(Omega), alpha, nu), # vcp=(betaCP, vech(Sigma), gamma1, gamma2M) # d=ncol(y), p=ncol(x) beta <- matrix(vdp[1:(p*d)], p, d) vOmega <- vdp[(p*d+1):(p*d+d*(d+1)/2)] Omega <- vech2mat(vOmega) # omega <- sqrt(diag(Omega)) alpha <- vdp[(p*d+d*(d+1)/2+1):(p*d+d*(d+1)/2+d)] nu <- vdp[p*d+d*(d+1)/2+d+1] dp <- list(beta=beta, Omega=Omega, alpha=alpha, nu=nu) cp <- mst.dp2cp(dp, cp.type=cp.type) c(cp[[1]], vech(cp[[2]]), cp[[3]], cp[[4]]) } # mst.logL <- function(vdp, X, y, dp=TRUE, penalty=NULL) { # calcola logL rispetto a DP (se dp=TRUE) oppure a theta (se dp=FALSE), # con eventuale inclusione del termine 'penalty' se presente; # funziona non solo per ST, ma anche per SN ponendo dp$nu=Inf n <- nrow(y) d <- ncol(y) if(missing(X)) X <- matrix(1,n,1) p <- ncol(X) beta <- matrix(vdp[1:(p*d)], p, d) vOmega <- vdp[(p*d+1):(p*d+d*(d+1)/2)] Omega <- vech2mat(vOmega) # if(any(eigen(Omega)$values <= 0)) return(NA) if(any(diag(Omega) <= 0)) return(-Inf) omega <- sqrt(diag(Omega)) tmp <- vdp[(p*d+d*(d+1)/2+1):(p*d+d*(d+1)/2+d)] alpha <- if(dp) tmp else tmp*omega nu <- vdp[p*d+d*(d+1)/2+d+1] if(nu <= 0) return(-Inf) Q <- if(is.null(penalty)) 0 else penalty(list(alpha, cov2cor(Omega)), nu) sum(dmst(y, X %*% beta, Omega, alpha, nu, log=TRUE)) - Q } st.infoMv <- function(dp, x=NULL, y, w, fixed.nu=NULL, symmetr=FALSE, penalty=NULL, norm2.tol=1e-06) {# Computes observed Fisher information matrices for multiv.ST distribution # using expressions of score function of Arellano-Valle (2010, Metron), # followed by numerical differentiation. Expected info matrix not implemented. # Info matrices are computed for DP, CP and pseudo-CP if(missing(y)) stop("missing y") if(!is.matrix(y)) stop("y is not matrix") type <- "observed" d <- ncol(dp$Omega) d2 <- d*(d+1)/2 if(missing(w)) w <- rep(1, nrow(cbind(x,y))) if(any(w != round(w)) || any(w<0)) stop("weights must be non-negative integers") n <- length(w) nw <- sum(w) if(is.null(x)) { p <- 1 xx <- sum.x <- nw x <- matrix(1, nrow=n, ncol=1) } else { p <- NCOL(x) # x <- matrix(x, n, p) xx <- drop(t(x) %*% (w*x)) sum.x <- drop(matrix(colSums(w*x))) } beta <- as.matrix(dp[[1]], p, d) Omega <- dp[[2]] omega <- sqrt(diag(Omega)) alpha <- if(symmetr) rep(0,d) else dp$alpha eta <- alpha/omega nu <- if(is.null(fixed.nu)) dp$nu else fixed.nu dp1 <- list(beta=beta, Omega=Omega, alpha=alpha, nu=nu) Obar <- cov2cor(Omega) Obar.alpha <- as.vector(Obar %*% alpha) alpha.star <- sqrt(sum(alpha * Obar.alpha)) # =\sqrt{\eta\T\Omega\eta} theta <- as.numeric(c(beta, vech(Omega), eta, nu)) vdp <- as.numeric(c(beta, vech(Omega), alpha, nu)) penalty.fn <- if(is.null(penalty)) NULL else get(penalty, inherits=TRUE) H <- numDeriv::hessian(mst.logL, vdp, X=x, y=y, dp=TRUE, penalty=penalty.fn) J <- mst.theta.jacobian(theta, p=NCOL(x), d=NCOL(y)) s <- 1:(length(theta) - as.numeric(!is.null(fixed.nu))) I.dp <- force.symmetry(-H[s,s]) J1 <- solve(J$Dtheta.dp[s,s]) I.theta <- force.symmetry(t(J1) %*% I.dp %*% J1) asyvar.dp <- pd.solve(I.dp, silent=TRUE) if(is.null(asyvar.dp)) { warning("Condition 'information_matrix > 0' fails, DP seems not at MLE") se.dp <- list(NULL) } else { diags.dp <- sqrt(diag(asyvar.dp)) se.beta <- matrix(diags.dp[1:(p*d)], p, d) se.diagOmega <- diags.dp[p*d + d2 +1 - rev(cumsum(1:d))] se.alpha <- diags.dp[p*d +d2 +(1:d)] se.dp <- list(beta=se.beta, diagOmega=se.diagOmega, alpha=se.alpha) if(is.null(fixed.nu)) se.dp$nu<- diags.dp[p*d +d2 + d +1] } if(nu>4) { cp <- mst.dp2cp(dp, cp.type="proper", fixed.nu=fixed.nu, symmetr=symmetr) I.cp <- force.symmetry(t(J$Dtheta.cp[s,s]) %*% I.theta %*% J$Dtheta.cp[s,s]) asyvar.cp <- pd.solve(I.cp, silent=TRUE) if(is.null(asyvar.cp)) { se.cp <- list(NULL) } else { diags.cp <- sqrt(diag(asyvar.cp)) se.beta <- matrix(diags.cp[1:(p*d)], p, d) se.diagSigma <- diags.cp[p*d + d2 +1 - rev(cumsum(1:d))] # se.sigma <- se.Sigma/(2*sigma) se.gamma1 <- if(!symmetr) diags.cp[p*d + d2 +(1:d)] else NULL se.cp <- list(beta=se.beta, var=se.diagSigma, gamma1=se.gamma1) if(is.null(fixed.nu)) se.cp$gamma2 <- diags.cp[p*d +d2 + d +1] }} else I.cp <- asyvar.cp <- se.cp <- cp <- NULL if(is.null(asyvar.dp)) { asyvar.pcp <- NULL se.pcp <- list(NULL) Jp <- NULL } else { vdp1 <- as.numeric(c(dp1[[1]], vech(dp1[[2]]), dp1[[3]], dp1[[4]])) Jp <- numDeriv::jacobian(mst.vdp2vcp, vdp1, p=ncol(x), d=ncol(y), cp.type="pseudo") asyvar.pcp <- (Jp[s,s]) %*% asyvar.dp %*% t(Jp[s,s]) diags.pcp <- sqrt(diag(asyvar.pcp)) se.beta <- matrix(diags.pcp[1:(p*d)], p, d) se.diagSigma <- diags.pcp[p*d + d2 +1 - rev(cumsum(1:d))] # se.sigma <- se.Sigma/(2*sigma) se.gamma1 <- if(!symmetr) diags.pcp[p*d + d2 +(1:d)] else NULL se.pcp <- list(beta=se.beta, var=se.diagSigma, gamma1=se.gamma1) if(is.null(fixed.nu)) se.pcp$gamma2 <- diags.pcp[p*d +d2 + d +1] } aux <- list(Dpseudocp.dp=Jp[s,s]) list(dp=dp, cp=cp, type=type, info.dp=I.dp, info.cp=I.cp, asyvar.dp=asyvar.dp, asyvar.cp=asyvar.cp, asyvar.p_cp=asyvar.pcp, se.dp=se.dp, se.cp=se.cp, se.p_cp=se.pcp, aux=aux) } sn.mple <- function(x, y, cp=NULL, w, penalty=NULL, trace=FALSE, opt.method=c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control=list()) {# MPLE for CP of univariate SN (not intendend for ESN) y <- drop(y) n <- length(y) if (missing(x)) x <- matrix(rep(1,n), nrow=n, ncol=1) else if (is.null(n <- nrow(x))) stop("'x' must be a matrix") if (n == 0) stop("0-row design matrix cases") if (missing(w)) w <- rep(1,n) if(length(w) != n) stop("incompatible dimensions") y.name <- deparse(substitute(y)) x.name <- deparse(substitute(x)) p <- ncol(x) max.gamma1 <- 0.5*(4-pi)*(2/(pi-2))^1.5 - (.Machine$double.eps)^(1/4) if(is.null(cp)) { qr.x <- qr(x) s <- sqrt(sum(qr.resid(qr.x, y)^2)/n) gamma1 <- sum(qr.resid(qr.x, y)^3)/(n*s^3) if(abs(gamma1) > max.gamma1) gamma1 <- sign(gamma1)*0.9*max.gamma1 cp <- as.numeric(c(qr.coef(qr.x, y), s, gamma1)) } else{ if(length(cp)!= (p+2)) stop("ncol(x)+2 != length(cp)")} penalty.fn <- if(is.null(penalty)) NULL else get(penalty, inherits=TRUE) opt.method <- match.arg(opt.method) if(opt.method == "nlminb") { opt <- nlminb(cp, objective=sn.pdev, gradient=sn.pdev.gh, hessian=sn.pdev.hessian, lower=c(-rep(Inf,p), sqrt(.Machine$double.eps), -max.gamma1), upper=c(rep(Inf,p), Inf, max.gamma1), control=control, x=x, y=y, w=w, penalty=penalty.fn, trace=trace) opt$value <- opt$objective } else { opt <- optim(cp, fn=sn.pdev, gr=sn.pdev.gh, method = opt.method, control = control, # lower & upper not used to allow all opt.method x=x, y=y, w=w, penalty=penalty.fn, trace=trace) } cp <- opt$par names(cp) <- param.names("CP", "SN", p, colnames(x)[-1]) logL <- (-opt$value)/2 boundary <- as.logical(abs(cp[p+2]) >= max.gamma1) if(trace) { cat("Message from function", opt.method, ": ", opt$message, "\n") cat("estimates (cp):", cp, "\n") cat("(penalized) log-likelihood:", logL, "\n") } opt$method <- opt.method opt$called.by <- "sn.mple" list(call=match.call(), cp=cp, logL=logL, boundary=boundary, opt.method=opt) } sn.pdev <- function(cp, x, y, w, penalty=NULL, trace=FALSE) { # "penalized deviance"=-2*(logL-Q) for centred parameters of SN distribution p <- ncol(x) if(abs(cp[p+2])> 0.9952717) return(Inf) if(missing(w)) w <- rep(1, length(y)) if(any(w < 0)) stop("weights must be non-negative") dp <- cp2dpUv(cp, "SN") xi <- as.vector(x %*% as.matrix(dp[1:p])) if(dp[p+1] <= 0) return(NA) logL <- sum(w * dsn(y, xi, dp[p+1], dp[p+2], log=TRUE)) Q <- if(is.null(penalty)) 0 else penalty(dp[p+2], der=0) if(trace) cat("sn.pdev: (cp,pdev) =", format(c(cp, -2*(logL-Q))),"\n") return(-2 * (logL - Q)) } sn.pdev.gh <- function(cp, x, y, w, penalty=NULL, trace=FALSE, hessian=FALSE) { # computes gradient and hessian of pdev=-2*(logL-Q) for centred parameters p <- ncol(x) n <- nrow(x) if(abs(cp[p+2]) > 0.9952717) return(rep(NA,p+2)) if(missing(w)) w <- rep(1,n) if(any(w < 0)) stop("weights must be non-negative") score <- rep(NA,p+2) info <- matrix(NA,p+2,p+2) beta <- cp[1:p] sigma <- cp[p+1] gamma1 <- cp[p+2] nw <- sum(w) dp <- cp2dpUv(cp, "SN") lambda <- dp[p+2] mu <- as.vector(x %*% as.matrix(beta)) d <- y-mu r <- d/sigma mu.z<- lambda*sqrt(2/(pi*(1+lambda^2))) sd.z<- sqrt(1-mu.z^2) z <- mu.z+sd.z*r p1 <- as.vector(zeta(1,lambda*z)) p2 <- as.vector(zeta(2,lambda*z)) omega<- sigma/sd.z af <- lambda*p1-mu.z Dmu.z <- sqrt(2/pi)/(1+lambda^2)^1.5 Dsd.z <- (-mu.z/sd.z)*Dmu.z Dz <- Dmu.z + r*Dsd.z DDmu.z<- (-3)*mu.z/(1+lambda^2)^2 DDsd.z<- -((Dmu.z*sd.z-mu.z*Dsd.z)*Dmu.z/sd.z^2+mu.z*DDmu.z/sd.z) DDz <- DDmu.z + r*DDsd.z score[1:p] <- omega^(-2) * t(x) %*% as.matrix(w*(y-mu-omega*af)) score[p+1] <- (-nw)/sigma + sd.z*sum(w*d*(z-p1*lambda))/sigma^2 score.l <- nw*Dsd.z/sd.z - sum(w*z*Dz) + sum(w*p1*(z+lambda*Dz)) if(!is.null(penalty)) { Q <- penalty(lambda, der=2) score.l <- (score.l - attr(Q, "der1")) } Dg.Dl <- 1.5*(4-pi)*mu.z^2 * (Dmu.z*sd.z - mu.z*Dsd.z)/sd.z^4 R <- mu.z/sd.z T <- sqrt(2/pi-(1-2/pi)*R^2) Dl.Dg <- 2*(T/(T*R)^2+(1-2/pi)/T^3)/(3*(4-pi)) R. <- 2/(3*R^2 * (4-pi)) T. <- (-R)*R.*(1-2/pi)/T DDl.Dg <- (-2/(3*(4-pi))) * (T./(R*T)^2+2*R./(T*R^3)+3*(1-2/pi)*T./T^4) score[p+2] <- score.l/Dg.Dl # convert deriv wrt lamda to gamma1 gradient <- (-2)*score if(hessian){ # info = -(second deriv of logL) info[1:p,1:p] <- omega^(-2) * t(x) %*% (w*(1-lambda^2*p2)*x) info[1:p,p+1] <- info[p+1,1:p] <- sd.z* t(x) %*% as.matrix(w*(z-lambda*p1)+ w*d*(1-lambda^2*p2)* sd.z/sigma)/sigma^2 info[p+1,p+1] <- (-nw)/sigma^2 + 2*sd.z*sum(w*d*(z-lambda*p1))/sigma^3 + sd.z^2*sum(w*d*(1-lambda^2*p2)*d)/sigma^4 info[1:p,p+2] <- info[p+2,1:p] <- t(x) %*% (w* (-2*Dsd.z*d/omega+Dsd.z*af+sd.z*(p1+lambda*p2*(z+lambda*Dz) -Dmu.z)))/sigma info[p+1,p+2] <- info[p+2,p+1] <- -sum(w*d*(Dsd.z*(z-lambda*p1)+sd.z*(Dz-p1-p2*lambda*(z+lambda*Dz)) ))/sigma^2 info[p+2,p+2] <- (nw*(-DDsd.z*sd.z+Dsd.z^2)/sd.z^2+sum(w*(Dz^2+z*DDz)) - sum(w*p2*(z+lambda*Dz)^2)- sum(w*p1*(2*Dz+lambda*DDz))) if(!is.null(penalty)) info[p+2,p+2] <- info[p+2,p+2] + attr(Q, "der2") info[p+2,] <- info[p+2,]/Dg.Dl # convert info wrt lambda to gamma1 info[,p+2] <- info[,p+2]*Dl.Dg # an equivalent form of the above info[p+2,p+2] <- info[p+2,p+2] - score.l*DDl.Dg attr(gradient,"hessian") <- force.symmetry(2*info) } if(trace) cat("sn.pdev.gh: gradient = ", format(gradient),"\n") return(gradient) } sn.pdev.hessian <- function(cp, x, y, w, penalty=NULL, trace=FALSE) { gh <- sn.pdev.gh(cp, x, y, w, penalty=penalty, trace=trace, hessian=TRUE) attr(gh, "hessian") } Qpenalty <- function(alpha_etc, nu=NULL, der=0) {# 'standard' penalty function of logL, possibly with derivatives e1 <- e1. <- 1/3 e2 <- e2. <- 0.2854166 if(!is.null(nu)) if(nu 0) attr(penalty,"der1") <- numDeriv::grad(MPpenalty, alpha) if(der > 1) attr(penalty,"der2") <- numDeriv::hessian(MPpenalty, alpha) return(penalty) } msn.mple <- function(x, y, start=NULL, w, trace=FALSE, penalty=NULL, opt.method=c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control=list() ) { y <- data.matrix(y) if(missing(x)) x <- rep(1,nrow(y)) else {if(!is.numeric(x)) stop("x must be numeric")} if(missing(w)) w <- rep(1,nrow(y)) opt.method <- match.arg(opt.method) x <- data.matrix(x) d <- ncol(y) n <- sum(w) p <- ncol(x) y.names <- dimnames(y)[[2]] x.names <- dimnames(x)[[2]] if(is.null(start)) start <- msn.mle(x, y, NULL, w)$dp if(trace){ cat("msn.mple initial parameters:\n") print(cbind(t(start[[1]]), start$Omega, start$alpha)) } param <- dplist2optpar(start) if(!is.null(penalty)) penalty <- get(penalty, inherits=TRUE) opt.method <- match.arg(opt.method) if(opt.method == "nlminb"){ opt <- nlminb(param, msn.pdev, # msn.pdev.grad, control=control, x=x, y=y, w=w, penalty=penalty, trace=trace) opt$value<- opt$objective } else{ opt <- optim(param, fn=msn.pdev, method=opt.method, control=control, x=x, y=y, w=w, penalty=penalty, trace=trace) } if(trace) cat(paste("Message from optimization routine:", opt$message,"\n")) logL <- opt$value/(-2) dp.list <- optpar2dplist(opt$par, d, p) beta <- dp.list$beta dimnames(beta)[2] <- list(y.names) dimnames(beta)[1] <- list(x.names) Omega <- dp.list$Omega alpha <- dp.list$alpha dimnames(Omega) <- list(y.names,y.names) names(alpha) <- y.names alpha2 <- sum(alpha * as.vector(cov2cor(Omega) %*% alpha)) delta.star <- sqrt(alpha2/(1+alpha2)) dp <- list(beta=beta, Omega=Omega, alpha=alpha) opt$method <- opt.method opt$called.by <- "msn.mple" aux <- list(penalty=penalty, alpha.star=sqrt(alpha2), delta.star=delta.star) list(call=match.call(), dp=dp, logL=logL, aux=aux, opt.method=opt) } msn.pdev <- function(param, x, y, w, penalty=NULL, trace=FALSE) { # -2*(profile.logL - Q) d <- ncol(y) if(missing(w)) w <- rep(1, nrow(y)) n <- sum(w) p <- ncol(x) dp. <- optpar2dplist(param, d=ncol(y), p=ncol(x)) logL <- sum(w * dmsn(y, x %*% dp.$beta, dp.$Omega, dp.$alpha, log=TRUE)) Q <- if(is.null(penalty)) 0 else penalty(list(dp.$alpha,dp.$Omega), der=0) pdev <- (-2)*(logL-Q) if(trace) cat("opt param:", format(param), "\nmsn.pdev:", format(pdev),"\n") return(pdev) } optpar2dplist <- function(param, d, p, x.names=NULL, y.names=NULL) {# convert vector form of optimization parameters to DP list; # output includes inverse(Omega) and its log determinant beta <- matrix(param[1:(p * d)], p, d) D <- exp(-2 * param[(p * d + 1):(p * d + d)]) A <- diag(d) i0 <- p*d + d*(d+1)/2 if(d>1) A[!lower.tri(A,diag=TRUE)] <- param[(p*d+d+1):i0] eta <- param[(i0 + 1):(i0 + d)] nu <- if(length(param) == (i0 + d + 1)) exp(param[i0 + d + 1]) else NULL Oinv <- t(A) %*% diag(D,d,d) %*% A # Omega <- pd.solve(Oinv) Ainv <- backsolve(A, diag(d)) Omega <- Ainv %*% diag(1/D,d,d) %*% t(Ainv) Omega <- (Omega + t(Omega))/2 omega <- sqrt(diag(Omega)) alpha <- eta * omega dimnames(beta) <- list(x.names, y.names) dimnames(Omega) <- list(y.names, y.names) if (length(y.names) > 0) names(alpha) <- y.names dp <- list(beta=beta, Omega=Omega, alpha=alpha) if(!is.null(nu)) dp$nu <- nu list(dp=dp, beta=beta, Omega=Omega, alpha=alpha, nu=nu, Omega.inv=Oinv, log.det=sum(log(D))) } dplist2optpar <- function(dp, Omega.inv=NULL) {# convert DP list to vector form of optimization parameters beta <- dp[[1]] Omega <- dp[[2]] alpha <- dp[[3]] d <- length(alpha) nu <- if(is.null(dp$nu)) NULL else dp$null eta <- alpha/sqrt(diag(Omega)) Oinv <- if(is.null(Omega.inv)) pd.solve(Omega) else Omega.inv if(is.null(Oinv)) stop("matrix Omega not symmetric positive definite") upper <- chol(Oinv) D <- diag(upper) A <- upper/D D <- D^2 param <- if(d > 1) c(beta, -log(D)/2, A[!lower.tri(A, diag = TRUE)], eta) else c(beta, -log(D)/2, eta) if(!is.null(dp$nu)) param <- c(param, log(dp$nu)) param <- as.numeric(param) attr(param, 'ind') <- cumsum(c(length(beta), d, d*(d-1)/2, d, length(dp$nu))) return(param) } force.symmetry <- function(x, tol=10*sqrt(.Machine$double.eps)) { if(!is.matrix(x)) stop("x must be a matrix") # err <- abs(x-t(x)) err <- abs(x-t(x))/(1+abs(x)) max.err <- max(err/(1+err)) if(max.err > tol) warning("matrix seems not symmetric") if(max.err > 100*tol) stop("this matrix really seems not symmetric") return((x + t(x))/2) } duplicationMatrix <- duplication_matrix <- function (n=1) {# translated by AA from Octave code written by if ( (n<1) | (round (n) != n) ) stop ("n must be a positive integer") d <- matrix (0, n * n, n * (n + 1) / 2) ## KH: It is clearly possible to make this a LOT faster! count = 0 for (j in 1 : n){ d [(j - 1) * n + j, count + j] = 1 if(j= 1)) stop("probs must be within (0,1)") if(sum(probs > 0 && probs < 1) == 0) stop("invalid probs") if(missing(npt)) npt <- rep(101, d) if(missing(main)) { main <- if(d==2) paste("Density function of", slot(obj, "name")) else paste("Bivariate densities of", slot(obj, "name")) } if(missing(comp)) comp <- seq(1,d) if(missing(compLabs)) compLabs <- compNames if(length(compLabs) != d) stop("wrong length of 'compLabs' or 'comp' vector") family <- toupper(obj@family) lc.family <- tolower(family) if(lc.family == "esn") lc.family <- "sn" dp <- slot(obj, "dp") if(missing(range)) { range <- matrix(NA,2,d) q.fn <- get(paste("q", lc.family, sep=""), inherits=TRUE) for(j in 1:d) { marg <- marginalSECdistr(obj, comp=j, drop=TRUE) q <- q.fn(c(0.05, 0.25, 0.75, 0.95), dp=marg@dp) dq <- diff(q) range[,j] <- c(q[1] - 1.5*dq[1], q[length(q)] + 1.5*dq[length(dq)]) if(!is.null(data)) { range[1,j] <- min(range[1,j], min(data[,j])) range[2,j] <- max(range[2,j], max(data[,j])) }} } dots <- list(...) nmdots <- names(dots) if(d == 1) { message("Since dimension=1, plot as a univariate distribution") objUv <- marginalSECdistr(obj, comp=1, drop=TRUE) out <- plot(objUv, data=data, ...) } if(d == 2) out <- list(object=obj, plot=plot.SECdistrBv(x, range, probs, npt, compNames, compLabs, landmarks, data, data.par, main, ...)) if(d > 2) { textPanel <- function(x = 0.5, y = 0.5, txt, cex, font) text(x, y, txt, cex = cex, font = font) localAxis <- function(side, x, y, xpd, bg, main, oma, ...) { if (side%%2 == 1) Axis(x, side = side, xpd = NA, ...) else Axis(y, side = side, xpd = NA, ...) } localPlot <- function(..., oma, font.main, cex.main) plot.SECdistrBv(...) text.diag.panel <- compLabs oma <- if ("oma" %in% nmdots) dots$oma else NULL if (is.null(oma)) { oma <- c(4, 4, 4, 4) if (!is.null(main)) oma[3L] <- 6 } opar <- par(mfrow = c(length(comp), length(comp)), mar = rep(c(gap,gap/2), each=2), oma=oma) on.exit(par(opar)) out <- list(object=obj) count <- 1 for (i in comp) for (j in comp) { count <- count + 1 if(i == j) { plot(1, type="n", xlab="", ylab="", axes=FALSE) text(1, 1, text.diag.panel[i], cex=2) box() out[[count]] <- list() names(out)[count] <- paste("diagonal component", compNames[i]) } else { ji <- c(j,i) marg <- marginalSECdistr(obj, comp=ji) out[[count]] <- localPlot(x=marg, range=range[,ji], probs=probs, npt=npt[ji], compNames= compNames[ji], compLabs=compLabs[ji], landmarks=landmarks, data=data[,ji], data.par=data.par, main="", yaxt="n", xaxt="n", ...) names(out)[count] <- paste("plot of components (", j, ",", i, ")") # if(i==comp[1]) {axis(3); if(j==length(comp)) axis(4)} # if(j==comp[1]) {axis(2); if(i==length(comp)) axis(1)} if(i==comp[1]) axis(3) ; if(j==length(comp)) axis(4) if(j==comp[1]) axis(2) ; if(i==length(comp)) axis(1) box() } } par(new = FALSE) if (!is.null(main)) { font.main <- if ("font.main" %in% nmdots) dots$font.main else par("font.main") cex.main <- if ("cex.main" %in% nmdots) dots$cex.main else par("cex.main") mtext(main, side=3, TRUE, line=5, outer = TRUE, at=NA, cex=cex.main, font=font.main, adj=0.5) }} invisible(out) } plot.SECdistrBv <- function(x, range, probs, npt=rep(101,2), compNames, compLabs, landmarks, data=NULL, data.par, main, ...) {# plot BiVariate SEC distribution obj <- x dp <- slot(obj, "dp") family <- slot(obj, "family") lc.family <- tolower(family) if(lc.family == "esn") lc.family <- "sn" d.fn <- get(paste("dm", lc.family, sep=""), inherits=TRUE) # density funct n1 <- npt[1] n2 <- npt[2] x1 <- seq(min(range[,1]), max(range[,1]), length=n1) x2 <- seq(min(range[,2]), max(range[,2]), length=n2) x1.x2 <- cbind(rep(x1, n2), as.vector(matrix(x2, n1, n2, byrow=TRUE))) X <- matrix(x1.x2, n1 * n2, 2, byrow = FALSE) pdf <- matrix(d.fn(X, dp=dp), n1, n2) Omega <- dp[[2]] Omega.bar <- cov2cor(Omega) alpha <- dp[[3]] alpha.star <- sqrt(sum(alpha * as.vector(Omega.bar %*% alpha))) omega <- sqrt(diag(Omega)) if(lc.family == "sn") { k.tau <- if (length(dp) == 4) (zeta(2,dp[[4]])*pi)^2/4 else 1 log.levels <- (log(1-probs) - log(2*pi)- 0.5*log(1-Omega.bar[1,2]^2) + k.tau * log(1+exp(-1.544/alpha.star))) - sum(log(omega)) } if(lc.family == "st" | lc.family == "sc") { nu <- if(lc.family == "st") obj@dp[[4]] else 1 l.nu <- (-1.3/nu - 4.93) if(alpha.star > 0) { h <- 100 * log(exp(((1.005*alpha.star-0.045)* l.nu -1.5)/alpha.star)+1) K <- h *(1.005*alpha.star-0.1)*(1+nu)/(alpha.star * nu) } else K <- 0 qF <- qf(probs, 2, nu) log.levels <- (lgamma(nu/2+1) -lgamma(nu/2) - log(pi*nu) -0.5*log(1-Omega.bar[1,2]^2) - (nu/2+1)*log(2*qF/nu + 1) + K -sum(log(omega))) } oo <- options() options(warn=-1) # contour(x1, x2, pdf, levels=exp(log.levels), # labels=paste("p=", as.character(probs), sep=""), # main=main, xlab=compLabs[1], ylab=compLabs[2], ...) plot(x1, x2, type="n", main=main, xlab=compLabs[1], ylab=compLabs[2], ...) if(!is.null(data)) { col <- if(!is.null(data.par$col)) data.par$col else par()$col pch <- if(!is.null(data.par$pch)) data.par$pch else par()$pch cex <- if(!is.null(data.par$cex)) data.par$cex else par()$cex points(data, col=col, pch=pch, cex=cex) if(!is.null(id.i <- data.par$id.i)) text(data[id.i,1], data[id.i,2], id.i, cex=cex/1.5, pos=1) } d.levels <- exp(log.levels) names(d.levels) <- as.character(probs) contour(x1, x2, pdf, levels=d.levels, labels=paste("p=", as.character(probs), sep=""), add=TRUE, ...) if(landmarks != "") { if(landmarks == "auto") { mean.type <- "proper" if(lc.family == "sc") mean.type <- "pseudo" if(lc.family == "st") { if(dp[[4]] <= 1) mean.type <- "pseudo"} } else mean.type <- landmarks landmarks.label <- c("origin", "mode", if(mean.type == "proper") "mean" else "mean~") cp <- dp2cpMv(dp, family, cp.type=mean.type, upto=1) mode <- modeSECdistrMv(dp, family) x.pts <- c(dp$xi[1], mode[1], cp[[1]][1]) y.pts <- c(dp$xi[2], mode[2], cp[[1]][2]) points(x.pts, y.pts, ...) text(x.pts, y.pts, landmarks.label, pos=2, offset=0.3, ...) lines(x.pts, y.pts, lty=2) } options(oo) cL <- contourLines(x1, x2, pdf, levels=d.levels) for(j in 1:length(probs)) cL[[j]]$prob <- probs[j] return(list(x=x1, y=x2, names=compNames, density=pdf, contourLines=cL)) } plot.selm <- function(x, param.type="CP", which = c(1:4), caption, panel = if (add.smooth) panel.smooth else points, main = "", # sub.caption = NULL, ask = prod(par("mfcol")) < length(which) && dev.interactive(), ..., id.n = 3, labels.id = names(x@residuals.dp), cex.id = 0.75, identline = TRUE, add.smooth = getOption("add.smooth"), label.pos = c(4, 2), cex.caption = 1) { if(class(x) != "selm") stop("object not of class 'selm'") show <- rep(FALSE, 4) show[which] <- TRUE dots <- list(...) nmdots <- names(dots) p <- slot(x, "size")["p"] if(missing(caption)) { caption <- if(p> 1) c("Residuals vs Fitted Values", "Residual values and fitted error distribution", "Q-Q plot of (scaled DP residuals)^2", "P-P plot of (scaled DP residuals)^2") else c("Boxplot of observed values", "Empirical values and fitted distribution", "Q-Q plot of (scaled DP residuals)^2", "P-P plot of (scaled DP residuals)^2")} all.par <- slot(x, "param") param.type <- tolower(param.type) param <- all.par[[param.type]] if(is.null(param)) { message(paste( "Requested param.type='", param.type, "' evaluates to NULL.", sep="")) if(param.type == "pseudo-cp" & x@family== "SN") message("Pseudo-CP makes no sense for SN family") if(param.type == "cp" & x@family== "SC") message("CP makes no sense for SC family") if(param.type == "cp" & x@family== "ST") message("CP of ST family requires nu>4") stop("Consider another choice of param.type (DP or pseudo-CP)") } r <- residuals(x, param.type) r.lab <- paste(toupper(param.type), "residuals") dp <- if(length(all.par$fixed) > 0) all.par$dp.complete else all.par$dp nu. <- switch(x@family, ST = dp[p+3], SN = Inf, SC=1) rs <- slot(x,"residuals.dp")/dp[p+1] rs2 <- rs^2 n <- slot(x, "size")["n.obs"] yh <- fitted(x, param.type) w <- weights(x) if (!is.null(w)) { wind <- (w != 0) r <- r[wind] yh <- yh[wind] w <- w[wind] labels.id <- labels.id[wind] } else w <- rep(1,n) rw <- n*w/slot(x,"size")["nw.obs"] cex.pts <- rw * if("cex" %in% nmdots) dots$cex else par("cex") if (is.null(id.n)) id.n <- 0 else { id.n <- as.integer(id.n) if (id.n < 0 || id.n > n) stop(gettextf("'id.n' must be in {1,..,%d}", n), domain = NA) } if (id.n > 0) { if (is.null(labels.id)) labels.id <- paste(1:n) iid <- 1:id.n # show.r <- sort.list(abs(r), decreasing = TRUE)[iid] show.rs <- sort.list(rs2, decreasing = TRUE)[iid] # rs2.lab <- paste("(scaled DP residuals)^2") text.id <- function(x, y, ind, adj.x = TRUE) { labpos <- if (adj.x) label.pos[1 + as.numeric(x > mean(range(x)))] else 3 text(x, y, labels.id[ind], cex = cex.id, xpd = TRUE, pos = labpos, offset = 0.25) } } one.fig <- prod(par("mfcol")) == 1 if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } if (show[1]) { if(all(is.na(r)) & p>1) message(paste("CP residuals not available;", "consider param.type='DP' or 'pseudo-CP'")) else { if(p == 1){ y <- (x@residuals.dp + x@fitted.values.dp) boxplot(y, plot=TRUE, col="gray85", border="gray60") } else { # p>1 # if (id.n > 0) # ylim <- extendrange(r = ylim, f = 0.08) ylim <- range(r, na.rm = TRUE) plot(yh, r, xlab = "Fitted values", ylab = r.lab, main = main, ylim = ylim, type = "n") panel(yh, r, ...) # previously it included 'cex=cex.pts' # if (one.fig) title(sub = sub.caption, ...) if (id.n > 0) { y.id <- r[show.rs] y.id[y.id < 0] <- y.id[y.id < 0] - strheight(" ")/3 text.id(yh[show.rs], y.id, show.rs) } abline(h = 0, lty = 2, col = "gray") } } mtext(caption[1], 3, 0.5, cex = cex.caption) } if (show[2]) { if(all(is.na(r)) & p>1) message( "CP residuals not available; consider param.type='DP' or 'pseudo-CP'") else { if (p == 1){ y <- (x@residuals.dp + x@fitted.values.dp) dp0 <- dp xlab="observed variable"} else { y <- r dp0 <- as.numeric(c(dp[1]-param[1], dp[-(1:p)])) xlab=r.lab } h <- hist(rep(y, w), plot=FALSE) extr <- extendrange(x=h$breaks) x.pts <- seq(max(extr), min(extr), length=501) d.fn <- get(paste("d", tolower(x@family), sep=""), inherits = TRUE) pdf <- d.fn(x.pts, dp=dp0) plot(c(h$mids, x.pts), c(h$density, pdf), type="n", main=main, xlab=xlab, ylab="probability density") hist(rep(y, w), col="gray95", border="gray60", probability=TRUE, freq=FALSE, add=TRUE) lines(x.pts, pdf, ...) rug(y, ticksize=0.02, ...) # if (id.n > 0) { rug(y, ticksize=0.015, ...) # text(y[show.rs], 0, labels.id[show.rs], srt=90, cex=0.5, pos=1, # offset=0.2) } mtext(caption[2], 3, 0.25, cex = cex.caption) }} if (show[3]) { ylim <- c(0, max(pretty(rs2))) q <- qf((1:n)/(n+1), 1, nu.) plot(q, sort(rs2), xlab="Theoretical values", ylab="Empirical values", ylim=ylim, type="p", main=main, ...) # cex=cex.pts if(identline) abline(0, 1, lty = 2, col = "gray50") # if (one.fig) title(sub = sub.caption, ...) mtext(caption[3], 3, 0.25, cex = cex.caption) if (id.n > 0) text.id(q[n+1-iid], rs2[show.rs], show.rs) } if (show[4]) { p <- (1:n)/(n+1) pr <- pf(sort(rs2), 1, nu.) plot(p, pr, xlab="Theoretical values", ylab="Empirical values", xlim=c(0,1), ylim=c(0,1), main=main, ...) # cex=cex.pts, if(identline) abline(0, 1, lty = 2, col = "gray50") # if (one.fig) title(sub = sub.caption, ...) mtext(caption[4], 3, 0.25, cex = cex.caption) if(identline) abline(0, 1, lty = 2, col = "gray50") if (id.n > 0) text.id(p[n+1-iid], pr[n+1-iid], show.rs) } # if (!one.fig && par("oma")[3] >= 1) # mtext(sub.caption, outer = TRUE, cex = 1.25) invisible() } print.summary.selm <- function(object) { obj <- object digits = max(3, getOption("digits") - 3) cat("Call: ") print(slot(obj, "call")) n <- obj@size["n.obs"] cat("Number of observations:", n, "\n") if(!is.null(slot(obj,"aux")$weights)) cat("Weighted number of observations:", obj@size["nw.obs"], "\n") show.family <- slot(obj,"family") cat("Family:", show.family,"\n") fixed <- slot(obj, "param.fixed") if(length(fixed) > 0) { fixed.char <- paste(names(fixed), format(fixed), sep=" = ", collapse=", ") cat("Fixed parameters:", fixed.char, "\n") } method <- slot(obj, "method") u <- if(length(method)==1) NULL else paste(", penalty function:", method[2]) cat("Estimation method: ", method[1], u, "\n", sep="") logL.name <- paste(if(method[1] == "MLE") "Log" else "Penalized log", "likelihood:", sep="-") cat(logL.name, format(slot(obj,"logL"), nsmall=2), "\n") param.type <- slot(obj, "param.type") cat("Parameter type:", param.type,"\n") if((note <- slot(object,"note")) != "") cat(paste("Note:", note, "\n")) if(obj@boundary) cat("Estimates on/near the boundary of the parameter space\n") resid <- slot(obj, "resid") if(n > 5) { nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- if (length(dim(resid)) == 2) structure(apply(t(resid), 1, quantile), dimnames = list(nam, dimnames(resid)[[2]])) else structure(quantile(resid), names = nam) cat("\n", param.type, " residuals:\n", sep="") print(rq, digits = digits) } param <- slot(obj,"param.table") p <- obj@size["p"] cat("\nRegression coefficients\n") printCoefmat(param[1:p, ,drop=FALSE], digits = digits, signif.stars = getOption("show.signif.stars"), na.print = "NA") cat("\nParameters of the SEC random component\n") printCoefmat(param[(p+1):nrow(param), 1:2, drop=FALSE], digits = digits, signif.stars = FALSE, na.print = "NA") if(!is.null(obj@aux$param.cor)) { cat("\nCorrelations of parameter estimates:\n") print(obj@aux$param.cor) } if(!is.null(obj@aux$param.cov)) { cat("\nCovariances of parameter estimates:\n") print(obj@aux$param.cov) } invisible(object) } plot.mselm <- function (x, param.type="CP", which, caption, panel = if (add.smooth) panel.smooth else points, main = "", # sub.caption = NULL, ask = prod(par("mfcol")) < length(which) && dev.interactive(), ..., id.n = 3, labels.id = names(x@residuals.dp), cex.id = 0.75, identline = TRUE, add.smooth = getOption("add.smooth"), label.pos = c(4, 2), cex.caption = 1) { p <- slot(x,"size")["p"] if(missing(which)) which <- if(p == 1) c(1,3,4) else 2:4 show <- rep(FALSE, 4) show[which] <- TRUE if(missing(caption)) caption <- c("Observed values and fitted distribution", paste("Distribution of", param.type, "residual values"), "Q-Q plot of Mahalanobis distances", "P-P plot of Mahalanobis distances") if(!show[2]) param.type <- "DP" # CP-residuals only used for show[2] param.type <- tolower(param.type) all.par <- slot(x, "param") param <- all.par[[param.type]] dots <- list(...) if(is.null(param)) { message(paste( "Requested param.type='", param.type, "' evaluates to NULL.", sep="")) if(param.type == "pseudo-cp" & x@family== "SN") message("Pseudo-CP makes no sense for SN family") if(param.type == "cp" & x@family== "SC") message("CP makes no sense for SC family") if(param.type == "cp" & x@family== "ST") message("CP of ST family requires nu>4") stop("Consider another choice of param.type") } r <- residuals(x, param.type) r.lab <- paste(toupper(param.type), "residuals") # family <- x@family dp <- if(length(all.par$fixed) > 0) all.par$dp.complete else all.par$dp cp <- dp2cpMv(dp, family=x@family, cp.type="auto") nu. <- switch(x@family, ST = dp$nu, SN = Inf, SC=1) n <- slot(x,"size")["n.obs"] d <- x@size["d"] yh <- fitted(x, param.type) w <- weights(x) if (!is.null(w)) { wind <- w != 0 r <- r[wind] yh <- yh[wind] w <- w[wind] labels.id <- labels.id[wind] } else w <- rep(1,n) rw <- n*w/slot(x,"size")["nw.obs"] if (is.null(id.n)) id.n <- 0 else { id.n <- as.integer(id.n) if (id.n < 0 || id.n > n) stop(gettextf("'id.n' must be in {1,..,%d}", n), domain = NA) } Omega.inv <- pd.solve(dp$Omega, silent=TRUE) r.dp <- t(slot(x, "residuals.dp")) rs2 <- colSums((Omega.inv %*% r.dp) * r.dp) if (id.n > 0) { if (is.null(labels.id)) labels.id <- paste(1:n) iid <- 1:id.n show.r <- sort.list(abs(r), decreasing = TRUE)[iid] show.rs <- sort.list(rs2, decreasing = TRUE)[iid] text.id <- function(x, y, ind, adj.x = TRUE) { labpos <- if (adj.x) label.pos[1 + as.numeric(x > mean(range(x)))] else 3 text(x, y, labels.id[ind], cex = cex.id, xpd = TRUE, pos = labpos, offset = 0.25) } } else show.rs <- NULL one.fig <- prod(par("mfcol")) == 1 if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } if (show[1]) { # data scatter matrix and fitted curves (only if p=1) if(p == 1) { y <- (x@residuals.dp + x@fitted.values.dp) fitted.distr <- makeSECdistr(dp, family=x@family, name="fitted distribution", compNames=colnames(x@param$dp[[1]])) data.par <- list(col=dots$col, pch=dots$pch, cex=dots$cex, id.i=show.rs) plot(fitted.distr, landmarks="", data=y, main=main, data.par=data.par, ...) # previously it included cex=sqrt(rw) # text.id(..) se d=1, ma se d>1 si deve fare per ogni pannello (?!) mtext(caption[1], 3, 1.5, cex = cex.caption) } else message(paste("plot of (observed data, fitted distribution)", "makes no sense if covariates 'x' exist", "and fitted distribution varies with 'x'")) } if (show[2]) { # scatter matrix of residuals and fitted curves dp0 <- dp dp0[[1]] <- as.numeric((dp[[1]]-param[[1]])[1,]) data.par <- list(col=dots$col, pch=dots$pch, cex=dots$cex, id.i=show.rs) resid.distr <- makeSECdistr(dp0, family=x@family, name="Residual distribution", compNames=colnames(x@residuals.dp)) plot(resid.distr, landmarks="", data=residuals(x, param.type), main=main, data.par=data.par) # mtext(caption[2], 3, 0.25, cex = cex.caption) mtext(caption[2], 3, 1.5, cex = cex.caption) } if (show[3]) { # QQ-plot # ylim <- c(0, max(pretty(rs2))) q <- qf((1:n)/(n+1), d, nu.) * d plot(q, sort(rs2), xlab="theoretical values", ylab="empirical values", main=main, ...) # cex=sqrt(rw) now dropped if(identline) abline(0, 1, lty = 2, col = "gray70") # if (one.fig) title(sub = sub.caption, ...) mtext(caption[3], 3, 0.25, cex = cex.caption) if (id.n > 0) text.id(q[n+1-iid], rs2[show.rs], show.rs) } if (show[4]) { # PP-plot p <- pf(rs2/d, d, nu.) p0 <- (1:n)/(n+1) plot(p0, sort(p), xlab="theoretical values", ylab="empirical values", xlim=c(0,1), ylim=c(0,1), main=main, ...) # cex=sqrt(rw) now dropped if(identline) abline(0, 1, lty = 2, col = "gray70") # if (one.fig) title(sub = sub.caption, ...) mtext(caption[4], 3, 0.25, cex = cex.caption) if (id.n > 0) text.id(p[show.rs], p0[n+1-iid], show.rs) } # if (!one.fig && par("oma")[3] >= 1) # mtext(sub.caption, outer = TRUE, cex = 1.25) invisible() } print.summary.mselm <- function(object) { obj <- object digits = max(3, getOption("digits") - 3) # cat("Obj: ", deparse(substitute(obj)),"\n") cat("Call: ") print(slot(obj,"call")) n <- obj@size["n.obs"] d <- obj@size["d"] # p <- obj@size["p"] cat("Number of observations:", n, "\n") nw <- obj@size["nw.obs"] if(n != nw) cat("Weighted number of observations:", nw, "\n") family <- slot(obj, "family") cat("Family:", family, "\n") method <- slot(object, "method") u <- if(length(method)==1) NULL else paste(", penalty function:", method[2]) cat("Estimation method: ", method[1], u, "\n", sep="") fixed <- slot(obj, "param.fixed") if(length(fixed) > 0) {fixed.char <- paste(names(fixed), format(fixed), sep=" = ", collapse=", ") cat("Fixed parameters:", fixed.char, "\n") } cat("Log-likelihood:", format(slot(obj,"logL"), nsmall=2), "\n") cat("Parameter type:", obj@param.type,"\n") if(obj@boundary) cat("Estimates on/near the boundary of the parameter space\n") names <- dimnames(obj@scatter$matrix)[[1]] for(j in 1:d) { param <- obj@coef.tables[[j]] cat("\n--- Response variable No.", j, ": ", names[j],"\n",sep="") resid <- obj@resid[,j] if(n>5) { nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- if (length(dim(resid)) == 2) structure(apply(t(resid), 1, quantile), dimnames = list(nam, dimnames(resid)[[2]])) else structure(quantile(resid), names = nam) cat(obj@param.type, "residuals\n") print(rq, digits = digits) } cat("\nRegression coefficients\n") printCoefmat(param[, ,drop=FALSE], digits = digits, signif.stars = getOption("show.signif.stars"), na.print = "NA") } cat("\n--- Parameters of the SEC random component\n") cat("Scatter matrix: ", obj@scatter$name,"\n", sep="") print(obj@scatter$matrix) if(length(obj@slant) > 0) { cat("\nSlant parameter: ", obj@slant$name, "\n", sep="") print(cbind(estimate=obj@slant$param, std.err=obj@slant$se)) } if(length(obj@tail) > 0) { cat("\nTail-weight parameter: ", obj@tail$name, "\n", sep="") print(c(estimate=obj@tail$param, std.err=obj@tail$se)) } if(!is.null(obj@aux$param.cor)) { cat("\nCorrelations of parameter estimates:\n") print(obj@aux$param.cor) } if(!is.null(obj@aux$param.cov)) { cat("\nVar-covariance matrix of parameter estimates:\n") print(obj@aux$param.cov) } } dp2op <- function(dp, family) { nt <- switch(tolower(family), "sn" = 3, "esn" = 4, "st" = 4, "sc" = 3, NULL) if(is.null(nt)) stop("unknown family") op <- dp if (is.list(dp)) { # multivariate case if(length(dp) != nt) stop("wrong length of 'dp'") Omega <- dp[[2]] alpha <- dp[[3]] d <- length(alpha) tmp <- delta.etc(alpha, Omega) delta <- tmp$delta Omega.cor <- tmp$Omega.cor D.delta <- sqrt(1 - delta^2) # (5.18) of SN book, but as vector lambda <- delta/D.delta # (5.20) omega <- sqrt(diag(as.matrix(Omega))) Psi <- Omega - outer(omega*delta, omega*delta) # four lines before (5.30) op[[2]] <- Psi op[[3]] <- lambda names(op)[2:3] <- c("Psi", "lambda") } else { # univariate case p <- length(dp) - nt + 1 if(p < 1) stop("wrong length of 'dp'") delta <- delta.etc(dp[p+2]) op[p+1] <- dp[p+1] * sqrt(1 - delta^2) names(op)[(p+1):(p+2)] <- c("psi", "lambda") } op } op2dp <- function(op, family) { nt <- switch(tolower(family), "sn" = 3, "esn" = 4, "st" = 4, "sc" = 3, NULL) if(is.null(nt)) stop("unknown family") dp <- op if(is.list(op)) { # multivariate case if(length(op) != nt) stop("wrong length of 'op'") Psi <- op[[2]] psi <- sqrt(diag(Psi)) lambda <- op[[3]] delta <- lambda/sqrt(1 + lambda^2) D.delta <- sqrt(1 - delta^2) Psi.bar <- cov2cor(Psi) omega <- psi/D.delta tmp <- as.vector(pd.solve(Psi.bar) %*% lambda) dp[[2]] <- Psi + outer(psi*lambda, psi*lambda) # four lines before (5.30) dp[[3]] <- (tmp/D.delta)/sqrt(1 + sum(lambda*tmp)) # (5.22) names(dp)[2:3] <- c("Omega", "alpha") } else { # univariate case p <- length(op) - nt + 1 if(p < 1) stop("wrong length of 'dp'") delta <- delta.etc(dp[p+2]) dp[p+1] <- op[p+1]/sqrt(1 - delta^2) names(dp)[(p+1):(p+2)] <- c("omega", "alpha") } dp } coef.selm <- function(object, param.type="CP", ...) { param <- slot(object,"param")[[tolower(param.type)]] if(is.null(param) & tolower(param.type)=="cp") { message("CP not defined, consider param.type='DP' or 'pseudo-CP'") return(NULL)} param} coef.mselm <- function(object, param.type="CP", vector=TRUE, ...) { list <- slot(object,"param")[[tolower(param.type)]] if(is.null(list) & tolower(param.type)=="cp") { message("CP not defined, consider param.type='DP' or 'pseudo-CP'") return(NULL)} if(!vector) return(list) as.vector(c(list[[1]], vech(list[[2]]), unlist(list[3:length(list)]))) } extractSECdistr <- function(object, name, compNames) { obj.class <- class(object) if(!(obj.class %in% c("selm", "mselm"))) stop(gettextf("wrong object class: '%s'", obj.class), domain = NA) param <- slot(object, "param") dp <- if(length(param$dp.complete) > 0) param$dp.complete else param$dp p <- slot(object, "size")[2] if(obj.class == "selm") { lead <- if(p > 1) 0 else dp[1] dp0 <- c(lead, dp[-(1:p)]) names(dp0)[1] <- "xi" } else { # class = "mselm" dp0 <- dp names(dp0)[1] <- "xi" dp0[[1]] <- if(p == 1) as.vector(dp0[[1]]) else rep(0, slot(object, "size")[1]) } if((obj.class == "mselm") & missing(compNames)) compNames <- names(dp$alpha) if(missing(name)) { name <- paste("SEC distribution of", deparse(substitute(object))) name <- if(p > 1) paste("Residual", name) else paste("Fitted", name) } if(obj.class == "selm") new("SECdistrUv", dp=dp0, family=slot(object, "family"), name=name) else new("SECdistrMv", dp=dp0, family=slot(object, "family"), name=name, compNames=compNames) } # introduce sd generic function, in the same fashion of package circular # sd <- function(x, ...) UseMethod("sd") sd.default <- function(x, na.rm = FALSE, ...) stats::sd(x=x, na.rm=na.rm) mean.SECdistrUv <- function(x) dp2cp(object=x, upto=1) mean.SECdistrMv <- function(x) dp2cp(object=x, upto=1)[[1]] sd.SECdistrUv <- function(x) dp2cp(object=x, upto=2)[2] vcov.SECdistrMv <- function(object) dp2cp(object=object, upto=2)[[2]] #--- # profile.selm <- function(fitted, param.type, param.name, param.values, npt, opt.control=list(), plot.it=TRUE, log=TRUE, level, trace=FALSE, ...) { obj <- fitted obj.class <- class(obj) if(obj.class != "selm" | attr(obj.class, "package") != "sn") stop(gettextf("wrong object class: '%s'", obj.class), domain = NA) param.type <- match.arg(toupper(param.type), c("DP", "CP")) family <- slot(obj, "family") obj.par <- slot(obj, "param") dp.full <- if(length(obj.par$fixed)==0) obj.par$dp else obj.par$dp.complete if(param.type == "CP") { cp.full <- mle.full <- dp2cpUv(dp.full, family) profile.comp <- match(param.name, names(cp.full)) } else { mle.full <- dp.full profile.comp <- match(param.name, names(dp.full)) } fixed.names <- setdiff(names(obj.par$dp.complete), names(obj.par$dp)) if(length(fixed.names) > 0) { fixed.comp <- match(fixed.names, names(dp.full)) fixed.values <- mle.full[fixed.comp] } else fixed.comp <- fixed.values <- NULL clash <- intersect(fixed.comp, profile.comp) if(length(clash) > 0) stop(paste("parameter component No.", clash, "is fixed in the model, it cannot be profiled")) p <- slot(obj, "size")["p"] method <- slot(obj, "method") penalty <- if(method[1] == "MPLE") method[2] else NULL constr.comp <- c(profile.comp, fixed.comp) free.comp <- setdiff(1:length(dp.full), constr.comp) if(anyNA(profile.comp)) stop("some wrong item in param.name") npc <- length(profile.comp) # number of terms in profile.comp (either 1 or 2) if((npc != 1) && (npc != 2)) stop("wrong length(param.name)") if(missing(npt)) npt <- rep((50+npc) %/% npc, npc) else if(length(npt) != npc) npt <- rep(npt[1], npc) log.comp <- if(!log) rep(NA, npc) else { if(param.type == "DP") match(c("omega", "nu"), param.name, NULL) else match(c("s.d.", "gamma2"), param.name, NULL) } logScale <- (1:2) %in% which(!is.na(log.comp)) m <- slot(obj,"input")$model x <- model.matrix(attr(m, "terms"), data=m) w <- slot(obj, "input")$model$"(weights)" weights <- if(is.null(w)) rep(1, nrow(x)) else w opt.control$fnscale <- (-1) par.val <- param.values if(npc == 1) { # one-parameter profile logLik par.val <- as.vector(par.val) if(any(diff(par.val) <= 0)) stop("param.values not an increasing sequence") if(prod(range(par.val) - mle.full[profile.comp]) > 0) stop(gettextf("param range does not bracket the MLE/MPLE point: '%s'"), format(mle.full[profile.comp]), domain=NA) logScale <- logScale[1] if(length(par.val) > 2) npt <- length(par.val) else par.val <- seqLog(par.val[1], par.val[2], length=npt, logScale) logL <- numeric(npt) for(k in 1:npt) { constr.values <- c(par.val[k], fixed.values) free.values <- mle.full[-constr.comp] opt <- optim(free.values, constrained.logLik, method="BFGS", control=opt.control, param.type=param.type, x=x, y=m[[1]], weights=weights, family=family, constr.comp=constr.comp, constr.values=constr.values, penalty=penalty, trace=trace) logL[k] <- opt$value } out <- list(call=match.call(), param=par.val, logLik=logL) names(out)[2] <- param.name deviance <- 2*(logLik(obj) - logL) if(any(deviance + sqrt(.Machine$double.eps) < 0)) warning(paste( "A relative maximum of the (penalized) likelihood seems to have been", "taken as\n the MLE (or MPLE).", "Re-fit the model with starting values suggested by the plot.")) s <- diff((sign(diff(deviance)))) if(length(which(s != 0)) > 1) { message(paste("The log-likelihood function appears to have multiple", "maxima.\n", "Confidence intervals may be handled improperly.\n")) # readline("Press to continue") # browser() } if(missing(level)) level <- 0.95 level <- level[1] if(is.na(level) | level <= 0 | level >= 1) { message("illegal level value is reset to default value") level <- 0.95 } if(obj.par$boundary) { message("parameter estimates at the boundary, no confidence interval") level <- NULL } if(!is.null(level)) { q <- qchisq(level[1], 1) if(deviance[1] < q | deviance[npt] < q) warning( "parameter range seems short; confidence interval may be inaccurate") dev.fn <- splinefun(par.val, deviance - q, method="monoH.FC") rootL <- try(uniroot(dev.fn, lower=min(par.val), check.conv=TRUE, upper=mle.full[profile.comp], extendInt="downX")) rootH <- try(uniroot(dev.fn, lower=mle.full[profile.comp], upper=max(par.val), check.conv=TRUE, extendInt="upX")) fail.confint <- (class(rootL)=="try-error" | class(rootH)=="try-error") out$confint <- if(fail.confint) rep(NULL,2) else c(rootL$root, rootH$root) out$level <- level } if(plot.it) { if(logScale) { par.val <- log(par.val) param.name <- paste("log(", param.name, ")", sep="") } plot(par.val, deviance, type="l", xlab=param.name, ylab="2*{max(logLik) - logLik}", ...) if(logScale) { rug(log(mle.full[profile.comp]), ticksize = 0.02) if(is.null(level) | fail.confint) low <- hi <- NULL else { low <- log(rootL$root) hi <- log(rootH$root) }} else { rug(mle.full[profile.comp], ticksize = 0.02) if(is.null(level)| fail.confint) low <- hi <- NULL else { low <- rootL$root hi <- rootH$root }} if(!is.null(level) & !fail.confint) { abline(h=q, lty=3, ...) lines(rep(low, 2), c(par()$usr[3], q), lty=3, ...) lines(rep(hi, 2), c(par()$usr[3], q), lty=3, ...) } } } else { # npc==2, two-parameter profile logLik if(length(par.val) != 2) stop("wrong dimension of param.values") u <- unlist(lapply(par.val, length)) param1 <- par.val[[1]] param2 <- par.val[[2]] if(prod(range(param1) - mle.full[profile.comp][1]) > 0 | prod(range(param2) - mle.full[profile.comp][2]) > 0) stop( gettextf("parameter range does not bracket the MLE/MPLE point: '%s'", paste(format(mle.full[profile.comp]), collapse=",")), domain=NA) if(u[1] > 2) npt[1] <- u[1] else param1 <- seqLog(param1[1], param1[2], length=npt[1], logScale[1]) if(u[2] > 2) npt[2] <- u[2] else param2 <- seqLog(param2[1], param2[2], length=npt[2], logScale[2]) logL <- matrix(NA, npt[1], npt[2]) if(any(diff(param1) <= 0)) stop("param.values[[1]] not an increasing sequence") if(any(diff(param2) <= 0)) stop("param.values[[2]] not an increasing sequence") for(k1 in 1:npt[1]) for(k2 in 1:npt[2]){ constr.values <- c(param1[k1], param2[k2], fixed.values) free.values <- mle.full[-constr.comp] opt <- optim(free.values, constrained.logLik, method="BFGS", control=opt.control, param.type=param.type, x=x, y=m[[1]], weights=weights, family=family, constr.comp=constr.comp, constr.values=constr.values, penalty=penalty, trace=trace) logL[k1,k2] <- opt$value } out <- list(call=match.call(), param1=param1, param2=param2, logLik=logL) names(out)[2:3] <- param.name if(missing(level)) level <- c(0.25, 0.5, 0.75, 0.9, 0.95, 0.99) if(anyNA(level) | any(level<=0) | any(level>=1)) { message("illegal level values; vector 'level' reset to default value") level <- c(0.25, 0.5, 0.75, 0.9, 0.95, 0.99) } if(obj.par$boundary) { message("parameter estimates at the boundary, no confidence regions") level <- NULL } q <- if(is.null(level)) c(1, 2, 5, 8, 15) else qchisq(level, 2) deviance <- 2*(logLik(obj)-logL) if(any(deviance + sqrt(.Machine$double.eps) < 0)) warning(paste( "A relative maximum of the (penalized) likelihood seems to have taken", "as\n the MLE (or MPLE).", "Re-fit the model with starting values suggested by the plot.")) cL <- contourLines(param1, param2, deviance, levels=q) out$deviance.contour <- cL if(!is.null(level)) for(j in 1:length(cL)) { k <- which(q == cL[[j]]$level) out$deviance.contour[[j]]$prob <- level[k] } if(plot.it) { if(logScale[1]) { param1 <- log(param1) param.name[1] <- paste("log(", param.name[1], ")", sep="") } if(logScale[2]) { param2 <- log(param2) param.name[2] <- paste("log(", param.name[2], ")", sep="") } contour(param1, param2, deviance, levels=q, labels=level, xlab=param.name[1], ylab=param.name[2], ...) mark <- mle.full[profile.comp] mark[logScale] <- log(mark[logScale]) points(mark[1], mark[2], ...) } } invisible(out) } constrained.logLik <- function(free.param, param.type, x, y, weights, family, constr.comp=NA, constr.values=NA, penalty=NULL, trace=FALSE) { if(trace) cat("constrained.logLik, free.param:", format(free.param)) n <- sum(weights) p <- ncol(x) param <- numeric(length(free.param) + length(constr.values)) param[constr.comp] <- constr.values param[-constr.comp] <- free.param par0 <- c(0, param[-(1:p)]) # if(par0[2] <= 0) return(-Inf) # if(family=="ST" & par0[4] <= 0) return(-Inf) # if(family=="ST" & par0[4] > 1e4) par0[4] <- Inf dp0 <- if(param.type =="DP") par0 else cp2dpUv(par0, family, tol=1e-7, silent=TRUE) if(anyNA(dp0)) { if(is.null(dp0)) {message("null dp0"); browser()} excess <- attr(dp0, "excess") if(length(excess) == 0) {message("0-length excess"); browser() } if(is.null(excess) | is.na(excess) | abs(excess)==Inf ) excess <- (.Machine$double.xmax)^(1/3) # {message("bad excess"); browser()} return(-1e9 * (1+ excess)^2) } d.fn <- get(paste("d", tolower(family), sep=""), inherits = TRUE) logL <- try(d.fn((y - x %*% param[1:p]), dp=dp0, log=TRUE)) if(class(logL) == "try-error") browser() Q <- if(is.null(penalty)) 0 else { penalty.fn <- get(penalty, inherits = TRUE) nu <- if(family=="ST") par0[4] else NULL penalty.fn(dp0[3], nu) } out <- if(anyNA(logL)) -Inf else sum(logL * weights) - Q if(trace) cat(", logL:", format(out), "\n") return(out) } seqLog <- function(from, to, length, logScale=FALSE) { if(logScale & any(c(from, to) <= 0)) stop("logScale requires positive arguments 'from' and 'to'") if(logScale) exp(seq(log(from), log(to), length.out=length)) else seq(from, to, length.out=length) } sn/R/sn_S4.R0000644000176200001440000003521512516746564012232 0ustar liggesusers# file sn/R/sn_S4.R (S4 methods and classes) # This file is a component of the package 'sn' for R # copyright (C) 1997-2014 Adelchi Azzalini # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 or 3 of the License # (at your option). # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # http://www.r-project.org/Licenses/ #--------- setClass("SECdistrUv", representation(family="character", dp="numeric", name="character"), validity=function(object){ if(!(object@family %in% c("SN","ST","SC","ESN"))) return(FALSE) np <- 3 + as.numeric(object@family %in% c("ST","ESN")) if(length(object@dp) != np) return(FALSE) if(object@dp[2] <= 0) return(FALSE) TRUE } ) setClass("summary.SECdistrUv", representation(family="character", dp="numeric", name="character", cp="numeric", cp.type="character", aux="list"), validity=function(object){ if(!(object@family %in% c("SN","ST","SC","ESN"))) return(FALSE) np <- 3 + as.numeric(object@family %in% c("ST","ESN")) if(length(object@dp) != np) return(FALSE) if(object@dp[2] <= 0) return(FALSE) # if(length(object@op) != length(object@dp)) return(FALSE) if(length(object@cp) != length(object@dp)) return(FALSE) TRUE } ) setClass("SECdistrMv", representation(family="character", dp="list", name="character", compNames="character"), validity=function(object){ if(!(object@family %in% c("SN","ST","SC","ESN"))) return(FALSE) np <- 3 + as.numeric(object@family %in% c("ST","ESN")) dp <- object@dp if(mode(unlist(dp)) != "numeric") return(FALSE) if(length(dp) != np) return(FALSE) d <- length(dp[[3]]) Omega <- dp[[2]] if(length(dp[[1]]) != d | any(dim(Omega) != c(d,d))) return(FALSE) if(any(Omega != t(Omega))) {message("non-symmetric Omega"); return(FALSE)} if(any(eigen(Omega, symmetric=TRUE, only.values=TRUE)$values <= 0)) { message("Omega not positive-definite") return(FALSE)} if(object@family == "ST") { if(dp[[4]] <= 0) return(FALSE) } if(length(object@compNames) != d) return(FALSE) if(length(object@name) != 1) return(FALSE) TRUE } ) setClass("summary.SECdistrMv", representation(family="character", dp="list", name="character", compNames="character", # op="list", cp="list", cp.type="character", aux="list"), validity=function(object){ family <- object@family if(!(family %in% c("SN","ST","SC","ESN"))) return(FALSE) np <- 3 + as.numeric(family %in% c("ST","ESN")) dp <- object@dp if(mode(unlist(dp)) != "numeric") return(FALSE) if(length(dp) != np) return(FALSE) d <- length(dp[[3]]) if(length(dp[[1]]) != d | any(dim(dp[[2]]) != c(d,d))) return(FALSE) if(family == "ST") { if(dp[[4]] <= 0) return(FALSE) } if(length(object@compNames) != d) return(FALSE) if(length(object@name) != 1) return(FALSE) if(length(object@cp) != length(object@dp)) return(FALSE) # if(length(object@op) != length(object@dp)) return(FALSE) TRUE } ) setMethod("show", "SECdistrUv", function(object){ if(object@name != "") cat("Probability distribution of variable '", object@name, "'\n", sep="") cat("Skew-elliptically contoured distribution of univariate family", object@family,"\nDirect parameters:\n") print(object@dp) } ) setMethod("show","SECdistrMv", function(object){ if(object@name != "") cat("Probability distribution of variable '", object@name, "'\n", sep="") dp <- object@dp attr(dp[[2]],"dimnames") <- list(paste("Omega[", object@compNames, ",]", sep=""), NULL) cat("Skew-elliptically contoured distribution of ", length(dp[[3]]), "-dimensional family ", object@family,"\nDirect parameters:\n", sep="") out <- rbind(xi=dp[[1]], Omega=dp[[2]], alpha=dp[[3]]) colnames(out) <- object@compNames print(out) if(object@family=="ST") cat("nu", "=", dp[[4]], "\n") if(object@family=="ESN") cat("tau", "=", dp[[4]], "\n") } ) # #-------------------- setMethod("show", "summary.SECdistrUv", function(object){ obj <- object if(obj@name != "") cat("Probability distribution of variable '", obj@name, "'\n", sep="") cat("\nSkew-elliptical distribution of univariate family", obj@family,"\n") cat("\nDirect parameters (DP):\n") print(c("", format(obj@dp)), quote=FALSE) # cat("\nOriginal parameters (OP):\n") # print(c("", format(obj@op)), quote=FALSE) cp <- obj@cp note <- if(obj@cp.type == "proper") NULL else ", type=pseudo-CP" cat(paste("\nCentred parameters (CP)", note, ":\n", sep="")) print(c("", format(cp)), quote=FALSE) cat("\nAuxiliary quantities:\n") print(c("", format(c(delta=obj@aux$delta, mode=obj@aux$mode))), quote=FALSE) cat("\nQuantiles:\n") q <- obj@aux$quantiles q0 <- c("q", format(q)) names(q0) <- c("p", names(q)) print(q0, quote=FALSE) measures <- rbind(obj@aux$std.cum, obj@aux$q.measures) cat("\nMeasures of skewness and kurtosis:\n ") attr(measures, "dimnames") <- list( c(" std cumulants", " quantile-based"), c("skewness", "kurtosis")) print(measures) } ) setMethod("show","summary.SECdistrMv", function(object){ obj <- object #------ DP dp <- obj@dp if(obj@name != "") cat("Probability distribution of",obj@name,"\n") cat("Skew-elliptically contoured distribution of ", length(dp[[3]]), "-dimensional family ", obj@family,"\n", sep="") cat("\nDirect parameters (DP):\n") attr(dp[[2]], "dimnames") <- list(paste(" Omega[", obj@compNames, ",]", sep=""),NULL) out.dp <- rbind(" xi"=dp[[1]], omega=dp[[2]]," alpha"=dp[[3]]) colnames(out.dp) <- obj@compNames print(out.dp) if(length(dp) > 3){ extra <- unlist(dp[-(1:3)]) names(extra) <- paste(" ",names(dp[-(1:3)]), sep="") # print(extra) for(j in 1:length(extra)) cat(names(extra)[j], "=", extra[j], "\n") } #------ OP if(FALSE) { op <- obj@op cat("\nOriginal parameters (OP):\n") attr(op[[2]], "dimnames") <- list(paste(" Psi[", obj@compNames, ",]", sep=""),NULL) out.op <- rbind(" xi"=op[[1]], " psi"=op[[2]]," lambda"=op[[3]]) colnames(out.op) <- obj@compNames print(out.op) if(length(op) > 3){ extra <- unlist(op[-(1:3)]) names(extra) <- paste(" ",names(op[-(1:3)]), sep="") # print(extra) for(j in 1:length(extra)) cat(names(extra)[j], "=", extra[j], "\n") } } #------ CP cp <- obj@cp note <- if(obj@cp.type == "proper") NULL else ", type=pseudo-CP" cat("\nCentred parameters (CP)", note, ":\n", sep="") attr(cp[[2]], "dimnames") <- list(paste(" var.cov[", obj@compNames, ",]", sep=""),NULL) out.cp <- rbind(" mean"=cp[[1]], cp[[2]], " gamma1"=cp[[3]]) colnames(out.cp) <- obj@compNames print(out.cp) if(length(cp) > 3) { extra <- unlist(cp[-(1:3)]) names(extra) <- paste(" ", names(cp[-(1:3)]), sep="") for(j in 1:length(extra)) cat(names(extra)[j], "=", extra[j], "\n") } aux <- obj@aux out.aux <- rbind(" delta" = aux$delta, " mode" = aux$mode) #" lambda"=aux$lambda, colnames(out.aux) <- obj@compNames cat("\nAuxiliary quantities:\n") print(out.aux) cat("\nGlobal quantities:\n") cat(" alpha* =", format(aux$alpha.star), ", delta* =", format(aux$delta.star), "\n") mardia <- obj@aux$mardia cat(" Mardia's measures: gamma1M = ", format(mardia[1]), ", gamma2M = ", format(mardia[2]),"\n", sep="") invisible() } ) setClass("selm", representation(call="call", family="character", logL="numeric", method="character", param="list", param.var="list", size="vector", fixed.param="vector", residuals.dp="numeric", fitted.values.dp="numeric", control="list", input="list", opt.method="list"), validity=function(object){ if(class(object) != "selm") return(FALSE) if(!is.numeric(object@logL)) return(FALSE) if(!(object@family %in% c("SN","ST","SC","ESN"))) return(FALSE) if(!is.vector(object@param$dp)) return(FALSE) TRUE } ) setMethod("coef", "selm", coef.selm) setMethod("logLik", "selm", function(object){ logL <- slot(object,"logL") attr(logL, "df") <- as.numeric(slot(object, "size")["n.param"]) class(logL) <- "logLik" return(logL) } ) setMethod("vcov", "selm", function(object, param.type="CP") { vcov <- slot(object, "param.var")[[tolower(param.type)]] if(is.null(vcov) & tolower(param.type) == "cp") { message("CP not defined, consider param.type='DP' or 'pseudo-CP'") return(NULL)} vcov} ) setMethod("show", "selm", function(object){ # cat("Object: ", deparse(substitute(obj)),"\n") cat("Object class:", class(object), "\n") cat("Call: ") print(object@call) cat("Number of observations:", object@size["n.obs"], "\n") if(!is.null(slot(object,"input")$weights)) cat("Weighted number of observations:", object@size["nw.obs"], "\n") cat("Number of covariates:", object@size["p"], "(includes constant term)\n") cat("Number of parameters:", object@size["n.param"], "\n") cat("Family:", slot(object,"family"),"\n") fixed <- slot(object, "param")$fixed if(length(fixed) > 0) { fixed.char <- paste(names(fixed), format(fixed), sep=" = ", collapse=", ") cat("Fixed parameters:", fixed.char, "\n") } method <- slot(object, "method") u <- if(length(method)==1) NULL else paste(", penalty function:", method[2]) cat("Estimation method: ", method[1], u, "\n", sep="") logL.name <- paste(if(method[1]=="MLE") "Log" else "Penalized log", "likelihood:", sep="-") cat(logL.name, format(object@logL, nsmall=2),"\n") if(object@param$boundary) cat("Estimates on/near the boundary of the parameter space\n") invisible(object) } ) #---------------------------------------------------------- setClass("summary.selm", representation(call="call", family="character", logL="numeric", method="character", param.type="character", param.table="matrix", param.fixed="list", resid="numeric", control="list", aux="list", size="vector", boundary="logical", note="character"), validity=function(object){ if(!(object@family %in% c("SN","ST","SC","ESN"))) return(FALSE) TRUE } ) #---------------------------------------------------------- setClass("mselm", representation(call="call", family="character", logL="numeric", method="character", param="list", param.var="list", size="vector", residuals.dp="matrix", fitted.values.dp="matrix", control="list", input="list", opt.method="list"), validity=function(object){ if(class(object) != "mselm") return(FALSE) if(!is.numeric(object@logL)) return(FALSE) if(!(object@family %in% c("SN","ST","SC","ESN"))) return(FALSE) if(!is.list(object@param$dp)) return(FALSE) TRUE } ) setMethod("coef", "mselm", coef.mselm) setMethod("logLik", "mselm", function(object){ logL <- slot(object,"logL") attr(logL, "df") <- as.numeric(slot(object, "size")["n.param"]) class(logL) <- "logLik" return(logL) } ) setMethod("vcov", "mselm", function(object, param.type="CP") { vcov <- slot(object,"param.var")[[tolower(param.type)]] if(is.null(vcov) & tolower(param.type) == "cp") { message("CP not defined, consider param.type='DP' or 'pseudo-CP'") return(NULL)} vcov} ) setMethod("show", "mselm", function(object){ cat("Object class:", class(object), "\n") cat("Call: ") print(object@call) cat("Number of observations:", object@size["n.obs"], "\n") if(!is.null(slot(object,"input")$weights)) cat("Weighted number of observations:", object@size["nw.obs"], "\n") cat("Dimension of the response:", object@size["d"], "\n") cat("Number of covariates:", object@size["p"], "(includes constant term)\n") cat("Number of parameters:", object@size["n.param"], "\n") cat("Family:", slot(object, "family"),"\n") fixed <- slot(object,"param")$fixed if(length(fixed) > 0) { fixed.char <- paste(names(fixed), format(fixed), sep=" = ", collapse=", ") cat("Fixed parameters:", fixed.char, "\n") } method <- slot(object, "method") u <- if(length(method) == 1) NULL else paste(", penalty function:", method[2]) cat("Estimation method: ", method[1], u, "\n", sep="") logL.name <- paste(if(method[1]=="MLE") "Log" else "Penalized log", "likelihood:", sep="-") cat(logL.name, format(object@logL, nsmall=2),"\n") if(object@param$boundary) cat("Estimates on/near the boundary of the parameter space\n") invisible(object) } ) #---------------------------------- setClass("summary.mselm", representation(call="call", family="character", logL="numeric", method="character", param.type="character", param.fixed="list", resid="matrix", coef.tables="list", scatter="list", slant="list", tail="list", control="list", aux="list", size="vector", boundary="logical"), validity=function(object) { if(!(object@family %in% c("SN","ST","SC","ESN"))) return(FALSE) TRUE } ) setMethod("mean", signature(x="SECdistrUv"), mean.SECdistrUv) setMethod("mean", signature(x="SECdistrMv"), mean.SECdistrMv) setMethod("sd", signature(x="SECdistrUv"), sd.SECdistrUv) setMethod("vcov", signature(object="SECdistrMv"), vcov.SECdistrMv) setMethod("plot", signature(x="SECdistrUv", y="missing"), plot.SECdistrUv) setMethod("plot", signature(x="SECdistrMv", y="missing"), plot.SECdistrMv) setMethod("plot", signature(x="selm"), plot.selm) # y="missing" not required? setMethod("plot", signature(x="mselm"), plot.mselm) setMethod("show", signature(object="summary.selm"), print.summary.selm) setMethod("show", signature(object="summary.mselm"), print.summary.mselm) setMethod("summary", signature(object="SECdistrUv"), summary.SECdistrUv) setMethod("summary", signature(object="SECdistrMv"), summary.SECdistrMv) setMethod("summary", signature(object="selm"), summary.selm) setMethod("summary", signature(object="mselm"), summary.mselm) setMethod("fitted", signature(object="selm"), fitted.selm) setMethod("fitted", signature(object="mselm"), fitted.mselm) setMethod("residuals", signature(object="selm"), residuals.selm) setMethod("residuals", signature(object="mselm"), residuals.mselm) sn/R/zzz.R0000644000176200001440000000071512550703637012066 0ustar liggesusers.onAttach <- function(library, pkg) { # require("stats4") # require("methods") # require("mnormt") # require("numDeriv") if(interactive()) { # pkg <- Package("sn") meta <- packageDescription("sn") packageStartupMessage( "Package 'sn', ", meta$Version, " (", meta$Date, "). ", "Type 'help(SN)' for summary information.\n", "The package redefines function 'sd' but its usual working is unchanged.") } invisible() } sn/MD50000644000176200001440000000457312620601735011215 0ustar liggesusers184f240f4ca7e4a4d6748b1880474aee *DESCRIPTION 1e52fa1dfd4969f12e97d53b2da03641 *NAMESPACE c65a1de34cb56e954f0f8a65bafe8cad *NEWS e886bce70960daadbd0316b91320f82a *R/sn-funct.R 612adb06be3abfe80d37f172bc45bf43 *R/sn_S4.R 111ff3ae97375c9b57aa355627798561 *R/zzz.R 23a5db3f59c58dd6977e88310758a45a *data/ais.rda ddeceb65dd6992569a28f8d978fd5f48 *data/barolo.rda d8589452e6faefae2313692f51500073 *data/frontier.rda 08e4c7d528df6b331d041c9e627a4523 *data/wines.rda 0a72b6c5096e1916370fde6792a25d99 *inst/CITATION 4b0c98761f8fedb579987ca3c743d578 *inst/doc/how_to_sample.pdf 04d4f3d752e239db2c8df7d9ba43c908 *man/Qpenalty.Rd 0cac7cda908cf82cbcf3150066af4532 *man/SECdistrMv-class.Rd c1be5ed5b919da51ff40a4c7a733c118 *man/SECdistrUv-class.Rd 3f63182baad164cf5e87610ab3da1a8d *man/T.Owen.Rd 7550f8a6ec80e37fd07760c0cfba696e *man/affineTransSECdistr.Rd 7dda1c9ecca749bbbbba933a8cc775c6 *man/ais.Rd d46cce4c875557a11d80ca8ac8c4b23b *man/barolo.Rd d0f80bb7fcd38aa51f6612aadcfe09f4 *man/coef.selm.Rd f9361d9091a1e5b06fa9583154ddfbe6 *man/conditionalSECdistr.Rd 1b3400b4122045b6e47ca3e005fea3b1 *man/dmsn.Rd 1b8c96e6c8de8122ebedbacc2bb9dff9 *man/dmst.Rd a96896e1d817dd4c94d320b74071daf2 *man/dp2cp.Rd 383f5b2e2f8c8bc78646c26cd047f42b *man/dsc.Rd bae16a8a11d799d9d3dd2a64eff172aa *man/dsn.Rd 38e5e782135bdc071bff25afb4f69d79 *man/dst.Rd b67cf66ffbbae5fcb041224cd7c35293 *man/extractSECdistr.Rd 8218c6b9b657d978d3000a194bd374c8 *man/frontier.Rd 68e2ac8cb5574e6a21e20cd951b18bb5 *man/makeSECdistr.Rd 6063e2cc72b8a091985ac3d16a561486 *man/matrix-op.Rd b0a05c86bc19aa420c76205d8bd98f97 *man/modeSECdistr.Rd 28c6969db750d78885dccc0c1a7d16d0 *man/plot.SECdistr.Rd 2c73aeb005c768fdfb0cfaff8557013e *man/plot.selm.Rd 1ebe0b59fecc7f68dc76e4ae4a7a0a95 *man/profile.selm.Rd 445e343d2dac5d87a89711e57758953f *man/residuals.selm.Rd cc3dc14383601c9fa0bf8d1196ed8049 *man/sd.Rd c0480f9c26d4d8d18f5f345f10672d1a *man/selm-class.Rd 6d80921a5a2e36a7435cb14c4f6c8771 *man/selm.Rd 334d2caf68caeeb720abd9c2f2222143 *man/selm.fit.Rd 7808aabb5cdc884c630648952953c670 *man/sn-package.Rd f1577d22428d3a2cc3845ee39ccfe9dc *man/sn-st.cumulants.Rd d3d8930d512a9ba340b01d63b8c25340 *man/sn-st.info.Rd ac9e41daa309fce5cf5fc2f3f389880a *man/summary.SECdistr-class.Rd 745b94d10d5b30fc6e0f0473223a4b40 *man/summary.SECdistr.Rd dd09948e59e1eea5cd04478ba8e2a49e *man/summary.selm.Rd c8315b00063afa04ad3801dfce8b91d2 *man/wines.Rd 6851821d713f6547a3f6d61297da1b75 *man/zeta.Rd sn/DESCRIPTION0000644000176200001440000000136512620601735012407 0ustar liggesusersPackage: sn Version: 1.3-0 Date: 2015-11-11 Title: The Skew-Normal and Skew-t Distributions Author: Adelchi Azzalini Maintainer: Adelchi Azzalini Depends: R (>= 2.15.3), methods, stats4 Imports: mnormt, numDeriv, stats, grDevices, graphics, utils Description: Build and manipulate probability distributions of the skew-normal family and some related ones, notably the skew-t family, and provide related statistical methods for data fitting and diagnostics, in the univariate and the multivariate case. License: GPL-2 | GPL-3 URL: http://azzalini.stat.unipd.it/SN Encoding: UTF-8 NeedsCompilation: no Packaged: 2015-11-11 07:27:46 UTC; aa Repository: CRAN Date/Publication: 2015-11-11 10:01:17 sn/man/0000755000176200001440000000000012620566034011451 5ustar liggesuserssn/man/dst.Rd0000644000176200001440000001274012567064602012542 0ustar liggesusers% file sn/man/dst.Rd % This file is a component of the package 'sn' for R % copyright (C) 2002-2014 Adelchi Azzalini %--------------------- \name{dst} \alias{dst} \alias{pst} \alias{qst} \alias{rst} \title{Skew-\eqn{t} Distribution} \description{Density function, distribution function, quantiles and random number generation for the skew-\eqn{t} (ST) distribution} \usage{ dst(x, xi=0, omega=1, alpha=0, nu=Inf, dp=NULL, log=FALSE) pst(x, xi=0, omega=1, alpha=0, nu=Inf, dp=NULL, method=0, ...) qst(p, xi=0, omega=1, alpha=0, nu=Inf, tol=1e-08, dp=NULL, method=0, ...) rst(n=1, xi=0, omega=1, alpha=0, nu=Inf, dp=NULL) } \arguments{ \item{x}{vector of quantiles. Missing values (\code{NA}s) are allowed.} \item{p}{vector of probabililities.} \item{xi}{vector of location parameters.} \item{omega}{vector of scale parameters; must be positive.} \item{alpha}{vector of slant parameters. With \code{pst} and \code{qst}, it must be of length 1.} \item{nu}{a single positive value representing the degrees of freedom; it can be non-integer. Default value is \code{nu=Inf} which corresponds to the skew-normal distribution. } \item{dp}{a vector of length 4, whose elements represent location, scale (positive), slant and degrees of freedom, respectively. If \code{dp} is specified, the individual parameters cannot be set. } \item{n}{sample size} \item{log}{logical; if TRUE, densities are given as log-densities} \item{tol}{ a scalar value which regulates the accuracy of the result of \code{qsn}, measured on the probability scale. } \item{method}{an integer value between \code{0} and \code{4} which selects the computing method; see \sQuote{Details} below for the meaning of these values. If \code{method=0} (default value), an automatic choice is made among the four actual computing methods, which depends on the other arguments.} \item{...}{additional parameters passed to \code{integrate} or \code{pmst}} } \value{Density (\code{dst}), probability (\code{pst}), quantiles (\code{qst}) and random sample (\code{rst}) from the skew-\eqn{t} distribution with given \code{xi}, \code{omega}, \code{alpha} and \code{nu} parameters.} \section{Details}{ Typical usages are \preformatted{% dst(x, xi=0, omega=1, alpha=0, nu=Inf, log=FALSE) dst(x, dp=, log=FALSE) pst(x, xi=0, omega=1, alpha=0, nu=Inf, method=0, ...) pst(x, dp=, log=FALSE) qst(p, xi=0, omega=1, alpha=0, nu=Inf, tol=1e-8, method=0, ...) qst(x, dp=, log=FALSE) rst(n=1, xi=0, omega=1, alpha=0, nu=Inf) rst(x, dp=, log=FALSE) } } \section{Background}{ The family of skew-\eqn{t} distributions is an extension of the Student's \eqn{t} family, via the introduction of a \code{alpha} parameter which regulates skewness; when \code{alpha=0}, the skew-\eqn{t} distribution reduces to the usual Student's \eqn{t} distribution. When \code{nu=Inf}, it reduces to the skew-normal distribution. When \code{nu=1}, it reduces to a form of skew-Cauchy distribution. See Chapter 4 of Azzalini & Capitanio (2014) for additional information. A multivariate version of the distribution exists; see \code{dmst}. } \section{Details}{ For evaluation of \code{pst}, and so indirectly of \code{qst}, four different methods are employed. Method 1 consists in using \code{pmst} with dimension \code{d=1}. Method 2 applies \code{integrate} to the density function \code{dst}. Method 3 again uses \code{integrate} too but with a different integrand, as given in Section 4.2 of Azzalini & Capitanio (2003), full version of the paper. Method 4 consists in the recursive procedure of Jamalizadeh, Khosravi and Balakrishnan (2009), which is recalled in Complement 4.3 on Azzalini & Capitanio (2014); the recursion over \code{nu} starts from the explicit expression for \code{nu=1} given by \code{psc}. Of these, Method 1 and 4 are only suitable for integer values of \code{nu}. Method 4 becomes progressively less efficient as \code{nu} increases, because its value corresponds to the number of nested calls, but the decay of efficiency is slower for larger values of \code{length(x)}. If the default argument value \code{method=0} is retained, an automatic choice among the above four methods is made, which depends on the values of \code{nu, alpha, length(x)}. The numerical accuracy of methods 1, 2 and 3 can be regulated via the \code{...} argument, while method 4 is conceptually exact, up to machine precision. If \code{qst} is called with \code{nu>1e4}, computation is transferred to \code{qsn}. } \references{ Azzalini, A. and Capitanio, A. (2003). Distributions generated by perturbation of symmetry with emphasis on a multivariate skew-\emph{t} distribution. \emph{J.Roy. Statist. Soc. B} \bold{65}, 367--389. Full version of the paper at \url{http://arXiv.org/abs/0911.2342}. Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-normal and Related Families}. Cambridge University Press, IMS Monographs series. Jamalizadeh, A., Khosravi, M., and Balakrishnan, N. (2009). Recurrence relations for distributions of a skew-$t$ and a linear combination of order statistics from a bivariate-$t$. \emph{Comp. Statist. Data An.} \bold{53}, 847--852. } \seealso{\code{\link{dmst}}, \code{\link{dsn}}, \code{\link{dsc}}} \examples{ pdf <- dst(seq(-4, 4, by=0.1), alpha=3, nu=5) rnd <- rst(100, 5, 2, -5, 8) q <- qst(c(0.25, 0.50, 0.75), alpha=3, nu=5) pst(q, alpha=3, nu=5) # must give back c(0.25, 0.50, 0.75) # p1 <- pst(x=seq(-3,3, by=1), dp=c(0,1,pi, 3.5)) p2 <- pst(x=seq(-3,3, by=1), dp=c(0,1,pi, 3.5), method=2, rel.tol=1e-9) } \keyword{distribution} sn/man/dmsn.Rd0000644000176200001440000001200612567620120012675 0ustar liggesusers% file sn/man/dmsn.Rd % This file is a component of the package 'sn' for R % copyright (C) 1998-2013 Adelchi Azzalini %--------------------- \name{dmsn} \alias{dmsn} \alias{pmsn} \alias{rmsn} \concept{skew-normal distribution} \title{Multivariate skew-normal distribution} \description{ Probability density function, distribution function and random number generation for the multivariate skew-normal (\acronym{SN}) distribution. } \usage{ dmsn(x, xi=rep(0,length(alpha)), Omega, alpha, tau=0, dp=NULL, log=FALSE) pmsn(x, xi=rep(0,length(alpha)), Omega, alpha, tau=0, dp=NULL, ...) rmsn(n=1, xi=rep(0,length(alpha)), Omega, alpha, tau=0, dp=NULL) } \arguments{ \item{x}{either a vector of length \code{d}, where \code{d=length(alpha)}, or a matrix with \code{d} columns, giving the coordinates of the point(s) where the density or the distribution function must be evaluated.} \item{xi}{a numeric vector of length \code{d} representing the location parameter of the distribution; see \sQuote{Background}. In a call to \code{dmsn} and \code{pmsn}, \code{xi} can be a matrix, whose rows represent a set of location parameters; in this case, its dimensions must match those of \code{x}.} \item{Omega}{a symmetric positive-definite matrix of dimension \code{(d,d)}; see \sQuote{Background}.} \item{alpha}{a numeric vector which regulates the slant of the density; see \sQuote{Background}. \code{Inf} values in \code{alpha} are not allowed.} \item{tau}{a single value representing the `hidden mean' parameter of the \acronym{ESN} distribution; \code{tau=0} (default) corresponds to a \acronym{SN} distribution.} \item{dp}{ a list with three elements, corresponding to \code{xi}, \code{Omega} and \code{alpha} described above; default value \code{FALSE}. If \code{dp} is assigned, individual parameters must not be specified. } \item{n}{a numeric value which represents the number of random vectors to be drawn.} \item{log}{logical (default value: \code{FALSE}); if \code{TRUE}, log-densities are returned.} \item{...}{ additional parameters passed to \code{pmnorm} }} \value{ A vector of density values (\code{dmsn}) or of probabilities (\code{pmsn}) or a matrix of random points (\code{rmsn}). } \details{Typical usages are \preformatted{% dmsn(x, xi=rep(0,length(alpha)), Omega, alpha, log=FALSE) dmsn(x, dp=, log=FALSE) pmsn(x, xi=rep(0,length(alpha)), Omega, alpha, ...) pmsn(x, dp=) rmsn(n=1, xi=rep(0,length(alpha)), Omega, alpha) rmsn(n=1, dp=) } Function \code{pmsn} makes use of \code{pmnorm} from package \pkg{mnormt}; the accuracy of its computation can be controlled via \code{...} } \section{Background}{ The multivariate skew-normal distribution is discussed by Azzalini and Dalla Valle (1996). The \code{(Omega,alpha)} parametrization adopted here is the one of Azzalini and Capitanio (1999). Chapter 5 of Azzalini and Capitanio (2014) provides an extensive account, including subsequent developments. Notice that the location vector \code{xi} does not represent the mean vector of the distribution. Similarly, \code{Omega} is not \emph{the} covariance matrix of the distribution, although it is \emph{a} covariance matrix. Finally, the components of \code{alpha} are not equal to the slant parameters of the marginal distributions; to fix the marginal parameters at prescribed values, it is convenient to start from the OP parameterization, as illustrated in the \sQuote{Examples} below. Another option is to start from the \acronym{CP} parameterization, but notice that, at variance from the \acronym{OP}, not all \acronym{CP} sets are invertible to lend a \acronym{DP} set.} \references{ Azzalini, A. and Capitanio, A. (1999). Statistical applications of the multivariate skew normal distribution. \emph{J.Roy.Statist.Soc. B} \bold{61}, 579--602. Full-length version available at \url{http://arXiv.org/abs/0911.2093} Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. Azzalini, A. and Dalla Valle, A. (1996). The multivariate skew-normal distribution. \emph{Biometrika} \bold{83}, 715--726. } \seealso{\code{\link{dsn}}, \code{\link{dmst}}, \code{\link[mnormt]{dmnorm}}, \code{\link{op2dp}}, \code{\link{cp2dp}}} \examples{ x <- seq(-3,3,length=15) xi <- c(0.5, -1) Omega <- diag(2) Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2,-6) pdf <- dmsn(cbind(x, 2*x-1), xi, Omega, alpha) cdf <- pmsn(cbind(x, 2*x-1), xi, Omega, alpha) p1 <- pmsn(c(2,1), xi, Omega, alpha) p2 <- pmsn(c(2,1), xi, Omega, alpha, abseps=1e-12, maxpts=10000) # rnd <- rmsn(10, xi, Omega, alpha) # # use OP parameters to fix marginal shapes at given lambda values: op <- list(xi=c(0,1), Psi=matrix(c(2,2,2,3), 2, 2), lambda=c(5, -2)) rnd <- rmsn(10, dp=op2dp(op,"SN")) # # use CP parameters to fix mean vector, variance matrix and marginal skewness: cp <- list(mean=c(0,0), var.cov=matrix(c(3,2,2,3)/3, 2, 2), gamma1=c(0.8, 0.4)) dp <- cp2dp(cp, "SN") rnd <- rmsn(5, dp=dp) } \keyword{distribution} \keyword{multivariate} sn/man/selm-class.Rd0000644000176200001440000001156712521715037014014 0ustar liggesusers% file sn/man/selm-class.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013-2014 Adelchi Azzalini %--------------------- \name{selm-class} \Rdversion{1.1} \docType{class} \alias{selm-class} %\alias{coef,selm-method} % superseded by coef.selm.Rd \alias{logLik,selm-method} \alias{plot,selm,ANY-method} \alias{plot,selm,missing-method} \alias{show,selm-method} % \alias{fitted,selm-method} % superseded by residuals.selm.Rd % \alias{residuals,selm-method} % superseded by residuals.selm.Rd \alias{vcov,selm-method} \alias{weights,selm-method} % \alias{mselm-class} % \alias{coef,mselm-method} % superseded by coef.selm.Rd \alias{logLik,mselm-method} \alias{plot,mselm,ANY-method} \alias{plot,mselm,missing-method} \alias{show,mselm-method} %\alias{fitted,mselm-method} % superseded by residuals.selm.Rd %\alias{residuals,mselm-method} % superseded by residuals.selm.Rd \alias{vcov,mselm-method} \alias{weights,mselm-method} \title{Classes \code{selm} and \code{mselm} of objects created by function \code{selm}} \description{A successful call to function \code{selm} creates an object of either of these classes, having a structure described in section \sQuote{Slots}. A set of methods for these classes of objects exist, listed in section \sQuote{Methods}.} \section{Objects from the class}{ An object can be created by a successful call to function \code{selm}.} \section{Slots}{ \describe{ \item{\code{call}:}{the calling statement.} \item{\code{family}:}{the parametric family of skew-ellitically contoured distributed (SEC) type.} \item{\code{logL}:}{log-likelihood or penalized log-likelihood value achieved at the end of the maximization process.} \item{\code{method}:}{estimation method (\code{"MLE"} or \code{"MPLE"}).} \item{\code{param}:}{estimated parameters, for various parameterizations.} \item{\code{param.var}:}{approximate variance matrices of the parameter estimates, for various parameterizations.} \item{\code{size}:}{a numeric vector with size of various components.} \item{\code{fixed.param}:}{a vector of parameters which have been kept fixed in the fitting process, if any.} \item{\code{residuals.dp}:}{residual values, for DP-type parameters.} \item{\code{fitted.values.dp}:}{fitted values, for DP-type parameters.} \item{\code{control}:}{a list with control parameters.} \item{\code{input}:}{a list of selected input values.} \item{\code{opt.method}:}{a list with details on the optimization method.} } } \section{Methods}{ \tabular{ll}{ \code{coef} \tab \code{signature(object = "selm")}: ... \cr \code{logLik} \tab \code{signature(object = "selm")}: ... \cr % \code{plot} \tab \code{signature(x = "selm", y = "ANY")}: ... \cr % \code{plot} \tab \code{signature(x = "selm", y = "missing")}: ... \cr \code{plot} \tab \code{signature(x = "selm")}: ... \cr \code{show} \tab \code{signature(object = "selm")}: ... \cr \code{summary} \tab \code{signature(object = "selm")}: ... \cr \code{residuals} \tab \code{signature(object = "selm")}: ... \cr \code{fitted} \tab \code{signature(object = "selm")}: ... \cr \code{vcov} \tab \code{signature(object = "selm")}: ... \cr \code{weights} \tab \code{signature(object = "selm")}: ... \cr \tab \cr \code{coef} \tab \code{signature(object = "mselm")}: ... \cr \code{logLik} \tab \code{signature(object = "mselm")}: ... \cr \code{plot} \tab \code{signature(x = "mselm")}: ... \cr \code{show} \tab \code{signature(object = "mselm")}: ... \cr \code{summary} \tab \code{signature(object = "mselm")}: ... \cr \code{residuals} \tab \code{signature(object = "mselm")}: ... \cr \code{fitted} \tab \code{signature(object = "mselm")}: ... \cr \code{vcov} \tab \code{signature(object = "mselm")}: ... \cr \code{weights} \tab \code{signature(object = "mselm")}: ... \cr } } %\references{%% ~~put references to the literature/web site here~~} \author{Adelchi Azzalini} \note{See \code{\link{dp2cp}} for a description of possible parameter sets. When \code{logLik} is used on an object obtained using the MPLE estimation method, the value reported is actually the \emph{penalized} log-likelihood. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{See also \code{\link{selm}} function, \code{\link{plot.selm}}, \code{\linkS4class{summary.selm}}, \code{\link{dp2cp}} } \examples{ data(ais) m1 <- selm(log(Fe) ~ BMI + LBM, family="SN", data=ais) summary(m1) plot(m1) logLik(m1) res <- residuals(m1) fv <- fitted(m1) # data(wines, package="sn") m2 <- selm(alcohol ~ malic + phenols, data=wines) # m12 <- selm(cbind(acidity, alcohol) ~ phenols + wine, family="SN", data=wines) coef(m12) cp <- coef(m12, vector=FALSE) dp <- coef(m12, "DP", vector=FALSE) plot(m12) plot(m12, which=2, col="gray60", pch=20) } \keyword{classes} sn/man/dp2cp.Rd0000644000176200001440000001665412614673506012772 0ustar liggesusers% file sn/man/dp2cp.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{dp2cp} \alias{dp2cp} \alias{cp2dp} \alias{dp2op} \alias{op2dp} \title{Conversion between parametrizations of a skew-elliptical distribution} \description{ Convert direct parameters (\acronym{DP}) to centred parameters (\acronym{CP}) of a skew-elliptical distribution and \emph{vice versa}.} \usage{ dp2cp(dp, family, object = NULL, cp.type = "proper", upto = NULL) cp2dp(cp, family) dp2op(dp, family) op2dp(op, family) } \arguments{ \item{dp}{a vector (in the univariate case) or a list (in the multivariate case) as described in \code{\link{makeSECdistr}}; see \sQuote{Background and Details} for an extented form of usage.} \item{cp}{a vector or a list, in agreement with \code{dp} as for type and dimension.} \item{op}{a vector or a list, in agreement with \code{dp} as for type and dimension.} \item{family}{a characther string with the family acronym, as described in \code{\link{makeSECdistr}}, except that family \code{"ESN"} is not implemented.} \item{object}{optionally, an S4 object of class \code{SECdistrUv} or \code{SECdistrMv}, as produced by \code{\link{makeSECdistr}} (default value: \code{NULL}). If this argument is not \code{NULL}, then \code{family} and \code{dp} must not be set.} \item{cp.type}{character string, which has effect only if \code{family="ST"} or \code{"SC"}, otherwise a warning message is generated. Possible values are \kbd{"proper", "pseudo", "auto"}, which correspond to the \acronym{CP} parameter set, their `pseudo-\acronym{CP}' version and an automatic selection based on \code{nu>4}, where \code{nu} represents the degrees of freedom of the \acronym{ST} distribution.} \item{upto}{numeric value (in \code{1:length(dp)}, default=\code{NULL}) to select how many \acronym{CP} components are computed. Default value \code{upto=NULL} is equivalent to \code{length(dp)}.} } \value{For \code{dp2cp}, a matching vector (in the univariate case) or a list (in the multivariate case) of \code{cp} parameters. For \code{cp2dp} and \code{op2dp}, a similar object of \code{dp} parameters, provided the set of input parameters is in the admissible region. For \code{dp2op}, a similar set of \code{op} parameters.} \section{Background}{For a description of the \acronym{DP} parameters, see Section \sQuote{Details} of \code{\link{makeSECdistr}}. The \acronym{CP} form of parameterization is cumulant-based. For a univariate distribution, the \acronym{CP} components are the mean value (first cumulant), the standard deviation (square root of the 2nd cumulant), the coefficient of skewness (3rd standardized cumulant) and, for the \acronym{ST}, the coefficient of excess kurtosis (4th standardized cumulant). For a multivariate distribution, there exists an extension based on the same logic; its components represent the vector mean value, the variance matrix, the vector of marginal coefficients of skewness and, only for the \acronym{ST}, the Mardia's coefficient of excess kurtosis. The pseudo-\acronym{CP} variant provides an `approximate form' of \acronym{CP} when not all required cumulants exist; however, this parameter set is not uniquely invertible to \acronym{DP}. The names of pseudo-\acronym{CP} components printed in summary output are composed by adding a \code{~} after the usual component name; for example, the first one is denoted \code{mean~}. Additional information is provided by Azzalini and Capitanio (2014). Specifically, their Section 3.1.4 presents \acronym{CP} in the univariate \acronym{SN} case, Section 4.3.4 \acronym{CP} for the \acronym{ST} case and the `pseudo-\acronym{CP}' version. Section 5.2.3 presents the multivariate extension for the \acronym{SN} distribution, Section 6.2.5 for the multivariate \acronym{ST} case. For a more detailed discussion, see Arellano-Valle and Azzalini (2013). The \acronym{OP} parameterization is very similar to \acronym{DP}, from which it differs only for the components which regulate dispersion (or scatter) and slant. Its relevance lies essentially in the multivariate case, where the components of the slant parameter can be interpreted component-wise and remain unaffected if marginalization with respect to some other components is performed. In the multivariate \acronym{SN} case, the components of \acronym{OP}, denoted \eqn{\xi, \Psi, \lambda}, are associated to the expression of the density function (5.30) of Azzalini \& Capitanio (2014); see pp.128--131 for more information. In the univariate case, the slant component of \acronym{DP} and the one of \acronym{OP} coincide, that is, \eqn{\alpha=\lambda}, Parameter \eqn{\xi} and other parameters which may exist with other families remain the same of the \acronym{DP} set. The term \acronym{OP} stands for `original parameterization' since this is, up to a negligible difference, the parameterization adopted by Azzalini & Dalla Valle (1996). } \section{Details}{ While any choice of the components of \acronym{DP} or \acronym{OP} is admissible, this is not true for \acronym{CP}. An implication is that a call to \code{cp2dp} may fail with an error message \code{"non-admissible CP"} for certain input values. The most extreme case is represented by the \acronym{SC} family, for which \acronym{CP} never exists; hence it makes to sense to call \code{cp2dp} with \code{family="SC"}. It is possible to call the functions with \code{dp} or \code{cp} having more components than those expected for a given family as described above and in \code{\link{makeSECdistr}}. In the univariate case, this means that \code{dp} or \code{cp} can be vectors of longer length than indicated earlier. This occurrence is interpreted in the sense that the additional components after the first one are regarded as regression coefficients of a \code{selm} model, and they are transferred unchanged to the matching components of the transformed parameter set; the motivation is given in Section 3.1.4 of Azzalini and Capitanio (2014). In the multivariate case, \code{dp[[1]]} and \code{cp[[1]]} can be matrices instead of vectors; the rows beyond the first one are transferred unchanged to \code{cp[[1]]} and \code{dp[[1]]}, respectively. } \references{ Arellano-Valle, R. B. and Azzalini, A. (2013, available on-line 12 June 2011). The centred parameterization and related quantities of the skew-\emph{t} distribution. \emph{J. Multiv. Analysis} \bold{113}, 73-90. Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. Azzalini, A. and Dalla Valle, A. (1996). The multivariate skew-normal distribution. \emph{Biometrika} \bold{83}, 715--726. } \seealso{ \code{\link{makeSECdistr}}, \code{\link{summary.SECdistr}}, \code{\link{sn.cumulants}}, the \sQuote{Note} at \code{\link{summary.selm}} for the reason why \acronym{CP} is the default parameterization in that function and in related ones, the \sQuote{Examples} at \code{\link{rmsn}} for use of the \acronym{CP} parameterization } \examples{ # univariate case cp <- dp2cp(c(1, 2222, 3333, 2, 3), "SN") dp <- cp2dp(cp, "SN") # notice that 2nd and 3rd component remain unchanged # # multivariate case dp3 <- list(xi=1:3, Omega=toeplitz(1/(1:3)), alpha=c(-3, 8, 5), nu=6) cp3 <- dp2cp(dp3, "ST") dp3.back <- cp2dp(cp3, "ST") # op3 <- dp2op(dp3, "ST") dp3back <- op2dp(op3,"ST") } \keyword{distribution} sn/man/plot.SECdistr.Rd0000644000176200001440000001612212565412353014401 0ustar liggesusers% file sn/man/plot.SECdistr.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{plot.SECdistr} \docType{methods} %\alias{plot,ANY,ANY-method} % \alias{plot,profile.mle,missing-method} % \alias{show,SECdistrMv-method} % \alias{show,SECdistrUv-method} \alias{plot.SECdistr} \alias{plot.SECdistrUv} \alias{plot.SECdistrMv} \alias{plot,SECdistrMv,missing-method} \alias{plot,SECdistrUv,missing-method} \alias{plot,SECdistrMv-method} \alias{plot,SECdistrUv-method} \title{Plotting methods for classes \code{SECdistrUv} and \code{SECdistrMv}} \description{Methods for classes \code{SECdistrUv} and \code{SECdistrMv}} \usage{ \S4method{plot}{SECdistrUv}(x, range, probs, main, npt = 251, \dots) \S4method{plot}{SECdistrMv}(x, range, probs, npt, landmarks = "auto", main, comp, compLabs, data = NULL, data.par = NULL, gap = 0.5, \dots) } \arguments{ \item{x}{an object of class \code{SECdistrUv} or \code{SECdistrMv}.} % \item{y}{not used, required by the generic \code{plot(x, y, ...)} function.} \item{range}{in the univariate case, a vector of length 2 which defines the plotting range; in the multivariate case, a matrix with two rows where each column defines the plotting range of the corresponding component variable. If missing, a sensible choice is made.} \item{probs}{a vector of probability values. In the univariate case, the corresponding quantiles are plotted on the horizontal axis; it can be skipped by setting \code{probs=NULL}. In the multivariate case, each probability value corresponds to a contour level in each bivariate plot; at least one probability value is required. See \sQuote{Details} for further information. Default value: \code{c(0.05, 0.25, 0.5, 0.75, 0.95)} in the univariate case, \code{c(0.25, 0.5, 0.75, 0.95)} in the multivariate case.} \item{npt}{a numeric value or vector (in the univariate and in the multivariate case, respectively) to assign the number of evaluation points of the distribution, on an equally-spaced grid over the \code{range} defined above. Default value: 251 in the univariate case, a vector of 101's in the multivariate case.} \item{landmarks}{a character string which affects the placement of some landmark values in the multivariate case, that is, the origin, the mode and the mean (or its substitute pseudo-mean), which are all aligned. Possible values: \code{"proper"}, \code{"pseudo"}, \code{"auto"} (default), \code{""}. The option \code{""} prevents plotting of the landmarks. With the other options, the landmarks are plotted, with some variation in the last one: \code{"proper"} plots the proper mean value, \code{"pseudo"} plots the pseudo-mean, useful when the proper mean does not exists, \code{"auto"} plots the proper mean if it exists, otherwise it switches automatically to the pseudo-mean. See \code{\link{dp2cp}} for more information on pseudo-\acronym{CP} parameters, including pseudo-mean.} \item{main}{a character string for main title; if missing, one is built from the available ingredients.} \item{comp}{a subset of the vector \code{1:d}, if \code{d} denotes the dimensionality of the multivariate distribution.} \item{compLabs}{a vector of character strings or expressions used to denote the variables in the plot; if missing, \code{slot(object,"compNames")} is used.} \item{data}{an optional set of data of matching dimensionity of \code{object} to be superimposed to the plot. The default value \code{data=NULL} produces no effect. In the univariate case, data are plotted using \code{\link[graphics]{rug}} at the top horizontal axis, unless if \code{probs=NULL}, in which case plotting is at the bottom axis. In the multivariate case, points are plotted in the form of a scatterplot or matrix of scatterplots; this can be regulated by argument \code{data.par}.} \item{data.par}{an optional list of graphical parameters used for plotting \code{data} in the multivariate case, when \code{data} is not \code{NULL}. Recognized parameters are: \code{col}, \code{pch}, \code{cex}. If missing, the analogous components of \code{par()} are used. } \item{gap}{a numeric value which regulates the gap between panels of a multivariate plot when \code{d>2}.} \item{\dots}{additional graphical parameters} } \section{Details}{ For univariate density plots, \code{probs} are used to compute quantiles from the appropriate distribution, and these are superimposed to the plot of the density function, unless \code{probs=NULL}. In the multivariate case, each bivariate plot is constructed as a collection of contour curves, one curve for each probability level; consequently, \code{probs} cannot be missing or \code{NULL}. The level of the density contour lines are chosen so that each curve circumscribes a region with the quoted probability, to a good degree of approssimation; for additional information, see Azzalini and Capitanio (2014), specifically Complement 5.2 and p.179, and references therein. } \value{an invisible list. In the univariate case the list has three components: the input object representing the distribution and two numeric vectors with the coordinates of the plotted density values. In the multivariate case, the first element of the list is the input object representing the distribution and all subsequent list elements are lists with components of the panels comprising the matrix plot; the elements of these sub-lists are: the vectors of \code{x} and \code{y} coordinates, the names of the variables, the density values at the \code{(x,y)} points, a vector of the density levels of the curves appearing in each panel plot, with the corresponding approximate probability content as a vector attribute.} \author{Adelchi Azzalini} \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \seealso{\code{\link{makeSECdistr}}, \code{\link{summary.SECdistr}}, \code{\link{dp2cp}}} \section{Methods}{ \describe{ % \item{\code{signature(x = "ANY", y = "ANY")}}{Generic function: see % \code{\link[graphics]{plot}}.} \item{\code{signature(x = "SECdistrUv")}}{Plot an object \code{x} of class \code{SECdistrUv}.} \item{\code{signature(x = "SECdistrMv")}}{Plot an object \code{x} of class \code{SECdistrMv}.} }} \examples{ # d=1 f1 <- makeSECdistr(dp=c(3,2,5), family="SC", name="Univariate Skew-Cauchy") plot(f1) plot(f1, range=c(-3,40), probs=NULL, col=4) # # d=2 Omega2 <- matrix(c(3, -3, -3, 5), 2, 2) f2 <- makeSECdistr(dp=list(c(10,30), Omega=Omega2, alpha=c(-3, 5)), family="sn", name="SN-2d", compNames=c("x1","x2")) plot(f2) x2 <- rmsn(100, dp=slot(f2,"dp")) plot(f2, main="Distribution 'f2'", probs=c(0.5,0.9), cex.main=1.5, col=2, cex=0.8, compLabs=c(expression(x[1]), expression(log(z[2]-beta^{1/3}))), data=x2, data.par=list(col=4, cex=0.6, pch=5)) } \keyword{methods} \keyword{hplot} sn/man/Qpenalty.Rd0000644000176200001440000000604012524604716013540 0ustar liggesusers% file sn/man/Qpenalty.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{Qpenalty} \alias{Qpenalty} \alias{MPpenalty} \concept{penalized likelihood} \concept{prior distribution} \title{Penalty function for log-likelihood of \code{selm} models} \description{Penalty function for the log-likelihood of \code{selm} models when \code{method="MPLE"}. \code{Qpenalty} is the default function; \code{MPpenalty} is an example of a user-defined function effectively corresponding to a prior distributio on \code{alpha}. } \usage{ Qpenalty(alpha_etc, nu = NULL, der = 0) MPpenalty(alpha, der = 0) } \arguments{ \item{alpha_etc, alpha}{in the univariate case, a single value \code{alpha}; in the multivariate case, a two-component list whose first component is the vector \code{alpha}, the second one is matrix \code{cov2cor(Omega)}. } \item{nu}{degrees of freedom, only required if \code{selm} is called with \code{family="ST"}. } \item{der}{a numeric value in the set \kbd{0,1,2} which indicates the required numer of derivatives of the function. In the multivariate case the function will only be called with \code{der} equal to 0 or 1.} } \details{The penalty is a function of \code{alpha}, but its expression may depend on other ingredients, specifically \code{nu} and \code{cov2cor(Omega)}. See \sQuote{Details} of \code{\link{selm}} for additional information. The penalty mechanism allows to introduce a prior distribution \eqn{\pi} for \eqn{\alpha} by setting \eqn{Q=-\log\pi}{Q=-log(\pi)}, leading to a maximum \emph{a posteriori} estimate in the stated sense. As an illustration of this mechanism, function \code{MPpenalty} implements the `matching prior' distribution for the univariate \acronym{SN} distribution studied by Cabras \emph{et al.} (2012); a brief summary of the proposal is provided in Section 3.2 of Azzalini and Capitanio (2014). Note that, besides \code{alpha=+/-Inf}, this choice also penalizes \code{alpha=0} with \code{Q=Inf}, effectively removing \code{alpha=0} from the parameter space. } \value{A positive number \code{Q} representing the penalty, possibly with attributes \code{attr(Q, "der1")} and \code{attr(Q, "der2")}, depending onthe input value \code{der}.} \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. Cabras, S., Racugno, W., Castellanos, M. E., and Ventura, L. (2012). A matching prior for the shape parameter of the skew-normal distribution. \emph{Scand. J. Statist.} \bold{39}, 236--247. } \author{Adelchi Azzalini} % \note{%% ~~further notes~~} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{selm}} function} \examples{ data(frontier) m2 <- selm(frontier ~ 1) # no penalty m2a <- selm(frontier ~ 1, method="MPLE") # penalty="Qpenalty" is implied here m2b <- selm(frontier ~ 1, method="MPLE", penalty="MPpenalty") } %\keyword{ ~kwd1 } sn/man/frontier.Rd0000644000176200001440000000142012262550007013560 0ustar liggesusers% file sn/man/frontier.Rd % This file is a component of the package 'sn' for R % copyright (C) 1998 Adelchi Azzalini %--------------------- \name{frontier} \alias{frontier} \title{Simulated sample from a skew-normal distribution} \usage{data(frontier)} \description{ A sample simulated from the SN(0,1,5) distribution with sample coefficient of skewness inside the admissible range (-0.9952719, 0.9952719) for the skew-normal family but maximum likelihood estimate on the frontier of the parameter space. } \format{A vector of length 50.} \source{Generated by a run of \code{rsn(50, 0, 1, 5)}.} \examples{ data(frontier, package="sn") fit <- selm(frontier ~ 1) plot(fit, which=2) # fit.p <- selm(frontier ~ 1, method="MPLE") plot(fit.p, which=2) } \keyword{datasets} sn/man/extractSECdistr.Rd0000644000176200001440000000414012521103632015001 0ustar liggesusers% file sn/man/extractSECdistr.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{extractSECdistr} \alias{extractSECdistr} \concept{skew-elliptical distribution} \title{Extract the SEC error term from an object created by \code{selm}} \description{ Given an object created by a call to \code{selm}, the function delivers the \acronym{SEC} distribution representing the stochastic term of the fitted distribution } \usage{ extractSECdistr(object, name, compNames) } \arguments{ \item{object}{an object of class \code{selm} or \code{mselm}, as created by \code{\link{selm}} } \item{name}{an optional character string representing the name of the outcome distribution; if missing, a string is constructed from the \code{object} ingredients.} \item{compNames}{in the multivariate case, an optional vector of character strings with the names of the components of the error distribution; if missing, one such vector is constructed from the \code{object} ingredients.} } \value{An object of class \code{SECdistrMv} or \code{SECdistrUv}, depending of the class of \code{object}.} \section{Details}{ When the formula of the fitted model includes only the constant \code{1}, the returned object represents the fitted \acronym{SEC} distribution. If the formula includes additional terms, the linear predictor is eliminated and the returned object corresponds to the error term of the model; hence the location parameter \code{xi} in the \acronym{DP} parameterization is set to zero. The returned object can be submitted to tools available for objects created by \code{\link{makeSECdistr}}, such as \code{\link{summary.SECdistr}}, \code{\link{conditionalSECdistr}} and and so on.} \seealso{\code{\link{selm}}, \code{\link{makeSECdistr}}} \examples{ data(ais) m2 <- selm(log(Fe) ~ 1, family="ST", data=ais, fixed=list(nu=8)) f2 <- extractSECdistr(m2) show(f2) # m4 <- selm(cbind(BMI, LBM) ~ 1, family="SN", data=ais) f4 <- extractSECdistr(m4) mean(f4) vcov(f4) } \keyword{multivariate} \keyword{distribution} sn/man/matrix-op.Rd0000644000176200001440000000356112424402147013661 0ustar liggesusers% file sn/man/vech.Rd % This file is a component of the package 'sn' for R % copyright (C) 1998,2013 Adelchi Azzalini %--------------------- \name{matrix-op} \encoding{UTF-8} \alias{vech} \alias{vech2mat} \alias{duplicationMatrix} \concept{matrix operator} \title{vech and other matrix operators} \description{vech and other matrix operators} \usage{ vech(A) vech2mat(v) duplicationMatrix(n) } \arguments{ \item{A}{a (symmetric) square matrix} \item{v}{a numeric vector such that \code{length(v)=n*(n+1)/2} for some positive integer \code{n}} \item{n}{a positive integer number; default is \code{n=1}} } \value{a vector in case of \code{vech}, otherwise a matrix} \section{Details}{% For a square matrix \code{A}, \code{vech(A)} returns the vector formed by the lower triangular portion of the matrix, including the diagonal; usually, this only makes sense for a symmetric matrix of numeric values. If \code{v=vech(M)} where \code{M} is a symmetric numeric matrix, \code{vect2mat(v)} performs the inverse operation and returns \code{M}; this explain the requirement on \code{length(v)}. For a positive integer \code{n}, \code{D=duplicationMatrix(n)} is a matrix of dimension \code{(n^2, n*(n+1)/2)} such that \code{D \%*\% vech(M)} returns the \code{vec}-form of a symmetric matrix \code{M} of order \code{n}, that is, the vector which stacks the columns of \code{M}; for more information, see Section 3.8 of Magnus and Neudecker (1988). } \section{Author}{Adelchi Azzalini; the original Octave code of \code{duplicationMatrix} is by Kurt Hornik} \references{ Magnus, Jan R. and Neudecker, Heinz (1988). \emph{Matrix differential calculus with application in statistics and econometrics}. Wiley series in probability and statistics. } \examples{ M <- toeplitz(1:4) v <- vech(M) vech2mat(v) - M D <- duplicationMatrix(ncol(M)) # D %*% vech(M) - as.vector(M) } \keyword{math} sn/man/sd.Rd0000644000176200001440000000130312504264237012344 0ustar liggesusers\name{sd} \title{Standard deviation} \alias{sd} \alias{sd.default} \description{ The \code{sd} function from the \pkg{stats} is replaced by a new \code{method} in order to introduce a separate method to deal with objects of class \code{SECdistrUv}. The function \code{sd.default} is an alias of the original function \code{\link[stats]{sd}}. } \usage{ sd(x, \dots) \method{sd}{default}(x, na.rm = FALSE, \dots) } \arguments{ \item{x}{a numeric vector, matrix or data frame.} \item{na.rm}{logical. Should missing values be removed?} \item{\dots}{further arguments passed to or from other methods.} } \seealso{ \code{\link[stats]{sd}}, \code{\linkS4class{SECdistrUv}} } \keyword{univar} sn/man/affineTransSECdistr.Rd0000644000176200001440000000556112436673322015614 0ustar liggesusers% file sn/man/affineTransSECdistr.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{affineTransSECdistr} \alias{marginalSECdistr} \alias{affineTransSECdistr} \title{Affine transformations and marginals of a skew-elliptical distribution} \description{ Compute the distribution of a (multivariate) marginal or the distribution of an affine transformation \eqn{a + A^{\top}Y}{a + A'Y} of a multivariate variable \eqn{Y} with skew-elliptical (\acronym{SEC}) distribution.} \usage{ affineTransSECdistr(object, a, A, name, compNames, drop=TRUE) marginalSECdistr(object, comp, name, drop=TRUE) } \arguments{ \item{object}{an object of class \code{SECdistrMv}, as created by \code{\link{makeSECdistr}} or by a previous call to these functions} \item{a}{a numeric vector with the length \code{ncol(A)}.} \item{A}{a full-rank matrix with \code{nrow(A)} equal to the dimensionality of \code{object}. } \item{name}{an optional character string representing the name of the outcome distribution; if missing, one such string is constructed.} \item{compNames}{an optional vector of length \code{ncol(A)} of character strings with the names of the components of the outcome distribution; if missing, one such vector is constructed.} \item{drop}{a logical flag (default value: \code{TRUE}), operating only if the returned object is has dimension \code{1}, in which case it indicates whether this object must be of class \code{SECdistrUv}.} \item{comp}{a vector formed by a subset of \code{1:d} which indicates which components must be extracted from \code{object}, on denoting by \code{d} its dimensionality.} } \value{If \code{object} defines the distribution of a \acronym{SEC} random variable \eqn{Y}, \code{affineTransSECdistr} computes the distribution of \eqn{a+A'Y} and \code{marginalSECdistr} computes the marginal distribution of the \code{comp} components. In both cases the returned object is of class \code{SECdistrMv}, except when \code{drop=TRUE} operates, leading to an object of class \code{SECdistrUv}.} \section{Background}{These functions implement formulae given in Sections 5.1.4, 5.1.6 and 6.2.2 of the reference below.} \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \seealso{\code{\link{makeSECdistr}}, \code{\link{SECdistrMv-class}}} \examples{ dp3 <- list(xi=1:3, Omega=toeplitz(1/(1:3)), alpha=c(3,-1,2), nu=5) st3 <- makeSECdistr(dp3, family="ST", name="ST3", compNames=c("U", "V", "W")) A <- matrix(c(1,-1,1, 3,0,-2), 3, 2) new.st <- affineTransSECdistr(st3, a=c(-3,0), A=A) # st2 <- marginalSECdistr(st3, comp=c(3,1), name="2D marginal of ST3") } \keyword{multivariate} \keyword{distribution} sn/man/conditionalSECdistr.Rd0000644000176200001440000000374712255403507015656 0ustar liggesusers% file sn/man/conditionalSECdistr.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{conditionalSECdistr} \alias{conditionalSECdistr} \title{Skew-normal conditional distribution} \description{For a multivariate (extended) skew-normal distribution, compute its conditional distribution for given values of some of its components.} \usage{ conditionalSECdistr(object, fixed.comp, fixed.values, name, drop = TRUE) } \arguments{ \item{object}{an object of class \code{SECdistrMv} with \code{family="SN"} or \code{family="ESN"}. } \item{fixed.comp}{a vector containing a subset of \code{1:d} which selects the components whose values are to be fixed, if \code{d} denotes the dimensionality of the distribution.} \item{fixed.values}{a numeric vector of values taken on by the components \code{fixed.comp}; it must be of the same length of \code{fixed.comp}.} \item{name}{an optional character string with the name of the outcome distribution; if missing, one such string is constructed.} \item{drop}{logical (default=\code{TRUE}), to indicate whether the returned object must be of class \code{SECdistrUv} when \code{length(fixed.comp)+1=d}.} } \value{an object of class \code{SECdistrMv}, except in the case when \code{drop=TRUE} operates, leading to an object of class \code{SECdistrUv-class}.} \details{For background information, see Section 5.3.2 of the reference below.} \references{ Azzalini, A. and Capitanio, A. (2014). \emph{The Skew-normal and Related Families}. Cambridge University Press, IMS Monographs series. } \seealso{\code{\link{makeSECdistr}}, \code{\link{SECdistrMv-class}}, \code{\link{affineTransSECdistr}} } \examples{ Omega <- diag(3) + outer(1:3,1:3) sn <- makeSECdistr(dp=list(xi=rep(0,3), Omega=Omega, alpha=1:3), family="SN") esn <- conditionalSECdistr(sn, fixed.comp=2, fixed.values=1.5) show(esn) } \keyword{multivariate} \keyword{distribution} sn/man/modeSECdistr.Rd0000644000176200001440000000417112503517424014267 0ustar liggesusers% file sn/man/mmodeSECdistr.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{modeSECdistr} \alias{modeSECdistr} \title{The mode of a skew-elliptically contoured (\acronym{SEC}) distribution} \description{ Compute compute the mode of a univariate or multivariate \acronym{SEC} distribution.} \usage{ modeSECdistr(dp, family, object=NULL) } \arguments{ \item{dp}{ a numeric vector (in the univariate case, for class \code{SECdistrUv}) or a list (in the multivariate case, , for class \code{SECdistrUv}) of parameters which identify the specific distribution within the named \code{family}. } \item{family}{a character string which identifies the parametric family among those admissible for classes \code{SECdistrUv} or \code{SECdistrMv} } \item{object}{an object of class \code{SECdistrUv} or \code{SECdistrMv} as created by \code{\link{makeSECdistr}} or \code{\link{extractSECdistr}} } } \value{a numeric vector} \section{Background}{The mode is obtained through numerical maximization. In the multivariate case, the problem is reduced to a one-dimensional search using Propositions 5.14 and 6.2 of the reference below.} \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \seealso{\code{\link{makeSECdistr}} and \code{\link{extractSECdistr}} for additional information and for constructing a suitable \code{object}, \code{\link{SECdistrUv-class}} and \code{\link{SECdistrMv-class}} for methods \code{mean} and \code{vcov} which compute the mean (vector) and the variance (matrix) of the \code{object} distribution } \examples{ dp3 <- list(xi=1:3, Omega=toeplitz(1/(1:3)), alpha=c(3,-1,2), nu=5) st3 <- makeSECdistr(dp3, family="ST", name="ST3", compNames=c("U", "V", "W")) A <- matrix(c(1,-1,1, 3,0,-2), 3, 2) new.st <- affineTransSECdistr(st3, a=c(-3,0), A=A) # st2 <- marginalSECdistr(st3, comp=c(3,1), name="2D marginal of ST3") } \keyword{multivariate} \keyword{distribution} sn/man/plot.selm.Rd0000644000176200001440000001520112436650113013651 0ustar liggesusers% file sn/man/plot.selm.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{plot.selm} \alias{plot.selm} \alias{plot.mselm} \alias{plot,selm-method} \alias{plot,mselm-method} \concept{QQ-plot} \title{Diagnostic plots for \code{selm} fits} \description{Diagnostic plots for objects of class \code{selm} and \code{mselm} generated by a call to function \code{selm}} \usage{ \S4method{plot}{selm}(x, param.type="CP", which = c(1:4), caption, panel = if (add.smooth) panel.smooth else points, main = "", ask = prod(par("mfcol")) < length(which) && dev.interactive(), ..., id.n = 3, labels.id = names(x@residuals.dp), cex.id = 0.75, identline = TRUE, add.smooth = getOption("add.smooth"), label.pos = c(4, 2), cex.caption = 1) \S4method{plot}{mselm}(x, param.type="CP", which, caption, panel = if (add.smooth) panel.smooth else points, main = "", ask = prod(par("mfcol")) < length(which) && dev.interactive(), ..., id.n = 3, labels.id = names(x@residuals.dp), cex.id = 0.75, identline = TRUE, add.smooth = getOption("add.smooth"), label.pos = c(4, 2), cex.caption = 1) } \arguments{ \item{x}{an object of class \code{selm} or \code{mselm}.} \item{param.type}{a character string which selects the type of residuals to be used for some of of the plots; possible values are: \code{"CP"} (default), \code{"DP"}, \code{"pseudo-CP"}. The various type of residuals only differ by an additive term; see \sQuote{Details} for more information.} \item{which}{if a subset of the plots is required, specify a subset of \code{1:4}; see \sQuote{Details} for a description of the plots.} \item{caption}{a vector of character strings with captions to appear above the plots.} \item{panel}{panel function. The useful alternative to \code{points}, \code{panel.smooth} can be chosen by \code{add.smooth = TRUE}.} \item{main}{title to each plot, in addition to the above caption.} \item{ask}{logical; if \code{TRUE}, the user is asked before each plot.} \item{\dots}{other parameters to be passed through to plotting functions.} % see \sQuote{Details} for restrictions.} \item{id.n}{number of points to be labelled in each plot, starting with the most extreme.} \item{labels.id}{vector of labels, from which the labels for extreme points will be chosen. \code{NULL} uses observation numbers..} \item{cex.id}{magnification of point labels.} \item{identline}{logical indicating if an identity line should be added to QQ-plot and PP-plot (default: \code{TRUE}).} \item{add.smooth}{logical indicating if a smoother should be added to most plots; see also \code{panel} above.} \item{label.pos}{ positioning of labels, for the left half and right half of the graph respectively, for plots 1-3.} \item{cex.caption}{controls the size of \code{caption}.} } \details{ The meaning of \code{param.type} is described in \code{\link{dp2cp}}. However, for these plot only the first parameter component is relevant, which affects the location of the residuals; the other components are not computed. Moreover, for \acronym{QQ}-plot and \acronym{PP}-plot, \acronym{DP}-residuals are used irrespectively of \code{param.type}; see Section \sQuote{Background}. % Graphical parameters can be specified via \code{\dots}, but not those % specified by the function: \code{xlab}, \code{ylab}, \code{cex}. Values \code{which=1} and \code{which=2} have a different effect for object of class \code{"selm"} and class \code{"mselm"}. In the univariate case, \code{which=1} plots the residual values versus the fitted values if \code{p>1}, where \code{p} denotes the number of covariates including the constant; if \code{p=1}, a boxplot of the response is produced. Value \code{which=2} produces an histogram of the residuals with superimposed the fitted curve, when \code{p>1}; if \code{p=1}, a similar plot is generated using the response variable instead of the residuals. Default value for \code{which} is \code{1:4}. In the multivariate case, \code{which=1} is feasible only if \code{p=1} and it displays the data scatter with superimposed the fitted distribution. Value \code{which=2} produces a similar plot but for residuals instead of data. Default value for code{which} is \code{2:4} if \code{p>1}, otherwise \code{c(1,3,4)}. Value \code{which=3} produces a QQ-plot, both in the univariate and in the multivariate case; the difference is that the squares of normalized residuals and suitably defined Mahalanobis distances, respectively, are used in the two cases. Similarly, \code{which=4} produces a PP-plot, working in a similar fashion.} \section{Background}{ Healy-type graphical diagnostics, in the form of QQ- and PP-plots, for the multivariate normal distribution have been extended to the skew-normal distribution by Azzalini and Capitanio (1999, section 6.1), and subsequently to the skew-\eqn{t} distribution in Azzalini and Capitanio (2003). A brief explanation in the univariate \acronym{SN} case is provided in Section 3.1.1 of Azzalini and Capitanio (2014); see also Section 3.1.6. For the univariate \acronym{ST} case, see p.102 and p.111 of the monograph. The multivariate case is discussed in Section 5.2.1 as for the \acronym{SN} distribution, in Section 6.2.6 as for the \acronym{ST} distribution. } \references{ Azzalini, A. and Capitanio, A. (1999). Statistical applications of the multivariate skew normal distribution. \emph{J.Roy.Statist.Soc. B} \bold{61}, 579-602. Full-length version available at \url{http://arXiv.org/abs/0911.2093} Azzalini, A. and Capitanio, A. (2003). Distributions generated by perturbation of symmetry with emphasis on a multivariate skew \emph{t} distribution. \emph{J.Roy. Statist. Soc. B} \bold{65}, 367-389. Full-length version available at \url{http://arXiv.org/abs/0911.2342} Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \seealso{\code{\link{selm}}, \code{\link{dp2cp}}} \examples{ data(wines) # m10 <- selm(flavanoids ~ 1, family="SN", data=wines, subset=(wine=="Barolo")) plot(m10) plot(m10, which=c(1,3)) # fig 3.1 and 3.2(a) of Azzalini and Capitanio (2014) # m18 <- selm(acidity ~ sugar + nonflavanoids + wine, family="SN", data=wines) plot(m18) plot(m18, param.type="DP") # m28 <- selm(cbind(acidity, alcohol) ~ sugar + nonflavanoids + wine, family="SN", data=wines) plot(m28, col=4) # data(ais) m30 <- selm(cbind(RCC, Hg, Fe) ~ 1, family="SN", data=ais) plot(m30, col=2, which=2) } \author{Adelchi Azzalini} \keyword{hplot} sn/man/sn-package.Rd0000644000176200001440000001467212620166365013766 0ustar liggesusers% file sn/man/sn-package.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{sn-package} \docType{package} \encoding{UTF-8} \alias{sn-package} \alias{SN} \concept{skew-elliptical distribution} \concept{skew-normal distribution} \concept{skew-t distribution} \concept{symmetric distribution} \title{Package \pkg{sn}: overview} \description{ The \pkg{sn} package provides facilities to define and manipulate probability distributions of the skew-normal (\acronym{SN}) family and some related ones, notably the skew-\eqn{t} (\acronym{ST}) family, and to apply connected statistical methods for data fitting and diagnostics, in the univariate and the multivariate case. } \section{Development and basic facts}{% The first version of the package was written in 1997 (on CRAN since 1998); subsequent versions have evolved gradually up to version 0.4-18 in May 2013. In January 2014, version 1.0-0 has been uploaded to CRAN; this represented a substantial re-writing of the earlier \sQuote{version 0.x}. Differences between the \sQuote{version 0} and the \sQuote{version 1} series are radical; they concern the core computational and graphical part as well as the user interface. Since version 1.0-0, the S4 protocol for classes and methods has been adopted. Broadly speaking, the available tools can be divided in two groups: the probability section and the statistics section. For a quick start, one could look at their key functions, \code{\link{makeSECdistr}} and \code{\link{selm}}, respectively, and from here explore the rest. In the probability section, one finds also functions \code{\link{dsn}}, \code{\link{dst}}, \code{\link{dmsn}} and others alike; these functions existed also in \sQuote{version 0} and their working is still very much the same (not necessarily so their code). The first version of \sQuote{version 1} series (that is, 1.0-0) has appeared at the same time when the companion book by Azzalini and Capitanio (2014) was published. Although the two projects are formally separate, they adopt the same notation, terminology and logical frame. This matching and the numerous references in the software documentation to specific sections of the book for background information should facilitate familiarizing with these tools. Information on additional and on more recent change to the package is provided in \code{NEWS} file, accessible from the package documentation index page. A word of explanation is appropriate about the numerous references to Azzalini and Capitanio (2014) in the documentation of the package. The reason why the documentation often refers to the monograph rather than to the original research papers is because the book provides a relatively informal summary of material which has been elaborated in a number of technical papers, sometimes very technical or with information on the point of interest mixed with other material. In other words, the motivation behind this policy is readibility, not indulgence in self-citation. When one or a few original sources appeared to deliver the required information in a compact and accessible form, they have been cited directly. In any case, the quoted sections of the book include bibliographic notes which refer back to the original sources. } \section{Backward Compatibility of \sQuote{version 1.x-y}}{% There is a partial backward compatibility of \sQuote{version 1.x-y} versus \sQuote{version 0-4.18}. Some functions of the older version would work as before with virtually no change; a wider set arguments is now allowed. Functions \code{\link{dsn}}, \code{\link{dst}}, \code{\link{dmsn}} and alike fall in this category: in some cases, the names of the arguments have been altered, but they work as before if called with unnamed arguments; similar cases are \code{\link{msn.mle}}, \code{\link{sn.cumulants}} and \code{\link{T.Owen}}. Notice, however, that \code{\link{msn.mle}} and other fitting functions have effectively been subsumed into the more comprehensive fitting function \code{\link{selm}}. A second group of functions will work with little or even minimal changes. Specific examples are functions \code{sn.mle} and \code{st.mle} which have become \code{\link{sn.mple}} and \code{\link{st.mple}}, with some additional arguments (again, one can achieve the same result via \code{\link{selm}}) and \code{dp.to.cp}, which has been replaced by the more general function \code{\link{dp2cp}}. Finally, some functions are not there any longer, with no similarly-working functions in the new version. The more prominent set of cases is represented by the functions for computing profile log-likelihoods. There is a long-term plan to re-instate similar facilities, possibly in a more flexible form, but not in the near future. } \section{Requirements}{ \R version 2.15-3 or higher, plus packages \pkg{mnormt}, \pkg{numDeriv}, \pkg{stats4} in addition to standard packages (\pkg{methods}, \pkg{graphics}, etc.) } \section{Version}{ The command \code{citation("sn")} indicates, among other information, the running version of the package. The most recent version of the package can be obtained from the web page: \url{http://azzalini.stat.unipd.it/SN} which also provides additional related material. From the above-indicated web page, one can also obtain the package \sQuote{sn0} which is essentially the last \sQuote{version 0} (that is, 0.4-18) with suitable renaming of certain ingredients. This allows to have both the current and the old package installed at the same time. } \section{Author}{Adelchi Azzalini. % Dipart. Scienze Statistiche, Università di Padova, Italia. Please send comments, error reports \emph{et cetera} to the author, whose web page is \url{http://azzalini.stat.unipd.it/}. } \section{Licence}{ This package and its documentation are usable under the terms of the \dQuote{GNU General Public License} version 3 or version 2, as you prefer; a copy of them is available from \url{http://www.R-project.org/Licenses/}. While the software is freely usable, it would be appreciated if a reference is inserted in publications or other work which makes use of it. For the appropriate way of referencing it, see the command \code{citation("sn")}. } \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \keyword{multivariate} \keyword{distribution} \keyword{univar} \keyword{regression} sn/man/SECdistrUv-class.Rd0000644000176200001440000000467212504265255015051 0ustar liggesusers% file sn/man/SECdistrUv-class.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{SECdistrUv-class} \Rdversion{1.1} \docType{class} \alias{SECdistrUv-class} \alias{show,SECdistrUv-method} \alias{mean,SECdistrUv-method} \alias{sd,SECdistrUv-method} \title{Class \code{"SECdistrUv"}} \description{Univariate skew-elliptically contoured distributions} \section{Objects from the class}{ Objects can be created by a call to function \code{\link{makeSECdistr}} when its argument \code{dp} is a vector. They can also obtained from an object generated by \code{selm} using the function \code{extractSEDdistr}. } \section{Slots}{ \describe{ \item{\code{family}:}{a character string which selects the parametric family; currently, possible values are: \kbd{"SN"}, \kbd{"ESN"}, \kbd{"ST"}, \kbd{"SC"}. } \item{\code{dp}:}{a numeric vector of parameters; its length depends on the selected \code{family}.} \item{\code{name}:}{a character string with name of the distribution.} } } \section{Methods}{ \describe{ \item{show}{\code{signature(object = "SECdistrUv")}: \dots} \item{plot}{\code{signature(x = "SECdistrUv")}: \dots } \item{summary}{\code{signature(object = "SECdistrUv")}: \dots} \item{mean}{\code{signature(x = "SECdistrUv")}: \dots} \item{sd}{\code{signature(object = "SECdistrUv")}: \dots} } } \author{Adelchi Azzalini} \note{ See \code{\link{makeSECdistr}} for a detailed description of \code{family} and \code{dp}. Unlike various other packages, methods \code{mean} and \code{sd} here are not targeted to data or to a fitted model, but to a \emph{probability distribution} instead, of which they provide the mean value and the standard deviation. If these methods are applied to a distribution of which the mean or the variance do not exist, a \code{NULL} value is returned and a warning message is issued. } \seealso{ \code{\linkS4class{SECdistrMv}}, \code{\link{plot,SECdistrUv-method}}, \code{\link{summary,SECdistrUv-method}}, \code{\link{extractSECdistr}} } \examples{ f2 <- makeSECdistr(dp=c(3, 5, -pi, 6), family="ST", name="My first ST") show(f2) plot(f2) plot(f2, probs=c(1,5,9)/10) plot(f2, range=c(-30,10), probs=NULL, col=2, main=NULL) summary(f2) mean(f2) # the mean value of the probability distribution sd(f2) # the standard deviation of the distribution } \keyword{classes} sn/man/zeta.Rd0000644000176200001440000000457612424125127012713 0ustar liggesusers% file sn/man/zeta.Rd % This file is a component of the package 'sn' for R % copyright (C) 1998,2013 Adelchi Azzalini %--------------------- \name{zeta} \alias{zeta} \concept{Mills ratio} \title{Function \eqn{log(2\Phi(x))} and its derivatives} \description{The function \code{log(2*(pnorm(x))} and its derivatives, including inverse Mills ratio.} \usage{zeta(k, x)} \arguments{ \item{k}{an integer number between 0 and 5.} \item{x}{a numeric vector. Missing values (\code{NA}s) and \code{Inf}s are allowed} } \value{ a vector representing the \code{k}-th order derivative evaluated at \code{x}} \details{ For \code{k} between 0 and 5, the derivative of order \code{k} of \eqn{log(2\Phi(x))} is evaluated, where \eqn{\Phi(x)} denotes the \eqn{N(0,1)} cumulative distribution function. The derivative of order \code{k=0} refers to the function itself. If \code{k} is not integer, it is converted to integer and a warning message is generated. If \code{k<0} or \code{k>5}, \code{NULL} is returned. } \section{Background}{ The computation for \code{k>1} is reduced to the case \code{k=1}, making use of expressions given by Azzalini and Capitanio (1999); see especially Section 4 of the full-length version of the paper. The main facts are summarized in Section 2.1.4 of Azzalini and Capitanio (2014). For numerical stability, the evaluation of \code{zeta(1,x)} when \code{x < -50} makes use of the asymptotic expansion (26.2.13) of Abramowitz and Stegun (1964). \code{zeta(1,-x)} equals \code{dnorm(x)/pnorm(-x)} (in principle, apart from the above-mentioned asymptotic expansion), called the \emph{inverse Mills ratio}. } \references{ Abramowitz, M. and Stegun, I. A., editors (1964). \emph{Handbook of Mathematical Functions}. Dover Publications. Azzalini, A. and Capitanio, A. (1999). Statistical applications of the multivariate skew normal distribution. \emph{J.Roy.Statist.Soc. B} \bold{61}, 579--602. Full-length version available at \url{http://arXiv.org/abs/0911.2093} Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \examples{ y <- zeta(2,seq(-20,20,by=0.5)) # for(k in 0:5) curve(zeta(k,x), from=-1.5, to=5, col = k+2, add = k > 0) legend(3.5, -0.5, legend=as.character(0:5), col=2:7, lty=1) } \keyword{math} sn/man/dsc.Rd0000644000176200001440000000531512354763532012523 0ustar liggesusers% file sn/man/dsc.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{dsc} \alias{dsc} \alias{psc} \alias{qsc} \alias{rsc} \title{Skew-Cauchy Distribution} \description{Density function, distribution function, quantiles and random number generation for the skew-Cauchy (SC) distribution.} \usage{ dsc(x, xi = 0, omega = 1, alpha = 0, dp = NULL, log = FALSE) psc(x, xi = 0, omega = 1, alpha = 0, dp = NULL) qsc(p, xi = 0, omega = 1, alpha = 0, dp = NULL) rsc(n = 1, xi = 0, omega = 1, alpha = 0, dp = NULL) } \arguments{ \item{x}{vector of quantiles. Missing values (\code{NA}s) and \code{Inf}'s are allowed.} \item{p}{vector of probabilities. Missing values (\code{NA}s) are allowed.} \item{xi}{ vector of location parameters.} \item{omega}{vector of (positive) scale parameters.} \item{alpha}{vector of slant parameters.} \item{dp}{a vector of length 3 whose elements represent the parameters described above. If \code{dp} is specified, the individual parameters cannot be set.} \item{n}{sample size.} \item{log}{logical flag used in \code{dsc} (default \code{FALSE}). When \code{TRUE}, the logarithm of the density values is returned.} } \value{density (\code{dsc}), probability (\code{psc}), quantile (\code{qsc}) or random sample (\code{rsc}) from the skew-Cauchy distribution with given \code{xi}, \code{omega} and \code{alpha} parameters or from the extended skew-normal if \code{tau!=0} } \section{Details}{ Typical usages are \preformatted{% dsc(x, xi=0, omega=1, alpha=0, log=FALSE) dsc(x, dp=, log=FALSE) psc(x, xi=0, omega=1, alpha=0) psc(x, dp= ) qsc(p, xi=0, omega=1, alpha=0) qsc(x, dp=) rsc(n=1, xi=0, omega=1, alpha=0) rsc(x, dp=) } } \section{Background}{ The skew-Cauchy distribution can be thought as a skew-\eqn{t} with tail-weight parameter \code{nu=1}. In this case, closed-form expressions of the distribution function and the quantile function have been obtained by Behboodian \emph{et al.} (2006). The key facts are summarized in Complement 4.2 of Azzalini and Capitanio (2014). A multivariate version of the distribution exists. } \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-normal and Related Families}. Cambridge University Press, IMS Monographs series. Behboodian, J., Jamalizadeh, A., and Balakrishnan, N. (2006). A new class of skew-Cauchy distributions. \emph{Statist. Probab. Lett.} \bold{76}, 1488--1493. } \seealso{\code{\link{dst}}, \code{\link{dmsc}}} \examples{ pdf <- dsc(seq(-5,5,by=0.1), alpha=3) cdf <- psc(seq(-5,5,by=0.1), alpha=3) q <- qsc(seq(0.1,0.9,by=0.1), alpha=-2) p <- psc(q, alpha=-2) rn <- rsc(100, 5, 2, 5) } \keyword{distribution} sn/man/ais.Rd0000644000176200001440000000352012262547574012526 0ustar liggesusers% file sn/man/ais.Rd % This file is a component of the package 'sn' for R % copyright (C) 2004-2013 Adelchi Azzalini %--------------------- \name{ais} \alias{ais} \docType{data} \encoding{UTF-8} \title{Australian Institute of Sport data} \description{Data on 102 male and 100 female athletes collected at the Australian Institute of Sport, courtesy of Richard Telford and Ross Cunningham. } \usage{data(ais)} \format{ A data frame with 202 observations on the following 13 variables. \tabular{rll}{ [,1]\tab \code{sex}\tab a factor with levels: \code{female}, \code{male}\cr [,2]\tab \code{sport}\tab a factor with levels: \code{B_Ball}, \code{Field}, \code{Gym}, \code{Netball}, \code{Row},\cr \tab\tab \code{Swim}, \code{T_400m}, \code{Tennis}, \code{T_Sprnt}, \code{W_Polo}\cr [,3]\tab \code{RCC}\tab red cell count (numeric)\cr [,4]\tab \code{WCC}\tab white cell count (numeric)\cr [,5]\tab \code{Hc}\tab Hematocrit (numeric)\cr [,6]\tab \code{Hg}\tab Hemoglobin (numeric)\cr [,7]\tab \code{Fe}\tab plasma ferritin concentration (numeric)\cr [,8]\tab \code{BMI}\tab body mass index, weight/(height)\eqn{^2}{²} (numeric)\cr [,9]\tab \code{SSF}\tab sum of skin folds (numeric)\cr [,10]\tab \code{Bfat}\tab body fat percentage (numeric)\cr [,11]\tab \code{LBM}\tab lean body mass (numeric)\cr [,12]\tab \code{Ht}\tab height, cm (numeric)\cr [,13]\tab \code{Wt}\tab weight, kg (numeric)\cr } } \details{The data have been made publicly available in connection with the book by Cook and Weisberg (1994).} \references{ Cook and Weisberg (1994), \emph{An Introduction to Regression Graphics}. John Wiley & Sons, New York. } \examples{ data(ais, package="sn") pairs(ais[,c(3:4,10:13)], col=as.numeric(ais[,1]), main = "AIS data") } \keyword{datasets} sn/man/T.Owen.Rd0000644000176200001440000000322712255656233013063 0ustar liggesusers% file sn/man/T.Owen.Rd % This file is a component of the package 'sn' for R % copyright (C) 1997-2013 Adelchi Azzalini %--------------------- \name{T.Owen} \alias{T.Owen} \title{ Owen's function } \description{ Evaluates function \eqn{T(h,a)} studied by D.B.Owen } \usage{ T.Owen(h, a, jmax=50, cut.point=8) } \arguments{ \item{h}{ a numerical vector. Missing values (\code{NA}s) and \code{Inf} are allowed. } \item{a}{ a numerical scalar. \code{Inf} is allowed. } \item{jmax}{ an integer scalar value which regulates the accuracy of the result. See the section Details below for explanation. } \item{cut.point}{ a scalar value which regulates the behaviour of the algorithm, as explained by the details below (default value: \code{8}). }} \value{ a numerical vector } \details{ If \code{a>1} and \code{01} and \code{h>cut.point}, an asymptotic approximation is used. In the other cases, various reflection properties of the function are exploited. See the reference below for more information. } \section{Background}{ The function \emph{T(h,a)} studied by Owen (1956) is useful for the computation of the bivariate normal distribution function and related quantities, including the distribution function of a skew-normal variate; see \code{psn}. See the reference below for more information on function \eqn{T(h,a)}. } \author{Adelchi Azzalini and Francesca Furlan} \references{ Owen, D. B. (1956). Tables for computing bivariate normal probabilities. \emph{Ann. Math. Statist.} \bold{27}, 1075-1090. } \seealso{ \code{\link{psn}}} \examples{ owen <- T.Owen(1:10, 2)} \keyword{math} sn/man/summary.selm.Rd0000644000176200001440000001103712434141321014365 0ustar liggesusers% file sn/man/summary.selm.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{summary.selm} \alias{summary.selm} \alias{summary.mselm} \alias{summary,selm-method} \alias{summary,mselm-method} \alias{summary.selm-class} \alias{summary.mselm-class} \alias{show,summary.selm-method} \alias{show,summary.mselm-method} \title{Summarizing \code{selm} fits} \description{\code{summary} method for class \code{"selm"} and \code{"mselm"}.} \usage{ \S4method{summary}{selm}(object, param.type = "CP", cov = FALSE, cor = FALSE) \S4method{summary}{mselm}(object, param.type = "CP", cov = FALSE, cor = FALSE) } \arguments{ \item{object}{an object of class \code{"selm"} or \code{"mselm"} as created by a call to function \code{selm}.} \item{param.type}{a character string which indicates the required type of parameter type; possible values are \code{"CP"} (default), \code{"DP"}, \code{"pseudo-CP"} and their equivalent lower-case expressions.} \item{cov}{a logical value, to indicate if an estimate of the variance and covariance matrix of the estimates is required (default: \code{FALSE}).} \item{cor}{a logical value, to indicate if an estimate of the correlation matrix of the estimates is required (default: \code{FALSE}).} } \value{An S4 object of class \code{summary.selm} with 12 slots. \item{\code{call}:}{the calling statement.} \item{\code{family}:}{the parametric family of skew-ellitically contoured distributed (\acronym{SEC}) type.} \item{\code{logL}:}{the maximized log-likelihood or penalized log-likelihood value} \item{\code{method}:}{estimation method (\code{"MLE"} or \code{"MPLE"})} \item{\code{param.type}:}{a characer string with the chosen parameter set.} \item{\code{param.table}:}{table of parameters, std.errors and z-values} \item{\code{fixed.param}:}{a list of fixed parameter values} \item{\code{resid}:}{residual values} \item{\code{control}:}{a list with control parameters} \item{\code{aux}:}{a list of auxiliary quantities} \item{\code{size}:}{a numeric vector with various lengths and dimensions} \item{\code{boundary}:}{a logical value which indicates whether the estimates are on the boundary of the parameter space} } \note{ There are two reasons why the default choice of \code{param.type} is \code{CP}. One is the the easier interpretation of cumulant-based quantities such as mean value, standard deviation, coefficient of skewness. The other reason is more technical and applies only to cases when the estimate of the slant parameter \eqn{alpha} of the \acronym{SN} distribution is close to the origin: standard asymptotic distribution theory of maximum likelihood estimates (MLE's) does not apply in this case and the corresponding standard errors are not trustworthy. The problem is especialy severe at \eqn{\alpha=0} but to some extent propagates to its vicinity. If \eqn{d=1}, adoption of \code{CP} leads to MLE's with regular asymptotic distribution across the parameter space, including \eqn{\alpha=0}. For \eqn{d>1} and \eqn{\alpha=0,} the problem is still unsolved at the present time, which is the reason why \code{selm} issues a warning message when the MLE is in the vicinity of \eqn{\alpha=0}; see \sQuote{Details} of \code{\link{selm}}. For background information, see Sections 3.1.4--6 and 5.2.3 of Azzalini and Capitanio (2014) and references therein. This problem does not occur with the the \acronym{SC} and the \acronym{ST} distribution (unless its tail-weight parameter \code{nu} diverges, that is, when we are effectively approaching the \code{SN} case). } \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \author{Adelchi Azzalini} \seealso{ \code{\link{selm}} function, \code{\linkS4class{selm}} (and \code{mselm}) class, \code{\link{plot.selm}}, \code{\link{dp2cp}} } \examples{ data(wines, package="sn") m5 <- selm(acidity ~ phenols + wine, family="SN", data=wines) summary(m5) summary(m5, "dp") s5 <- summary(m5, "dp", cor=TRUE, cov=TRUE) dp.cor <- slot(s5, "aux")$param.cor cov2cor(vcov(m5, "dp")) # the same # # m6 <- selm(acidity ~ phenols + wine, family="ST", data=wines) # boundary!? # m12 <- selm(cbind(acidity, alcohol) ~ phenols + wine, family="SN", data=wines) s12 <- summary(m12) coef(m12, 'dp') coef(m12, "dp", vector=FALSE) # # see other examples at function selm } \keyword{regression} sn/man/selm.fit.Rd0000644000176200001440000002321212524610602013453 0ustar liggesusers% file sn/man/selm.fit.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{selm.fit} \alias{selm.fit} \alias{sn.mple} \alias{st.mple} \alias{msn.mle} \alias{msn.mple} \alias{mst.mple} \title{Fitting functions for \code{selm} models} \description{A call to \code{selm} activates a call to \code{selm.fit} and from here to some other function which actually performs the parameter search, among those listed below. These lower-level functions can be called directly for increased efficiency, at the expense of some more programming effort and lack of methods for the returned object.} \usage{ selm.fit(x, y, family = "SN", start = NULL, w, fixed.param = list(), offset = NULL, selm.control) sn.mple(x, y, cp = NULL, w, penalty = NULL, trace = FALSE, opt.method = c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control = list()) st.mple(x, y, dp = NULL, w, fixed.nu = NULL, symmetr = FALSE, penalty = NULL, trace = FALSE, opt.method = c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control = list()) msn.mle(x, y, start = NULL, w, trace = FALSE, opt.method = c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control = list()) msn.mple(x, y, start = NULL, w, trace = FALSE, penalty = NULL, opt.method = c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control = list()) mst.mple(x, y, start = NULL, w, fixed.nu = NULL, symmetr=FALSE, penalty = NULL, trace = FALSE, opt.method = c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"), control = list()) } \arguments{ \item{x}{a full-rank design matrix with the first column of all 1's.} \item{y}{a vector or a matrix of response values such that \code{NROW(y)=nrow(x)}.} \item{family}{a character string which selects the parametric family of distributions assumed for the error term of the regression model. It must one of \code{"SN"} (default), \code{"ST"} or \code{"SC"}, which correspond to the skew-normal, the skew-\emph{t} and the skew-Cauchy family, respectively. See \code{\link{makeSECdistr}} for more information on these families and the skew-elliptically contoured (\acronym{SEC}) distributions; notice that family \code{"ESN"} is not allowed here.} \item{start, dp, cp}{a vector or a list of initial parameter values, depeding whether \code{y} is a vector or a matrix. It is assumed that \code{cp} is given in the \acronym{CP} parameterization, \code{dp} and \code{start} in the \acronym{DP} parameterization. } \item{w}{a vector of non-negative integer weights of length equal to \code{NROW(y)}; if missing, a vector of all 1's is generated.} \item{fixed.param}{a list of assignments of parameter values to be kept fixed during the optimization process. Currently, there is only one such option, namely \code{fixed.param=list(nu='value')}, to fix the degrees of freedom at the named \code{'value'} when \code{family="ST"}, for instance \code{list(nu=3)}. Setting \code{fixed.param=list(nu=1)} is equivalent to select \code{family="SC"}.} \item{penalty}{an optional character string with the name of the penalty function of the log-likelihood; default value \code{NULL} corresponds to no penalty.} \item{offset}{this can be used to specify an \emph{a priori} known component to be included in the linear predictor during fitting. This should be \code{NULL} or a numeric vector of length equal to the number of cases. One or more \code{\link{offset}} terms can be included in the formula instead or as well, and if more than one are specified their sum is used.} %See \code{\link[stats]{model.offset}.} \item{trace}{a logical value which regulates printing of successive calls to the target function; default value is \code{FALSE} which suppresses printing.} \item{fixed.nu}{a positive value to keep fixed the parameter \code{nu} of the \acronym{ST} distribution in the optimization process; with default value \code{NULL}, \code{nu} is estimated like the other parameters.} \item{symmetr}{a logical flag indicating whether a contraint of symmetry is imposed on the slant parameter; default is \code{symmetr=FALSE}.} \item{opt.method}{a character string which selects the optimization method within the set \code{c("nlminb", "Nelder-Mead", "BFGS", "CG", "SANN")}; the last four of these are \code{"methods"} of function \code{optim}.} \item{selm.control}{a list whose components regulate the working of \code{selm.fit}; see \sQuote{Details} for their description;} \item{control}{a list of control items passed to the optimization function.} } \details{ A call to \code{selm} produces a call to \code{selm.fit} which selects the appropriate function among \code{sn.mple}, \code{st.mple}, \code{msn.mle}, \code{msn.mple}, \code{mst.mple}, depending on the arguments of the calling statement. In the adopted scheme for function names, \code{msn} refers to a multivariate skew-normal distribution and \code{mst} refers to a multivariate skew-\eqn{t} distribution, while \code{mle} and \code{mple} refers to maximum likelihood and maximum penalized likelihood estimation, respectively. Of these functions, \code{sn.mple} works in \acronym{CP} space; the others in the \acronym{DP} space. In all cases, a correspondig mapping to the alternative parameter space is performed before exiting \code{selm.fit}, in addition to the selected parameter set. The components of \code{selm.control} are as follows: \itemize{ \item \code{method}: the estimation method, \code{"MLE"} or \code{"MPLE"}. \item \code{penalty}: a string with the name of the penalty function. \item \code{info.type}: a string with the name of the information matrix, \code{"observed"} or \code{"expected"}; currently fixed at "observed". \item \code{opt.method}: a character string which selects the optimization method. \item \code{opt.control}: a list of control parameters of \code{opt.method}. } Function \code{msn.mle}, for \acronym{MLE} estimation of linear models with \acronym{SN} errors, is unchanged from version 0.4-x of the package. Function \code{msn.mple} is similar to \code{msn.mle} but allows to introduce a penalization of the log-likelihood; when \code{penalty=NULL}, a call to \code{msn.mle} is more efficient. Functions \code{sn.mple} and \code{mst.mple} work like \code{sn.mle} and \code{mst.mle} in version 0.4-x if the argument \code{penalty} is not set or it is set to \code{NULL}, except that \code{mst.mple} does not handle a univariate response (use \code{st.mple} for that). } \value{A list whose specific components depend on the named function. Typical components are: \item{call}{the calling statement} \item{dp}{vector or list of estimated \acronym{DP} parameters} \item{cp}{vector or list of estimated \acronym{CP} parameters} \item{logL}{the maximized (penalized) log-likelihood} \item{aux}{a list with auxiliary output values, depending on the function} \item{opt.method}{a list produced by the numerical \code{opt.method}} } \section{Background}{ Computational aspects of maximum likelihood estimation for univariate \acronym{SN} distributions are discussed in Section 3.1.7 of Azzalini and Capitanio (2014). The working of \code{sn.mple} follows these lines; maximization is performed in the \acronym{CP} space. All other functions operate on the \acronym{DP} space. The technique underlying \code{msn.mle} is based on a partial analytical maximization, leading implicitly to a form of profile log-likelihood. This scheme is formulated in detail in Section 6.1 of Azzalini and Capitanio (1999) and summarized in Section 5.2.1 of Azzalini and Capitanio (2014). The same procedure is not feasible when one adopts \acronym{MPLE}; hence function \code{msn.mple} has to maximize over a larger parameter space. Maximization of the univariate \acronym{ST} log-likelihood is speeded-up by using the expressions of the gradient given by DiCiccio and Monti (2011), reproduced with inessential variants in Section 4.3.3 of Azzalini and Capitanio (2014). The working of \code{mst.mple} is based on a re-parameterization described in Section 5.1 of Azzalini and Capitanio (2003). The expressions of the corresponding log-likelihood derivatives are given in Appendix B of the full version of the paper. } \references{ Azzalini, A. and Capitanio, A. (1999). Statistical applications of the multivariate skew normal distribution. \emph{J.Roy.Statist.Soc. B} \bold{61}, 579--602. Full-length version available at \url{http://arXiv.org/abs/0911.2093} Azzalini, A. and Capitanio, A. (2003). Distributions generated by perturbation of symmetry with emphasis on a multivariate skew \emph{t} distribution. \emph{J.Roy. Statist. Soc. B} \bold{65}, 367--389. Full-length version available at \url{http://arXiv.org/abs/0911.2342} Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. DiCiccio, T. J. and Monti, A. C. (2011). Inferential aspects of the skew \eqn{t}-distribution. \emph{Quaderni di Statistica} \bold{13}, 1--21. } \author{Adelchi Azzalini} % \note{} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{selm}} for a comprehensive higher level fitting function, \code{\link{Qpenalty}} for specification of a penalty function } \examples{ data(wines, package="sn") X <- model.matrix(~ phenols + wine, data=wines) fit <- msn.mle(x=X, y=cbind(wines$acidity, wines$alcohol), opt.method="BFGS") fit <- st.mple(x=X, y = wines$acidity, fixed.nu=4, penalty="Qpenalty") } \keyword{regression} \keyword{multivariate} sn/man/summary.SECdistr.Rd0000644000176200001440000000723612561734246015132 0ustar liggesusers% file sn/man/summary.SECdistr.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013-2015 Adelchi Azzalini %--------------------- \name{summary.SECdistr} \alias{summary.SECdistr} \alias{summary.SECdistrUv} \alias{summary.SECdistrMv} \alias{summary,SECdistrUv-method} \alias{summary,SECdistrMv-method} \title{Summary of a \acronym{SEC} distribution object} \description{Produce a summary of an object of class either \code{"SECdistrUv"} or \code{"SECdistrMv"}, which refer to a univariate or a multivariate \acronym{SEC} distribution, respectively. Both types of objects can be produced by \code{makeSECditr}. } \usage{ \S4method{summary}{SECdistrUv}(object, cp.type = "auto", probs) \S4method{summary}{SECdistrMv}(object, cp.type = "auto") } \arguments{ \item{object}{an object of class \code{"SECdistrUv"} or \code{"SECdistrMv"}.} \item{cp.type}{a character string to select the required variance of \acronym{CP} parameterization; possible values are \code{"proper"}, \code{"pseudo"}, \code{"auto"} (default). For a description of these codes, see \code{\link{dp2cp}}.} \item{probs}{in the univariate case, a vector of probabilities for which the corresponding quantiles are required. If missing, the vector \code{c(0.05, 0.25, 0.50, 0.75, 0.95)} is used.} } %\details{%% ~~ If necessary, more details than the description above ~~} \value{A list with the following components: \item{family}{name of the family within the \acronym{SEC} class, character} \item{dp}{\acronym{DP} parameters, a list or a vector} \item{name}{the name of the distribution, character string} \item{compNames}{in the multivariate case the names of the components, a character vector} \item{cp}{\acronym{CP} parameters, a list or a vector} \item{cp.type}{the name of the selected variant of the \acronym{CP} set} \item{aux}{a list with auxiliary ingredients (mode, coefficients of skewness and kurtosis, in the parametric and non-parametric variants, and more).} \acronym{DP} and \acronym{CP} are vectors if \code{class(object)} is \code{SECdistrUv} (univariate distribution); they are lists if code{class(object)} is \code{SECdistrMv} (multivariate distribution). The examples below show how extract components from \code{aux} and other slots. } \author{Adelchi Azzalini} %\note{%% ~~further notes~~} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{makeSECdistr}} for extracting a \acronym{SEC} distribution from a \code{\link{selm}} fit methods \code{\link[base]{mean}} and \code{\link[stats]{vcov}} for computing the mean (vector) and the variance (matrix) of \code{\link{SECdistrUv-class}} and \code{\link{SECdistrMv-class}} objects } \examples{ f3 <- makeSECdistr(dp=c(3,2,5), family="SC") summary(f3) s <- summary(f3, probs=(1:9)/10) print(slotNames(s)) print(names(slot(s,"aux"))) # the components of the 'aux' slot slot(s, "aux")$mode # the same of modeSECdistr(object=f3) slot(s, "aux")$q.measures # quantile-based measures of skewness and kurtosis # dp3 <- list(xi=1:3, Omega=toeplitz(1/(1:3)), alpha=c(-3, 8, 5), nu=6) st3 <- makeSECdistr(dp=dp3, family="ST", compNames=c("U", "V", "W")) s <- summary(st3) dp <- slot(s, "dp") # the same of slot(st3, "dp") slot(s, "cp")$var.cov # the same of vcov(st3) slot(s, "aux")$delta.star # comprehensive coefficient of shape slot(s, "aux")$mardia # Mardia's measures of asymmetry and kurtosis # dp2 <- list(xi=rep(0,2), Omega=matrix(c(2,2,2,4),2,2), alpha=c(3,-5), tau=-1) esn2 <- makeSECdistr(dp=dp2, family="ESN", name="ESN-2d") summary(esn2) } \keyword{multivariate} \keyword{distribution} sn/man/makeSECdistr.Rd0000644000176200001440000001332312565376101014262 0ustar liggesusers% file sn/man/makeSECdistr.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013-2014 Adelchi Azzalini %--------------------- \name{makeSECdistr} \encoding{UTF-8} \alias{makeSECdistr} \concept{skew-elliptical distribution} \title{Build a skew-elliptically contoured distribution} \description{Build an object which identifies a skew-elliptically contoured distribution (\acronym{SEC}), in the univariate and in the multivariate case. The term \sQuote{skew-elliptical distribution} is a synonym of \acronym{SEC} distribution.} \usage{makeSECdistr(dp, family, name, compNames)} \arguments{ \item{dp}{a numeric vector (in the univariate case) or a list (in the multivariate case) of parameters which identify the specific distribution within the named \code{family}. See \sQuote{Details} for their expected structure.} \item{family}{a character string which identifies the parametric family; currently, possible values are: \kbd{"SN"}, \kbd{"ESN"}, \kbd{"ST"}, \kbd{"SC"}. See \sQuote{Details} for additional information.} \item{name}{an optional character string with the name of the distribution. If missing, one is created.} \item{compNames}{in the multivariate case, an optional vector of character strings with the names of the component variables; its length must be equal to the dimensionality of the distribution being generated. If missing and the first component of \code{dp} is a named vector, its names used as \code{compNames}; otherwise the components are named \code{"V1"}, \code{"V2"}, \dots} } \details{If \code{dp} is a numeric vector, a univariate distribution is built. Alternatively, if \code{dp} is a list, a multivariate distribution is built. In both cases, the required number of components of \code{dp} depends on \code{family}: it must be \code{3} for \kbd{"SN"} and \kbd{"SC"}; it must be \code{4} for \kbd{"ESN"} and \kbd{"ST"}. In the univariate case, the first three components of \code{dp} represent what for the specific distributions are denoted \code{xi} (location), \code{omega} (scale, positive) and \code{alpha} (slant); see functions \code{\link{dsn}}, \code{\link{dst}}, \code{\link{dsc}} for their description. The fourth component, when it exists, represents either \code{tau} (hidden variable mean) for \kbd{"ESN"} or \code{nu} (degrees of freedom) for \kbd{"ST"}. The names of the individual parameters are attached to the components of \code{dp} in the returned object. In the multivariate case, \code{dp} is a list with components having similar role as in the univariate case, but \code{xi=dp[[1]]} and \code{alpha=dp[[3]]} are now vectors and the scale parameter \code{Omega=dp[[2]]} is a symmetric positive-definite matrix. For a multivariate distribution of dimension 1 (which can be created, although a warning message is issued), \code{Omega} corresponds to the square of \code{omega} in the univariate case. Vectors \code{xi} and \code{alpha} must be of length \code{ncol(Omega)}. See also functions \code{\link{dmsn}}, \code{\link{dmst}} and \code{\link{dmsc}}. The fourth component, when it exists, is a scalar with the same role as in the univariate case. In the univariate case \code{alpha=Inf} is allowed, but in the multivariate case all components of the vector \code{alpha} must be finite. } \section{Background}{ For background information, see Azzalini and Capitanio (2014), specifically Chapters 2 and 4 for univariate cases, Chapters 5 and 6 for multivariate cases; Section 6.1 provides a general formulation of \acronym{SEC} distributions. If the slant parameter \code{alpha} is \code{0} (or a vector of \code{0}'s, in the multivariate case), the distribution is of classical elliptical type. Among the admissible families, the \acronym{ESN} distribution is not, strictly speaking, of \acronym{SEC} type, but it is nevertheless included because of its strong connection. } \value{In the univariate case, an object of class \code{SECdistrUv}; in the multivariate case, an object of class \code{SECdistrMv}. See \code{\link{SECdistrUv-class}} and \code{\link{SECdistrMv-class}} for their description. } \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \author{Adelchi Azzalini} \seealso{ The description of classes \code{\link{SECdistrUv-class}} and \code{\link{SECdistrMv-class}} \code{\link{plot.SECdistr}} for plotting and \code{\link{summary.SECdistr}} for summaries Related functions \code{\link{dsn}}, \code{\link{dst}}, \code{\link{dsc}}, \code{\link{dmsn}}, \code{\link{dmst}}, \code{\link{dp2cp}} Functions \code{\link{affineTransSECdistr}} and \code{\link{conditionalSECdistr}} to manipulate objects of class \code{\link{SECdistrMv-class}} Function \code{\link{extractSECdistr}} to extract objects of class \code{\link{SECdistrMv-class}} and \code{\link{SECdistrUv-class}} representing the \acronym{SEC} distribution of a \code{\link{selm}} fit } \examples{ f1 <- makeSECdistr(dp=c(3,2,5), family="SN", name="First-SN") show(f1) summary(f1) plot(f1) plot(f1, probs=c(0.1, 0.9)) # f2 <- makeSECdistr(dp=c(3, 5, -4, 8), family="ST", name="First-ST") f9 <- makeSECdistr(dp=c(5, 1, Inf, 0.5), family="ESN", name="ESN,alpha=Inf") # dp0 <- list(xi=1:2, Omega=diag(3:4), alpha=c(3, -5)) f10 <- makeSECdistr(dp=dp0, family="SN", name="SN-2d", compNames=c("u1", "u2")) # dp1 <- list(xi=1:2, Omega=diag(1:2)+outer(c(3,3),c(2,2)), alpha=c(-3, 5), nu=6) f11 <- makeSECdistr(dp=dp1, family="ST", name="ST-2d", compNames=c("t1", "t2")) } \keyword{distribution} \keyword{multivariate} sn/man/profile.selm.Rd0000644000176200001440000001570612620333412014340 0ustar liggesusers% file sn/man/profile.selm.Rd % This file is a component of the package 'sn' for R % copyright (C) 2015 Adelchi Azzalini %--------------------- \name{profile.selm} \alias{profile.selm} \alias{profile.selm-method} \concept{confidence interval} \concept{confidence region} \title{Profile log-likelihood function of selm-class objects} \description{ One- or two-dimensional profile (penalized) log-likelihood function of a \code{selm} fit and corresponding confidence interval or regions } \usage{ \S3method{profile}{selm}(fitted, param.type, param.name, param.values, npt, opt.control = list(), plot.it = TRUE, log = TRUE, level, trace = FALSE, ...) } \arguments{ \item{fitted}{an object of class \code{selm} as produced by a call to function \code{selm} with univariate response.} \item{param.type}{ a character string with the required parameterization; it must be either \code{"CP"} or \code{"DP"}, or possibly their equivalent lowercase.} \item{param.name}{ either a single character string or a vector of two such terms with the name(s) of the parameter(s) for which the profile log-likelihood is required; these names must match those appearing in \code{\link{summary.selm}(object, param.type)}.} \item{param.values}{in the one-parameter case, a numeric vector with the values where the log-likelihood must be evaluated; in the two-parameter case, a list of two such vectors used to build a grid of coordinates of points. Their range must identify an interval or a rectangle which includes the \acronym{MLE} or \acronym{MPLE} obtained by \code{\link{selm}}. See \sQuote{Details} for more information.} \item{npt}{ in case the vector or any of the vectors of argument \code{param.values} has length 2, an equally spaced grid of values is build with length equal to the corresponding component of \code{npt}. If the above condition is met but this argument is missing, a default choice is made, namely 51 or (26,26) in the one- or two-parameter case, respectively.} \item{opt.control}{ an optional list passed as argument \code{control} to \code{optim} to optimize the log-likelihood; see \sQuote{Details} for more information.} \item{plot.it}{a logical value; if \code{TRUE} (default value), a plot is produced representing the deviance, which is described in \sQuote{Details} below. In the one-parameter case, a confidence interval of prescribed \code{level} is marked on the plot; in the two-parameter case, the contour curves are labelled with approximate confidence levels. See however for more information. } \item{log}{a logical value (default: \code{TRUE}) indicating whether the scale and tail-weight parameters must be log-transformed, if case any of them occurs in \code{param.name}. This applied to \code{omega} and \code{nu} in the \code{DP} parameter set and to \code{s.d.} and \code{gamma2} in the \code{CP} parameter set.} \item{level}{a single probability value (in the one-parameter case) or a vector of such values (in the two-parameter case) for which the confidence interval or region is requited; see \sQuote{Details} for more information.} \item{trace}{a logical value (default: \code{FALSE}) to activate printing of intermediate outcome of the log-likelihood optimization process} \item{\dots}{optional graphical parameters passed to the plotting functions.} } \details{ For each chosen point of the parameter(s) to be profiled, the log-likelihood is maximized with respect to the remaining parameters. The optimization process is accomplished using the \code{\link[stats]{optim}} optimization function, with \code{method="BFGS"}. This step can be regulated by the user via \code{opt.control} which is passed to \code{\link[stats]{optim}} as \code{control} argument, apart from element \code{fnscale} whose use is reserved. If the original \code{fitted} object included a fixed parameter value, this is kept fixed here. If the estimation method was \code{"MPLE"}, that choice carries on here; in case the penalty function was user-defined, it must still be accessible. For plotting purposes and also in the numerical output, the deviance function \eqn{D} is used, namely \deqn{D = 2\left[\max(\log L) - \log L\right]}{D = 2*[max(log L)- log L]} where \eqn{L} denotes the likelihood. The range of \code{param.values} must enclose the maximum (penalized) likelihood estimates (\acronym{MLE} or \acronym{MPLE}) by an adequate extent such that suitable confidence intervals or regions can be established from standard asymptotic theory. For the \acronym{SN} family and \acronym{DP} parameterization, the asymptotic theory is actually non-standard near the important point \eqn{\alpha=0}, but the correspondence with the regular case of the \acronym{CP} parameterization, still allows to derive confidence regions using standard procedures; for more information on this point, see Section 3.1.6 of Azzalini and Capitanio (2014). When the \acronym{MLE} occurs on the frontier of the parameter space, a message is issued and no confidence interval is produced, while in the two-parameter case the plot is not labelled with probability values, but only deviance levels. } \value{An invisible list whose components, described below, are partly different in the one- and the two-parameter cases. \item{call}{the calling statement} \item{}{values of the first parameter} \item{}{values of the second parameter (in a two-parameter case)} \item{logLik}{numeric vector or matrix of the profile log-likelihood values} \item{confint}{in the one-parameter case, the confidence interval} \item{level}{in the one-parameter case, the confidence level} \item{deviance.contour}{in the two-parameter case, a list of lists whose elements identify each curve of the contour plot} } \author{Adelchi Azzalini} \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } % \note{} \section{Warnings}{ \itemize{ \item This function is experimental and changes in future versions of the package may occur. Users should not rely on the persistence of the same user interface or the same name. \item It is a known fact that, in some critical situations, peculiar outcomes are produced. }} \seealso{ \code{\link{selm}}, \code{\link{summary.selm}}, \code{\link{makeSECdistr}} for the \acronym{CP}/\acronym{DP} parameterizations, \code{\link[stats]{optim}} for its \code{control} argument } \examples{ data(ais) m1 <- selm(log(Fe) ~ BMI + LBM, family = "sn", data = ais) pll <- profile(m1, "dp", param.name="alpha", param.val=c(-3,2)) profile(m1, "cp", param.name="gamma1", param.val=seq(-0.7, 0.5, by=0.1)) # reduce grid points to save time pll <- profile(m1, "cp", param.name=c("(Intercept.CP)", "gamma1"), param.val=list(c(1.5, 4), c(-0.8, 0.5)), npt=c(11,16) ) } sn/man/coef.selm.Rd0000644000176200001440000000437612503264064013623 0ustar liggesusers% file sn/man/coef.selm.Rd % This file is a component of the package 'sn' for R % copyright (C) 2014 Adelchi Azzalini %--------------------- \name{coef.selm} \alias{coef.selm} \alias{coef.mselm} \alias{coef,selm-method} \alias{coef,mselm-method} \title{Coefficients of objects created by \code{selm}} \description{ \code{coef} method for classes \code{"selm"} and \code{"mselm"}.} \usage{ \S4method{coef}{selm}(object, param.type = "CP", ...) \S4method{coef}{mselm}(object, param.type = "CP", vector=TRUE, ...) } \arguments{ \item{object}{an object of class \code{"selm"} or \code{"mselm"} as created by a call to function \code{selm}.} \item{param.type}{a character string which indicates the required type of parameter type; possible values are \code{"CP"} (default), \code{"DP"}, \code{"pseudo-CP"} and their equivalent lower-case expressions.} \item{vector}{a logical value (default is \code{TRUE}) which selects a vector or a list format of the retuned value} \item{...}{not used, included for compatibility with the generic method} } \value{a numeric vector or a list (the latter only for \code{mselm-class} objects if \code{vector=FALSE}) } \note{The possible options of \code{param.type} are described in the documentation of \code{\link{dp2cp}}; their corresponding outcomes differ by an additive constant only. With the \code{"CP"} option (that is, the \sQuote{centred parametrization}), the residuals are centred around 0, at least approximately; this is a reason for setting \code{"CP"} as the default option. For more information, see the \sQuote{Note} in the documentation of \code{\link{summary.selm}}. } \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \author{Adelchi Azzalini} \seealso{ \code{\link{dp2cp}}, \code{\link{summary.selm}}, \code{\link{selm}} function, \code{\linkS4class{selm}-class} } \examples{ data(wines, package="sn") m5 <- selm(acidity ~ phenols + wine, family="SN", data=wines) coef(m5) coef(m5, "dp") # m12 <- selm(cbind(acidity, alcohol) ~ phenols + wine, family="SN", data=wines) coef(m12) coef(m12, "DP", vector=FALSE) } \keyword{regression} sn/man/wines.Rd0000644000176200001440000000721312567341211013066 0ustar liggesusers% file sn/man/wines.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{wines} \alias{wines} \docType{data} \encoding{UTF-8} \title{Piedmont wines data} \description{Data refer to chemical properties of 178 specimens of three types of wine produced in the Piedmont region of Italy. } \usage{data(wines)} \format{ A data frame with 178 observations on the following 28 variables. \tabular{ll}{% \code{wine}\tab wine name (categorical variable % i.e. factor, with levels \code{Barbera}, \code{Barolo}, \code{Grignolino})\cr \code{alcohol}\tab alcohol percentage (numeric)\cr \code{sugar}\tab sugar-free extract (numeric)\cr \code{acidity}\tab fixed acidity (numeric)\cr \code{tartaric}\tab tartaric acid (numeric)\cr \code{malic}\tab malic acid (numeric)\cr \code{uronic}\tab uronic acids (numeric)\cr \code{pH}\tab pH (numeric)\cr \code{ash}\tab ash (numeric)\cr \code{alcal_ash}\tab alcalinity of ash (numeric)\cr \code{potassium}\tab potassium (numeric)\cr \code{calcium}\tab calcium (numeric)\cr \code{magnesium}\tab magnesium (numeric)\cr \code{phosphate}\tab phosphate (numeric)\cr \code{cloride}\tab chloride (numeric)\cr \code{phenols}\tab total phenols (numeric)\cr \code{flavanoids}\tab flavanoids (numeric)\cr \code{nonflavanoids}\tab nonflavanoid phenols (numeric)\cr \code{proanthocyanins}\tab proanthocyanins (numeric)\cr \code{colour}\tab colour intensity (numeric)\cr \code{hue}\tab hue (numeric)\cr \code{OD_dw}\tab \eqn{OD_{280}/OD_{315}}{OD₂??/OD₃₁?} of diluted wines (numeric)\cr \code{OD_fl}\tab \eqn{OD_{280}/OD_{315}}{OD₂??/OD₃₁?} of flavanoids (numeric)\cr \code{glycerol}\tab glycerol (numeric)\cr \code{butanediol}\tab 2,3-butanediol (numeric)\cr \code{nitrogen}\tab total nitrogen (numeric)\cr \code{proline}\tab proline (numeric)\cr \code{methanol}\tab methanol (numeric)\cr } } \details{ The data represent 27 chemical measurements on each of 178 wine specimens belonging to three types of wine produced in the Piedmont region of Italy. The data have been presented and examined by Forina \emph{et al.} (1986) and were freely accessible from the \acronym{PARVUS} web-site until it was active. These data or, more often, a subset of them are now available from various places, including some \R packages. The present dataset includes all variables available on the \acronym{PARVUS} repository, which are the variables listed by Forina \emph{et al.} (1986) with the exception of \sQuote{Sulphate}. Moreover, it reveals the undocumented fact that the original dataset appears to include also the vintage year; see the final portion of the \sQuote{Examples} below.} \source{ Forina, M., Lanteri, S. Armanino, C., Casolino, C., Casale, M. and Oliveri, P. \acronym{V-PARVUS 2008}: an extendible package of programs for esplorative data analysis, classification and regression analysis. Dip. Chimica e Tecnologie Farmaceutiche ed Alimentari, Università di Genova, Italia. Web-site (not accessible as of 2014): \samp{http://www.parvus.unige.it} } \references{ Forina M., Armanino C., Castino M. and Ubigli M. (1986). Multivariate data analysis as a discriminating method of the origin of wines. \emph{Vitis} \bold{25}, 189--201. } \examples{ data(wines) pairs(wines[,c(2,3,16:18)], col=as.numeric(wines$wine)) # code <- substr(rownames(wines), 1, 3) table(wines$wine, code) # year <- as.numeric(substr(rownames(wines), 6, 7)) table(wines$wine, year) # coincides with Table 1(a) of Forina et al. (1986) } \keyword{datasets} sn/man/sn-st.cumulants.Rd0000644000176200001440000000374612255404021015017 0ustar liggesusers% file sn/man/sn-st.cumulants.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{sn-st.cumulants} \alias{sn.cumulants} \alias{st.cumulants} \concept{cumulant} \title{Cumulants of univariate skew-normal and skew-\eqn{t} distributions} \description{Compute cumulants of univariate (extended) skew-normal and skew-\eqn{t} distributions up to a given order.} \usage{ sn.cumulants(xi=0, omega=1, alpha=0, tau=0, dp=NULL, n=4) st.cumulants(xi=0, omega=1, alpha=0, nu=Inf, dp=NULL, n=4) } \arguments{ \item{xi}{location parameters (numeric vector)} \item{omega}{scale parameters (numeric vector, positive)} \item{alpha}{slant parameters (numeric vector)} \item{tau}{hidden mean parameter (numeric scalar)} \item{nu}{degrees of freedom (numeric scalar, positive); the default value is \code{nu=Inf} which corresponds to the skew-normal distribution.} \item{dp}{a vector containing the appropriate set of parameters. If 0 \code{dp} is not \code{NULL}, the individual parameters must not be supplied.} \item{n}{maximal order of the cumulants. For \code{st.cumulants} and for \code{sn.cumulants} with \code{tau!=0} (\acronym{ESN} distribution), it cannot exceed 4} } \section{Background}{ See Sections 2.1.4, 2.2.3 and 4.3.1 of the reference below} \value{A vector of length \code{n} or a matrix with \code{n} columns, in case the input values are vectors.} \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \author{Adelchi Azzalini} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{dsn}}, \code{\link{dsn}}} \examples{ sn.cumulants(omega=2, alpha=c(0, 3, 5, 10), n=5) sn.cumulants(dp=c(0, 3, -8), n=6) st.cumulants(dp=c(0, 3, -8, 5), n=6) # only four of them are computed st.cumulants(dp=c(0, 3, -8, 3)) } \keyword{distribution} sn/man/residuals.selm.Rd0000644000176200001440000000465712436567013014711 0ustar liggesusers% file sn/man/summary.selm.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013-2014 Adelchi Azzalini %--------------------- \name{residuals.selm} \alias{residuals.selm} \alias{residuals.mselm} \alias{residuals,selm-method} \alias{residuals,mselm-method} \alias{fitted.selm} \alias{fitted.mselm} \alias{fitted,selm-method} \alias{fitted,mselm-method} \title{Residuals and fitted values from \code{selm} fits} \description{ \code{residuals} and \code{fitted} methods for classes \code{"selm"} and \code{"mselm"}.} \usage{ \S4method{residuals}{selm}(object, param.type = "CP", ...) \S4method{residuals}{mselm}(object, param.type = "CP", ...) \S4method{fitted}{selm}(object, param.type = "CP", ...) \S4method{fitted}{mselm}(object, param.type = "CP", ...) } \arguments{ \item{object}{an object of class \code{"selm"} or \code{"mselm"} as created by a call to function \code{selm}.} \item{param.type}{a character string which indicates the required type of parameter type; possible values are \code{"CP"} (default), \code{"DP"}, \code{"pseudo-CP"} and their equivalent lower-case expressions.} \item{...}{not used, included for compatibility with the generic method} } \value{a numeric vector (for \code{selm-class} objects) or a matrix (for \code{mselm-class} objects) } \note{The possible options of \code{param.type} are described in the documentation of \code{\link{dp2cp}}; their corresponding outcomes differ by an additive constant only. With the \code{"CP"} option (that is, the \sQuote{centred parametrization}), the residuals are centred around 0, at least approximately; this is a reason for setting \code{"CP"} as the default option. For more information, see the \sQuote{Note} in the documentation of \code{\link{summary.selm}}. } \references{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \author{Adelchi Azzalini} \seealso{ \code{\link{dp2cp}}, \code{\link{summary.selm}}, \code{\link{selm}} function, \code{\linkS4class{selm}-class} } \examples{ data(wines, package="sn") m5 <- selm(acidity ~ phenols + wine, family="SN", data=wines) residuals(m5) residuals(m5, "dp") fitted(m5, "dp") # m12 <- selm(cbind(acidity, alcohol) ~ phenols + wine, family="SN", data=wines) residuals(m12) # # see other examples at function selm } \keyword{regression} sn/man/SECdistrMv-class.Rd0000644000176200001440000000543112504013705015022 0ustar liggesusers% file sn/man/SECdistrMv-class.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{SECdistrMv-class} \Rdversion{1.1} \docType{class} \alias{SECdistrMv-class} \alias{show,SECdistrMv-method} \alias{mean,SECdistrMv-method} \alias{vcov,SECdistrMv-method} \title{Class \code{"SECdistrMv"}} \description{Multivariate skew-elliptically contoured distributions} \section{Objects from the Class}{ Objects can be created by a call to function \code{\link{makeSECdistr}}, when its argument \code{dp} is a list, or by a suitable transformation of some object of this class. They can also obtained from an object generated by \code{selm} using the function \code{extractSEDdistr}.} \section{Slots}{ \describe{ \item{\code{family}:}{a character string which identifies the parametric family; currently, possible values are: \kbd{"SN"}, \kbd{"ESN"}, \kbd{"ST"}, \kbd{"SC"}.} \item{\code{dp}:}{a list of parameters; its length depends on the selected \code{family}.} \item{\code{name}:}{a character string with the name of the multivariate variable; it can be an empty string.} \item{\code{compNames}:}{a vector of character strings with the names of the component variables.} } } \section{Methods}{ \describe{ \item{show}{\code{signature(object = "SECdistrMv-class")}: \dots } \item{plot}{\code{signature(x = "SECdistrMv-class")}: \dots } \item{summary}{\code{signature(object = "SECdistrMv-class")}: \dots } \item{mean}{\code{signature(x = "SECdistrUv")}: \dots} \item{vcov}{\code{signature(object = "SECdistrUv")}: \dots} } } \author{Adelchi Azzalini} \note{See \code{\link{makeSECdistr}} for a detailed description of \code{family} and \code{dp}. Note that here methods \code{mean} and \code{vcov} are not applied to data or to a fitted model, but to a \emph{probability distribution} instead, of which they provide the mean (vector) value and the variance-covariance matrix. If methods \code{mean} and \code{vcov} are applied to a distribution for which the mean or the variance do not exist, a \code{NULL} value is returned and a warning message is issued.} \seealso{ \code{\linkS4class{SECdistrUv}}, \code{\link{plot,SECdistrMv-method}}, \code{\link{summary,SECdistrMv-method}}, \code{\link{affineTransSECdistr}}, \code{\link{marginalSECdistr}}, \code{\link{extractSECdistr}} } \examples{ dp0 <- list(xi=1:2, Omega=diag(3:4), alpha=c(3, -5)) f10 <- makeSECdistr(dp=dp0, family="SN", name="SN-2D", compNames=c("x", "y")) show(f10) plot(f10) summary(f10) mean(f10) # the mean value of the probability distribution vcov(f10) # the variance-covariance matrix of the probability distribution } \keyword{classes} sn/man/dmst.Rd0000644000176200001440000001275412550701402012710 0ustar liggesusers% file sn/man/dmst.Rd % This file is a component of the package 'sn' for R % copyright (C) 2002-2013 Adelchi Azzalini %--------------------- \name{dmst} \alias{dmst} \alias{pmst} \alias{rmst} \alias{dmsc} \alias{pmsc} \alias{rmsc} \title{Multivariate skew-\eqn{t} distribution and skew-Cauchy distribution} \description{Probability density function, distribution function and random number generation for the multivariate skew-\eqn{t} (\acronym{ST}) and skew-Cauchy (\acronym{SC}) distributions.} \usage{ dmst(x, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, dp=NULL, log=FALSE) pmst(x, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, dp=NULL, ...) rmst(n=1, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, dp=NULL) dmsc(x, xi=rep(0,length(alpha)), Omega, alpha, dp=NULL, log=FALSE) pmsc(x, xi=rep(0,length(alpha)), Omega, alpha, dp=NULL, ...) rmsc(n=1, xi=rep(0,length(alpha)), Omega, alpha, dp=NULL) } \arguments{ \item{x}{for \code{dmst} and \code{dmsc}, this is either a vector of length \code{d}, where \code{d=length(alpha)}, or a matrix with \code{d} columns, representing the coordinates of the point(s) where the density must be avaluated; for \code{pmst} and \code{pmsc}, only a vector of length \code{d} is allowed.} \item{xi}{a numeric vector of length \code{d} representing the location parameter of the distribution; see \sQuote{Background}. In a call to \code{dmst} or \code{dmsc}, \code{xi} can be a matrix, whose rows represent a set of location parameters; in this case, its dimensions must match those of \code{x}.} \item{Omega}{a symmetric positive-definite matrix of dimension \code{(d,d)}; see Section \sQuote{Background}.} \item{alpha}{a numeric vector of length \code{d} which regulates the slant of the density; see Section \sQuote{Background}. \code{Inf} values in \code{alpha} are not allowed.} \item{nu}{a positive value representing the degrees of freedom of \acronym{ST} distribution; does not need to be integer. Default value is \code{nu=Inf} which corresponds to the multivariate skew-normal distribution.} \item{dp}{a list with three elements named \code{xi}, \code{Omega}, \code{alpha} and \code{nu}, containing quantities as described above. If \code{dp} is specified, this prevents specification of the individual parameters.} \item{n}{a numeric value which represents the number of random vectors to be drawn; default value is \code{1}.} \item{log}{logical (default value: \code{FALSE}); if \code{TRUE}, log-densities are returned.} \item{...}{additional parameters passed to \code{pmt}.} } \value{A vector of density values (\code{dmst} and \code{dmsc}) or a single probability (\code{pmst} and \code{pmsc}) or a matrix of random points (\code{rmst} and \code{rmsc}).} \details{Typical usages are \preformatted{% dmst(x, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, log=FALSE) dmst(x, dp=, log=FALSE) pmst(x, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf, ...) pmst(x, dp=, ...) rmst(n=1, xi=rep(0,length(alpha)), Omega, alpha, nu=Inf) rmst(n=1, dp=) dmsc(x, xi=rep(0,length(alpha)), Omega, alpha, log=FALSE) dmsc(x, dp=, log=FALSE) pmsc(x, xi=rep(0,length(alpha)), Omega, alpha, ...) pmsc(x, dp=, ...) rmsc(n=1, xi=rep(0,length(alpha)), Omega, alpha) rmsc(n=1, dp=) } Function \code{pmst} requires \code{\link[mnormt]{dmt}} from package \pkg{mnormt}; the accuracy of its computation can be controlled via argument \code{\dots}.} \section{Background}{ The family of multivariate \acronym{ST} distributions is an extension of the multivariate Student's \eqn{t} family, via the introduction of a \code{alpha} parameter which regulates asymmetry; when \code{alpha=0}, the skew-\eqn{t} distribution reduces to the commonly used form of multivariate Student's \eqn{t}. Further, location is regulated by \code{xi} and scale by \code{Omega}, when its diagonal terms are not all 1's. When \code{nu=Inf} the distribution reduces to the multivariate skew-normal one; see \code{dmsn}. Notice that the location vector \code{xi} does not represent the mean vector of the distribution (which in fact may not even exist if \code{nu <= 1}), and similarly \code{Omega} is not \emph{the} covariance matrix of the distribution, although it is \emph{a} covariance matrix. For additional information, see Section 6.2 of the reference below. The family of multivariate \acronym{SC} distributions is the subset of the \acronym{ST} family, obtained when \code{nu=1}. While in the univariate case there are specialized functions for the \acronym{SC} distribution, \code{dmsc}, \code{pmsc} and \code{rmsc} simply make a call to \code{dmst, pmst, rmst} with argument \code{nu} set equal to 1.} \references{ % Azzalini, A. and Capitanio, A. (2003). % Distributions generated by perturbation of symmetry % with emphasis on a multivariate skew \emph{t} distribution. % \emph{J.Roy. Statist. Soc. B} \bold{65}, 367--389. Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monograph series. } \seealso{ \code{\link{dst}}, \code{\link{dsc}}, \code{\link{dmsn}}, \code{\link[mnormt]{dmt}}, \code{\link{makeSECdistr}} } \examples{ x <- seq(-4,4,length=15) xi <- c(0.5, -1) Omega <- diag(2) Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2,2) pdf <- dmst(cbind(x,2*x-1), xi, Omega, alpha, 5) rnd <- rmst(10, xi, Omega, alpha, 6) p1 <- pmst(c(2,1), xi, Omega, alpha, nu=5) p2 <- pmst(c(2,1), xi, Omega, alpha, nu=5, abseps=1e-12, maxpts=10000) } \keyword{distribution} \keyword{multivariate} sn/man/selm.Rd0000644000176200001440000004516412565376264012726 0ustar liggesusers% file sn/man/selm.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{selm} \encoding{UTF-8} \alias{selm} \concept{regression} \concept{skew-elliptical distribution} \title{Fitting linear models with skew-elliptical error term} \description{Function \code{selm} fits a \code{l}inear \code{m}odel with \code{s}kew-\code{e}lliptical error term. The term \sQuote{skew-elliptical distribution} is an abbreviated equivalent of skew-elliptically contoured (\acronym{SEC}) distribution. The function works for univariate and multivariate response variables.} \usage{ selm(formula, family = "SN", data, weights, subset, na.action, start = NULL, fixed.param = list(), method = "MLE", penalty=NULL, offset, model = TRUE, x = FALSE, y = FALSE, ...) } \arguments{ \item{formula}{an object of class \code{"\link[stats]{formula}"} (or one that can be coerced to that class): a symbolic description of the model to be fitted, using the same syntax used for the similar parameter of e.g. \code{"\link[stats]{lm}"}, with the restriction that the constant term must not be removed from the linear predictor. % The details of model specification are given under \sQuote{Details}. } \item{family}{a character string which selects the parametric family of \acronym{SEC} type assumed for the error term. It must one of \code{"SN"} (default), \code{"ST"} or \code{"SC"}, which correspond to the skew-normal, the skew-\emph{t} and the skew-Cauchy family, respectively. See \code{\link{makeSECdistr}} for more information on these families and the set of \acronym{SEC} distributions; notice that family \code{"ESN"} listed there is not allowed here.} \item{data}{an optional data frame containing the variables in the model. If not found in \code{data}, the variables are taken from \code{environment(formula)}, typically the environment from which \code{selm} is called.} \item{weights}{a numeric vector of weights associated to individual observations. Weights are supposed to represent frequencies, hence must be non-negative integers (not all 0) and \code{length(weights)} must equal the number of observations. If not assigned, a vector of all 1's is generated.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. The default is set by the \code{na.action} setting of \code{\link[base]{options}}. The \sQuote{factory-fresh} default is \code{\link{na.omit}}. Another possible value is \code{NULL}, no action. % Value \code{\link[stats]{na.exclude}} can be useful. } \item{start}{a vector (in the univariate case) or a list (in the multivariate case) of initial values for the search of the parameter estimates. If \code{start=NULL} (default), initial values are selected by the procedure.} \item{fixed.param}{a list of assignments of parameter values which must be kept fixed in the estimation process. Currently, there only two types of admissible constraint: one is to set \code{alpha=0} to impose a symmetry condition of the distribution; the other is to set \code{nu=}, to fix the degrees of freedom at the named \code{} when \code{family="ST"}, for instance \code{list(nu=3)}. See \sQuote{Details} for additional information. } \item{method}{a character string which selects the estimation method to be used for fitting. Currently two options exist: \code{"MLE"} (default) and \code{"MPLE"}, corresponding to standard maximum likelihood and maximum penalized likekelihood estimation, respectively. See \sQuote{Details} for additional information. } \item{penalty}{a character string which denotes the penalty function to be subtracted to the log-likelihood function, when \code{method="MPLE"}; if \code{penalty=NULL} (default), a pre-defined function is adopted. See \sQuote{Details} for a description of the default penalty function and for the expected format of alternative specifications. When \code{method="MLE"}, no penalization is applied and this argument has no effect.} \item{offset}{this can be used to specify an \emph{a priori} known component to be included in the linear predictor during fitting. This should be \code{NULL} or a numeric vector of length equal to the number of cases. One or more \code{\link{offset}} terms can be included in the formula instead or as well, and if more than one are specified their sum is used. } \item{model, x, y}{logicals. If \code{TRUE}, the corresponding components of the fit are returned.} \item{\dots}{optional control parameters, as follows. \itemize{ \item \code{trace}: a logical value which indicates whether intermediate evaluations of the optimization process are printed (default: \code{FALSE}). \item \code{info.type}: a character string which indicates the type of Fisher information matrix; possible values are \code{"observed"} (default) and \code{"expected"}. Currently \code{"expected"} is implemented only for the \acronym{SN} family. \item \code{opt.method}: a character string which selects the numerical optimization method, among the possible values \code{"nlminb", "Nelder-Mead", "BFGS", "CG", "SANN"}. If \code{opt.method="nlminb"} (default), function \code{\link[stats]{nlminb}} is called, otherwise function \code{\link[stats]{optim}} is called with \code{method} equal to \code{opt.method}. \item \code{opt.control}: a list of control parameters which is passed on to \code{nlminb} or to \code{optim}, depending on the chosen \code{opt.method}. } } } \details{By default, \code{selm} fits the selected model by maximum likelihood estimation (\acronym{MLE}), making use of some numerical optimization method. Maximization is performed in one parameterization, usually \acronym{DP}, and then the estimates are mapped to other parameter sets, \acronym{CP} and pseudo-\acronym{CP}; see \code{\link{dp2cp}} for more information on parameterizations. These parameter transformations are carried out trasparently to the user. The observed information matrix is used to obtain the estimated variance matrix of the \acronym{MLE}'s and from this the standard errors. Background information on \acronym{MLE} in the context of \acronym{SEC} distributions is provided by Azzalini and Capitanio (2014); see specifically Chapter 3, Sections 4.3, 5.2, 6.2.5--6. For additional information, see the original research work referenced therein. Although the density functionof SEC distributions are expressed using \acronym{DP} parameter sets, the methods associated to the objects created by this function communicate, by default, their outcomes in the \acronym{CP} parameter set, or its variant form pseudo-\acronym{CP} when \acronym{CP} does not exist; the \sQuote{Note} at \code{\link{summary.selm}} explains why. A more detailed discussion is available in Sections 3.1.4--6 and 5.2.3 of Azzalini and Capitanio (2014) and in Section 4 of Arellano-Valle and Azzalini (2008). There is a known open issue which affects computation of the information matrix of the multivariate skew-normal distribution when the slant parameter \eqn{\alpha} approaches the null vector; see p.149 of Azzalini and Capitanio (2014). Consequently, if a model with multivariate response is fitted with \code{family="SN"} and the estimate \code{alpha} of \eqn{\alpha} is at the origin or neary so, the information matrix and the standard errors are not computed and a warning message is issued. In this unusual circumstance, a simple work-around is to re-fit the model with \code{family="ST"}, which will work except in remote cases when (i) the estimated degrees of freedom \code{nu} diverge and (ii) still \code{alpha} remains at the origin. The optional argument \code{fixed.param=list(alpha=0)} imposes the constraint \eqn{\alpha=0} in the estimation process; in the multivariate case, the expression is interpreted in the sense that all the components of vector \eqn{\alpha} are zero, which implies symmetry of the error distribution, irrespectively of the parameterization subsequently adopted for summaries and diagnostics. When this restriction is selected, the estimation method cannot be set to \code{"MPLE"}. Under the constraint \eqn{\alpha=0}, if \code{family="SN"}, the model is fitted similarly to \code{lm}, except that here \acronym{MLE} is used for estimation of the covariance matrix. If \code{family="ST"} or \code{family="SC"}, a symmetric Student's \eqn{t} or Cauchy distribution is adopted. Under the constraint \eqn{\alpha=0}, the location parameter \eqn{\xi}{xi} coincides with the mode and the mean of the distribution, when the latter exists; in addition, when the covariance matrix exists, it differs from \eqn{\Omega}{Omega} only by a multiplicative factor. For this reason, the summaries of a model of this sort automatically adopt the \acronym{DP} parametrization. The other possible form of constraint allows to fix the degrees of freedom when \code{family="ST"}. The two constraints can be combined writing, for instance, \code{fixed.param=list(alpha=0, nu=6)}. The constraint \code{nu=1} is equivalent to select \code{family="SC"}. In practice, an expression of type \code{fixed.param=list(..)} can be abbreviated to \code{fixed=list(..)}. In some cases, especially for small sample size, the \acronym{MLE} occurs on the frontier of the parameter space, leading to \acronym{DP} estimates with \code{alpha=Inf} or to a similar situation in the multivariate case or in an alternative parameterization. Such outcome is regared by many as unsatisfactory; surely it prevents using the observed information matrix to compute standard errors. This problem motivates the use of maximum penalized likelihood estimation (\acronym{MPLE}), where the regular log-likelihood function \eqn{\log~L}{log(L)} is penalized by subtracting an amount \eqn{Q}, say, increasingly large as \eqn{|\alpha|} increases. Hence the function which is maximized at the optimization stage is now \eqn{\log\,L~-~Q}{log(L) - Q}. If \code{method="MPLE"} and \code{penalty=NULL}, the default function \code{Qpenalty} is used, which implements the penalization: \deqn{Q(\alpha) = c_1 \log(1 + c_2 \alpha_*^2)}{% Q(\alpha)= c₁ log(1 + c₂ [\alpha*]²)} where \eqn{c_1}{c₁} and \eqn{c_2}{c₂} are positive constants, which depends on the degrees of freedom \code{nu} in the \code{ST} case, \deqn{\alpha_*^2 = \alpha^\top \bar\Omega \alpha}{%? [\alpha*]² = \alpha' cor(\Omega) \alpha} and \eqn{\bar\Omega}{cor(\Omega)} denotes the correlation matrix associated to the scale matrix \code{Omega} described in connection with \code{\link{makeSECdistr}}. In the univariate case \eqn{\bar\Omega=1}{cor(\Omega)=1}, so that \eqn{\alpha_*^2=\alpha^2}{[\alpha*]²=\alpha²}. Further information on \acronym{MPLE} and this choice of the penalty function is given in Section 3.1.8 and p.111 of Azzalini and Capitanio (2014); for a more detailed account, see Azzalini and Arellano-Valle (2013) and references therein. It is possible to change the penalty function, to be declared via the argument \code{penalty}. For instance, if the calling statement includes \code{penalty="anotherQ"}, the user must have defined \verb{ }\code{anotherQ <- function(alpha_etc, nu = NULL, der = 0)} with the following arguments. \itemize{ \item \code{alpha_etc}: in the univariate case, a single value \code{alpha}; in the multivariate case, a two-component list whose first component is the vector \code{alpha}, the second one is matrix equal to \code{cov2cor(Omega)}. % \eqn{\bar\Omega}{corOmega}. \item \code{nu}: degrees of freedom, only relevant if \code{family="ST"}. \item \code{der}: a numeric value which indicates the required order of derivation; if \code{der=0} (default value), only the penalty \code{Q} needs to be retuned by the function; if \code{der=1}, \code{attr(Q, "der1")} must represent the first order derivative of \code{Q} with respect to \code{alpha}; if \code{der=2}, also \code{attr(Q, "der2")} must be assigned, containing the second derivative (only required in the univariate case). } This function must return a single numeric value, possibly with required attributes when is called with \code{der>1}. Since \pkg{sn} imports functions \code{\link[numDeriv]{grad}} and \code{\link[numDeriv]{hessian}} from package \pkg{numDeriv}, one can rely on them for numerical evaluation of the derivatives, if they are not available in an explicit form. This penalization scheme allows to introduce a prior distribution \eqn{\pi} for \eqn{\alpha} by setting \eqn{Q=-\log\pi}{Q=-log(\pi)}, leading to a maximum \emph{a posteriori} estimate in the stated sense. See \code{\link{Qpenalty}} for more information and an illustration. The actual computations are not performed within \code{selm} which only sets-up ingredients for work of \code{\link{selm.fit}} and other functions further below this one. See \code{\link{selm.fit}} for more information. } \value{an S4 object of class \code{selm} or \code{mselm}, depending on whether the response variable of the fitted model is univariate or multivariate; these objects are described in the \code{\linkS4class{selm} class}. } \references{ Arellano-Valle, R. B., and Azzalini, A. (2008). The centred parametrization for the multivariate skew-normal distribution. \emph{J. Multiv. Anal.} \bold{99}, 1362--1382. Corrigendum: \bold{100} (2009), 816. Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. Azzalini, A. and Arellano Valle, R. V. (2013, available on line 30 June 2012). Maximum penalized likelihood estimation for skew-normal and skew-\emph{t} distributions. \emph{J. Stat. Planning & Inference} \bold{143}, 419--433. } \author{Adelchi Azzalini} \section{Warning}{ The estimates are obtained by numerical optimization methods and, as usual in similar cases, there is no guarantee that the maximum of the objective function is achieved. Both consideration of model simplicity and numerical experience indicate that models with \acronym{SN} error terms generally produce more reliable results compared to those with the \acronym{ST} family. Take into account that models involving a traditional Student's \eqn{t} distribution with unknown degres of freedom can already be problematic; the presence of the (multivariate) slant parameter \eqn{\alpha} in the \acronym{ST} family cannot make things any simpler. Consequently, care must be exercised, especially so if one works with the (multivariate) \acronym{ST} family. Consider re-fitting a model with different starting values and, in the \acronym{ST} case, building the profile log-likelihood for a range of \eqn{\nu} values. Details on the numerical optimization which has produced object \code{obj} can be estracted with \code{slot(obj, "opt.method")}. Be aware that occasionally \code{optim} and \code{nlminb} declare successful completion of a regular minimization problem at a point where the Hessian matrix is not positive-definite. Two cases of this sort are presented in the final portion of the examples below. } \seealso{\itemize{ \item \code{\linkS4class{selm}-class} for classes \code{"selm"} and \code{"mselm"}, \code{\link{summary.selm}} for summaries, \code{\link{plot.selm}} for plots, \code{\link{residuals.selm}} for residuals and fitted values \item the generic functions \code{\link{coef}}, \code{\link{logLik}}, \code{\link{vcov}}. \item the underlying function \code{\link{selm.fit}} and those further down \item the selection of a penalty function of the log-likelihood, such as \code{\link{Qpenalty}} \item the function \code{\link{extractSECdistr}} to extract the \acronym{SEC} error distribution from an object returned by \code{selm} }} \examples{ data(ais) m1 <- selm(log(Fe) ~ BMI + LBM, family="SN", data=ais) print(m1) summary(m1) s<- summary(m1, "DP", cov=TRUE, cor=TRUE) plot(m1) plot(m1, param.type="DP") logLik(m1) coef(m1) coef(m1, "DP") var <- vcov(m1) # m1a <- selm(log(Fe) ~ BMI + LBM, family="SN", method="MPLE", data=ais) m1b <- selm(log(Fe) ~ BMI + LBM, family="ST", fixed.param=list(nu=8), data=ais) # data(barolo) attach(barolo) A75 <- (reseller=="A" & volume==75) logPrice <- log(price[A75],10) m <- selm(logPrice ~ 1, family="ST") summary(m) plot(m, which=2, col=4, main="Barolo log10(price)") # cfr Figure 4.7 of Azzalini & Capitanio (2014), p.107 detach(barolo) #----- # examples with multivariate response # m3 <- selm(cbind(BMI, LBM) ~ WCC + RCC, family="SN", data=ais) plot(m3, col=2, which=2) summary(m3, "dp") coef(m3) coef(m3, vector=FALSE) # data(wines) m28 <- selm(cbind(chloride, glycerol, magnesium) ~ 1, family="ST", data=wines) dp28 <- coef(m28, "DP", vector=FALSE) pcp28 <- coef(m28, "pseudo-CP", vector=FALSE) \donttest{# the next statement takes a little more time than others plot(m28) } \donttest{ # example of computation and plot of a (relative twice) profile log-likelihood; # since it takes some time, set a coarse grid of nu values nu.vector <- seq(3, 8, by=0.5) logL <- numeric(length(nu.vector)) for(k in 1:length(nu.vector)) { m28.f <- selm(cbind(chloride, glycerol, magnesium) ~ 1, family="ST", fixed=list(nu=nu.vector[k]), data=wines) logL[k] <- logLik(m28.f) cat(format(c(nu.vector[k], logL[k])), "\n") } plot(nu.vector, 2*(logL-max(logL)), type="b") ok <- which.max(logL) abline(v=nu.vector[ok], lty=2) # compare maximum of this curve with MLE of nu in summary(m28, 'dp') } # m4 <- selm(cbind(alcohol,sugar)~1, family="ST", data=wines) m5 <- selm(cbind(alcohol,sugar)~1, family="ST", data=wines, fixed=list(alpha=0)) print(1 - pchisq(2*as.numeric(logLik(m4)-logLik(m5)), 2)) # test for symmetry # \donttest{ # illustrate final passage of 'Warning' section above: # the execution of the next selm command is known to produce warning messages # although the optimizer declares successful convergence m31 <- selm(cbind(BMI, LBM)~ Ht + Wt, family="ST", data=ais) # Warning message... slot(m31, "opt.method")$convergence # a 0 value indicates success # the next case is similar m32 <- selm(cbind(BMI, LBM)~ Ht + Wt, family="ST", data=ais, opt.method="BFGS") # Warning message... slot(m32, "opt.method")$convergence } } \keyword{regression} \keyword{univar} \keyword{multivariate} sn/man/summary.SECdistr-class.Rd0000644000176200001440000000407012255404114016212 0ustar liggesusers% file sn/man/summary.SECdistr-class.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{summary.SECdistrMv-class} \Rdversion{1.1} \docType{class} \alias{summary.SECdistrMv-class} \alias{summary.SECdistrUv-class} \alias{show,summary.SECdistrMv-method} \alias{show,summary.SECdistrUv-method} \title{Classes \code{summary.SECdistrMv} and \code{summary.SECdistrUv}} \description{Summaries of objects of classes \code{SECdistrMv} and \code{SECdistrUv}} \section{Objects from the Class}{ Objects can be created by calls of type \code{summary(object)} when \code{object} is of class either \code{"SECdistrMv"} or \code{"SECdistrUv"}.} \section{Slots}{ \describe{ \item{\code{family}:}{A character string which represents the parametric family of \acronym{SEC} type } \item{\code{dp}:}{Object of class \code{"list"} or \code{"vector"} for \code{"SECdistrMv"} and \code{"SECdistrUv"}, respectively} \item{\code{name}:}{Object of class \code{"character"} with the name of distribution } \item{\code{compNames}:}{For \code{"SECdistrMv"} objects, a character vector with names of the components of the multivariate distribution} \item{\code{cp}:}{Object of class \code{"list"} or \code{"vector"} for \code{"SECdistrMv"} and \code{"SECdistrUv"}, respectively} \item{\code{cp.type}:}{a character string of the \acronym{CP} version} \item{\code{aux}:}{A list of auxiliary quantities } } } \section{Methods}{ \describe{ \item{show}{\code{signature(object = "summary.SECdistrMv")}: ... } \item{show}{\code{signature(object = "summary.SECdistrUv")}: ... } } } %\references{%% ~~put references to the literature/web site here~~} \author{Adelchi Azzalini} % \note{%% ~~further notes~~} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{summary.SECdistrMv}}, \code{\link{summary.SECdistrUv}}, \code{\link{makeSECdistr}}, \code{\link{dp2cp}} } % \examples{showClass("summary.SECdistrMv")} \keyword{classes} sn/man/barolo.Rd0000644000176200001440000000347412531106134013216 0ustar liggesusers% file sn/man/barolo.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{barolo} \alias{barolo} \docType{data} \title{Price of Barolo wine} \description{A data frame with prices of bottles of Barolo wine and some auxiliary variables} \usage{data(barolo)} \format{A data frame with 307 observations on five variables, as follows: \tabular{ll}{% \code{reseller}\tab reseller code (factor with levels \code{A, B, C, D}) \cr \code{vintage} \tab vintage year (numeric) \cr \code{volume} \tab content volume in centilitres (numeric) \cr \code{price} \tab price in Euro (numeric) \cr \code{age} \tab age in 2010 (numeric) } For six items, \code{vintage} is \code{NA}'s and so also \code{age}. Three items have a non-standard volume of 50 cl. } \details{The data have been obtained in July 2010 from the websites of four Italian wine resellers, selecting only quotations of Barolo wine, which is produced in the Piedmont region of Italy. The price does not include the delivery charge. The data have been presented in Section 4.3.2 of the reference below, where a subset of them has been used for illustrative purposes. This subset refers to reseller \code{"A"} and bottles of 75cl. } \source{ Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \examples{ data(barolo) attach(barolo) f <- cut(age, c(0, 5, 6, 8, 11, 30)) table(volume, f) plot(volume, price, col=as.numeric(f), pch=as.character(reseller)) legend(400, 990, col=1:5, lty=1, title="age class", legend=c("4-5", "6", "7-8", "9-11", "12-30")) # A75 <- (reseller=="A" & volume==75) hist(log(price[A75],10), col="gray85") # see Figure 4.7 of the source } \keyword{datasets} sn/man/sn-st.info.Rd0000644000176200001440000001465612517400552013747 0ustar liggesusers% file sn/man/sn-st.info.Rd % This file is a component of the package 'sn' for R % copyright (C) 2013 Adelchi Azzalini %--------------------- \name{sn-st.info} \alias{sn.infoUv} \alias{sn.infoMv} \alias{st.infoUv} \alias{st.infoMv} \title{Expected and observed Fisher information for \acronym{SN} and \acronym{ST} distributions} \description{ Computes Fisher information for parameters of simple sample having skew-normal (\acronym{SN}) or skew-\eqn{t} (\acronym{ST}) distribution or for a regression model with errors term having such distributions, in the \acronym{DP} and \acronym{CP} parametrizations. } \usage{ sn.infoUv(dp=NULL, cp=NULL, x=NULL, y, w, penalty=NULL, norm2.tol=1e-06) sn.infoMv(dp, x=NULL, y, w, penalty=NULL, norm2.tol=1e-06) st.infoUv(dp = NULL, cp = NULL, x = NULL, y, w, fixed.nu = NULL, symmetr = FALSE, penalty = NULL, norm2.tol = 1e-06) st.infoMv(dp, x = NULL, y, w, fixed.nu = NULL, symmetr = FALSE, penalty = NULL, norm2.tol = 1e-06) } \arguments{ \item{dp, cp}{direct or centred parameters, respectively; one of the two vectors must be supplied, but not both. For the univariate \acronym{SN} distribution, \code{sn.infoUv} is to be used, and these arguments are vectors. In the multivariate case, \code{sn.infoMv} is to be used and these arguments are lists. See \code{\link{dp2cp}} for their description.} \item{x}{an optional matrix which represents the design matrix of a regression model} \item{y}{a numeric vector (for \code{sn.infoUv} and \code{st.infoUv}) or a matrix (for \code{sn.infoMv} and \code{st.infoMv}) representing the response. In the \acronym{SN} case ( \code{sn.infoUv} and \code{sn.infoMv}), \code{y} can be missing, and in this case the expected information matrix is computed; otherwise the observed information is computed. In the \acronym{ST} case (\code{st.infoUv} and \code{st.infoMv}), \code{y} is a required argument, since only the observed information matrix for \acronym{ST} distributions is implemented. See \sQuote{Details} for additional information.} \item{w}{an optional vector of weights; if missing, a vector of 1's is generated.} \item{fixed.nu}{an optional numeric value which declared a fixed value of the degrees of freedom, \code{nu}. If not \code{NULL}, the information matrix has a dimension reduced by 1.} \item{symmetr}{a logical flag which indicates whether a symmetry condition of the distribution is being imposed; default is \code{symmetr=FALSE}.} \item{penalty}{a optional character string with the name of the penalty function used in the call to \code{\link{selm}}; see this function for its description;} \item{norm2.tol}{for the observed information case, the Mahalanobis squared distance of the score 0 is evaluated; if it exceeds \code{norm2.tol}, a warning message is issued, since the \sQuote{information matrix} so evaluated may be not positive-definite. See \sQuote{Details} for additional information. } } \value{ a list containing the following components: \item{dp, cp}{one of the two arguments is the one supplied on input; the other one matches the previous one in the alternative parametrization.} \item{type}{the type of information matrix: "observed" or "expected".} \item{info.dp, info.cp}{matrices of Fisher (observed or expected) information in the two parametrizations.} \item{asyvar.dp, asyvar.cp}{inverse matrices of Fisher information in the two parametrizations, when available; See \sQuote{Details} for additional information. } \item{aux}{a list containing auxiliary elements, depending of the selected function and the type of computation.} } \section{Details}{ In the univariate \acronym{SN} case, when \code{x} is not set, then a simple random sample is assumed and a matrix \code{x} with a single column of all 1's is constructed; in this case, the supplied vector \code{dp} or \code{cp} must have length 3. If \code{x} is set, then the supplied vector of parameters, \code{dp} or \code{cp}, must have length \code{ncol(x)+2}. In the multivariate case, a direct extension of this scheme applies. If the observed information matrix is required, \code{dp} or \code{dp} should represent the maximum likelihood estimates (MLE) for the given \code{y}, otherwise the information matrix may fail to be positive-definite. Therefore, the squared Mahalobis norm of the score vector is evaluated and compared with \code{norm2.tol}. If it exceeds this threshold, it is taken as an indication that the parameter is not at the \acronym{MLE} and a warning message is issued. The returned list still includes \code{info.dp} and \code{info.cp}, but in this case these represent merely the matrices of second derivatives; \code{asyvar.dp} and \code{asyvar.cp} are set to \code{NULL}. } \section{Background}{ The information matrix for the the univariate \acronym{SN} distribution in the two stated parameterizations in discussed in Sections 3.1.3--4 of Azzalini and Capitanio (2014). For the multivariate distribution, Section 5.2.2 of this monograph summarizes briefly the findings of Arellano-Valle and Azzalini (2008). For \acronym{ST} distributions, only the observed information matrix is provided currently. Computation for the univariate case is based on DiCiccio and Monti (2011). For the multivariate case, the score function is computed using expression of Arellano-Valle (2010) followed by numerical differentiation. } \references{ Arellano-Valle, R. B. (2010). The information matrix of the multivariate skew-$t$ distribution. \emph{Metron}, \bold{LXVIII}, 371--386. Arellano-Valle, R. B., and Azzalini, A. (2008). The centred parametrization for the multivariate skew-normal distribution. \emph{J. Multiv. Anal.} \bold{99}, 1362--1382. Corrigendum: vol.\,100 (2009), p.\,816. Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. DiCiccio, T. J. and Monti, A. C. (2011). Inferential aspects of the skew \eqn{t}-distribution. \emph{Quaderni di Statistica} \bold{13}, 1--21. } \seealso{\code{\link{dsn}}, \code{\link{dmsn}}, \code{\link{dp2cp}}} \examples{ infoE <- sn.infoUv(dp=c(0,1,5)) infoO <- sn.infoUv(cp=c(0,1,0.8), y=rsn(50, dp=c(0,1,5))) # data(wines) X <- model.matrix(~ pH + wine, data=wines) fit <- sn.mple(x=X, y=wines$alcohol) infoE <- sn.infoUv(cp=fit$cp, x=X) infoO <- sn.infoUv(cp=fit$cp, x=X, y=wines$alcohol) } \keyword{distribution} sn/man/dsn.Rd0000644000176200001440000001201512424404564012524 0ustar liggesusers% file sn/man/dsn.Rd % This file is a component of the package 'sn' for R % copyright (C) 1998-2013 Adelchi Azzalini %--------------------- \name{dsn} \alias{dsn} \alias{psn} \alias{qsn} \alias{rsn} \title{Skew-Normal Distribution} \description{Density function, distribution function, quantiles and random number generation for the skew-normal (\acronym{SN}) and the extended skew-normal (\acronym{ESN}) distribution.} \usage{ dsn(x, xi=0, omega=1, alpha=0, tau=0, dp=NULL, log=FALSE) psn(x, xi=0, omega=1, alpha=0, tau=0, dp=NULL, engine, ...) qsn(p, xi=0, omega=1, alpha=0, tau=0, dp=NULL, tol=1e-8, solver="NR", ...) rsn(n=1, xi=0, omega=1, alpha=0, tau=0, dp=NULL) } \arguments{ \item{x}{vector of quantiles. Missing values (\code{NA}'s) and \code{Inf}'s are allowed.} \item{p}{vector of probabilities. Missing values (\code{NA}s) are allowed} \item{xi}{vector of location parameters.} \item{omega}{vector of scale parameters; must be positive.} \item{alpha}{ vector of slant parameters; \code{+/- Inf} is allowed. With \code{psn} and \code{qsn}, it must be of length 1 if \code{engine="T.Owen"}.} \item{tau}{a single value representing the `hidden mean' parameter of the \acronym{ESN} distribution; \code{tau=0} (default) corresponds to a \acronym{SN} distribution.} \item{dp}{a vector of length 3 (in the \acronym{SN} case) or 4 (in the \acronym{ESN} case), whose components represent the individual parameters described above. If \code{dp} is specified, the individual parameters cannot be set.} \item{n}{sample size.} \item{tol}{a scalar value which regulates the accuracy of the result of \code{qsn}, measured on the probability scale.} \item{log}{logical flag used in \code{dsn} (default \code{FALSE}). When \code{TRUE}, the logarithm of the density values is returned.} \item{engine}{a character string which selects the computing engine; this is either \code{"T.Owen"} or \code{"biv.nt.prob"}, the latter from package \code{mnormt}. If \code{tau != 0} or \code{length(alpha)>1}, \code{"biv.nt.prob"} must be used. If this argument is missing, a default selection rule is applied.} \item{solver}{a character string which selects the numerical method used for solving the quantile equation; possible options are \code{"NR"} (default) and \code{"RFB"}, described in the \sQuote{Details} section.} \item{...}{ additional parameters passed to \code{T.Owen}} } \value{density (\code{dsn}), probability (\code{psn}), quantile (\code{qsn}) or random sample (\code{rsn}) from the skew-normal distribution with given \code{xi}, \code{omega} and \code{alpha} parameters or from the extended skew-normal if \code{tau!=0} } \section{Details}{ Typical usages are \preformatted{% dsn(x, xi=0, omega=1, alpha=0, log=FALSE) dsn(x, dp=, log=FALSE) psn(x, xi=0, omega=1, alpha=0, ...) psn(x, dp=, ...) qsn(p, xi=0, omega=1, alpha=0, tol=1e-8, ...) qsn(x, dp=, ...) rsn(n=1, xi=0, omega=1, alpha=0) rsn(x, dp=) } \code{psn} and \code{qsn} make use of function \code{\link{T.Owen}} or \code{\link[mnormt:dmt]{biv.nt.prob}} In \code{qsn}, the choice \code{solver="NR"} selects the Newton-Raphson method for solving the quantile equation, while option \code{solver="RFB"} alternates a step of \emph{regula falsi} with one of bisection. The \code{"NR"} method is generally more efficient, but \code{"RFB"} is occasionally required in some problematic cases. } \section{Background}{ The family of skew-normal distributions is an extension of the normal family, via the introdution of a \code{alpha} parameter which regulates asymmetry; when \code{alpha=0}, the skew-normal distribution reduces to the normal one. The density function of the \acronym{SN} distribution in the \sQuote{normalized} case having \code{xi=0} and \code{omega=1} is \eqn{2\phi(x)\Phi(\alpha x)}, if \eqn{\phi} and \eqn{\Phi} denote the standard normal density and distribution function. An early discussion of the skew-normal distribution is given by Azzalini (1985); see Section 3.3 for the \acronym{ESN} variant, up to a slight difference in the parameterization. An updated exposition is provided in Chapter 2 of Azzalini and Capitanio (2014); the \acronym{ESN} variant is presented Section 2.2. See Section 2.3 for an historical account. A multivariate version of the distribution is examined in Chapter 5.} \references{ Azzalini, A. (1985). A class of distributions which includes the normal ones. \emph{Scand. J. Statist.} \bold{12}, 171-178. Azzalini, A. with the collaboration of Capitanio, A. (2014). \emph{The Skew-Normal and Related Families}. Cambridge University Press, IMS Monographs series. } \seealso{ Functions used by \code{psn}: \code{\link{T.Owen}}, \code{\link[mnormt:dmt]{biv.nt.prob}} Related distributions: \code{\link{dmsn}}, \code{\link{dst}}, \code{\link{dmst}} } \examples{ pdf <- dsn(seq(-3, 3, by=0.1), alpha=3) cdf <- psn(seq(-3, 3, by=0.1), alpha=3) q <- qsn(seq(0.1, 0.9, by=0.1), alpha=-2) r <- rsn(100, 5, 2, 5) qsn(1/10^(1:4), 0, 1, 5, 3, solver="RFB") } \keyword{distribution}