؝Bey#N ITQ{E
v6n8
!KU2\Ȼ3,TA1pjjfug JțULV9M։.f6+4`LFq0m ÝMtf H3@+ 0`(]G! X[6?]݆^Zv6 Klbm0_RUa]h0b]hclvEl7y&iZ,Ù/+k˅Ydm6j?O6uqQ}4Apy~XVu>&1_=>Y_"
G i^jT=|J`EDYp2\c9.C.t:nHnjKb/^ > }${Aki1gߴ~O_ uqO뻉S6Ӯ.qJ'Xqq[WܿKe[U׃P^2xo ɦ?-/ⷆs b5ͤڴ\&^Pn"(HGS, effects/data/Wells.rda 0000644 0001762 0000144 00000037300 12654134354 014372 0 ustar ligges users 7zXZ i"6 ! XL>] )TW"nRʟ)-t^JiȖo Hq9F2)\N^&Z
zxZ:r\`
͓NTZfNGO[/vXLO}j 6d2/q^Dzȳvj&֘!) X̧ 3 Ng#~"⡿D2S9n5xI٠6RUWM)+˖~*tvX doGf3&`V8ٮi[|@Z1XTvȃ@RFL"Bd/ٚLF*blx9C(iwb1Ĵyɒ %Bx%?$h\d i`mdKfm٠9xð O鵎rHajT P
\(ǩŝ
JLj=}]Ma-*}RkB& LH쐭+oe_@T?JJ: l> X\_4 o3S*Ǹ]>u/=|OA{y~9ABOk~K)i5WA2M$C`X# /A &}L~nqzaO-I<][d߯LMRi/@ iA奃XLPo3~V3s](- V;i#@csfco^J4Hm%yݽ3QpC *bycӬ[K}#K<n}`KfuH4"UCu T$k
XtșR A2L D~4yn)mCc,p1ePi0tLXRp xɛbC Yh fX!ͦ27B ?Yyh{yq98
` g d<7rیRG\їJmSf- d"_Ut'lU =crݾ A@!,(D¹OfZD]DkQlKO#rB:&`-\kD\qn*REx" [>l} LDuFv8T,d?< b=.&EKsIy@Y{4vY+?ڵ:jBaɠILZdF ! Np6ԡt5`MLXd,ʸ s l}Ɩ~]>؇.a"Skǔ ~-e8Ie ğE!*pSE\zan2ʏb֚<'+"o^pz!? x5'ɉs
Aī @.q4ߍCӡYet-oԻ*KwU7F}}el%Z ,Q~KV Z Pss|1cڎ+O!
^W X̬UQewB>lƽV* {W
(S6ag+5|x.RFH ^ꐺNllmc0~4^bGݢ ʥJX7At Q}0?kZzH 8i"p S1$@vkX@2la֫iNkL{Pbr@Tmxi
!d~P%8SիPVn2NqsBYs6jf*p+
kv ĵ42CrK|+ ȳu#z`Ah}؇xE6c7kX4+#stsT3eQj/ N U~`UZh-@v)/KtA:aVp|@h7x}s*$'ů2`Mސ q6id]t,(u940b_RV/'^'2"X#ڡ?z24/oI͏)sjƅQ8(ѲbL7d)rwpQ%cWJStr0rM[!+GlV=Y: !Ôǚ+)4N R2WTڏ %o#!C+{'
HцV+vލWS [ tWo[~A
>ޛ`;RRSAQK{A!
{H*RgB:]tώ /F '$fBaHr@ä)ai+fTs::z2G?;ql @1N$
: `4g'j)ƅOтfZVLӴ,6r> uO.oVp^oL6{h *yņ -!Rx.Kezu|uLS.OLR;!*dJ<:V\& qX,l(
|ң5_/UafhQSB"fe~J2& OCXt1 @)eڛԊU![3)1n
HwŜOĒtZ`B$ uvKʌGsZ>AĢXh
EF:IfY` b#w,@Hr&27 vLKYn@WhXG+Ni՚{Ҵcx[w%p-2}#.}}.o IuS1 ٷ.Jl/sG `\.uݳlWuɢˬ^Pqy6vm(Ҽ/Uo3t ^7 fM:&kh֖p
GN'QOrd}w9~ .Њо^U)G_WPnտϞ⃗zD Y%$O/߹c'
W/U"Xm~P.Q w>co%N! 7Mlp.f\1~?ı=;_I9o<U䌾DUg4$#Qo4xY$吤-"^-D8|25CqtV`F8?J akܙ #Y7Ĝ,)@Q QsG3eY@xq?eʠn)Ci@ z msF
O4&0U@p32Vf`d _o$?]6cJF$+9XyuX
d$`(Rp' 5Ym*Cm``S
F2ԧ8\sa Vl5@V褥W:Hr]
m]]y$KJšP}Di)d};})q
tyՑ iY/7,
-FÛ PBzfgfuMyGD }-B(h(M==gT\vO@QVs1 ԉkoI$A>eΔ>81 %JɶXQˬH`m 4r֊*2<- [E HSdәAEe ؉Q2b/P\B0S"T1,{"~A)`3
{ OV#
\ L߫З[LzA/w;e
KOVt](t"taA_'x7wg,ާ 2l@ 20,̅V; "}9d9Mda =x T4{6@/`M/7)K˲(ဇ0z>_5~yDLhRSvG:%1 q T12 X(-כ0 sYr =VD,͍Etz|swY43>*P,i}R[V 20 dҹcӊ&CycSҕujZr*ެEMw+6 PH i|nalM Bi(D,$ ~?g4 p(;hNkMcY}y161#A#_( r!;kGΚ; ۾c jYkc~1S?h` )ZuL\,[ ]S 8i ս0$W!>
nc $9V#z'OՌ<8A
bP;{
ffv>p ϊ0 㻨؍0H|WgHkqܓc,|
7- ta"bp+
Ŋ~y[x˩.w.U Xsޞ`|7VF ^4+K\/3RuID#W pmD5H5b mA pP2TOʧ~7 pj3']``hG?3xf
>$e AɺSR4 c+u6t߈0D pKeA&'B4#F<Ǩ_+ϑqzBEdDs椓ȩƚgFPyrz $C/(4~+|5 &qrb |BInMp͗gM7H~2RN .ɱ¿dy\
\')Tw](Fڀ-6le03oN1˛`c͝MOs8 p}i3j[S-
ua@U-%Dԭ^PN M @ML47aA
jL\LnBNČ/P˝[o w t8d">6TxJvw ,Ot6uyVJ F`(n7b!ƒ$Y1Fr;h
C,4$i ǝ \!;/*gZ` ,'"#%ћ]$יTxvnU7 Ha ۃ&1 Q쯯9EG.k,eظMx>rF->$O\&
ս/mxŀ k״r*p cL7=%}}zFqpg4vkh]+T\b;ε0 2
r91AP|rSKI}ǥC&Nzi6p OT [gJBЀu[y2W D =7BL S8U[ ZZz -
,Rxe`# 6Voލx1W3JϨz؊nCCS=QgRapϐ| DkI5O% k ˷_T,1 Dod
vuxqЬ;DTPLm.0MBXFW~{ 7^2u[ёF6 KV4 7 ;A>#W %Zu[}L Oa $3Up(5Zlat ̡E]BÌмi^N7u$/%۪Q]'uoY' ){F= 2&#Y+[QV7T*i!%G0`LxLeJ$m0B=IZ*fz7:aYB Qg kѯ6lp75.Q͘aPC}h@-&i[pR'*\ayaw'bCm$,E˦\ȋZ"SXN 2\
pg`Y$~e<Z
`+,}4;o-0aIv1Ti8VAσ̮8vب۳։w87Y4!`n} Z]={M$4I&
7#_ qE1m C )f uq;*OM卐7,PY%֩n.v9vZmѯd
wW>2&_qŲɂ Pi%L!-w59Eڙ`zbw "a6p̷~$+ϟyָ/U'r4{+%(z\ɒb+[gj1KtOdYc
CM'<|ވaġkM@#'1cC-[蕷ID&KT@qn$=y\-;9 .s ޢ}&C6E4aSF${MygQ^w@[_{&e] CgjoP{aD'G- -,nf _]b(X fq%fGR@_RHZgd+}@IV ^r~B\CJܿ ,( e/( ٴC P7)&1.nW S|Lo ,\標Ѹ^c>KqldZLi ~E/M C#~mc^L-tܲnUzJ{[H%l:X/,8H$b$1$p>rEP^L9:ɹ6g3ovP2R_3 R :~9`\~]pl%m\'73UD`B±GNt)JHm<<BՕ??+BP ̘LRS_ݩTM/l@
}'g冏@$ZD:6E:t=.~U}xV Y>}qfc ;=*~or,Q7w $Zf.t+.s!+y,;@ZBr!;l<
vBe|oU{SX|T~ݝG~?-:~
Ǧݎj Ej%
ggu8 apIʎ(#v^5p&BsUGV;Vl^|KHxj$Upee;,SϢ12u yK]J?m+bI%4鉴Mc;
~__
Tw0 %x *KW
sU {ok?:Z7Z#_KYM> ;= P>nHDW/g2b'8R`b*Q>$4J ^LN0z^`Uښ<' dHڅVf
ʘrɧY2BѲ>6@8jQЩ bG F}#T暥J=n | UJtx=! nBi
RRPΘJO
xS;Ftн=_BB+'?RaQFt-8k~+/O F_+H!"V f,kA]zb v!0=CSBA<'9_fSN.@ZQ"xL3.`pz%u oĿ
7Ie<]zvMΓ^qHYPMHע3c?βj]&?ցZ&8m~[]Kn~· I.aq捷 ytQ':^FZ% mmS'Qȴ$)7i69څ\$WʓDV- 3 >/
úeK&L$wռQN_ ` w Ubr.l2폌a$)pܬbfc-XSpx1r (ySTk6Zĵ{WJ[s
s V 68(&bS5n}J
`k){/U r3"IYS"'Lx =ςD
qb:| Ԃ cW^:_du>YHIcUꗹWv _ܾ (BW$B9n`
hCEt d1-p>+nάXZ<SKJPuwD&f9^iUXt2W^ꜽt. ek Aيuf;[[+7d( vsgMJ1ԑa 07*L J8[kʩoW݀QVTa2YYrBŲ\
IVpwN˖Kw̶RhzC$CYZ-ܦWyK"n";@wFH/oݿXΧ'"``^#/alq:L|.w?¼$ @*eN^_An~fؓ]g^~HlNV\fH= g<68ںtzkshv Q+dsb
"YAORc"W=_U"߮h&\u XcuȼeHrh%Bu/NRg|z k(m$ 0ܩj,c^ ۙ't^6UWvӑ7R`*n0 ]ּIUntCKTDz 0txPܑR`գGF%
k(pX tgO0qO|gGs&H< sfۃN܇?[؟A!/ }u9S`ObOՠC5HÁl
#=7V~w"iJ+QƜ>v'cVPSe rICV2&I ^h'WޣxJo+*B6q;$ts!vxM*ə~?prgJ;݄bxfj`A\05(ߛM /7˲Jhnp)dnI$ w"R@"T_m,>hjM|i3xpzt`rX-Kd> fjy`]Tݹ3 Keuܶ8B4yxp pHXdO[ukM*n0XMH 栬97m)0G+o풾0<h8r@Յm8L0v]E=D=3dqܦnkAgg{^
bk@~@ +RʥRHH wێT`>OcyLw ܈Pgk@#ps73 e(2xW9}q[5mES)gXY'wHf#aw2uY%&hm dBE@b
Ɲ;(fm 5AT
^.Z&.
E3eWYU<
K.\)KqɀS !uMɲHQB则w]7~
e
jQ橀z Zf& S&ko h`'I,f/%mLwU[KAYJ= lr\4M"6}@Z
-^$ Mx4;2_=NVu" ..EG$^W:VXvw=Y5Q8!gKVȲ&KC.kL `^l䠄z+dPTS0B VFr f ~ ŬxZ.R%f4= Wc]WmJ?Qy(5ziN& ͌E0O RǴ0 ?
pDZv*♇tKEʥ AG?oƗSJa/9k^>Zjnϡ4(te<"U k T(J ݸdۻ#\
h %f OnN>W< V6ub
w$rTha!pz[M{xYm7Ƃ̍ӱM'SX\sXE$@ y.e@d[
/eT>/a,5fa+e*lȮ d3Ks6Z&M {XRcm~ c< sO?ܕp|ȴpŞ $/:W e1~@h";`J|{dk voRx lLƲ
(Qe{F&lcY>d~9exw(LJ8Pn8ё#ydI@ܒ+ʧ^-B8n<&5ۈwGz31v ;jLQbh-t߭"9nFvrnrs0I03m#κTmD,>pJ1X|SnzsIx2pui Á|@?,H \BئPN3t^fPkֳZ6SL3<)|pxثl I?gyc!s.zlkDƑ8Lq過!O$]llVLa~Ǝ;qQ^:RR3f=,Wn+ 4DJܚKH+ˉwW<ʼn+R+%MxbRT! =PlzO#yn.{r"jv=w/j- u]{ҁ6>F*0 tI_ 'cB05* j0tQ3wr|LZ}& .*Ǝ6Ru8ɣD 8="ueBWgQ D3z5zw~(z>" [-n$ աҗ zh ^d !WGY$j~=xW>X4}
t #%_~% EL_V^m*e +YsQ7
cNhh= m(@PcAH 缴ghšO[R}`O.z ;Fέ
x W6Ci5U .2C79m\5=П1'k9R&Ss-.#mxsFa}=5&S {֕GG'Իw -_*Nx~~Vѱ:{> L eRb8p&<2%Ro( H|?@:^͆'}rq-㤷C &A>3 чkk&BSKҐ5lyvVToS`gMKxX aaM 76:zH=k싥lUFэ8薩<;JRVEԙ. FZZBdHQnt>oboykVF5Z;WZHǨhvW!4tK<@+2e?H9kvG`ܦ&'};6(z!0S7mV\єfL@?
3r&cNp:~@WNi}%-)EC,
? zNNS؏Hn1O
qURsq%hLFl=ջ]R+ bQ_G3-:!_`v0gݟ㙃61P݀+ )($z,0%FITkxS K%.`ܐi. SD&<
B~?w =u-t=#Vk ).ξW kvEZ߅ xA:9`*u;e%vcm3n"A=Xp~k5Lo\+1՛S54xp8 %+ gEt ]<8Pe5% ,&u CUpIǏXP 9 ``\JR'=LFÂ5 Iǽ笈_% 2.\qr*8b U }
@a>0
YZ effects/data/Prestige.rda 0000644 0001762 0000144 00000005264 12654134353 015071 0 ustar ligges users Wkl W ?k{mo<ݵqgL'MRٻΌgf6UhSB ?T*PT$(/*DxTD-
*D B{fgn!u{=9;cMᏱ&[ZX'[b VH7dYGco'y嘚}9Qw׆Gԉ7JQ*7j
uwLMc?%YunpNu֏_ I 5|~*5wgݬQ'^]Cx7>Axc~v4S>}$}pv>|I efVg,X?2Lve\˒O6wح+Ye¡2~[g{j4JcTӄ?J|2m86;HǤ}_|)xou[K&;DS3M8if=}& xQRT197?|
cbliI2_`, vm3ؤY{9$16ݶ?3*cӰ Cnck3v{04c265ð' 17KOG\b%H
k8?
n.pm,Ћk!߇8փh1Nu؇N>ؖk} uKi>z+ݏA6R>D 7#}sG2cc9>#$te) C$rfoTo8ANJtfx }Z8{~F窋tԏ&e?fzs4n"+㥾$MS9tE?JyCq
gDqRWNp мEF8ge]& d_%ԫ
ZꡙGVW}}E|; [996h=
bShLvELz {٢|W>?&=)TOewB2&`
!|{\wZ+uˠpx.ח( x%}r3G89h|Ӿ9pJ~i w="ǻ gwH8 {}iA⽏!}@|N8g:LB<Ƃ^ÄO "y~gGȟ }נJ OO>Ђ-O{;n mǽlL@f!?Ý !'㘋8688]q7{~xHB!`&B>1
p'` tbIHb?I'n I|g ]?66Ag x؆^2;=2@ *=))45҈cI]%y'dw gM23*~Ɔaj`ÿ;3" ͔ ʺ)+655Jd[!izUS[O.}h$ ImEr@{azɅx9|ݸKVRv,O'N-~`)TW5-]\:JCg6ݻp~AY>
:ΝD+ZU˺=qi&QpɋfUL^+VnPеpuVe@]wu-a4Z]ӣUPYM'|٨p+NU̇{;R,ynYg*O8XEC,ӊy@۵4 и,C9ѹh6V-{e+ #d!3WL+g}jv2w,qz# \ܺusMX6J8p-R(fqE IzLU`ǡ1C[cKaZ`a żZ.sv[LEmn* ^_`R>
U-se{SĿ^)Ѐ9f'r# @#Fʺj+Suf2} qjPg]̵..0tŋIɃ%\o*awwV=sr+_,eLM d5;n m Yyqŕ nmJ˕ ϖ~5Wr2N\ǢSc}cF7:M8nu&4Uy3I |/Lb <d[\i&. "P=L=U*UDd-̨9ׯP:wRʪ
-|a+ ]Ί/wDvw(ԫ3.뎺E_l``b?
HYIUr ʿ{gj|ZM\w:s 5 S*9 G=+7캺 >|k}ض>%̎>yW1Fi*MĮ\>dRΙ^/1z6GN$d
96큑o]u`=YRinX 5f6. keKQUʤ%y<ͤZWn0]I c&p*uH$. ?#߂`
>]˿`D"4+7U)
"3Rw -te7Q>Kr6
V
sU ({dmjǻ l{ HAoB:F
~ -@ldhKXMK5nJ 7sKIetHn##,փ hIոΖwMfkdRо;k=r~-֥eNZQ<}r: ?YM2MD7J[/M303-Knd_3
-5o4.ibz!cO%z YnĞ1?H ?@I7sV0ȯLc^gqOo*=E:qdj((%_Hx`%;$W,*Q}Sm?[%2J2{ -@s`9)
Rʏ%#()@Ʉ
< I
2Z (]0Ct[=4`5/JQ ZGaɻ0<2eϬDľcNơ^`M@; 2>&CK #-aA;-ΤpM{iG[[ ưv2m銈({܆eKoLX*~W2#Q>/-d@ tY $( nP@7SS>.eQQR(T1a ]vÜ]{#buT6.c:~Î[
#Azyx:Ђভ$ipD>$qx`v%LښWvŋ]$Q !oCQkZ8u8uWc287vxRkPĥ(9kkRћxcx
$jd-kA_qRCX *:xq"(
*M
C]0&^Aobn;XCz<]霮 tu[Y܁峓5 VGe 7HAA#SM@G *}g}Yrh2L|
yk~s}@5(}CX#y"R".yGĻ0gEB gS
xCIby)ӬRx G$ADgI17RI}S[s0b-30gK- Mg -9Z
JTktx(nm ! ဨ3]ߤ!+Ts<48Bvl&*u&{}Cd>U
ͨlJ{gqX` _--;^}Sq6%
4@;\'Wo_PQjox?Tg찤Nb} W'Ti[ࢨyh\ q\, 2%pFhBM?0rTR \6c`F7lW;Q4sŵn @j@-T\, bj {jy)4:` D$ps)5Hޟ p@+D ͤEiەRə3
^ ] "oI 0}JD Q8wIX1hQ2R(b́~W_k$ =MhFNm*J=5[V '>gpCvyI0VӉ,>ĿIufLjE 00ODk @|,zEU1d, ϗ53Oo0!ωVf4 z`TK?{!u-O% wSd JbʢmxytXz ygל6! v3{IK`dAXP GgE~ G Mz_vU|^Q6ZG k#Wn DY97Gwy*FL}((560&q ӭhqTaXt:Ek>:pil,v2q@%}&ǜl*N=Mܜ'k:S7 qKiU Q*ׅ\>o33:_%%cTe$Ek)O1:ЂS,9 QGüYSʝڧ]'
X\g8( c;fwU?u::.ru\e X 8k ̈́JYs;>eOiL:ލiH b{fwϬ8UYyzqSoŝ$ r3!,n(7@:ŕc u×?UOO9GQ#&l4- 5E(& dQD[COPA骓L@H 5ѧ}#<G擲b; + %3J<N)1Ż[fK x݈R:,VD zפBrmca:ȍ]A !4|ˢh0@i) $ {l > nHtƞ_I lA2mc=sz}3/5UTx ReR-@&I {5zzE.E߸z,L> `xJe3o0q.&ğgDzb4{0ctBn| lm3 DmRwƓ2~ݬx⏻ qIy]!N6 Ї ` =<ٞFR %T)R WkW0H;YȂs?ʍu }+})\VtѦk%~V]1a<ۧkvJ:W|<2lQaTfc-&PrA|3
R+I| uv*$ARQ
[C8h(ubose&u:`>?1/H2#,
,~a sȶbax>A(
)y%Ew $LIm CU#v&}qg6~WqN@CIr.*b --Ñ ] A0 װ^?@ x7YzdN h# X[͔\Z=+tC{f6]*JRNu=-y(3_2,5H'G #m$=Yi*+/3_kv3De]
yx%>ae>)K(8Ď@7IxUG_}!0@MhRֻa5
Wפg E&tɨfa7)R W'P
v=ʗԚSᾳDo<NÌבjz@sS*Hjg q&xUNx0,=b Ag
`G^^Tױ9JtR?X~Ҽ3L}mBw ^LUa=IW̠iXըG{e{[wu8]1 >]2Lc {\v\L$ͦ(h [葨EREH+z1RRFr>ngZg@u١& @[G}DH(>KğH-<\l};*h80[Ȁ͟7lB|3 h[g+yk>r[
j@(': ooǠ~ I8~$8(gMavXUt^&iAa?q R) X[_ ,u )N.) LnIOԭw|#1}rͱv Nh ,ڹ3v+*|(E 6+/4?c5Ec7H~~]2RaU `n^BgYS0Gl^j*ow'o|]p;0c;7'4az Q*φ/ 1k4duF>;3R Ty9Z sS/+ "\W 4 pX\Z9 xyƛ;{~@iL0w-fқEv+7X9bg?U0O.=Kg䃁DKs xhUA]9@ f|Ȱ7G%FjʆÙNdI jBvxE<|0/^u&bCՙr U*=$Ws·LQ#9 3O"} x~+'jW~G XlqI
gnD (OSOyN`c{/y5bpynDG=|zS^MݢR8u07Q%4ƞڹs Z|*@c}(K@hs9>{Jv>u)(rΘ9%Oc#gVXn\~Z2[iY/ \^6AG?sK ܣ?իDW.8b<͂@ͨ
0В撆pٴW`/iIFx9us=Mpgx ں~/_6Q-`\ ԭkdSi}rU_&/p* 0qW 3;wq/VQO(]B <]gܽ\x}19ɨ
iW R GJI(Kި_FG2HQs$/5- ɪ{ 0n8eD~_5lvR$t Ŝ YAv@805k9K˾iK.\'9a0KFkQ}PU_Ys,@x) Z2ֹ~u~,ў{^iIO }Fl
hCB~ *\6}P͛wf@'+#;Mދ 5_.bUmO Oo :7@36̡זv+^1̔QGDPx^B" Y*
^tQ68}7YCGmwL
yɎr~1^, ?Nӭg|#6D|Ǫٙ[^3TD#- %u/N涇WNe#}V(z0a"a lS< aR4ȒG}KVfC1-Fěp
9#[KïM
08XR/ju
*ʽ{Q.
l)
v\7";Ce
4O; v 35JpQMq0C0^^9.WΔka]ϵ.L7"= a1eL
P6NHS 3q!E }}QHJGjmbOR ]62NC\EpKYw:ݘ4< 8i 7Q fsco>QIӜ Z4n2|n1E)QHwYv,S'ptS~s'5Ǖ3lpC3e 1jUR:6X|1U,&i/_,U:X }c+Yk0Z
7*T7D?r0 xGoW1`9 BeB= nu9Jq!euYApx"8[^G? և@{KD?k_ *FJH͏h/rP%m} 5*!`+D"Qp Oʩ(
3U )Ҽۙ3Vӳʹӗ V 2<3Ң 6uH ͐6!eFuuڀY2ڳew3 y47#R"ZW?Ba 8
߱vQ',{#cE0MmaXT`2~~SsA z h p2<4!\%
SRn =
,"WW 0PE.W(^=,er&)+"l> HVzᕵ`+
)!$y,Q't;}XN}; NeD![_ ӅVU 4 z!V:5 DT/2Z=^ #ښb :X` `K0ٟM>M7#CZ︊~1lx+dqkПh]c5J {
iTۨirM*Y
#&~ #[ʑIL7#Y ĘsDpbäx!ڨ
@1KXzӤ473qQ:XsupsSo}V I4U=f8"CB>Dr(bQgDyneg- jz-wr6 ;%}Ļp%3J d
'َ+dLM5M"kuYKDerC^YNjL >
$j}.>O14g,
a=M8k68< Tp8Y@`Ry 5tIݓk Y#'_"8:s_ql;E<[F 7>* Z$ҍ/ȲS-_шhR%_F+Тɺ\~X+&6r_ z#bŋcz^F*cnsq Wj@?T$o2wmuݻu!m 0
,;C/t.Y9*(.q\ ĥȲ;?`-A9}vK*LlAP1f
NUQh 7ΰ ۜ
0%\0u:V<]=j /9ÎKEU`qz(t8햂@0}Tҥc,lƄ x%!ߣbj+P*Ȃ1
9zpTOVUVH2vِ?s1lBkI.z XT?%>
cf&!
a]U9%DF}y'g 7R^8xKj&|/E֪>/ML$P$2^."9ңcOdҒC!7=`mXL+:]KW1yp" =)Q^H Nr ;Q?"KdL6I}drsM"$-bO@ʻ/6H_4.G|V "^oqO.t|gM7&e#ᦏvmlzҾj*n2lxYhZEx"-`1?@{>ӏ㕟 Q\%N=,>O,1I6푕%<;?#5y7;(|46RDU =ב a.FMoRk!.ek='b &) pI_[/ڻhREG{D8(aӭiGٍ f QDs>0
YZ effects/data/Hartnagel.rda 0000644 0001762 0000144 00000002132 12654134353 015203 0 ustar ligges users ]lSe߶ ^hflb#0܂9k}vMDPDL1zCx
K!$t\x <>_=YNbU+))UŏGU :RP/3~j@=hTz &$x ow. {`/ 8> C08>G8> p| Nn)Uۢ * g g" @ OV
m` Tj}` hA+@ {=DAUr
L_
+
}xb9=Ӕnp\x< ~kYKܒd{/㾓g{._ӝ"S+yNJޤ 9ř⿆/^W3*~:o'c<Go-tc/=./2Y]}迤s^0i繜'Ħ-.tE%"l
O?xas:jB];TYgD՛ @PѧK+NA꺢&Vca<2""v Я+gO&è_^샼?u{,qxGô∷Ds'et5%WWT"D `,v_R47ݱT([O>@!F͑Ң_oAsR[4@[ ֿk*6Gg_+:m̽ RB:[ P 5@ -@_xI \>&+*p.3qn&(Jr=ڝ5&ϵ=6͇dtWQ*伆_k̥0su'Sw_G'gJqB:߂`i6W.u})T!dL,~})<4I}` f AĎ7plqhŴ nW.u, ='V QynA)A_Bcx>&fsEyd`2 ࠷"M Xd~WDAS{JEhqx
DaGm4I[^ Js!C- j
U$ lo]nl0 fφ\k6S ]6YO]:*Zհ&l |%(a/0N;FcmIV VXuIr &<6:˥g>B R HfnE]' ^77YNpgF -DIӑ}WΎ3@v#)I(S_zsj DUzՎ?Kf&LI]ŗa."Sx* gႶ|
f
1(U{͈؎&i!Pc(JO g┸
SH>Wf>+GO
d<[6", )M>53&$
$HsnDf7 $F_3{5"^]>6g8&Q ]\.8g} _
bv&D)ML /t{P \Vn=Lcuc- +,H מf[12" npZ-./L;zڝv?:oB(v} \/W$h>D6u^tG y:jUgT,Q=e)S<9wY< g/6t3Sh>r+.^χĪ\ VV4TaA' ތb*e-I%tEĮ +ی n?'a[oo'7|"ѩZo#tYT}MS"$jhsڅlxO:S1+oā܍J#{lˢ S
9Uyh[cL''T[XA&V_uK~?LǶHNq̙(F.mXQ>M,N{ eo:IH}Zat z
n6HZ
'yFΔDmF*F|AgC VeK砛.0張ծ3YѻJá9J%vW3?۱ƚkH=9)|#V9-c;4@jo4Jfd{t*9_Dq,5tGZ.K;GH G+o6v
|`1q+LԦ#Ed*|:h?e2Cz/O8'}V^o@";@yy9 vqLŵ*P58
'
d63A:Q8_~P; %pP pр}Va8Kdy~ExఫVyP֠%?v͙ g4b~%#ӎ6O &b$D%Gl$` <~W@ퟗǝ0C-/oF>j2[CIֳ2P.^ld{@5\Q.]cC9ff_PI6rd^<m,# @6u$bXv|k蟕7]
f=369=MܓW['[WAlsKUW+KstR v6}0{QhLifzy{<%gV,Owy! RI|3W605NXQ2dndD~`EWfJ`;gu ַ9 F2ެqpѻBFSq|Z 7Fi g$i
?q F 1_#2}aiT -" =Q 917L~#h2n L+]a;ؠ7V$xNq&YvjW#[}#Ԛb&x,W -& .Yˋngz; )wGFZ^AWQ=D_G&SY; 5GK
ڑV U|R@YY)M
t7g*|!@.,4XUx#|@@Y3]
8'~&nF~B\&HMƒ5C=WTKZXs^m0u} e7eZ,`(O t2шv$պ[</ FlUt > Xu *D9q>g"ݣjcpoҨRo4Bq)&&ݸbc wfMS>u;/ R,묥,vE
r%; yfWW"˂
Q*y , Nүbo`Yg5:J5_$ѿ/3}47nS"JfNFyB>롪ppBsYGeH]1"E
%E[Yv:W~wA
<-ܵ
̂k]/ !U9Xfev\I,
bwO>}}NsI]ZQZ\Bh"qlR r -!u]X3)TT+p#})ʍ/I'c Wi*(cWaE4b[D9UWg3
[
>.T/T
:180,%Z-jߢN
3Ac/OݥڽFH/:p6y*EkH'-ĝpK뇣g]Bt܀Эԩ
I՞so_lvvDJ y St̊JB p B~hjR_~'
!¹1B` 77 \3qCaژcJ$[pbˇsT30LD~x~¥M
((@Qwipaf8P4S`㞅j8AIHź6!AR
J3(VIgDvTnM-eibޅoKM!oN/a& a-#oYq`I^fnz[T(ڲ:g1t0HAU[D
a!B
C_ٖE 8YQTqV&72>pʵA#@@ }sf CiK1CiRߜsVl ,wa篝 $&{hJg] H?Ȯ{ si"A^ڱ~F:I/}Bk@;;= £B?zkº$>ү'=ELUE XH2\#$ſT5K(n
&Sbyv+WMלPo> [DWuC5}kyF]DeR
3c,X"J[.|Qi F`6i!hіAm /m
Ε֠M$E =Nق %->n2c{
u
#VʆlkdMNAmf8)KlhlC5 e\w-:dpQKZQmW
+bx{8M w}#qKܶz5LE5`(D Mھik3u # ʑ`MWQYJgzL#ͯ +܋*CI?*@ϼ;.+_k:(' rxRwM<2l8҄c>הeשy4ωb:-EZd
ZTfAF.jFfhij\p (~G[Z_S/ی80(/ M#
] H51n+-1Bܗܩ!_( 8[sIn; JΗVWcjRue͠L21 j ZkqoB恙=?`)?&<#н\d}%qID,;m+,7IRj!{` kxh7߃=?l %"#~}UN]Ȣ
POZ{I+: /.R3ny@x3ۻəh*]ױxou^cS 4mJj#V
b3e=?l;ig̡-h9 9"
6 =>0
YZ effects/R/ 0000755 0001762 0000144 00000000000 12654133545 012102 5 ustar ligges users effects/R/effectspoLCA.R 0000644 0001762 0000144 00000003606 12415772752 014534 0 ustar ligges users # 2013-07-31: extend effects to poLCA objects. S. Weisberg
# 2013-10-15: removed effect.poLCA. J. Fox
#The next two functions should be exported to the namespace
allEffects.poLCA <- function(mod, ...){
allEffects(poLCA.to.fake(mod), ...)
}
Effect.poLCA <- function(focal.predictors, mod, ...) {
result <- Effect(focal.predictors, poLCA.to.fake(mod), ...)
result$formula <- as.formula(formula(mod))
result
}
# this function makes a 'fake' multinom object or 'glm' object so
# effect.mulitnom or effect.glm can be used.
# effect.multinom requires at least 3 classes, so if classes=2 use
# effect.glm
poLCA.to.fake <- function(mod) {
dta <- eval(mod$call$data)
form <- as.formula(eval(mod$call$formula))
# find the missing data:
omit <- attr(model.frame(form, dta), "na.action")
if(length(omit) == 0) dta$.class <- factor(mod$predclass) else{
dta$.class <- rep(NA, dim(dta)[1])
dta$.class[-omit] <- mod$predclass
dta$.class <- factor(dta$.class)
}
# end of missing data correction
formula1 <- update(form, .class ~ .)
if(length(mod$P) == 2L){
mod1 <- glm(formula1, family=binomial, data=dta)
mod1$call$data <- dta
mod1$call$formula <- formula1
mod1$coef <- mod$coeff[, 1]
mod1$vcov <- mod$coeff.V
class(mod1) <- c("fakeglm", class(mod1)) }
else {
mod1 <- multinom(formula1, dta, Hess=TRUE, trace=FALSE, maxit=1)
mod1$call$data <- dta
mod1$call$formula <- formula1
mod1$coeff <- mod$coeff
mod1$coeff.V <- mod$coeff.V
class(mod1) <- c("fakemultinom", class(mod1))
}
mod1
}
coef.fakemultinom <- function(mod){
coef <- t(mod$coeff)
dimnames(coef) <- list(mod$lab[-1L], mod$vcoefnames)
coef
}
vcov.fakemultinom <- function(mod){mod$coeff.V}
effects/R/effectsclmm.R 0000644 0001762 0000144 00000004160 12536037056 014515 0 ustar ligges users # 2014-12-11 Effects plots for ordinal and ordinal mixed models from the 'ordinal' package
# 2014-12-11 effect.clm built from effect.mer as modified 2014-12-07, by S. Weisberg
# 2015-06-10: requireNamespace("MASS") rather than require("MASS)
clm2.to.polr <- function(mod) {
if (requireNamespace("MASS", quietly=TRUE)){
polr <- MASS::polr
}
else stop("The MASS package is needed for this function")
cl <- mod$call
present <- match(c("scale", "nominal", "link", "threshold"), names(cl), 0L)
if(any(present != 0)) {
if(present[3] != 0){if(cl$link != "logistic") stop("'link' must be 'logisitic' for use with effects")}
if(present[4] != 0){if(cl$threshold != "flexible") stop("'threshold' must be 'flexible' for use with effects")}
if(present[1] != 0){if(!is.null(cl$scale)) stop("'scale' must be NULL for use with effects")}
if(present[2] != 0){if(!is.null(cl$nominal)) stop("'nominal' must be NULL for use with effects")}
}
if(is.null(mod$Hessian)){
message("\nRe-fitting to get Hessian\n")
mod <- update(mod, Hess=TRUE)
}
cl$formula <- cl$location
cl$method <- cl$link
m <- match(c("formula", "data", "subset","weights",
"na.action", "contrasts", "method"), names(cl), 0L)
cl <- cl[c(1L, m)]
cl$start <- c(mod$beta, mod$Theta)
cl[[1L]] <- as.name("polr")
mod2 <- eval(cl)
mod2$coefficients <- mod$beta
# get vcov
numTheta <- length(mod$Theta)
numBeta <- length(mod$beta)
or <- c( (numTheta+1):(numTheta + numBeta), 1:(numTheta))
mod2$vcov <- as.matrix(vcov(mod)[or, or])
class(mod2) <- c("fakeclm2", class(mod2))
mod2
}
#method for 'fakeglm' objects. Do not export
vcov.fakeclm2 <- function(object, ...) object$vcov
#The next thre functions should be exported
effect.clm2 <- function(term, mod, ...) {
effect(term, clm2.to.polr(mod))
}
allEffects.clm2 <- function(mod, ...){
allEffects(clm2.to.polr(mod), ...)
}
Effect.clm2 <- function(focal.predictors, mod, ...){
Effect(focal.predictors, clm2.to.polr(mod))
}
effects/R/effectsmer.R 0000644 0001762 0000144 00000016067 12647513565 014370 0 ustar ligges users # effect.mer and effect.lme built from effect.lm by S. Weisberg 29 June 2011
# last modified 2012-03-08 to require() lme4 or nlme. J. Fox
# 2012-10-05 effect.lme didn't work with 'weights', now corrected. S. Weisberg
# 2013-03-05: introduced merMod methods for development version of lme4. J. Fox
# 2013-04-06: added support for lme4.0, J. Fox
# 2013-07-30: added 'data' argument to lme.to.glm and mer.to.glm to allow
# calling effect from within a subroutine.
# 2013-09-25: removed the 'data' argument as it make the functions fail with
# logs, splines and polynomials
# 2014-09-24: added option for KR cov matrix to mer.to.glm(). J. Fox
# 2014-12-07: don't assume that pbkrtest is installed. J. Fox
# 2014-12-20: mer.to.glm failed for negative.binomial() because the link has an argument
# that was handled incorrectly by the family.glmResp function. This function is no longer
# used by mer.to.glm. The same error will recur in any link with an argument.
# 2015-06-10: requireNamespace("pbkrtest") rather than require("pbkrtest)
# 2015-07-02: fixed bug when the name of the data frame was the name of a function (e.g., sort, or lm)
# 2015-12-13: make it work with pbkrtest 0.4-3. J. Fox
# 2016-01-07: modified 'fixmod' to allow "||" in variance formulae
# 2016-01-19: Fixed bug in glm.to.mer when 'poly' is used in a model.
# the function lm.wfit fit gets the hessian wrong for mer's. Get the variance
# from the vcov method applied to the mer object.
fixmod <- function (term)
{
if (!("|" %in% all.names(term)) && !("||" %in% all.names(term)))
return(term)
if ((is.call(term) && term[[1]] == as.name("|")) ||
(is.call(term) && term[[1]] == as.name("||")))
return(NULL)
if (length(term) == 2) {
nb <- fixmod(term[[2]])
if (is.null(nb))
return(NULL)
term[[2]] <- nb
return(term)
}
nb2 <- fixmod(term[[2]])
nb3 <- fixmod(term[[3]])
if (is.null(nb2))
return(nb3)
if (is.null(nb3))
return(nb2)
term[[2]] <- nb2
term[[3]] <- nb3
term
}
# lme.to.glm evaluates a 'glm' model that is as similar to a given 'lme'
# model, in the same pattern as mer.to.glm. This could be speeded up
# slightly by using 'lm' rather than 'glm' but I use 'glm' to parallel
# mer.to.glm more closely. The differences are: (1) match fewer args
# in the call; (2) different def of mod2$coefficients; no other
# changes
# The argument 'data' to lme.to.glm and to mer.to.glm copies the data
# from the object into the local environment and makes it visible when 'effect'
# is called from within another function.
lme.to.glm <- function(mod) {
cl <- mod$call
cl$formula <- cl$fixed
m <- match(c("formula", "data", "subset",
"na.action", "contrasts"), names(cl), 0L)
cl <- cl[c(1L, m)]
cl[[1L]] <- as.name("glm")
mod2 <- eval(cl)
pw <- attr(mod$modelStruct$varStruct, "weights")
if(!is.null(pw)) mod2$prior.weights <- pw
mod2$coefficients <- mod$coefficients$fixed
mod2$vcov <- as.matrix(vcov(mod))
mod2$linear.predictors <- model.matrix(mod2) %*% mod2$coefficients
mod2$fitted.values <- mod2$family$linkinv(mod2$linear.predictors)
mod2$weights <- as.vector(with(mod2,
prior.weights * (family$mu.eta(linear.predictors)^2 /
family$variance(fitted.values))))
mod2$residuals <- with(mod2,
prior.weights * (y - fitted.values)/weights )
class(mod2) <- c("fakeglm", class(mod2))
mod2
}
# mer.to.glm evaluates a 'glm' model that is as similar to a given 'mer'
# model as follows. It is of class c("fakeglm", "glm", "lm")
# several items are added to the created objects. Do not export
mer.to.glm <- function(mod, KR=FALSE) {
if (KR && !requireNamespace("pbkrtest", quietly=TRUE)){
KR <- FALSE
warning("pbkrtest is not available, KR set to FALSE")
}
# object$family$family doesn't work correctly with the negative binomial family because of the
# argument in the family function, so the old line
# family <- family(mod)
# returns an error message for these models. The following kluge fixes this.
# If this bug is fixed in lme4, this code may break because it expects resp$family$family
# to return "Link Name(arg)" with ONE argument, and so spaces between Name and "(arg)"
family1 <- function(object, ...) {UseMethod("family1", object@resp)}
family1.lmResp <- function(object, ...) family(object, ...)
family1.glmResp <- function(object, ...){
famname <- object@resp$family$family
open.paren <- regexpr("\\(", famname)
if(open.paren==-1) {
name <- famname
arg <- list()
} else {
name <- sub(" ", ".", tolower(substr(famname, 1, -1 + open.paren)))
arg <- list(as.numeric(gsub("\\)", "", substr(famname, 1 + open.paren, 100))))
}
if(is.null(object@resp$family$initialize)) do.call(name, arg) else object@resp$family
}
family <- family1(mod)
# end
link <- family$link
family <- family$family
cl <- mod@call
if(cl[[1]] =="nlmer") stop("effects package does not support 'nlmer' objects")
m <- match(c("formula", "family", "data", "weights", "subset",
"na.action", "start", "offset",
"model", "contrasts"), names(cl), 0L)
cl <- cl[c(1L, m)]
cl[[1L]] <- as.name("glm")
cl$formula <- fixmod(as.formula(cl$formula))
# cl$data <- mod@frame # caused bug with a 'poly' in the formula
mod2 <- eval(cl)
mod2$coefficients <- lme4::fixef(mod) #mod@fixef
mod2$vcov <- if (family == "gaussian" && link == "identity" && KR) as.matrix(pbkrtest::vcovAdj(mod)) else as.matrix(vcov(mod))
mod2$linear.predictors <- model.matrix(mod2) %*% mod2$coefficients
mod2$fitted.values <- mod2$family$linkinv(mod2$linear.predictors)
mod2$weights <- as.vector(with(mod2,
prior.weights * (family$mu.eta(linear.predictors)^2 /
family$variance(fitted.values))))
mod2$residuals <- with(mod2,
prior.weights * (y - fitted.values)/weights )
class(mod2) <- c("fakeglm", class(mod2))
mod2
}
#method for 'fakeglm' objects. Do not export
vcov.fakeglm <- function(object, ...) object$vcov
#The next six functions should be exported as S3 methods
effect.mer <- function(term, mod, vcov.=vcov, KR=FALSE, ...) {
result <- effect(term, mer.to.glm(mod, KR=KR), vcov., ...)
result$formula <- as.formula(formula(mod))
result
}
effect.merMod <- function(term, mod, vcov.=vcov, KR=FALSE, ...){
effect.mer(term, mod, vcov.=vcov, KR=KR, ...)
}
effect.lme <- function(term, mod, ...) {
mod1 <- lme.to.glm(mod)
result <- effect(term, mod1)
result$formula <- as.formula(formula(mod))
result
}
allEffects.mer <- function(mod, KR=FALSE,...){
allEffects(mer.to.glm(mod,KR=KR), ...)
}
allEffects.merMod <- function(mod, KR=FALSE,...){
allEffects(mer.to.glm(mod,KR=KR), ...)
}
allEffects.lme <- function(mod, ...){
allEffects(lme.to.glm(mod), ...)
}
effects/R/plot.effpoly.R 0000644 0001762 0000144 00000055411 12503556754 014660 0 ustar ligges users # Plot method for effpoly objects
# modified by Michael Friendly: added ci.style="bands" & alpha.band= arg
# modified by Michael Friendly: added lwd= argument for llines (was lwd=2)
# 2013-11-06: fixed drop dimension when only one focal predictor. John
# 2014-10-10: namespace fixes. John
# 2014-12-05: made key.args more flexible. John
# 2014-03-22: use wide columns by default only when x for legend not set. J. Fox
plot.effpoly <- function(x,
type=c("probability", "logit"),
x.var=which.max(levels),
rug=TRUE,
xlab,
ylab=paste(x$response, " (", type, ")", sep=""),
main=paste(effect, "effect plot"),
colors, symbols, lines, cex=1.5, lwd=2,
factor.names=TRUE, ci.style, band.colors, band.transparency=0.3,
style=c("lines", "stacked"),
confint=(style == "lines" && !is.null(x$confidence.level)),
transform.x=NULL, ticks.x=NULL, xlim=NULL,
ylim, rotx=0, alternating=TRUE, roty=0, grid=FALSE,
layout, key.args=NULL,
row=1, col=1, nrow=1, ncol=1, more=FALSE, use.splines=TRUE, ...){
ci.style <- if(missing(ci.style)) NULL else
match.arg(ci.style, c("bars", "lines", "bands", "none"))
type <- match.arg(type)
style <- match.arg(style)
effect.llines <- llines
has.se <- !is.null(x$confidence.level)
if (confint && !has.se) stop("there are no confidence limits to plot")
if (style == "stacked"){
if (type != "probability"){
type <- "probability"
warning('type set to "probability" for stacked plot')
}
if (confint){
confint <- FALSE
warning('confint set to FALSE for stacked plot')
}
}
if (missing(colors)){
if (style == "stacked"){
colors <- if (x$model == "multinom") rainbow_hcl(length(x$y.levels))
else sequential_hcl(length(x$y.levels))
}
else colors <- palette()
}
if (missing(band.colors)) band.colors <- colors
if (missing(symbols)) symbols <- 1:length(colors)
if (missing(lines)) lines <- 1:length(colors)
.mod <- function(a, b) ifelse( (d <- a %% b) == 0, b, d)
.modc <- function(a) .mod(a, length(colors))
.mods <- function(a) .mod(a, length(symbols))
.modl <- function(a) .mod(a, length(lines))
effect <- paste(sapply(x$variables, "[[", "name"), collapse="*")
split <- c(col, row, ncol, nrow)
n.predictors <- length(names(x$x))
y.lev <- x$y.lev
n.y.lev <- length(y.lev)
ylevel.names <- make.names(paste("prob",y.lev))
colnames(x$prob) <- colnames(x$logit) <-
colnames(x$lower.logit) <- colnames(x$upper.logit) <-
colnames(x$lower.prob) <- colnames(x$upper.prob)<- ylevel.names
x.frame <-as.data.frame(x)
predictors <- names(x.frame)[1:n.predictors]
levels <- if (n.predictors==1) length (x.frame[,predictors])
else sapply(apply(x.frame[, predictors, drop=FALSE], 2, unique), length)
if (is.character(x.var)) {
which.x <- which(x.var == predictors)
if (length(which.x) == 0) stop(paste("x.var = '", x.var, "' is not in the effect.", sep=""))
x.var <- which.x
}
x.vals <- x.frame[, names(x.frame)[x.var]]
response <-matrix(0, nrow=nrow(x.frame), ncol=n.y.lev)
for (i in 1:length(x$y.lev)){
level <- which(colnames(x$prob)[i] == ylevel.names)
response[,i] <- rep(x$y.lev[level], length(response[,i]))
}
prob <- as.vector(x$prob)
logit <- as.vector(x$logit)
response <- as.vector(response)
if (has.se){
lower.prob <- as.vector(x$lower.prob)
upper.prob <- as.vector(x$upper.prob)
lower.logit <- as.vector(x$lower.logit)
upper.logit <- as.vector(x$upper.logit)
}
response <- factor(response, levels=y.lev)
data <- data.frame(prob, logit)
if (has.se) data <- cbind(data, data.frame(lower.prob, upper.prob, lower.logit, upper.logit))
data[[x$response]] <- response
for (i in 1:length(predictors)){
data <-cbind(data, x.frame[predictors[i]])
}
levs <- levels(x$data[[predictors[x.var]]])
n.predictor.cats <- sapply(data[, predictors[-c(x.var)], drop=FALSE],
function(x) length(unique(x)))
if (length(n.predictor.cats) == 0) n.predictor.cats <- 1
ci.style <- if(is.null(ci.style)) {
if(is.factor(x$data[[predictors[x.var]]])) "bars" else "bands"} else ci.style
if( ci.style=="none" ) confint <- FALSE
### no confidence intervals if confint == FALSE or ci.style=="none"
if (!confint){ # plot without confidence bands
layout <- if (missing(layout)){
lay <- c(prod(n.predictor.cats[-(n.predictors - 1)]),
prod(n.predictor.cats[(n.predictors - 1)]), 1)
if (lay[1] > 1) lay else lay[c(2, 1, 3)]
}
else layout
if (style == "lines"){ # line plot
if (n.y.lev > min(c(length(colors), length(lines), length(symbols))))
warning('Colors, lines and symbols may have been recycled')
if (is.factor(x$data[[predictors[x.var]]])){ # x-variable a factor
key <- list(title=x$response, cex.title=1, border=TRUE,
text=list(as.character(unique(response))),
lines=list(col=colors[.modc(1:n.y.lev)], lty=lines[.modl(1:n.y.lev)], lwd=lwd),
points=list(pch=symbols[.mods(1:n.y.lev)], col=colors[.modc(1:n.y.lev)]),
columns = if ("x" %in% names(key.args)) 1 else find.legend.columns(n.y.lev))
for (k in names(key.args)) key[k] <- key.args[k]
result <- xyplot(eval(if (type=="probability")
parse(text=if (n.predictors==1)
paste("prob ~ as.numeric(", predictors[x.var], ")")
else paste("prob ~ as.numeric(", predictors[x.var],") | ",
paste(predictors[-x.var], collapse="*")))
else parse(text=if (n.predictors==1)
paste("logit ~ as.numeric(", predictors[x.var], ")")
else paste("logit ~ as.numeric(", predictors[x.var],") | ",
paste(predictors[-x.var], collapse="*")))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, rug, z, x.vals, ...){
if (grid) panel.grid()
for (i in 1:n.y.lev){
sub <- z[subscripts] == y.lev[i]
good <- !is.na(y[sub])
effect.llines(x[sub][good], y[sub][good], lwd=lwd, type="b", col=colors[.modc(i)], lty=lines[.modl(i)],
pch=symbols[i], cex=cex, ...)
}
},
ylab=ylab,
ylim= if (missing(ylim))
if (type == "probability") range(prob) else range(logit)
else ylim,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
x.vals=x$data[[predictors[x.var]]],
rug=rug,
z=response,
scales=list(x=list(at=1:length(levs), labels=levs, rot=rotx),
y=list(rot=roty),
alternating=alternating),
main=main,
# key=c(key, key.args),
key=key,
layout=layout,
data=data, ...)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
else { # x-variable numeric
if(use.splines) effect.llines <- spline.llines # added 10/17/13
nm <- predictors[x.var]
x.vals <- x$data[[nm]]
if (nm %in% names(ticks.x)){
at <- ticks.x[[nm]]$at
n <- ticks.x[[nm]]$n
}
else{
at <- NULL
n <- 5
}
xlm <- if (nm %in% names(xlim)){
xlim[[nm]]
}
else range.adj(data[nm]) # range(x.vals)
tickmarks.x <- if ((nm %in% names(transform.x)) && !(is.null(transform.x))){
trans <- transform.x[[nm]]$trans
make.ticks(trans(xlm), link=transform.x[[nm]]$trans, inverse=transform.x[[nm]]$inverse, at=at, n=n)
}
else {
trans <- I
make.ticks(xlm, link=I, inverse=I, at=at, n=n)
}
key <- list(title=x$response, cex.title=1, border=TRUE,
text=list(as.character(unique(response))),
lines=list(col=colors[.modc(1:n.y.lev)], lty=lines[.modl(1:n.y.lev)], lwd=lwd),
columns = if ("x" %in% names(key.args)) 1 else find.legend.columns(n.y.lev))
for (k in names(key.args)) key[k] <- key.args[k]
result <- xyplot(eval(if (type=="probability")
parse(text=if (n.predictors==1) paste("prob ~ trans(", predictors[x.var], ")")
else paste("prob ~ trans(", predictors[x.var],") |",
paste(predictors[-x.var], collapse="*")))
else parse(text=if (n.predictors==1) paste("logit ~ trans(", predictors[x.var], ")")
else paste("logit ~ trans(", predictors[x.var],") | ",
paste(predictors[-x.var], collapse="*")))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, rug, z, x.vals, ...){
if (grid) panel.grid()
if (rug) lrug(trans(x.vals))
for (i in 1:n.y.lev){
sub <- z[subscripts] == y.lev[i]
good <- !is.na(y[sub])
effect.llines(x[sub][good], y[sub][good], lwd=lwd, type="l", col=colors[.modc(i)], lty=lines[.modl(i)], ...)
}
},
ylab=ylab,
xlim=suppressWarnings(trans(xlm)),
ylim= if (missing(ylim))
if (type == "probability") range(prob) else range(logit)
else ylim,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
x.vals=x$data[[predictors[x.var]]],
rug=rug,
z=response,
scales=list(x=list(at=tickmarks.x$at, labels=tickmarks.x$labels, rot=rotx), y=list(rot=roty),
alternating=alternating),
main=main,
# key=c(key, key.args),
key=key,
layout=layout,
data=data, ...)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
}
else { # stacked plot
if (n.y.lev > length(colors))
stop(paste('Not enough colors to plot', n.y.lev, 'regions'))
key <- list(text=list(lab=rev(y.lev)), rectangle=list(col=rev(colors[1:n.y.lev])))
for (k in names(key.args)) key[k] <- key.args[k]
if (is.factor(x$data[[predictors[x.var]]])){ # x-variable a factor
result <- barchart(eval(parse(text=if (n.predictors == 1)
paste("prob ~ ", predictors[x.var], sep="")
else paste("prob ~ ", predictors[x.var]," | ",
paste(predictors[-x.var], collapse="*")))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
groups = response,
col=colors,
horizontal=FALSE,
stack=TRUE,
data=data,
ylim=if (missing(ylim)) 0:1 else ylim,
ylab=ylab,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
scales=list(x=list(rot=rotx), y=list(rot=roty),
alternating=alternating),
main=main,
# key=c(key, key.args),
key=key,
layout=layout)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
else { # x-variable numeric
if(use.splines) effect.llines <- spline.llines # added 10/17/13
nm <- predictors[x.var]
x.vals <- x$data[[nm]]
if (nm %in% names(ticks.x)){
at <- ticks.x[[nm]]$at
n <- ticks.x[[nm]]$n
}
else{
at <- NULL
n <- 5
}
xlm <- if (nm %in% names(xlim)){
xlim[[nm]]
}
else range.adj(data[nm]) # range(x.vals)
tickmarks.x <- if ((nm %in% names(transform.x)) && !(is.null(transform.x))){
trans <- transform.x[[nm]]$trans
make.ticks(trans(xlm), link=transform.x[[nm]]$trans, inverse=transform.x[[nm]]$inverse, at=at, n=n)
}
else {
trans <- I
make.ticks(xlm, link=I, inverse=I, at=at, n=n)
}
result <- densityplot(eval(parse(text=if (n.predictors == 1)
paste("~ trans(", predictors[x.var], ")", sep="")
else paste("~ trans(", predictors[x.var], ") | ",
paste(predictors[-x.var], collapse="*")))),
probs=x$prob,
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel = function(x, subscripts, rug, x.vals, probs=probs, col=colors, ...){
fill <- function(x, y1, y2, col){
if (length(y2) == 1) y2 <- rep(y2, length(y1))
if (length(y1) == 1) y1 <- rep(y1, length(y2))
panel.polygon(c(x, rev(x)), c(y1, rev(y2)), col=col)
}
n <- ncol(probs)
Y <- t(apply(probs[subscripts,], 1, cumsum))
fill(x, 0, Y[,1], col=col[1])
for (i in 2:n){
fill(x, Y[,i-1], Y[,i], col=col[i])
}
if (rug) lrug(trans(x.vals))
},
rug=rug,
x.vals=x$data[[predictors[x.var]]],
data=x$x,
xlim=suppressWarnings(trans(xlm)),
ylim=if (missing(ylim)) 0:1 else ylim,
ylab=ylab,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
scales=list(x=list(at=tickmarks.x$at, labels=tickmarks.x$labels, rot=rotx), y=list(rot=roty),
alternating=alternating),
main=main,
# key=c(key, key.args),
key=key,
layout=layout, ...)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
}
}
### with confidence bands
else{ # plot with confidence bands
layout <- if(missing(layout)) c(prod(n.predictor.cats), length(levels(response)), 1)
else layout
if (type == "probability"){
lower <- lower.prob
upper <- upper.prob
}
else {
lower <- lower.logit
upper <- upper.logit
}
### factor
if (is.factor(x$data[[predictors[x.var]]])){ # x-variable a factor
levs <- levels(x$data[[predictors[x.var]]])
result <- xyplot(eval(if (type=="probability")
parse(text=if (n.predictors==1)
paste("prob ~ as.numeric(", predictors[x.var],") |", x$response)
else paste("prob ~ as.numeric(", predictors[x.var],") |",
paste(predictors[-x.var], collapse="*"),
paste("*", x$response)))
else parse(text=if (n.predictors==1)
paste("logit ~ as.numeric(", predictors[x.var],") |", x$response)
else paste("logit ~ as.numeric(", predictors[x.var],")|",
paste(predictors[-x.var], collapse="*"),
paste("*", x$response)))),
par.strip.text=list(cex=0.8),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, x.vals, rug, lower, upper, ... ){
if (grid) panel.grid()
good <- !is.na(y)
effect.llines(x[good], y[good], lwd=lwd, type="b", pch=19, col=colors[1], cex=cex, ...)
subs <- subscripts+as.numeric(rownames(data)[1])-1
if (ci.style == "bars"){
larrows(x0=x[good], y0=lower[subs][good],
x1=x[good], y1=upper[subs][good],
angle=90, code=3, col=colors[.modc(2)], length=0.125*cex/1.5)
}
else if(ci.style == "lines"){
effect.llines(x[good], lower[subs][good], lty=2, col=colors[.modc(2)])
effect.llines(x[good], upper[subs][good], lty=2, col=colors[.modc(2)])
}
else { if(ci.style == "bands") {
panel.bands(x[good], y[good],
lower[subs][good], upper[subs][good],
fill=band.colors[1], alpha=band.transparency)
}}
},
ylab=ylab,
ylim= if (missing(ylim)) c(min(lower), max(upper)) else ylim,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
main=main,
x.vals=x$data[[predictors[x.var]]],
rug=rug,
lower=lower,
upper=upper,
scales=list(x=list(at=1:length(levs), labels=levs, rot=rotx),
y=list(rot=roty), alternating=alternating),
layout=layout,
data=data, ...)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
else { # x-variable numeric
if(use.splines) effect.llines <- spline.llines # added 10/17/13
nm <- predictors[x.var]
x.vals <- x$data[[nm]]
if (nm %in% names(ticks.x)){
at <- ticks.x[[nm]]$at
n <- ticks.x[[nm]]$n
}
else{
at <- NULL
n <- 5
}
xlm <- if (nm %in% names(xlim)){
xlim[[nm]]
}
else range.adj(data[nm]) # range(x.vals)
tickmarks.x <- if ((nm %in% names(transform.x)) && !(is.null(transform.x))){
trans <- transform.x[[nm]]$trans
make.ticks(trans(xlm), link=transform.x[[nm]]$trans, inverse=transform.x[[nm]]$inverse, at=at, n=n)
}
else {
trans <- I
make.ticks(xlm, link=I, inverse=I, at=at, n=n)
}
result <- xyplot(eval(if (type=="probability")
parse(text=if (n.predictors==1)
paste("prob ~ trans(", predictors[x.var],") |", x$response)
else paste("prob ~ trans(", predictors[x.var],") |",
paste(predictors[-x.var], collapse="*"),
paste("*", x$response)))
else parse(text=if (n.predictors==1)
paste("logit ~ trans(", predictors[x.var],") |", x$response)
else paste("logit ~ trans(", predictors[x.var],") |",
paste(predictors[-x.var], collapse="*"),
paste("*", x$response)))
),
par.strip.text=list(cex=0.8),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, x.vals, rug, lower, upper, ... ){
if (grid) panel.grid()
if (rug) lrug(trans(x.vals))
good <- !is.na(y)
effect.llines(x[good], y[good], lwd=lwd, col=colors[1], ...)
subs <- subscripts+as.numeric(rownames(data)[1])-1
if (ci.style == "bars"){
larrows(x0=x[good], y0=lower[subs][good],
x1=x[good], y1=upper[subs][good],
angle=90, code=3, col=colors[.modc(2)], length=0.125*cex/1.5)
}
else if(ci.style == "lines"){
effect.llines(x[good], lower[subs][good], lty=2, col=colors[.modc(2)])
effect.llines(x[good], upper[subs][good], lty=2, col=colors[.modc(2)])
}
else { if(ci.style == "bands") {
panel.bands(x[good], y[good],
lower[subs][good], upper[subs][good],
fill=band.colors[1], alpha=band.transparency)
}}
},
ylab=ylab,
xlim=suppressWarnings(trans(xlm)),
ylim= if (missing(ylim)) c(min(lower), max(upper)) else ylim,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
main=main,
x.vals=x$data[[predictors[x.var]]],
rug=rug,
lower=lower,
upper=upper,
scales=list(y=list(rot=roty), x=list(at=tickmarks.x$at, labels=tickmarks.x$labels, rot=rotx),
alternating=alternating),
layout=layout,
data=data, ...)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
}
result
}
effects/R/utilities.R 0000644 0001762 0000144 00000062746 12647513565 014265 0 ustar ligges users # utilities and common functions for effects package
# John Fox, Jangman Hong, and Sanford Weisberg
# 7-25-2013 S. Weisberg modified analyze.model and Analyze.model to ignore
# default.levels, and use xlevels to set default. Use grid.pretty by default
# 11-09-2013: fixed error message in Analyze.model(), bug reported by Joris Meys. J. Fox
# 2013-10-15: eliminated functions not needed after effect() methods removed. J. Fox
# 2013-10-29: fixed as.data.frame.*() to handle NA levels. J. Fox
# 2014-03-13: modified Fixup.model.matrix() and Analyze.model() to handle partial residuals;
# added is.factor.predictor() and is.numeric.predictor(). J. Fox
# 2014-03-14: error message for non-factor, non-numeric predictor
# 2014-07-08: if no numeric predictor, partial residuals suppressed with warning rather than an error
# 2014-10-09: namespace fixes. J. Fox
# 2015-04-08: added setStrip(), restoreStrip(). J. Fox
# 2015-07-07: fixed matchVarName() so that it handles periods in names properly. J. Fox
# 2015-09-10: added a fix for class = 'array' in Analyze.model. S. Weisberg
has.intercept <- function(model, ...) any(names(coefficients(model))=="(Intercept)")
term.names <- function (model, ...) {
term.names <- gsub(" ", "", labels(terms(model)))
if (has.intercept(model)) c("(Intercept)", term.names)
else term.names
}
response.name <- function (model, ...) deparse(attr(terms(model), "variables")[[2]])
mfrow <- function(n, max.plots=0){
# number of rows and columns for array of n plots
if (max.plots != 0 & n > max.plots)
stop(paste("number of plots =",n," exceeds maximum =", max.plots))
rows <- round(sqrt(n))
cols <- ceiling(n/rows)
c(rows, cols)
}
expand.model.frame <- function (model, extras, envir = environment(formula(model)),
na.expand = FALSE){ # modified version of R base function
f <- formula(model)
data <- eval(model$call$data, envir)
ff <- foo ~ bar + baz
if (is.call(extras))
gg <- extras
else gg <- parse(text = paste("~", paste(extras, collapse = "+")))[[1]]
ff[[2]] <- f[[2]]
ff[[3]][[2]] <- f[[3]]
ff[[3]][[3]] <- gg[[2]]
if (!na.expand) {
naa <- model$call$na.action
subset <- model$call$subset
rval <- if (is.null(data)) eval(call("model.frame", ff, # modified
subset = subset, na.action = naa), envir) # lines
else eval(call("model.frame", ff, data = data, #
subset = subset, na.action = naa), envir) #
}
else {
subset <- model$call$subset
rval <- eval(call("model.frame", ff, data = data, subset = subset,
na.action = I), envir)
oldmf <- model.frame(model)
keep <- match(rownames(oldmf), rownames(rval))
rval <- rval[keep, ]
class(rval) <- "data.frame"
}
return(rval)
}
is.relative <- function(term1, term2, factors) {
all(!(factors[,term1]&(!factors[,term2])))
}
descendants <- function(term, mod, ...){
names <- term.names(mod)
if (has.intercept(mod)) names <- names[-1]
if(length(names)==1) return(NULL)
which.term <- which(term == names)
if (length(which.term) == 0){
factors <- attr(terms(...), "factors")
rownames(factors) <- gsub(" ", "", rownames(factors))
colnames(factors) <- gsub(" ", "", colnames(factors))
(1:length(names))[sapply(names,
function(term2) is.relative(term, term2, factors))]
}
else {
factors <- attr(terms(mod), "factors")
rownames(factors) <- gsub(" ", "", rownames(factors))
colnames(factors) <- gsub(" ", "", colnames(factors))
(1:length(names))[-which.term][sapply(names[-which.term],
function(term2) is.relative(term, term2, factors))]
}
}
is.high.order.term <- function(term, mod,...){
0 == length(descendants(term, mod, ...))
}
subscripts <- function(index, dims){
subs <- function(dims, index){
dim <- length(dims)
if (dim == 0) return(NULL)
cum <- c(1,cumprod(dims))[dim]
i <- index %/% cum
if (index %% cum != 0) i <- i + 1
c(i, subs(dims[-dim], index - (i - 1)*cum))
}
rev(subs(dims, index))
}
matrix.to.df <- function(matrix, colclasses){
opt <- options(warn = -1)
on.exit(options(opt))
ncol <- ncol(matrix)
colnames <- colnames(matrix)
colclasses[sapply(colclasses, function(x) "integer" %in% x)] <- "numeric"
result <- vector(mode="list", length=ncol)
names(result) <- colnames
for (j in 1:ncol){
result[[j]] <- matrix[, j]
class <- colclasses[[colnames[j]]]
result[[colnames[j]]] <- if ("numeric" %in% class) {
decChar <- getOption('OutDec')
if (decChar == '.') as.numeric(result[[colnames[j]]])
else as.numeric(gsub(decChar, '.', matrix[,j]))
}
else if ("ordered" %in% class) ordered(result[[colnames[j]]])
else if ("factor" %in% class) factor(result[[colnames[j]]])
else result[[colnames[j]]]
}
as.data.frame(result)
}
# the following function is a modification of code contributed by Steve Taylor
as.data.frame.eff <- function(x, row.names=NULL, optional=TRUE, transform=x$transformation$inverse, ...){
xx <- x$x
for (var in names(xx)){
if (is.factor(xx[[var]])){
xx[[var]] <- addNA(xx[[var]]) # handle factors with "valid" NA level
}
}
x$x <- xx
result <- if (is.null(x$se)) data.frame(x$x, fit=transform(x$fit))
else data.frame(x$x, fit=transform(x$fit), se=x$se, lower=transform(x$lower), upper=transform(x$upper))
attr(result, "transformation") <- transform
result
}
as.data.frame.effpoly <- function(x, row.names=NULL, optional=TRUE, ...){
factors <- sapply(x$variables, function(x) x$is.factor)
factor.levels <- lapply(x$variables[factors], function(x) x$levels)
if (!length(factor.levels) == 0){
factor.names <- names(factor.levels)
for (fac in factor.names){
x$x[[fac]] <- factor(x$x[[fac]], levels=factor.levels[[fac]], exclude=NULL)
}
}
result <- data.frame(x$x, x$prob, x$logit)
if (!is.null(x$confidence.level)) result <- cbind(result,
x$se.prob, x$se.logit, x$lower.prob, x$upper.prob, x$lower.logit, x$upper.logit)
result
}
as.data.frame.efflatent <- function(x, row.names=NULL, optional=TRUE, ...){
xx <- x$x
for (var in names(xx)){
if (is.factor(xx$var)){
xx$var <- addNA(xx$var) # handle factors with "valid" NA level
}
}
x$x <- xx
if (is.null(x$se)) data.frame(x$x, fit=x$fit)
else data.frame(x$x, fit=x$fit, se=x$se, lower=x$lower, upper=x$upper)
}
logit2p <- function(logit) 1/(1 + exp(-logit))
p2logit <- function(p) log(p/(1 - p))
lrug <- function(x) {
if (length(unique(x)) < 0.8 * length(x)) x <- jitter(x)
grid.segments(x, unit(0, "npc"), x, unit(0.5, "lines"),
default.units="native")
}
## model.response not generic
model.response.gls <- function(model){
model.response(model.frame(as.formula(model$call$model), data=eval(model$call$data)))
}
terms.gls <- function(x, ...) terms(formula(x))
## vcov method for eff objects
vcov.eff <- function(object, ...) object$vcov
## [ method for efflist objects
`[.efflist` <- function(x, ...){
y <- NextMethod("[")
class(y) <- class(x)
y
}
### the following functions are for use by Effect() methods
Analyze.model <- function(focal.predictors, mod, xlevels, default.levels=NULL, formula.rhs,
partial.residuals=FALSE, quantiles, x.var=NULL, data=NULL){
#browser()
if ((!is.null(mod$nan.action)) && class(mod$na.action) == "exclude")
class(mod$na.action) <- "omit"
all.predictors <- all.vars(formula.rhs)
check.vars <- !(focal.predictors %in% all.predictors)
excluded.predictors <- setdiff(all.predictors, focal.predictors)
number.bad <- sum(check.vars)
if (any(check.vars)) {
message <- if (number.bad == 1) paste("the following predictor is not in the model:",
focal.predictors[check.vars])
else paste("the following predictors are not in the model:",
paste(focal.predictors[check.vars], collapse=", "))
stop(message)
}
X.mod <- model.matrix(mod)
cnames <- colnames(X.mod)
factor.cols <- rep(FALSE, length(cnames))
names(factor.cols) <- cnames
for (name in all.predictors){
if (is.factor.predictor(name, mod)) factor.cols[grep(paste("^", name, sep=""), cnames)] <- TRUE
}
factor.cols[grep(":", cnames)] <- FALSE
X <- na.omit(expand.model.frame(mod, all.predictors))
bad <- sapply(X[, all.predictors, drop=FALSE], function(x) !(is.factor(x) || is.numeric(x)))
if (any(bad)){
message <- if (sum(bad) == 1) paste("the following predictor isn't a factor or numeric:",
all.predictors[bad])
else paste("the following predictors aren't factors or numeric:",
paste(all.predictors[bad], collapse=", "))
stop(message)
}
x <- list()
factor.levels <- list()
if(length(xlevels)==0 & length(default.levels) == 1L) xlevels <- default.levels
if(is.numeric(xlevels) & length(xlevels) == 1L){
levs <- xlevels
for(name in focal.predictors) xlevels[[name]] <- levs
}
for (name in focal.predictors){
levels <- mod$xlevels[[name]]
if(is.null(levels)) levels <- mod$xlevels[[paste("factor(",name,")",sep="")]]
fac <- !is.null(levels)
if (!fac) {
levels <- if (is.null(xlevels[[name]])){
if (partial.residuals){
quantile(X[, name], quantiles)
}
else{
grid.pretty(range(X[, name]))
}
}
else {
if(length(xlevels[[name]]) == 1L) {
seq(min(X[, name]), max(X[,name]), length=xlevels[[name]])} else
xlevels[[name]]}
}
else factor.levels[[name]] <- levels
x[[name]] <- list(name=name, is.factor=fac, levels=levels)
}
if (partial.residuals){
numeric.predictors <- sapply(focal.predictors, function(predictor) is.numeric.predictor(predictor, mod))
if (!any(numeric.predictors)) warning("there are no numeric focal predictors", "\n partial residuals suppressed")
else{
x.var <- which(numeric.predictors)[1]
x.var.name <- focal.predictors[x.var]
if (is.null(mod$xlevels[[x.var.name]])){
x.var.levels <- x[[x.var]][["levels"]]
x.var.range <- range(X[, focal.predictors[x.var]])
x[[x.var]][["levels"]] <- seq(from=x.var.range[1], to=x.var.range[2], length=100)
}
}
}
x.excluded <- list()
for (name in excluded.predictors){
levels <- mod$xlevels[[name]]
fac <- !is.null(levels)
level <- if (fac) levels[1] else mean(X[, name])
if (fac) factor.levels[[name]] <- levels
x.excluded[[name]] <- list(name=name, is.factor=fac,
level=level)
}
dims <- sapply(x, function(x) length(x$levels))
len <- prod(dims)
n.focal <- length(focal.predictors)
n.excluded <- length(excluded.predictors)
n.vars <- n.focal + n.excluded
predict.data <-matrix('', len, n.vars)
excluded <- sapply(x.excluded, function(x) x$level)
for (i in 1:len){
subs <- subscripts(i, dims)
for (j in 1:n.focal){
predict.data[i,j] <- x[[j]]$levels[subs[j]]
}
if (n.excluded > 0)
predict.data[i, (n.focal + 1):n.vars] <- excluded
}
colnames(predict.data) <- c(sapply(x, function(x) x$name),
sapply(x.excluded, function(x) x$name))
colclasses <- lapply(X, class)
colclasses[colclasses == "matrix"] <- "numeric"
colclasses[colclasses == "array"] <- "numeric"
predict.data <- matrix.to.df(predict.data, colclasses=colclasses)
list(predict.data=predict.data,
factor.levels=factor.levels,
factor.cols=factor.cols, focal.predictors=focal.predictors, n.focal=n.focal,
excluded.predictors=excluded.predictors, n.excluded=n.excluded,
x=x, X.mod=X.mod, cnames=cnames, X=X, x.var=x.var)
}
# Analyze.model <- function(focal.predictors, mod, xlevels, default.levels=NULL, formula.rhs){
# if ((!is.null(mod$na.action)) && class(mod$na.action) == "exclude")
# class(mod$na.action) <- "omit"
# all.predictors <- all.vars(formula.rhs)
# check.vars <- !(focal.predictors %in% all.predictors)
# excluded.predictors <- setdiff(all.predictors, focal.predictors)
# number.bad <- sum(check.vars)
# if (any(check.vars)) {
# message <- if (number.bad == 1) paste("the following predictor is not in the model:",
# focal.predictors[check.vars])
# else paste("the following predictors are not in the model:",
# paste(focal.predictors[check.vars], collapse=", "))
# stop(message)
# }
# X.mod <- model.matrix(mod)
# cnames <- colnames(X.mod)
# factor.cols <- rep(FALSE, length(cnames))
# names(factor.cols) <- cnames
# X <- model.frame(mod)
# for (name in all.predictors){
# if (is.factor(X[[name]])) factor.cols[grep(paste("^", name, sep=""), cnames)] <- TRUE
# }
# factor.cols[grep(":", cnames)] <- FALSE
# X <- na.omit(expand.model.frame(mod, all.predictors))
# x <- list()
# factor.levels <- list()
# if(length(xlevels)==0 & length(default.levels) == 1L) xlevels <- default.levels
# if(is.numeric(xlevels) & length(xlevels) == 1L){
# levs <- xlevels
# for(name in focal.predictors) xlevels[[name]] <- levs}
# for (name in focal.predictors){
# levels <- mod$xlevels[[name]]
# if(is.null(levels)) levels <- mod$xlevels[[paste("factor(",name,")",sep="")]]
# fac <- !is.null(levels)
# if (!fac) {
# levels <- if (is.null(xlevels[[name]])){
# grid.pretty(range(X[, name]))} else {
# if(length(xlevels[[name]]) == 1L) {
# seq(min(X[, name]), max(X[,name]), length=xlevels[[name]])} else
# xlevels[[name]]}
# }
# else factor.levels[[name]] <- levels
# x[[name]] <- list(name=name, is.factor=fac, levels=levels)
# }
# x.excluded <- list()
# for (name in excluded.predictors){
# levels <- mod$xlevels[[name]]
# fac <- !is.null(levels)
# level <- if (fac) levels[1] else mean(X[, name])
# if (fac) factor.levels[[name]] <- levels
# x.excluded[[name]] <- list(name=name, is.factor=fac,
# level=level)
# }
# dims <- sapply(x, function(x) length(x$levels))
# len <- prod(dims)
# n.focal <- length(focal.predictors)
# n.excluded <- length(excluded.predictors)
# n.vars <- n.focal + n.excluded
# predict.data <-matrix('', len, n.vars)
# excluded <- sapply(x.excluded, function(x) x$level)
# for (i in 1:len){
# subs <- subscripts(i, dims)
# for (j in 1:n.focal){
# predict.data[i,j] <- x[[j]]$levels[subs[j]]
# }
# if (n.excluded > 0)
# predict.data[i, (n.focal + 1):n.vars] <- excluded
# }
# colnames(predict.data) <- c(sapply(x, function(x) x$name),
# sapply(x.excluded, function(x) x$name))
# colclasses <- lapply(X, class)
# colclasses[colclasses == "matrix"] <- "numeric"
# predict.data <- matrix.to.df(predict.data, colclasses=colclasses)
# list(predict.data=predict.data, factor.levels=factor.levels,
# factor.cols=factor.cols, focal.predictors=focal.predictors, n.focal=n.focal,
# excluded.predictors=excluded.predictors, n.excluded=n.excluded,
# x=x, X.mod=X.mod, cnames=cnames, X=X)
# }
Fixup.model.matrix <- function(mod, mod.matrix, mod.matrix.all, X.mod,
factor.cols, cnames, focal.predictors, excluded.predictors,
typical, given.values,
partial.residuals=FALSE, mod.matrix.all.rounded){
vars <- as.character(attr(terms(mod), "variables"))[-(1:2)]
attr(mod.matrix, "assign") <- attr(mod.matrix.all, "assign")
if (length(excluded.predictors) > 0){
sel <- apply(sapply(excluded.predictors, matchVarName, expressions=vars), 1, any)
strangers <- Strangers(mod, focal.predictors, excluded.predictors)
stranger.cols <-
apply(outer(strangers, attr(mod.matrix,'assign'), '=='), 2, any)
}
else stranger.cols <- rep(FALSE, ncol(mod.matrix))
if (has.intercept(mod)) stranger.cols[1] <- TRUE
if (any(stranger.cols)) {
facs <- factor.cols & stranger.cols
covs <- (!factor.cols) & stranger.cols
if (any(facs)){
mod.matrix[,facs] <- matrix(apply(as.matrix(X.mod[,facs]), 2, mean),
nrow=nrow(mod.matrix), ncol=sum(facs), byrow=TRUE)
if (partial.residuals) {
mod.matrix.all.rounded[,facs] <- mod.matrix.all[,facs] <-
matrix(apply(as.matrix(X.mod[,facs]), 2, mean), nrow=nrow(mod.matrix.all), ncol=sum(facs), byrow=TRUE)
}
}
if (any(covs)){
mod.matrix[,covs] <- matrix(apply(as.matrix(X.mod[,covs]), 2, typical),
nrow=nrow(mod.matrix), ncol=sum(covs), byrow=TRUE)
if (partial.residuals) {
mod.matrix.all.rounded[,covs] <- mod.matrix.all[,covs] <-
matrix(apply(as.matrix(X.mod[,covs]), 2, typical), nrow=nrow(mod.matrix.all), ncol=sum(covs), byrow=TRUE)
}
}
if (!is.null(given.values)){
stranger.names <- cnames[stranger.cols]
given <- stranger.names %in% names(given.values)
if (any(given)) {
mod.matrix[,stranger.names[given]] <- matrix(given.values[stranger.names[given]], nrow=nrow(mod.matrix),
ncol=length(stranger.names[given]), byrow=TRUE)
if (partial.residuals) {
mod.matrix.all.rounded[,stranger.names[given]] <- mod.matrix.all[,stranger.names[given]] <-
matrix(given.values[stranger.names[given]], nrow=nrow(mod.matrix.all), ncol=length(stranger.names[given]), byrow=TRUE)
}
}
}
for (name in cnames){
components <- unlist(strsplit(name, ':'))
components <- components[components %in% cnames]
if (length(components) > 1) {
mod.matrix[,name] <- apply(mod.matrix[,components], 1, prod)
if (partial.residuals) {
mod.matrix.all[,name] <- apply(mod.matrix.all[,components], 1, prod)
mod.matrix.all.rounded[,name] <- apply(mod.matrix.all.rounded[,components], 1, prod)
}
}
}
}
if (partial.residuals) list(mod.matrix=mod.matrix, mod.matrix.all=mod.matrix.all, mod.matrix.all.rounded=mod.matrix.all.rounded) else mod.matrix
}
# Fixup.model.matrix <- function(mod, mod.matrix, mod.matrix.all, X.mod,
# factor.cols, cnames, focal.predictors, excluded.predictors, typical, given.values){
# vars <- as.character(attr(terms(mod), "variables"))[-(1:2)]
# attr(mod.matrix, "assign") <- attr(mod.matrix.all, "assign")
# if (length(excluded.predictors) > 0){
# sel <- apply(sapply(excluded.predictors, matchVarName, expressions=vars), 1, any)
# strangers <- Strangers(mod, focal.predictors, excluded.predictors)
# stranger.cols <-
# apply(outer(strangers, attr(mod.matrix,'assign'), '=='), 2, any)
# }
# else stranger.cols <- rep(FALSE, ncol(mod.matrix))
# if (has.intercept(mod)) stranger.cols[1] <- TRUE
# if (any(stranger.cols)) {
# facs <- factor.cols & stranger.cols
# covs <- (!factor.cols) & stranger.cols
# if (any(facs)) mod.matrix[,facs] <-
# matrix(apply(as.matrix(X.mod[,facs]), 2, mean),
# nrow=nrow(mod.matrix), ncol=sum(facs), byrow=TRUE)
# if (any(covs)) mod.matrix[,covs] <-
# matrix(apply(as.matrix(X.mod[,covs]), 2, typical),
# nrow=nrow(mod.matrix), ncol=sum(covs), byrow=TRUE)
# if (!is.null(given.values)){
# stranger.names <- cnames[stranger.cols]
# given <- stranger.names %in% names(given.values)
# if (any(given)) mod.matrix[,stranger.names[given]] <-
# matrix(given.values[stranger.names[given]], nrow=nrow(mod.matrix),
# ncol=length(stranger.names[given]), byrow=TRUE)
# }
# }
# for (name in cnames){
# components <- unlist(strsplit(name, ':'))
# components <- components[components %in% cnames]
# if (length(components) > 1)
# mod.matrix[,name] <- apply(mod.matrix[,components], 1, prod)
# }
# mod.matrix
# }
# matchVarName <- function(name, expressions){
# a <- !grepl(paste("[.]+", name, sep=""), expressions)
# b <- !grepl(paste(name, "[.]+", sep=""), expressions)
# c <- grepl(paste("\\b", name, "\\b", sep=""), expressions)
# a & b & c
# }
matchVarName <- function(name, expressions){
scratch <- "zAMIjw4RN3" # randomly generated string
name <- gsub("\\.", scratch, name)
expressions <- gsub("\\.", scratch, as.character(expressions))
a <- !grepl(paste("[.]+", name, sep=""), expressions)
b <- !grepl(paste(name, "[.]+", sep=""), expressions)
c <- grepl(paste("\\b", name, "\\b", sep=""), expressions)
a & b & c
}
Strangers <- function(mod, focal.predictors, excluded.predictors){
names <- term.names(mod)
if (has.intercept(mod)) names <- names[-1]
sel <- apply(sapply(excluded.predictors, matchVarName, expressions=names), 1, any)
(1:length(sel))[sel]
}
# the following is used by effect.multinom() and Effect.multinom()
eff.mul <- function(x0, B, se, m, p, r, V){
mu <- exp(x0 %*% B)
mu <- mu/(1 + sum(mu))
mu[m] <- 1 - sum(mu)
logits <- log(mu/(1 - mu))
if (!se) return(list(p=mu, logits=logits))
d <- array(0, c(m, m - 1, p))
exp.x0.B <- as.vector(exp(x0 %*% B))
sum.exp.x0.B <- sum(exp.x0.B)
for (j in 1:(m-1)){
d[m, j,] <- - exp.x0.B[j]*x0
for (jj in 1:(m-1)){
d[j, jj,] <- if (jj != j)
- exp(x0 %*% (B[,jj] + B[,j]))*x0
else exp.x0.B[j]*(1 + sum.exp.x0.B - exp.x0.B[j])*x0
}
}
d <- d/(1 + sum.exp.x0.B)^2
V.mu <- rep(0, m)
for (j in 1:m){
dd <- as.vector(t(d[j,,]))
for (s in 1:r){
for (t in 1:r){
V.mu[j] <- V.mu[j] + V[s,t]*dd[s]*dd[t]
}
}
}
V.logits <- V.mu/(mu^2 * (1 - mu)^2)
list(p=mu, std.err.p=sqrt(V.mu), logits=logits,
std.error.logits=sqrt(V.logits))
}
# the following are used by effect.polr() and Effect.polr()
eff.polr <- function(x0, b, alpha, V, m, r, se){
eta0 <- x0 %*% b
mu <- rep(0, m)
mu[1] <- 1/(1 + exp(alpha[1] + eta0))
for (j in 2:(m-1)){
mu[j] <- exp(eta0)*(exp(alpha[j - 1]) - exp(alpha[j]))/
((1 + exp(alpha[j - 1] + eta0))*(1 + exp(alpha[j] + eta0)))
}
mu[m] <- 1 - sum(mu)
logits <- log(mu/(1 - mu))
if (!se) return(list(p=mu, logits=logits))
d <- matrix(0, m, r)
d[1, 1] <- - exp(alpha[1] + eta0)/(1 + exp(alpha[1] + eta0))^2
d[1, m:r] <- - exp(alpha[1] + eta0)*x0/(1 + exp(alpha[1] + eta0))^2
for (j in 2:(m-1)){
d[j, j-1] <- exp(alpha[j-1] + eta0)/(1 + exp(alpha[j-1] + eta0))^2
d[j, j] <- - exp(alpha[j] + eta0)/(1 + exp(alpha[j] + eta0))^2
d[j, m:r] <- exp(eta0)*(exp(alpha[j]) - exp(alpha[j-1]))*
(exp(alpha[j-1] + alpha[j] + 2*eta0) - 1) * x0 /
(((1 + exp(alpha[j-1] + eta0))^2)*
((1 + exp(alpha[j] + eta0))^2))
}
d[m, m-1] <- exp(alpha[m-1] + eta0)/(1 + exp(alpha[m-1] + eta0))^2
d[m, m:r] <- exp(alpha[m-1] + eta0)*x0/(1 + exp(alpha[m-1] + eta0))^2
V.mu <- rep(0, m)
for (j in 1:m){
dd <- d[j,]
for (s in 1:r){
for (t in 1:r){
V.mu[j] <- V.mu[j] + V[s,t]*dd[s]*dd[t]
}
}
}
V.logits <- V.mu/(mu^2 * (1 - mu)^2)
list(p=mu, std.err.p=sqrt(V.mu), logits=logits,
std.error.logits=sqrt(V.logits))
}
eff.latent <- function(X0, b, V, se){
eta <- X0 %*% b
if (!se) return(list(fit=eta))
var <- diag(X0 %*% V %*% t(X0))
list(fit=eta, se=sqrt(var))
}
# determine class of a predictor
is.factor.predictor <- function(predictor, model) {
!is.null(model$xlevels[[predictor]])
}
is.numeric.predictor <- function(predictor, model) {
is.null(model$xlevels[[predictor]])
}
# manage lattice strips
setStrip <- function(bg=3, fg="black", clip=c("off", "on")){
clip <- match.arg(clip)
bg.save <- strip.background <- trellis.par.get("strip.background")
if (is.numeric(bg) && length(bg) == 1){
if (bg <= 0) stop("bg should be a positive integer or vector of colors")
bg <- gray(seq(.95, .5, length=round(bg)))
}
strip.background$col <- bg
fg.save <- strip.shingle <- trellis.par.get("strip.shingle")
trellis.par.set("strip.background", strip.background)
if (length(fg) != 1 && length(fg) != length(bg))
stop("lengths of fg and bg incompatible")
strip.shingle$col <- fg
trellis.par.set("strip.shingle", strip.shingle)
clip.save <- .clip <- trellis.par.get("clip")
.clip$strip <- clip
trellis.par.set("clip", .clip)
invisible(list(strip.background=bg.save, strip.shingle=fg.save, clip=clip.save))
}
restoreStrip <- function(saved){
if (!identical(names(saved), c("strip.background", "strip.shingle", "clip")))
stop("argument saved does not contain strip parameters")
trellis.par.set("strip.background", saved$strip.background)
trellis.par.set("strip.shingle", saved$strip.shingle)
trellis.par.set("clip", saved$clip)
} effects/R/effects.R 0000644 0001762 0000144 00000005244 12442332475 013647 0 ustar ligges users # effect generic and methods; allEffects
# John Fox, Sanford Weisberg, and Jangman Hong
# last modified 2012-12-08 by J. Fox
# 10/31/2012 modifed effect.lm to use z distn for ses with mer and nlme objects
# 12-21-2012 Allow for empty cells in factor interactions, S. Weisberg
# 7-15-2013: S. Weisberg: deleted 'default.levels' argument. Changed and
# generalized xlevels argument to include the function of default.levels.
# 2013-10-15: eliminated generic effect() and all its methods. J. Fox
# 2014-07-02: added vcov. argument to effect
# 2014-12-10: Changed 'effect' back to a generic function. S. Weisberg
effect <- function(term, mod, vcov.=vcov, ...){
UseMethod("effect", mod)
}
effect.default <- function(term, mod, vcov.=vcov, ...){
term <- gsub(" ", "", gsub("\\*", ":", term))
terms <- term.names(mod)
if (has.intercept(mod)) terms <- terms[-1]
which.term <- which(term == terms)
mod.aug<- list()
if (length(which.term) == 0){
message("NOTE: ", term, " does not appear in the model")
mod.aug <- update(formula(mod), eval(parse(text=paste(". ~ . +", term))))
}
if (!is.high.order.term(term, mod, mod.aug))
message("NOTE: ", term, " is not a high-order term in the model")
predictors <- all.vars(parse(text=term))
Effect(predictors, mod, vcov.=vcov., ...)
}
allEffects <- function(mod, ...) UseMethod("allEffects")
allEffects.default <- function(mod, ...){
high.order.terms <- function(mod){
names <- term.names(mod)
if (has.intercept(mod)) names<-names[-1]
rel <- lapply(names, descendants, mod=mod)
(1:length(names))[sapply(rel, function(x) length(x)==0)]
}
names <- term.names(mod)
if (has.intercept(mod)) names <- names[-1]
if (length(names) == 0) stop("the model contains no terms (beyond a constant)")
terms <- names[high.order.terms(mod)]
result <- lapply(terms, effect, mod=mod, ...)
names(result) <- terms
class(result) <- 'efflist'
result
}
allEffects.gls <- function(mod, ...){
high.order.terms <- function(mod){
mod <- lm(as.formula(mod$call$model), data=eval(mod$call$data))
names <- term.names(mod)
if (has.intercept(mod)) names<-names[-1]
rel <- lapply(names, descendants, mod=mod)
(1:length(names))[sapply(rel, function(x) length(x)==0)]
}
names <- term.names(mod)
if (has.intercept(mod)) names <- names[-1]
if (length(names) == 0) stop("the model contains no terms (beyond a constant)")
terms <- names[high.order.terms(mod)]
result <- lapply(terms, effect, mod=mod, ...)
names(result) <- terms
class(result) <- 'efflist'
result
}
all.effects <- function(...){
.Deprecated("allEffects")
allEffects(...)
} effects/R/plot-methods.R 0000644 0001762 0000144 00000106700 12647513565 014656 0 ustar ligges users # plot.eff method for effects package, moved here from plot-summary-print-methods.R
# The plot.effpoly method remains there for now.
# 2013-10-17: Added use.splines keyword to plot.eff. Sandy
# 2013-10-17: Made ci.style="bands" default for variates; allow "bands" if multiline=TRUE
# 2013-10-29: fixed plot.eff() to handle factors with "valid" NA level. J. Fox
# 2014-03-03: modified plot.eff() to handle partial residuals. J. Fox
# 2014-09-20: fixed plot.eff() to work with partial residuals when rescale.axis=FALSE;
# added smooth.residuals argument. J. Fox
# 2014-10-10: namespace fixes. J. Fox
# 2014-12-05: made key.args more flexible. J. Fox
# 2015-03-22: use wide columns by default only when x for legend not set. J. Fox
# 2015-03-25: use non-robust loess smooth for partial residuals for non-Gaussian families. J. Fox
# 2015-03-25: rationalized type and rescale.axis args to plot.eff(); deprecated rescale.axis arg. J. Fox
# 2015-05-28: added residuals.smooth.color argument. J. Fox
# 2015-08-28: added residuals.cex argument. J. Fox
# the following functions aren't exported
find.legend.columns <- function(n, target=min(4, n)){
rem <- n %% target
if (rem != 0 && rem < target/2) target <- target - 1
target
}
make.ticks <- function(range, link, inverse, at, n) {
warn <- options(warn=-1)
on.exit(options(warn))
link <- if (is.null(link))
function(x) nlm(function(y) (inverse(y) - x)^2,
mean(range))$estimate
else link
if (is.null(n)) n <- 5
labels <- if (is.null(at)){
labels <- pretty(sapply(range, inverse), n=n+1)
}
else at
ticks <- sapply(labels, link)
list(at=ticks, labels=format(labels))
}
range.adj <- function(x){
range <- range(x, na.rm=TRUE)
c(range[1] - .025*(range[2] - range[1]),
range[2] + .025*(range[2] - range[1]))
}
# added, modified from http://www.r-bloggers.com/confidence-bands-with-lattice-and-r/
panel.bands <- function(x, y, upper, lower, fill, col,
subscripts, ..., font, fontface, use.splines=FALSE)
{
if(!missing(subscripts)) {
upper <- upper[subscripts]
lower <- lower[subscripts]
}
if (use.splines){
up <- spline(x, upper)
down <- spline(x, lower)
x <- up$x
upper <- up$y
lower <- down$y
}
panel.polygon(c(x, rev(x)), c(upper, rev(lower)),
col = fill, fill=fill, border = FALSE,
...)
}
# modified by Michael Friendly: added key.args:
# modified by Michael Friendly: added ci.style="bands"
# modified by Michael Friendly: added lwd= argument for llines (not used elsewhere)
# modified by Michael Friendly: added alpha.band= argument for ci.style="bands"
spline.llines <- function(x, y, ...) llines(spline(x, y), ...)
plot.eff <- function(x, x.var,
z.var=which.min(levels), multiline=is.null(x$se), rug=TRUE,
xlab, ylab, main=paste(effect, "effect plot"),
colors=palette(), symbols=1:length(colors), lines=1:length(colors),
cex=1.5, lwd=2, ylim, xlim=NULL,
factor.names=TRUE, ci.style, band.transparency=0.15, band.colors=colors,
type=c("rescale", "response", "link"), ticks=list(at=NULL, n=5),
alternating=TRUE, rotx=0, roty=0, grid=FALSE, layout, rescale.axis,
transform.x=NULL, ticks.x=NULL,
key.args=NULL,
row=1, col=1, nrow=1, ncol=1, more=FALSE,
use.splines=TRUE, partial.residuals=c("adjusted", "raw"), show.fitted=FALSE,
residuals.color="blue", residuals.pch=1, residuals.cex=1,
smooth.residuals=TRUE, residuals.smooth.color=residuals.color, span=2/3, ...)
{
.mod <- function(a, b) ifelse( (d <- a %% b) == 0, b, d)
.modc <- function(a) .mod(a, length(colors))
.mods <- function(a) .mod(a, length(symbols))
.modl <- function(a) .mod(a, length(lines))
.modb <- function(a) .mod(a, length(band.colors))
ci.style <- if(missing(ci.style)) NULL else
match.arg(ci.style, c("bars", "lines", "bands", "none"))
if (smooth.residuals && !is.null(x$family)){
loess.family <- if (x$family == "gaussian") "symmetric" else "gaussian"
}
type <- if (!missing(rescale.axis)){
message("NOTE: the rescale.axis argument is deprecated; use type instead")
if (!is.logical(rescale.axis)) stop ("rescale.axis must be logical (TRUE or FALSE)")
if (rescale.axis) "rescale" else "response"
}
else match.arg(type)
switch(type,
rescale = {
type <- "response"
rescale.axis <- TRUE
},
response = {
type <- "response"
rescale.axis <- FALSE
},
link = {
type <- "link"
rescale.axis <- TRUE
}
)
partial.residuals <- match.arg(partial.residuals)
levels <- sapply(x$variables, function(z) length(as.vector(z[["levels"]])))
thresholds <- x$thresholds
has.thresholds <- !is.null(thresholds)
effect.llines <- llines
if (missing(ylab)){
ylab <- if (has.thresholds) paste(x$response, ": ", paste(x$y.levels, collapse=", "), sep="")
else x$response
}
if (has.thresholds){
threshold.labels <- abbreviate(x$y.levels, minlength=1)
threshold.labels <- paste(" ",
paste(threshold.labels[-length(threshold.labels)], threshold.labels[-1], sep=" - "),
" ", sep="")
}
trans.link <- x$transformation$link
trans.inverse <- x$transformation$inverse
residuals <- if (partial.residuals == "adjusted") x$partial.residuals.adjusted else x$partial.residuals.raw
fitted <- x$fitted.rounded
if (!is.null(residuals) && !rescale.axis) {
residuals <- trans.inverse(residuals)
fitted <- trans.inverse(fitted)
}
if (!rescale.axis){
x$lower[!is.na(x$lower)] <- trans.inverse(x$lower[!is.na(x$lower)])
x$upper[!is.na(x$upper)] <- trans.inverse(x$upper[!is.na(x$upper)])
x$fit[!is.na(x$fit)] <- trans.inverse(x$fit)[!is.na(x$fit)]
trans.link <- trans.inverse <- I
}
x.all <- x$x.all
mod.matrix.all <- x$mod.matrix.all
split <- c(col, row, ncol, nrow)
ylab # force evaluation
if (missing(x.var)) x.var <- x$x.var
if (!is.null(x.var) && is.numeric(x.var)) x.var <- names(x.var)
x.data <- x$data
effect <- paste(sapply(x$variables, "[[", "name"), collapse="*")
vars <- x$variables
x <- as.data.frame(x, transform=I)
for (i in 1:length(vars)){
if (!(vars[[i]]$is.factor)) next
x[,i] <- factor(x[,i], levels=vars[[i]]$levels, exclude=NULL)
}
has.se <- !is.null(x$se)
n.predictors <- ncol(x) - 1 - 3*has.se
if (n.predictors == 1){
predictor <- names(x)[1]
### factor no other predictors
if (is.factor(x[,1])){
ci.style <- if(is.null(ci.style)) "bars" else ci.style
range <- if(has.se & ci.style!="none")
range(c(x$lower, x$upper), na.rm=TRUE) else range(x$fit, na.rm=TRUE)
ylim <- if (!missing(ylim)) ylim else c(range[1] - .025*(range[2] - range[1]),
range[2] + .025*(range[2] - range[1]))
tickmarks <- if (type == "response") make.ticks(ylim,
link=trans.link, inverse=trans.inverse, at=ticks$at, n=ticks$n)
else make.ticks(ylim, link=I, inverse=I, at=ticks$at, n=ticks$n)
levs <- levels(x[,1])
plot <- xyplot(eval(parse(
text=paste("fit ~ as.numeric(", names(x)[1], ")"))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, lower, upper, has.se, ...){
if (grid) panel.grid()
good <- !is.na(y)
if (has.se){
if (ci.style == "bars"){
larrows(x0=x[good], y0=lower[good], x1=x[good], y1=upper[good], angle=90,
code=3, col=colors[.modc(2)], length=0.125*cex/1.5)
}
else if(ci.style == "lines") {
effect.llines(x[good], lower[good], lty=2, col=colors[.modc(2)])
effect.llines(x[good], upper[good], lty=2, col=colors[.modc(2)])
}
else{ if(ci.style == "bands") {
panel.bands(x[good], y[good], upper[good], lower[good], fill=band.colors[1],
alpha=band.transparency, use.splines=FALSE)
}}
}
effect.llines(x[good], y[good], lwd=lwd, col=colors[1], type='b', pch=19, cex=cex, ...)
if (has.thresholds){
panel.abline(h=thresholds, lty=3)
panel.text(rep(current.panel.limits()$xlim[1], length(thresholds)),
thresholds, threshold.labels, adj=c(0,0), cex=0.75)
panel.text(rep(current.panel.limits()$xlim[2], length(thresholds)),
thresholds, threshold.labels, adj=c(1,0), cex=0.75)
}
},
ylim=ylim,
ylab=ylab,
xlab=if (missing(xlab)) names(x)[1] else xlab,
scales=list(x=list(at=1:length(levs), labels=levs, rot=rotx),
y=list(at=tickmarks$at, labels=tickmarks$labels, rot=roty),
alternating=alternating, y=roty),
main=main,
lower=x$lower, upper=x$upper, has.se=has.se, data=x, ...)
result <- update(plot, layout = if (missing(layout)) c(0, prod(dim(plot)))
else layout)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
### variate, no other predictors ***
else {
effect.llines <- if(use.splines) spline.llines else effect.llines
ci.style <- if(is.null(ci.style)) "bands" else ci.style
range <- if(has.se & ci.style!="none")
range(c(x$lower, x$upper), na.rm=TRUE) else range(x$fit, na.rm=TRUE)
ylim <- if (!missing(ylim)) ylim
else if (is.null(residuals)) c(range[1] - .025*(range[2] - range[1]), range[2] + .025*(range[2] - range[1]))
else c(min(min(residuals), range[1] - .025*(range[2] - range[1])),
max(max(residuals), range[2] + .025*(range[2] - range[1])))
tickmarks <- if (type == "response") make.ticks(ylim,
link=trans.link, inverse=trans.inverse, at=ticks$at, n=ticks$n)
else make.ticks(ylim, link=I, inverse=I, at=ticks$at, n=ticks$n)
nm <- names(x)[1]
x.vals <- x.data[, nm]
if (nm %in% names(ticks.x)){
at <- ticks.x[[nm]]$at
n <- ticks.x[[nm]]$n
}
else{
at <- NULL
n <- 5
}
xlm <- if (nm %in% names(xlim)){
xlim[[nm]]
}
else range.adj(x[nm]) # range(x.vals)
tickmarks.x <- if ((nm %in% names(transform.x)) && !(is.null(transform.x))){
trans <- transform.x[[nm]]$trans
make.ticks(trans(xlm), link=transform.x[[nm]]$trans, inverse=transform.x[[nm]]$inverse, at=at, n=n)
}
else {
trans <- I
make.ticks(xlm, link=I, inverse=I, at=at, n=n)
}
if (is.null(x.var)){
if (!is.null(residuals)){
x.var <- names(x)[1]
}
else x.var <- which.max(levels)
}
if (!is.null(residuals)) x.fit <- x.data[, predictor]
if (is.numeric(x.var)) x.var <- predictor
plot <- xyplot(eval(parse(
text=paste("fit ~ trans(", x.var, ")"))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, x.vals, rug, lower, upper, has.se, ...){
if (grid) panel.grid()
good <- !is.na(y)
axis.length <- diff(range(x))
effect.llines(x[good], y[good], lwd=lwd, col=colors[1], ...)
if (rug && is.null(residuals)) lrug(trans(x.vals))
if (has.se){
if (ci.style == "bars"){
larrows(x0=x[good], y0=lower[good],
x1=x[good], y1=upper[good],
angle=90, code=3, col=eval(colors[.modc(2)]),
length=.125*cex/1.5)
}
else if(ci.style == "lines") {
effect.llines(x[good], lower[good], lty=2, col=colors[.modc(2)])
effect.llines(x[good], upper[good], lty=2, col=colors[.modc(2)])
}
else{ if(ci.style == "bands") {
panel.bands(x[good], y[good], upper[good], lower[good], fill=band.colors[1],
alpha=band.transparency, use.splines=use.splines)
}}
}
if (has.thresholds){
panel.abline(h=thresholds, lty=3)
panel.text(rep(current.panel.limits()$xlim[1], length(thresholds)),
thresholds, threshold.labels, adj=c(0,0), cex=0.75)
panel.text(rep(current.panel.limits()$xlim[2], length(thresholds)),
thresholds, threshold.labels, adj=c(1,0), cex=0.75)
}
if (!is.null(residuals)){
lpoints(trans(x.fit), residuals, col=residuals.color, pch=residuals.pch, cex=residuals.cex)
if (show.fitted) lpoints(trans(x.fit), fitted, pch=16, col=residuals.color) # REMOVE ME
if (smooth.residuals){
llines(loess.smooth(trans(x.fit), residuals, span=span, family=loess.family), lwd=lwd, lty=2, col=residuals.smooth.color)
}
}
},
ylim=ylim,
xlim=suppressWarnings(trans(xlm)),
ylab=ylab,
xlab=if (missing(xlab)) names(x)[1] else xlab,
x.vals=x.vals, rug=rug,
main=main,
lower=x$lower, upper=x$upper, has.se=has.se, data=x,
scales=list(y=list(at=tickmarks$at, labels=tickmarks$labels, rot=roty),
x=list(at=tickmarks.x$at, labels=tickmarks.x$labels, rot=rotx), alternating=alternating), ...)
result <- update(plot, layout = if (missing(layout)) c(0, prod(dim(plot)))
else layout)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
return(result)
}
### more than one variate
predictors <- names(x)[1:n.predictors]
levels <- sapply(apply(x[,predictors], 2, unique), length)
if (is.null(x.var)){
if (!is.null(residuals)){
x.var <- names(x)[1]
}
else x.var <- which.max(levels)
}
if (!is.null(residuals)) x.fit <- x.data[, x.var]
if (is.character(x.var)) {
which.x <- which(x.var == predictors)
if (length(which.x) == 0) stop(paste("x.var = '", x.var, "' is not in the effect.", sep=""))
x.var <- which.x
}
if (is.character(z.var)) {
which.z <- which(z.var == predictors)
if (length(which.z) == 0) stop(paste("z.var = '", z.var, "' is not in the effect.", sep=""))
z.var <- which.z
}
if (x.var == z.var) z.var <- z.var + 1
### multiline
if (multiline){
ci.style <- if(is.null(ci.style)) "none" else ci.style
if(ci.style == "lines") {
cat("Confidence interval style 'lines' changed to 'bars'\n")
ci.style <- "bars"}
range <- if (has.se && ci.style !="none")
range(c(x$lower, x$upper), na.rm=TRUE) else range(x$fit, na.rm=TRUE)
ylim <- if (!missing(ylim)) ylim else c(range[1] - .025*(range[2] - range[1]),
range[2] + .025*(range[2] - range[1]))
tickmarks <- if (type == "response") make.ticks(ylim, link=trans.link,
inverse=trans.inverse, at=ticks$at, n=ticks$n)
else make.ticks(ylim, link=I, inverse=I, at=ticks$at, n=ticks$n)
zvals <- unique(x[, z.var])
### multiline factor
if (is.factor(x[,x.var])){
levs <- levels(x[,x.var])
key <- list(title=predictors[z.var], cex.title=1, border=TRUE,
text=list(as.character(zvals)),
lines=list(col=colors[.modc(1:length(zvals))], lty=lines[.modl(1:length(zvals))], lwd=lwd),
points=list(col=colors[.modc(1:length(zvals))], pch=symbols[.mods(1:length(zvals))]),
columns = if ("x" %in% names(key.args)) 1 else find.legend.columns(length(zvals)))
for (k in names(key.args)) key[k] <- key.args[k]
plot <- xyplot(eval(parse(
text=paste("fit ~ as.numeric(", predictors[x.var], ")",
if (n.predictors > 2) paste(" |",
paste(predictors[-c(x.var, z.var)])), collapse="*"))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, z, lower, upper, show.se, ...){
if (grid) panel.grid()
for (i in 1:length(zvals)){
sub <- z[subscripts] == zvals[i]
good <- !is.na(y[sub])
os <- if(show.se)
(i - (length(zvals) + 1)/2) * (2/(length(zvals)-1)) *
.01 * (length(zvals) - 1) else 0
effect.llines(x[sub][good]+os, y[sub][good], lwd=lwd, type='b', col=colors[.modc(i)],
pch=symbols[.mods(i)], lty=lines[.modl(i)], cex=cex, ...)
if (show.se){
larrows(x0=x[sub][good]+os, y0=lower[subscripts][sub][good],
x1=x[sub][good]+os, y1=upper[subscripts][sub][good],
angle=90, code=3, col=eval(colors[.modc(i)]),
length=.125*cex/1.5)
}
}
if (has.thresholds){
panel.abline(h=thresholds, lty=3)
panel.text(rep(current.panel.limits()$xlim[1], length(thresholds)),
thresholds, threshold.labels, adj=c(0,0), cex=0.75)
panel.text(rep(current.panel.limits()$xlim[2], length(thresholds)),
thresholds, threshold.labels, adj=c(1,0), cex=0.75)
}
},
ylim=ylim,
ylab=ylab,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
z=x[,z.var],
scales=list(x=list(at=1:length(levs), labels=levs, rot=rotx),
y=list(at=tickmarks$at, labels=tickmarks$labels, rot=roty),
alternating=alternating),
zvals=zvals,
main=main,
key=key,
lower=x$lower, upper=x$upper,
show.se=has.se && ci.style=="bars",
data=x, ...)
result <- update(plot, layout = if (missing(layout))
c(0, prod(dim(plot))) else layout)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
### multiline variate
else{
effect.llines <- if(use.splines) spline.llines else effect.llines
nm <- names(x)[x.var]
x.vals <- x.data[, nm]
if (nm %in% names(ticks.x)){
at <- ticks.x[[nm]]$at
n <- ticks.x[[nm]]$n
}
else{
at <- NULL
n <- 5
}
xlm <- if (nm %in% names(xlim)){
xlim[[nm]]
}
else range.adj(x[nm]) # range(x.vals)
tickmarks.x <- if ((nm %in% names(transform.x)) && !(is.null(transform.x))){
trans <- transform.x[[nm]]$trans
# make.ticks(trans(xlm), link=transform.x[[nm]]$trans, inverse=transform.x[[nm]]$inverse, at=ticks.x$at, n=ticks.x$n)
make.ticks(trans(xlm), link=transform.x[[nm]]$trans, inverse=transform.x[[nm]]$inverse, at=at, n=n)
}
else {
trans <- I
make.ticks(xlm, link=I, inverse=I, at=at, n=n)
}
key <- list(title=predictors[z.var], cex.title=1, border=TRUE,
text=list(as.character(zvals)),
lines=list(col=colors[.modc(1:length(zvals))], lty=lines[.modl(1:length(zvals))], lwd=lwd),
columns = if ("x" %in% names(key.args)) 1 else find.legend.columns(length(zvals)))
for (k in names(key.args)) key[k] <- key.args[k]
plot <- xyplot(eval(parse(
text=paste("fit ~trans(", predictors[x.var], ")",
if (n.predictors > 2) paste(" |",
paste(predictors[-c(x.var, z.var)])), collapse="*"))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, x.vals, rug, z, lower, upper, show.se, ...){
if (grid) panel.grid()
if (rug && is.null(residuals)) lrug(trans(x.vals))
axis.length <- diff(range(x))
for (i in 1:length(zvals)){
sub <- z[subscripts] == zvals[i]
good <- !is.na(y[sub])
effect.llines(x[sub][good], y[sub][good], lwd=lwd, type='l',
col=colors[.modc(i)], lty=lines[.modl(i)], cex=cex, ...)
if(show.se){
if(ci.style == "bars"){
os <- (i - (length(zvals) + 1)/2) * (2/(length(zvals)-1)) *
.01 * axis.length
larrows(x0=x[sub][good]+os, y0=lower[subscripts][sub][good],
x1=x[sub][good]+os, y1=upper[subscripts][sub][good],
angle=90, code=3, col=eval(colors[.modc(i)]),
length=.125*cex/1.5)
}
if(ci.style == "bands"){
panel.bands(x[sub][good], y[sub][good],
upper[subscripts][sub][good], lower[subscripts][sub][good],
fill=eval(band.colors[.modb(i)]),
alpha=band.transparency, use.splines=use.splines)
}
}
}
if (has.thresholds){
panel.abline(h=thresholds, lty=3)
panel.text(rep(current.panel.limits()$xlim[1], length(thresholds)),
thresholds, threshold.labels, adj=c(0,0), cex=0.75)
panel.text(rep(current.panel.limits()$xlim[2], length(thresholds)),
thresholds, threshold.labels, adj=c(1,0), cex=0.75)
}
},
ylim=ylim,
xlim=suppressWarnings(trans(xlm)),
ylab=ylab,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
x.vals=x.vals, rug=rug,
z=x[,z.var],
zvals=zvals,
main=main,
key=key,
#
lower=x$lower, upper=x$upper,
show.se=has.se && ci.style %in% c("bars", "bands"),
#
data=x, scales=list(y=list(at=tickmarks$at, labels=tickmarks$labels),
rot=roty, x=list(at=tickmarks.x$at, labels=tickmarks.x$labels, rot=rotx),
alternating=alternating), ...)
result <- update(plot, layout = if (missing(layout)) c(0, prod(dim(plot)))
else layout)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
return(result)
}
# multiplot
ci.style <- if(is.null(ci.style)){
if(is.factor(x[, x.var])) "bars" else "bands"} else ci.style
range <- if (has.se && ci.style !="none")
range(c(x$lower, x$upper), na.rm=TRUE) else range(x$fit, na.rm=TRUE)
# multiplot factor
if (is.factor(x[,x.var])){
ylim <- if (!missing(ylim)) ylim else c(range[1] - .025*(range[2] - range[1]),
range[2] + .025*(range[2] - range[1]))
tickmarks <- if (type == "response") make.ticks(ylim, link=trans.link,
inverse=trans.inverse, at=ticks$at, n=ticks$n)
else make.ticks(ylim, link=I, inverse=I, at=ticks$at, n=ticks$n)
levs <- levels(x[,x.var])
plot <- xyplot(eval(parse(
text=paste("fit ~ as.numeric(", predictors[x.var], ") |",
paste(predictors[-x.var], collapse="*")))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, lower, upper, has.se, ...){
if (grid) panel.grid()
good <- !is.na(y)
if (has.se){
if (ci.style == "bars"){
larrows(x0=x[good], y0=lower[subscripts][good], x1=x[good], y1=upper[subscripts][good],
angle=90, code=3, col=colors[.modc(2)], length=0.125*cex/1.5)
}
else if(ci.style == "lines") {
effect.llines(x[good], lower[subscripts][good], lty=2, col=colors[.modc(2)])
effect.llines(x[good], upper[subscripts][good], lty=2, col=colors[.modc(2)])
}
else{ if(ci.style == "bands") {
panel.bands(x[good], y[good], upper[subscripts][good], lower[subscripts][good],
fill=band.colors[1], alpha=band.transparency, use.splines=FALSE)
}}
}
effect.llines(x[good], y[good], lwd=lwd, type='b', col=colors[1], pch=19, cex=cex, ...)
if (has.thresholds){
panel.abline(h=thresholds, lty=3)
panel.text(rep(current.panel.limits()$xlim[1], length(thresholds)),
thresholds, threshold.labels, adj=c(0,0), cex=0.75)
panel.text(rep(current.panel.limits()$xlim[2], length(thresholds)),
thresholds, threshold.labels, adj=c(1,0), cex=0.75)
}
},
ylim=ylim,
ylab=ylab,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
scales=list(x=list(at=1:length(levs), labels=levs, rot=rotx),
y=list(at=tickmarks$at, labels=tickmarks$labels, rot=roty),
alternating=alternating),
main=main,
lower=x$lower, upper=x$upper, has.se=has.se, data=x, ...)
result <- update(plot, layout = if (missing(layout)) c(0, prod(dim(plot))) else layout)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
### multiplot variate ***
else{
effect.llines <- if(use.splines) spline.llines else effect.llines
nm <- names(x)[x.var]
x.vals <- x.data[, nm]
if (nm %in% names(ticks.x)){
at <- ticks.x[[nm]]$at
n <- ticks.x[[nm]]$n
}
else{
at <- NULL
n <- 5
}
xlm <- if (nm %in% names(xlim)){
xlim[[nm]]
}
else range.adj(x[nm])
tickmarks.x <- if ((nm %in% names(transform.x)) && !(is.null(transform.x))){
trans <- transform.x[[nm]]$trans
make.ticks(trans(xlm), link=transform.x[[nm]]$trans, inverse=transform.x[[nm]]$inverse, at=at, n=n)
}
else {
trans <- I
make.ticks(xlm, link=I, inverse=I, at=at, n=n)
}
ylim <- if (!missing(ylim)) ylim
else if (is.null(residuals)) c(range[1] - .025*(range[2] - range[1]), range[2] + .025*(range[2] - range[1]))
else c(min(min(residuals), range[1] - .025*(range[2] - range[1])),
max(max(residuals), range[2] + .025*(range[2] - range[1])))
tickmarks <- if (type == "response") make.ticks(ylim, link=trans.link,
inverse=trans.inverse, at=ticks$at, n=ticks$n)
else make.ticks(ylim, link=I, inverse=I, at=ticks$at, n=ticks$n)
x.fit <- x.data[, predictors[x.var]]
use <- rep(TRUE, length(residuals))
xx <- x[, predictors[-x.var], drop=FALSE]
plot <- xyplot(eval(parse(
text=paste("fit ~ trans(", predictors[x.var], ") |",
paste(predictors[-x.var], collapse="*")))),
strip=function(...) strip.default(..., strip.names=c(factor.names, TRUE)),
panel=function(x, y, subscripts, x.vals, rug, lower, upper, has.se, ...){
if (grid) panel.grid()
good <- !is.na(y)
effect.llines(x[good], y[good], lwd=lwd, col=colors[1], ...)
if (rug && is.null(residuals)) lrug(trans(x.vals))
if (has.se){
if (ci.style == "bars"){
larrows(x0=x[good], y0=lower[subscripts][good],
x1=x[good], y1=upper[subscripts][good],
angle=90, code=3, col=eval(colors[.modc(2)]),
length=.125*cex/1.5)
}
else if(ci.style == "lines") {
effect.llines(x[good], lower[subscripts][good], lty=2, col=colors[.modc(2)])
effect.llines(x[good], upper[subscripts][good], lty=2, col=colors[.modc(2)])
}
else if(ci.style == "bands") {
panel.bands(x[good], y[good], upper[subscripts][good], lower[subscripts][good],
fill=band.colors[1], alpha=band.transparency, use.splines=use.splines)
}
if (!is.null(residuals)){
predictors <- predictors[-x.var]
factors <- sapply(xx, is.factor)
for (predictor in predictors){
use <- use & if(factors[predictor]) x.all[, predictor] == xx[subscripts[1], predictor]
else x.all[, predictor] == xx[subscripts[1], predictor]
}
n.in.panel <- sum(use)
if (n.in.panel > 0){
lpoints(trans(x.fit[use]), residuals[use], col=residuals.color, pch=residuals.pch, cex=residuals.cex)
if (show.fitted) lpoints(trans(x.fit[use]), fitted[use], pch=16, col=residuals.color) # REMOVE ME
if (smooth.residuals && n.in.panel >= 10) {
llines(loess.smooth(x.fit[use], residuals[use], span=span, family=loess.family),
lwd=lwd, lty=2, col=residuals.smooth.color)
}
}
}
}
if (has.thresholds){
panel.abline(h=thresholds, lty=3)
panel.text(rep(current.panel.limits()$xlim[1], length(thresholds)),
thresholds, threshold.labels, adj=c(0,0), cex=0.75)
panel.text(rep(current.panel.limits()$xlim[2], length(thresholds)),
thresholds, threshold.labels, adj=c(1,0), cex=0.75)
}
},
ylim=ylim,
xlim=suppressWarnings(trans(xlm)),
ylab=ylab,
xlab=if (missing(xlab)) predictors[x.var] else xlab,
x.vals=x.vals, rug=rug,
main=main,
lower=x$lower, upper=x$upper, has.se=has.se, data=x,
scales=list(y=list(at=tickmarks$at, labels=tickmarks$labels, rot=roty),
x=list(at=tickmarks.x$at, labels=tickmarks.x$labels, rot=rotx),
alternating=alternating), ...)
result <- update(plot, layout = if (missing(layout)) c(0, prod(dim(plot))) else layout)
result$split <- split
result$more <- more
class(result) <- c("plot.eff", class(result))
}
return(result)
}
print.plot.eff <- function(x, ...){
NextMethod(split=x$split, more=x$more, ...)
invisible(x)
}
plot.efflist <- function(x, selection, rows, cols, ask=FALSE, graphics=TRUE, ...){
if (!missing(selection)){
if (is.character(selection)) selection <- gsub(" ", "", selection)
return(plot(x[[selection]], ...))
}
effects <- gsub(":", "*", names(x))
if (ask){
repeat {
selection <- menu(effects, graphics=graphics, title="Select Term to Plot")
if (selection == 0) break
else print(plot(x[[selection]], ...))
}
}
else {
neffects <- length(x)
mfrow <- mfrow(neffects)
if (missing(rows) || missing(cols)){
rows <- mfrow[1]
cols <- mfrow[2]
}
for (i in 1:rows) {
for (j in 1:cols){
if ((i-1)*cols + j > neffects) break
more <- !((i-1)*cols + j == neffects)
print(plot(x[[(i-1)*cols + j]], row=i, col=j, nrow=rows, ncol=cols, more=more, ...))
}
}
}
}
effects/R/summary-print-methods.R 0000644 0001762 0000144 00000022466 12230233005 016505 0 ustar ligges users # plot, summary, and print methods for effects package
# John Fox and Jangman Hong
# last modified 2012-11-30 by J. Fox
# 29 June 2011 added grid, rotx and roty arguments to the two plot methods
# by S. Weisberg
# 21 Dec 2012 modest modification of empty cells with crossed factors
# 2013-01-17: Added factor.ci.style arg to plot.eff() and plot.effpoly(). J. Fox
# 2013-01-18: Added CI bars to multiline plots with factor.ci.style="bars"
# 2013-01-19: Renamed 'factor.ci.style' to 'ci.style'. Added a 'none' option
# extended to variate terms if multiline=TRUE, ci.style="bars"
# 2013-01-30: scale arrow "heads" for error bars relative to cex
# 2013-05-31: fixed symbol colors in legends in plot.eff(). J. Fox
# 2013-08-14: fixed bug in restoring warn option. J. Fox
# 2013-08-27: fixed symbols argument for multiline plot in plot.eff(), reported by Ulrike Gromping. J. Fox
# 2013-08-31: fixed handling of ticks.x argument. John
# 2013-09-25: moved plot.eff methods to plot.methods.R for easier work. Michael
# 2013-10-17: added use.splines argument to plot.effpoly. Sandy
summary.eff <- function(object, type=c("response", "link"), ...){
result <- list()
result$header <- paste("\n", gsub(":", "*", object$term), 'effect\n')
result$offset <- object$offset
type <- match.arg(type)
if (type == "response") {
object$fit <- object$transformation$inverse(object$fit)
if (!is.null(object$confidence.level)){
object$lower <- object$transformation$inverse(object$lower)
object$upper <- object$transformation$inverse(object$upper)
}
}
result$effect <- array(object$fit,
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
if (!is.null(object$se)){
result$lower.header <- paste('\n Lower', round(100*object$confidence.level, 2),
'Percent Confidence Limits\n')
result$lower <- array(object$lower,
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
result$upper.header <- paste('\n Upper', round(100*object$confidence.level, 2),
'Percent Confidence Limits\n')
result$upper <- array(object$upper,
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
}
if (object$discrepancy > 1e-3) result$warning <- paste("\nWarning: There is an average discrepancy of",
round(object$discrepancy, 3),
"percent \n in the 'safe' predictions for effect", object$term, '\n')
class(result) <- "summary.eff"
result
}
print.summary.eff <- function(x, ...){
cat(x$header)
if (x$offset != 0) cat("\noffset = ", x$offset, "\n\n")
print(x$effect, ...)
if (!is.null(x$lower)){
cat(x$lower.header)
print(x$lower, ...)
cat(x$upper.header)
print(x$upper, ...)
}
if (!is.null(x$thresholds)){
cat("\nThresholds:\n")
print(x$thresholds, ...)
}
if (!is.null(x$warning)) cat(x$warning)
invisible(x)
}
print.eff <- function(x, type=c("response", "link"), ...){
cat(paste("\n", gsub(":", "*", x$term), 'effect\n'))
if (x$offset != 0) cat("\noffset = ", x$offset, "\n\n")
type <- match.arg(type)
if (type == "response") x$fit <- x$transformation$inverse(x$fit)
table <- array(x$fit,
dim=sapply(x$variables, function(x) length(x$levels)),
dimnames=lapply(x$variables, function(x) x$levels))
print(table, ...)
if (x$discrepancy > 1e-3) cat(paste("\nWarning: There is an average discrepancy of",
round(x$discrepancy, 3),
"percent \n in the 'safe' predictions for effect", x$term, '\n'))
invisible(x)
}
print.efflist <- function(x, ...){
cat(" model: ")
form <- x[[1]]$formula
attributes(form) <- NULL
print(form)
for (effect in names(x)){
print(x[[effect]], ...)
}
invisible(x)
}
summary.efflist <- function(object, ...){
cat(" model: ")
form <- object[[1]]$formula
attributes(form) <- NULL
print(form)
for (effect in names(object)){
print(summary(object[[effect]], ...))
}
invisible(NULL)
}
print.effpoly <- function(x, type=c("probability", "logits"), ...){
type <- match.arg(type)
x.frame <-as.data.frame(x)
n.predictors <- length(names(x$x))
predictors <- names(x.frame)[1:n.predictors]
y.lev <- x$y.lev
ylevel.names <- make.names(paste("prob",y.lev))
colnames(x$prob) <- colnames(x$logit) <- ylevel.names
y.categories <- matrix(0, nrow=length(x.frame[,predictors[1]]), ncol=length(y.lev))
for (i in 1:length(y.lev)){
level <- which(colnames(x$prob)[i] == ylevel.names)
y.categories[,i] <- rep(y.lev[level], length(y.categories[,i]))
}
y.categories <- as.vector(y.categories)
y.categories <- factor(y.categories)
for (i in 1:length(y.lev)){
cat(paste("\n", gsub(":", "*", x$term), " effect (", type,") for ", y.lev[i], "\n", sep=""))
table <- array(if (type == "probability") {x$prob[y.categories==y.lev[i]]}
else {x$logit[y.categories==y.lev[i]]},
dim=sapply(x$variables, function(x) length(x$levels)),
dimnames=lapply(x$variables, function(x) x$levels))
print(table, ...)
}
if (x$discrepancy > 0.1) cat(paste("\nWarning: There is an average discrepancy of",
round(x$discrepancy, 2),
"percent \n in the 'safe' predictions for effect", x$term, '\n'))
invisible(x)
}
summary.effpoly <- function(object, type=c("probability", "logits"), ...){
type <- match.arg(type)
x.frame <-as.data.frame(object)
n.predictors <- length(names(object$x))
predictors <- names(x.frame)[1:n.predictors]
y.lev <- object$y.lev
ylevel.names <- make.names(paste("prob",y.lev))
colnames(object$prob) <- colnames(object$logit) <-
colnames(object$lower.logit) <- colnames(object$upper.logit) <-
colnames(object$lower.prob) <- colnames(object$upper.prob)<- ylevel.names
y.categories <-matrix(0, nrow=length(x.frame[,predictors[1]]), ncol=length(y.lev))
for (i in 1:length(y.lev)){
level <- which(colnames(object$prob)[i] == ylevel.names)
y.categories[,i] <- rep(y.lev[level], length(y.categories[,i]))
}
y.categories <- as.vector(y.categories)
y.categories <- factor(y.categories)
for (i in 1:length(y.lev)){
cat(paste("\n", gsub(":", "*", object$term), " effect (" , type, ") for ", y.lev[i], "\n", sep=""))
table <- array(if (type == "probability") {object$prob[y.categories==y.lev[i]]}
else {object$logit[y.categories==y.lev[i]]},
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
print(table, ...)
}
if (is.null(object$confidence.level)) return(invisible(NULL))
for (i in 1:length(y.lev)){
cat(paste("\n", 'Lower', object$confidence.level*100, 'Percent Confidence Limits for'
, y.lev[i],'\n'))
table <- if (type == "probability") object$lower.prob else object$lower.logit
table <- array(table[y.categories==y.lev[i]],
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
print(table, ...)
}
for (i in 1:length(y.lev)){
cat(paste("\n", 'Upper', object$confidence.level*100, 'Percent Confidence Limits for'
, y.lev[i],'\n'))
table <- if (type == "probability") object$upper.prob else object$upper.logit
table <- array(table[y.categories==y.lev[i]],
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
print(table, ...)
}
if (object$discrepancy > 0.1) cat(paste("\nWarning: There is an average discrepancy of",
round(object$discrepancy, 2),
"percent \n in the 'safe' predictions for effect", object$term, '\n'))
invisible(NULL)
}
print.efflatent <- function(x, ...){
cat(paste("\n", gsub(":", "*", x$term), 'effect\n'))
table <- array(x$fit,
dim=sapply(x$variables, function(x) length(x$levels)),
dimnames=lapply(x$variables, function(x) x$levels))
print(table, ...)
cat("\nThresholds:\n")
print(x$thresholds, ...)
if (x$discrepancy > 0.1) cat(paste("\nWarning: There is an average discrepancy of",
round(x$discrepancy, 3),
"percent \n in the 'safe' predictions for effect", x$term, '\n'))
invisible(x)
}
summary.efflatent <- function(object, ...){
result <- list()
result$header <- paste("\n", gsub(":", "*", object$term), 'effect\n')
result$effect <- array(object$fit,
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
if (!is.null(object$se)){
result$lower.header <- paste('\n Lower', round(100*object$confidence.level, 2),
'Percent Confidence Limits\n')
result$lower <- array(object$lower,
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
result$upper.header <- paste('\n Upper', round(100*object$confidence.level, 2),
'Percent Confidence Limits\n')
result$upper <- array(object$upper,
dim=sapply(object$variables, function(x) length(x$levels)),
dimnames=lapply(object$variables, function(x) x$levels))
}
result$thresholds <- object$thresholds
if (object$discrepancy > 0.1) result$warning <- paste("\nWarning: There is an average discrepancy of",
round(object$discrepancy, 3),
"percent \n in the 'safe' predictions for effect", object$term, '\n')
class(result) <- "summary.eff"
result
}
effects/R/Effect.R 0000644 0001762 0000144 00000061434 12504572513 013425 0 ustar ligges users # Effect generic and methods
# John Fox and Sanford Weisberg
# 12-21-2012 Allow for empty cells in factor interactions, S. Weisberg
# 2012-03-05: Added .merMod method for development version of lme4, J. Fox
# 2012-04-06: Added support for lme4.0, J. Fox
# 2013-07-15: Changed default xlevels and default.levels
# 2013-10-15: Added Effect.default(). J. Fox
# 2013-10-22: fixed bug in Effect.lm() when na.action=na.exclude. J. Fox
# 2013-10-29: code to handle "valid" NAs in factors. J. Fox
# 2013-11-06: fixed bug in Effect.multinom() in construction of effect object
# when there is only one focal predictor; caused as.data.frame.effpoly() to fail
# 2014-03-13: modified Effect.lm() to compute partial residuals. J. Fox
# 2014-05-06: fixed bug in Effect.gls() when cor or var structure depends on variables in the data set. J. Fox
# 2014-08-02: added vcov.=vcov argument to allow other methods of estimating var(coef.estimates)
# 2014-09-25: added KR argument to Effect.mer() and Effect.merMod(). J. Fox
# 2014-12-07: don't assume that pbkrtest is installed. J. Fox
# 2015-03-25: added "family" element to eff objects returned by Effect.lm(). J. Fox
Effect <- function(focal.predictors, mod, ...){
UseMethod("Effect", mod)
}
Effect.lm <- function (focal.predictors, mod, xlevels = list(),
default.levels = NULL, given.values,
vcov. = vcov, se = TRUE, confidence.level = 0.95,
transformation = list(link = family(mod)$linkfun, inverse = family(mod)$linkinv),
typical = mean, offset = mean, partial.residuals=FALSE, quantiles=seq(0.2, 0.8, by=0.2),
x.var=NULL, ...){
data <- if (partial.residuals){
all.vars <- all.vars(formula(mod))
expand.model.frame(mod, all.vars)[, all.vars]
}
else NULL
if (missing(given.values))
given.values <- NULL
else if (!all(which <- names(given.values) %in% names(coef(mod))))
stop("given.values (", names(given.values[!which]), ") not in the model")
off <- if (is.numeric(offset) && length(offset) == 1) offset
else if (is.function(offset)) {
mod.off <- model.offset(model.frame(mod))
if (is.null(mod.off)) 0 else offset(mod.off)
}
else stop("offset must be a function or a number")
formula.rhs <- formula(mod)[[3]]
model.components <- Analyze.model(focal.predictors, mod, xlevels, default.levels, formula.rhs,
partial.residuals=partial.residuals, quantiles=quantiles, x.var=x.var, data=data)
excluded.predictors <- model.components$excluded.predictors
predict.data <- model.components$predict.data
predict.data.all.rounded <- predict.data.all <- if (partial.residuals) na.omit(data[, all.vars(formula(mod))]) else NULL
factor.levels <- model.components$factor.levels
factor.cols <- model.components$factor.cols
n.focal <- model.components$n.focal
x <- model.components$x
X.mod <- model.components$X.mod
cnames <- model.components$cnames
X <- model.components$X
x.var <- model.components$x.var
formula.rhs <- formula(mod)[c(1, 3)]
Terms <- delete.response(terms(mod))
mf <- model.frame(Terms, predict.data, xlev = factor.levels, na.action=NULL)
mod.matrix <- model.matrix(formula.rhs, data = mf, contrasts.arg = mod$contrasts)
if (is.null(x.var)) partial.residuals <- FALSE
factors <- sapply(predict.data, is.factor)
if (partial.residuals){
for (predictor in focal.predictors[-x.var]){
if (!factors[predictor]){
values <- unique(predict.data[, predictor])
predict.data.all.rounded[, predictor] <- values[apply(outer(predict.data.all[, predictor], values, function(x, y) (x - y)^2), 1, which.min)]
}
}
mf.all <- model.frame(Terms, predict.data.all, xlev = factor.levels, na.action=NULL)
mod.matrix.all <- model.matrix(formula.rhs, data = mf.all, contrasts.arg = mod$contrasts)
mf.all.rounded <- model.frame(Terms, predict.data.all.rounded, xlev = factor.levels, na.action=NULL)
mod.matrix.all.rounded <- model.matrix(formula.rhs, data = mf.all.rounded, contrasts.arg = mod$contrasts)
}
else mod.matrix.all <- model.matrix(mod)
wts <- weights(mod)
if (is.null(wts))
wts <- rep(1, length(residuals(mod)))
res <- Fixup.model.matrix(mod, mod.matrix, mod.matrix.all,
X.mod, factor.cols, cnames, focal.predictors, excluded.predictors,
typical, given.values,
partial.residuals=partial.residuals, mod.matrix.all.rounded)
mod.matrix <- if (partial.residuals) res$mod.matrix else res
mod.matrix.cases <- if (partial.residuals) res$mod.matrix.all else NULL
mod.matrix.cases.rounded <- if (partial.residuals) res$mod.matrix.all.rounded else NULL
# look for aliased coefficients and remove those columns from mod.matrix
mod.matrix <- mod.matrix[, !is.na(mod$coefficients)]
effect <- off + mod.matrix %*% mod$coefficients[!is.na(mod$coefficients)]
if (partial.residuals){
mod.matrix.cases <- na.omit(mod.matrix.cases[, !is.na(mod$coefficients)])
fitted <- as.vector(off + mod.matrix.cases %*% mod$coefficients[!is.na(mod$coefficients)])
mod.matrix.cases.rounded <- na.omit(mod.matrix.cases.rounded[, !is.na(mod$coefficients)])
fitted.rounded <- as.vector(off + mod.matrix.cases.rounded %*% mod$coefficients[!is.na(mod$coefficients)])
res <- na.omit(residuals(mod, type="working"))
partial.residuals.raw <- fitted + res
partial.residuals.adjusted <- fitted.rounded + res
}
else {
partial.residuals.raw <- partial.residuals.adjusted <- fitted.rounded <- fitted <- NULL
}
result <- list(term = paste(focal.predictors, collapse="*"),
formula = formula(mod), response = response.name(mod),
variables = x, fit = effect, x = predict.data[, 1:n.focal, drop=FALSE], x.all=predict.data.all.rounded, #[, 1:n.focal, drop=FALSE],
model.matrix = mod.matrix, mod.matrix.all=mod.matrix.cases, data = X,
discrepancy = 0, offset=off, fitted.rounded=fitted.rounded, fitted=fitted,
partial.residuals.raw=partial.residuals.raw, partial.residuals.adjusted=partial.residuals.adjusted,
x.var=x.var)
# find empty cells, if any, and correct
whichFact <- unlist(lapply(result$variables, function(x) x$is.factor))
zeroes <- NULL
if(sum(whichFact) > 1){
nameFact <- names(whichFact)[whichFact]
counts <- xtabs(as.formula( paste("~", paste(nameFact, collapse="+"))),
model.frame(mod))
zeroes <- which(counts == 0)
}
if(length(zeroes) > 0){
levs <- expand.grid(lapply(result$variables, function(x) x$levels))
good <- rep(TRUE, dim(levs)[1])
for(z in zeroes){
good <- good &
apply(levs, 1, function(x) !all(x == levs[z, whichFact]))
}
result$fit[!good] <- NA
}
if (se) {
if (any(family(mod)$family == c("binomial", "poisson"))) {
# dispersion <- 1
z <- qnorm(1 - (1 - confidence.level)/2)
}
else {
# dispersion <- sum(wts * (residuals(mod))^2, na.rm=TRUE)/mod$df.residual
z <- qt(1 - (1 - confidence.level)/2, df = mod$df.residual)
}
# old
# V2 <- dispersion * summary.lm(mod)$cov
# V1 <- vcov(mod)
# V <- if (inherits(mod, "fakeglm"))
# V1
# else V2
# end old, begin new August 2, 2014
V <- vcov.(mod) # I can see no reason to use dispersion * summary.lm(mod)$cov
# end new
eff.vcov <- mod.matrix %*% V %*% t(mod.matrix)
rownames(eff.vcov) <- colnames(eff.vcov) <- NULL
var <- diag(eff.vcov)
result$vcov <- eff.vcov
result$se <- sqrt(var)
result$lower <- effect - z * result$se
result$upper <- effect + z * result$se
result$confidence.level <- confidence.level
if(length(zeroes) > 0){
result$se[!good] <- NA
result$lower[!good] <- NA
result$upper[!good] <- NA
}
}
if (is.null(transformation$link) && is.null(transformation$inverse)) {
transformation$link <- I
transformation$inverse <- I
}
result$transformation <- transformation
result$family <- family(mod)$family
class(result) <- "eff"
result
}
Effect.mer <- function(focal.predictors, mod, KR=FALSE, ...) {
result <- Effect(focal.predictors, mer.to.glm(mod, KR=KR), ...)
result$formula <- as.formula(formula(mod))
result
}
Effect.merMod <- function(focal.predictors, mod, KR=FALSE, ...){
Effect.mer(focal.predictors, mod, KR=KR, ...)
}
Effect.lme <- function(focal.predictors, mod, ...) {
result <- Effect(focal.predictors, lme.to.glm(mod), ...)
result$formula <- as.formula(formula(mod))
result
}
Effect.gls <- function (focal.predictors, mod, xlevels = list(), default.levels = NULL, given.values,
vcov. = vcov, se = TRUE, confidence.level = 0.95,
transformation = NULL,
typical = mean, ...){
if (missing(given.values))
given.values <- NULL
else if (!all(which <- names(given.values) %in% names(coef(mod))))
stop("given.values (", names(given.values[!which]), ") not in the model")
formula.rhs <- formula(mod)[[3]]
.data <- eval(mod$call$data)
mod.lm <- lm(as.formula(mod$call$model), data=.data, na.action=na.exclude)
model.components <- Analyze.model(focal.predictors, mod.lm, xlevels, default.levels, formula.rhs)
excluded.predictors <- model.components$excluded.predictors
predict.data <- model.components$predict.data
factor.levels <- model.components$factor.levels
factor.cols <- model.components$factor.cols
n.focal <- model.components$n.focal
x <- model.components$x
X.mod <- model.components$X.mod
cnames <- model.components$cnames
X <- model.components$X
formula.rhs <- formula(mod)[c(1, 3)]
nrow.X <- nrow(X)
mf <- model.frame(formula.rhs, data=rbind(X[,names(predict.data),drop=FALSE], predict.data),
xlev=factor.levels)
mod.matrix.all <- model.matrix(formula.rhs, data=mf, contrasts.arg=mod$contrasts)
mod.matrix <- mod.matrix.all[-(1:nrow.X),]
mod.matrix <- Fixup.model.matrix(mod.lm, mod.matrix, model.matrix(mod.lm),
X.mod, factor.cols, cnames, focal.predictors, excluded.predictors, typical, given.values)
fit.1 <- na.omit(predict(mod))
mod.2 <- lm.fit(mod.matrix.all[1:nrow.X,], fit.1)
class(mod.2) <- "lm"
use <- !is.na(residuals(mod.lm))
.data <- .data[use, ]
.data$.y <- model.response.gls(mod)
.data$.X <- mod.matrix.all[1:nrow.X, ]
mod.3 <- update(mod, .y ~ .X - 1, data=.data)
discrepancy <- 100*mean(abs(fitted(mod.2)- fit.1)/(1e-10 + mean(abs(fit.1))))
if (discrepancy > 1e-3) warning(paste("There is a discrepancy of", round(discrepancy, 3),
"percent \n in the 'safe' predictions used to generate effect", paste(focal.predictors, collapse="*")))
effect <- mod.matrix %*% mod$coefficients
result <- list(term = paste(focal.predictors, collapse="*"),
formula = formula(mod), response = response.name(mod),
variables = x, fit = effect, x = predict.data[, 1:n.focal, drop=FALSE], model.matrix = mod.matrix, data = X,
discrepancy = discrepancy, offset=0)
if (se){
df.res <- mod$dims[["N"]] - mod$dims[["p"]]
z <- qt(1 - (1 - confidence.level)/2, df=df.res)
mod.2$terms <- terms(mod)
V <- vcov.(mod.3)
eff.vcov <- mod.matrix %*% V %*% t(mod.matrix)
rownames(eff.vcov) <- colnames(eff.vcov) <- NULL
var <- diag(eff.vcov)
result$vcov <- eff.vcov
result$se <- sqrt(var)
result$lower <- effect - z*result$se
result$upper <- effect + z*result$se
result$confidence.level <- confidence.level
}
if (is.null(transformation$link) && is.null(transformation$inverse)){
transformation$link <- I
transformation$inverse <- I
}
result$transformation <- transformation
class(result) <- "eff"
result
}
Effect.multinom <- function(focal.predictors, mod,
confidence.level=.95, xlevels=list(), default.levels=NULL,
given.values, vcov. = vcov, se=TRUE, typical=mean, ...){
if (length(mod$lev) < 3) stop("effects for multinomial logit model only available for response levels > 2")
if (missing(given.values)) given.values <- NULL
else if (!all(which <- colnames(given.values) %in% names(coef(mod))))
stop("given.values (", colnames(given.values[!which]),") not in the model")
formula.rhs <- formula(mod)[c(1, 3)]
model.components <- Analyze.model(focal.predictors, mod, xlevels, default.levels, formula.rhs)
excluded.predictors <- model.components$excluded.predictors
predict.data <- model.components$predict.data
factor.levels <- model.components$factor.levels
factor.cols <- model.components$factor.cols
n.focal <- model.components$n.focal
x <- model.components$x
X.mod <- model.components$X.mod
cnames <- model.components$cnames
X <- model.components$X
formula.rhs <- formula(mod)[c(1, 3)]
Terms <- delete.response(terms(mod))
mf <- model.frame(Terms, predict.data, xlev = factor.levels)
mod.matrix <- model.matrix(formula.rhs, data = mf, contrasts.arg = mod$contrasts)
X0 <- Fixup.model.matrix(mod, mod.matrix, model.matrix(mod),
X.mod, factor.cols, cnames, focal.predictors, excluded.predictors, typical, given.values)
resp.names <- make.names(mod$lev, unique=TRUE)
resp.names <- c(resp.names[-1], resp.names[1]) # make the last level the reference level
B <- t(coef(mod))
V <- vcov.(mod)
m <- ncol(B) + 1
p <- nrow(B)
r <- p*(m - 1)
n <- nrow(X0)
P <- Logit <- matrix(0, n, m)
colnames(P) <- paste("prob.", resp.names, sep="")
colnames(Logit) <- paste("logit.", resp.names, sep="")
if (se){
z <- qnorm(1 - (1 - confidence.level)/2)
Lower.P <- Upper.P <- Lower.logit <- Upper.logit <- SE.P <- SE.logit <- matrix(0, n, m)
colnames(Lower.logit) <- paste("L.logit.", resp.names, sep="")
colnames(Upper.logit) <- paste("U.logit.", resp.names, sep="")
colnames(Lower.P) <- paste("L.prob.", resp.names, sep="")
colnames(Upper.P) <- paste("U.prob.", resp.names, sep="")
colnames(SE.P) <- paste("se.prob.", resp.names, sep="")
colnames(SE.logit) <- paste("se.logit.", resp.names, sep="")
}
for (i in 1:n){
res <- eff.mul(X0[i,], B, se, m, p, r, V) # compute effects
P[i,] <- prob <- res$p # fitted probabilities
Logit[i,] <- logit <- res$logits # fitted logits
if (se){
SE.P[i,] <- se.p <- res$std.err.p # std. errors of fitted probs
SE.logit[i,] <- se.logit <- res$std.error.logits # std. errors of logits
Lower.P[i,] <- logit2p(logit - z*se.logit)
Upper.P[i,] <- logit2p(logit + z*se.logit)
Lower.logit[i,] <- logit - z*se.logit
Upper.logit[i,] <- logit + z*se.logit
}
}
resp.levs <- c(m, 1:(m-1)) # restore the order of the levels
P <- P[, resp.levs]
Logit <- Logit[, resp.levs]
if (se){
Lower.P <- Lower.P[, resp.levs]
Upper.P <- Upper.P[, resp.levs]
Lower.logit <- Lower.logit[, resp.levs]
Upper.logit <- Upper.logit[, resp.levs]
SE.P <- SE.P[, resp.levs]
SE.logit <- SE.logit[, resp.levs]
}
result <- list(term=paste(focal.predictors, collapse="*"), formula=formula(mod), response=response.name(mod),
y.levels=mod$lev, variables=x, x=predict.data[, focal.predictors, drop=FALSE],
model.matrix=X0, data=X, discrepancy=0, model="multinom",
prob=P, logit=Logit)
if (se) result <- c(result, list(se.prob=SE.P, se.logit=SE.logit,
lower.logit=Lower.logit, upper.logit=Upper.logit,
lower.prob=Lower.P, upper.prob=Upper.P,
confidence.level=confidence.level))
# find empty cells, if any, and correct
whichFact <- unlist(lapply(result$variables, function(x) x$is.factor))
zeroes <- NULL
if(sum(whichFact) > 1){
nameFact <- names(whichFact)[whichFact]
counts <- xtabs(as.formula( paste("~", paste(nameFact, collapse="+"))),
model.frame(mod))
zeroes <- which(counts == 0)
}
if(length(zeroes) > 0){
levs <- expand.grid(lapply(result$variables, function(x) x$levels))
good <- rep(TRUE, dim(levs)[1])
for(z in zeroes){
good <- good &
apply(levs, 1, function(x) !all(x == levs[z, whichFact]))
}
result$prob[!good, ] <- NA
result$logit[!good, ] <- NA
if (se){
result$se.prob[!good, ] <- NA
result$se.logit[!good, ] <- NA
result$lower.prob[!good, ] <- NA
result$upper.prob[!good, ] <- NA
}
}
class(result) <-'effpoly'
result
}
Effect.polr <- function(focal.predictors, mod,
confidence.level=.95, xlevels=list(), default.levels=NULL,
given.values, vcov.=vcov, se=TRUE, typical=mean, latent=FALSE, ...){
if (mod$method != "logistic") stop('method argument to polr must be "logistic"')
if (missing(given.values)) given.values <- NULL
else if (!all(which <- names(given.values) %in% names(coef(mod))))
stop("given.values (", names(given.values[!which]),") not in the model")
formula.rhs <- formula(mod)[c(1, 3)]
model.components <- Analyze.model(focal.predictors, mod, xlevels, default.levels, formula.rhs)
excluded.predictors <- model.components$excluded.predictors
predict.data <- model.components$predict.data
factor.levels <- model.components$factor.levels
factor.cols <- model.components$factor.cols
n.focal <- model.components$n.focal
x <- model.components$x
X.mod <- model.components$X.mod
cnames <- model.components$cnames
X <- model.components$X
Terms <- delete.response(terms(mod))
mf <- model.frame(Terms, predict.data, xlev = factor.levels, na.action=NULL)
mod.matrix <- model.matrix(formula.rhs, data = mf, contrasts.arg = mod$contrasts)
X0 <- Fixup.model.matrix(mod, mod.matrix, model.matrix(mod),
X.mod, factor.cols, cnames, focal.predictors, excluded.predictors, typical, given.values)
resp.names <- make.names(mod$lev, unique=TRUE)
X0 <- X0[,-1, drop=FALSE]
b <- coef(mod)
p <- length(b) # corresponds to p - 1 in the text
alpha <- - mod$zeta # intercepts are negatives of thresholds
z <- qnorm(1 - (1 - confidence.level)/2)
result <- list(term=paste(focal.predictors, collapse="*"), formula=formula(mod), response=response.name(mod),
y.levels=mod$lev, variables=x,
x=predict.data[, focal.predictors, drop=FALSE],
model.matrix=X0, data=X, discrepancy=0, model="polr")
if (latent){
res <- eff.latent(X0, b, vcov.(mod)[1:p, 1:p], se)
result$fit <- res$fit
if (se){
result$se <- res$se
result$lower <- result$fit - z*result$se
result$upper <- result$fit + z*result$se
result$confidence.level <- confidence.level
}
transformation <- list()
transformation$link <- I
transformation$inverse <- I
result$transformation <- transformation
result$thresholds <- -alpha
class(result) <- c("efflatent", "eff")
return(result)
}
m <- length(alpha) + 1
r <- m + p - 1
indices <- c((p+1):r, 1:p)
V <- vcov.(mod)[indices, indices]
for (j in 1:(m-1)){ # fix up the signs of the covariances
V[j,] <- -V[j,] # for the intercepts
V[,j] <- -V[,j]}
n <- nrow(X0)
P <- Logit <- matrix(0, n, m)
colnames(P) <- paste("prob.", resp.names, sep="")
colnames(Logit) <- paste("logit.", resp.names, sep="")
if (se){
Lower.logit <- Upper.logit <- Lower.P <- Upper.P <- SE.P <- SE.Logit <- matrix(0, n, m)
colnames(Lower.logit) <- paste("L.logit.", resp.names, sep="")
colnames(Upper.logit) <- paste("U.logit.", resp.names, sep="")
colnames(Lower.P) <- paste("L.prob.", resp.names, sep="")
colnames(Upper.P) <- paste("U.prob.", resp.names, sep="")
colnames(SE.P) <- paste("se.prob.", resp.names, sep="")
colnames(SE.Logit) <- paste("se.logit.", resp.names, sep="")
}
for (i in 1:n){
res <- eff.polr(X0[i,], b, alpha, V, m, r, se) # compute effects
P[i,] <- prob <- res$p # fitted probabilities
Logit[i,] <- logit <- res$logits # fitted logits
if (se){
SE.P[i,] <- se.p <- res$std.err.p # std. errors of fitted probs
SE.Logit[i,] <- se.logit <- res$std.error.logits # std. errors of logits
Lower.P[i,] <- logit2p(logit - z*se.logit)
Upper.P[i,] <- logit2p(logit + z*se.logit)
Lower.logit[i,] <- logit - z*se.logit
Upper.logit[i,] <- logit + z*se.logit
}
}
result$prob <- P
result$logit <- Logit
if (se) result <- c(result,
list(se.prob=SE.P, se.logit=SE.Logit,
lower.logit=Lower.logit, upper.logit=Upper.logit,
lower.prob=Lower.P, upper.prob=Upper.P,
confidence.level=confidence.level))
class(result) <-'effpoly'
result
}
Effect.default <- function(focal.predictors, mod, xlevels = list(), default.levels = NULL, given.values,
vcov. = vcov, se = TRUE, confidence.level = 0.95,
transformation = list(link = I, inverse = I),
typical = mean, offset = mean, ...){
if (missing(given.values))
given.values <- NULL
else if (!all(which <- names(given.values) %in% names(coef(mod))))
stop("given.values (", names(given.values[!which]), ") not in the model")
off <- if (is.numeric(offset) && length(offset) == 1) offset
else if (is.function(offset)) {
mod.off <- model.offset(model.frame(mod))
if (is.null(mod.off)) 0 else offset(mod.off)
}
else stop("offset must be a function or a number")
formula.rhs <- formula(mod)[[3]]
model.components <- Analyze.model(focal.predictors, mod, xlevels, default.levels, formula.rhs)
excluded.predictors <- model.components$excluded.predictors
predict.data <- model.components$predict.data
factor.levels <- model.components$factor.levels
factor.cols <- model.components$factor.cols
n.focal <- model.components$n.focal
x <- model.components$x
X.mod <- model.components$X.mod
cnames <- model.components$cnames
X <- model.components$X
formula.rhs <- formula(mod)[c(1, 3)]
Terms <- delete.response(terms(mod))
mf <- model.frame(Terms, predict.data, xlev = factor.levels, na.action=NULL)
mod.matrix <- model.matrix(formula.rhs, data = mf, contrasts.arg = mod$contrasts)
mod.matrix <- Fixup.model.matrix(mod, mod.matrix, model.matrix(mod),
X.mod, factor.cols, cnames, focal.predictors, excluded.predictors, typical, given.values)
mod.matrix <- mod.matrix[, !is.na(coef(mod))]
effect <- off + mod.matrix %*% mod$coefficients[!is.na(coef(mod))]
result <- list(term = paste(focal.predictors, collapse="*"),
formula = formula(mod), response = response.name(mod),
variables = x, fit = effect, x = predict.data[, 1:n.focal, drop=FALSE], model.matrix = mod.matrix, data = X,
discrepancy = 0, offset=off)
whichFact <- unlist(lapply(result$variables, function(x) x$is.factor))
zeroes <- NULL
if(sum(whichFact) > 1){
nameFact <- names(whichFact)[whichFact]
counts <- xtabs(as.formula( paste("~", paste(nameFact, collapse="+"))),
model.frame(mod))
zeroes <- which(counts == 0)
}
if(length(zeroes) > 0){
levs <- expand.grid(lapply(result$variables, function(x) x$levels))
good <- rep(TRUE, dim(levs)[1])
for(z in zeroes){
good <- good &
apply(levs, 1, function(x) !all(x == levs[z, whichFact]))
}
result$fit[!good] <- NA
}
if (se) {
z <- qnorm(1 - (1 - confidence.level)/2)
V <- vcov.(mod)
eff.vcov <- mod.matrix %*% V %*% t(mod.matrix)
rownames(eff.vcov) <- colnames(eff.vcov) <- NULL
var <- diag(eff.vcov)
result$vcov <- eff.vcov
result$se <- sqrt(var)
result$lower <- effect - z * result$se
result$upper <- effect + z * result$se
result$confidence.level <- confidence.level
if(length(zeroes) > 0){
result$se[!good] <- NA
result$lower[!good] <- NA
result$upper[!good] <- NA
}
}
result$transformation <- transformation
class(result) <- "eff"
result
} effects/R/Effect.mlm.R 0000644 0001762 0000144 00000003035 12310147362 014175 0 ustar ligges users # Calculate Effects for term(s) in a Multivariate Linear Model
# 2014-03-12: Introduced allEffects.mlm(). J. Fox
Effect.mlm <- function(focal.predictors, mod, response, ...) {
if (missing(response)) {
mod.frame <- model.frame(mod)
response <- colnames(model.response(mod.frame))
}
else if (is.numeric(response)) {
mod.frame <- model.frame(mod)
response.names <- colnames(model.response(mod.frame))
response <- response.names[response]
}
if (length(response)==1) {
mod.1 <- update(mod, as.formula(paste(response, " ~ .")))
result <- Effect(focal.predictors, mod.1, ...)
}
else {
result <- as.list(NULL)
for (resp in response) {
mod.1 <- update(mod, as.formula(paste(resp, " ~ .")))
lab <- resp
result[[lab]] <- Effect(focal.predictors, mod.1, ...)
}
class(result) <- "efflist"
}
result
}
allEffects.mlm <- function(mod, ...){
result <- NextMethod()
class(result) <- "mlm.efflist"
result
}
plot.mlm.efflist <- function(x, ...){
x <- do.call(c, x)
class(x) <- "efflist"
plot(x, ...)
}
summary.mlm.efflist <- function(object, ...){
object <- do.call(c, object)
for (effect in names(object)){
cat("\n\nResponse:", object[[effect]]$response, "\n")
print(summary(object[[effect]], ...))
}
}
print.mlm.efflist <- function(x, ...){
x <- do.call(c, x)
for (effect in names(x)){
cat("\n\nResponse:", x[[effect]]$response, "\n")
print(x[[effect]], ...)
}
invisible(x)
}
effects/MD5 0000644 0001762 0000144 00000003313 12654472141 012207 0 ustar ligges users 9babab4452646b150015dec3888e93d1 *DESCRIPTION
1abbab63bfd9f409265bf62f443bb09e *NAMESPACE
3c18e4d569c5078df67b72d66914a07d *NEWS
5813199c8d50d68dd051d43339e7adf9 *R/Effect.R
fd5534d1b50f0256571b3e20a4211520 *R/Effect.mlm.R
c020ab794be53beba8b33f354c0fa04f *R/effects.R
333a68e50375fc19512396135be9ed3c *R/effectsclmm.R
82d6651fdaa4d2eedf50cd9242d3f712 *R/effectsmer.R
1403f40a00195b3a06fdcb8c680d2fdf *R/effectspoLCA.R
4485bfda834494fd0c85641d0652c36e *R/plot-methods.R
b210448fcd1e33be31f94bc8316cdc05 *R/plot.effpoly.R
0bb21fdd0b65a9093bdc583428a82600 *R/summary-print-methods.R
9c18eaddb0e3e864e33bdf5969d11717 *R/utilities.R
b68033b2f2ddc5020875693045fec265 *data/Arrests.rda
a545d973c61588f5ca78894cb38b4319 *data/BEPS.rda
cb8193a7b56ada2c8482825b80317cd3 *data/Cowles.rda
ff3a8d5a0670d05b1a1b36a6315ec18c *data/Hartnagel.rda
eb70cef30f5e1f72b0f52145b8119517 *data/Prestige.rda
67035a606a0f9a31a23a5196e2873a6f *data/TitanicSurvival.rda
68b5153cab85b6f874edcf7abd941f4a *data/WVS.rda
3e49132323090d5f7aac873dc4a78b39 *data/Wells.rda
809fa4f25bbbd3e6d146c26d7ae3907e *inst/CHANGES
e6b77c2338408b6fdf1a617eaa014a2b *inst/CITATION
2cf51c803a105bfe15c89e1d38075dd4 *man/Arrests.Rd
8a5faaf5977b8922131c28944958e8bf *man/BEPS.Rd
8751e2c091279ca02cfac5845b196c77 *man/Cowles.Rd
73d76fd4ac46673ccbdbd07b8e199300 *man/Hartnagel.Rd
3f0741a1feb35e53cdc4fc6da672c28e *man/Prestige.Rd
a2697326c6634deeba023eb2db80ffea *man/Titanic.Rd
3ea67e3d3d057bd0eae08ca5e4f2a0ad *man/WVS.Rd
18f83ed88afe8b1ecae2dbc3dc986b66 *man/Wells.Rd
50cea9d1ad78eccee1fe51783ea0933c *man/effect.Rd
03336c030e40258fc3316c4cb0c707d1 *man/effects-deprecated.Rd
e4354fddbebb2b2d2b05767af3592d92 *man/effects-package.Rd
69766f376830496012f1f0865b4e0f5a *man/summary.effect.Rd
effects/DESCRIPTION 0000644 0001762 0000144 00000002641 12654472141 013410 0 ustar ligges users Package: effects
Version: 3.0-6
Date: 2016-02-02
Title: Effect Displays for Linear, Generalized Linear, and Other Models
Authors@R: c(person("John", "Fox", role = c("aut", "cre"), email = "jfox@mcmaster.ca"),
person("Sanford", "Weisberg", role = "aut", email = "sandy@umn.edu"),
person("Michael", "Friendly", role = "aut", email = "friendly@yorku.ca"),
person("Jangman", "Hong", role = "aut"),
person("Robert", "Andersen", role = "ctb"),
person("David", "Firth", role = "ctb"),
person("Steve", "Taylor", role = "ctb"))
Suggests: pbkrtest (>= 0.4-4), nlme, MASS, poLCA, heplots, splines,
ordinal
Imports: lme4, nnet, lattice, grid, colorspace, graphics, grDevices,
stats, utils
LazyLoad: yes
LazyData: yes
Description:
Graphical and tabular effect displays, e.g., of interactions, for
various statistical models with linear predictors.
License: GPL (>= 2)
URL: http://www.r-project.org, http://socserv.socsci.mcmaster.ca/jfox/
Author: John Fox [aut, cre],
Sanford Weisberg [aut],
Michael Friendly [aut],
Jangman Hong [aut],
Robert Andersen [ctb],
David Firth [ctb],
Steve Taylor [ctb]
Maintainer: John Fox
Repository: CRAN
Repository/R-Forge/Project: effects
Repository/R-Forge/Revision: 215
Repository/R-Forge/DateTimeStamp: 2016-02-02 13:48:13
Date/Publication: 2016-02-03 22:42:57
NeedsCompilation: no
Packaged: 2016-02-02 14:10:51 UTC; rforge
Depends: R (>= 2.10)
effects/man/ 0000755 0001762 0000144 00000000000 12654133545 012454 5 ustar ligges users effects/man/summary.effect.Rd 0000644 0001762 0000144 00000055163 12570102253 015672 0 ustar ligges users \name{summary.eff}
\alias{print.eff}
\alias{print.effpoly}
\alias{print.efflatent}
\alias{print.efflist}
\alias{print.mlm.efflist}
\alias{print.summary.eff}
\alias{summary.eff}
\alias{summary.effpoly}
\alias{summary.efflatent}
\alias{summary.efflist}
\alias{summary.mlm.efflist}
\alias{plot.eff}
\alias{plot.effpoly}
\alias{plot.efflist}
\alias{plot.mlm.efflist}
\alias{setStrip}
\alias{restoreStrip}
\alias{[.efflist}
\title{Summarizing, Printing, and Plotting Effects}
\description{
\code{summary}, \code{print}, \code{plot}, and \code{[} methods for \code{eff}, \code{effpoly},
\code{efflist}, and \code{mlm.efflist} objects.
}
\usage{
\method{print}{eff}(x, type=c("response", "link"), ...)
\method{print}{effpoly}(x, type=c("probability", "logits"), ...)
\method{print}{efflatent}(x, ...)
\method{print}{efflist}(x, ...)
\method{print}{mlm.efflist}(x, ...)
\method{print}{summary.eff}(x, ...)
\method{summary}{eff}(object, type=c("response", "link"), ...)
\method{summary}{effpoly}(object, type=c("probability", "logits"), ...)
\method{summary}{efflatent}(object, ...)
\method{summary}{efflist}(object, ...)
\method{summary}{mlm.efflist}(object, ...)
\method{plot}{eff}(x, x.var,
z.var=which.min(levels), multiline=is.null(x$se), rug=TRUE,
xlab, ylab, main=paste(effect, "effect plot"),
colors=palette(), symbols=1:length(colors), lines=1:length(colors),
cex=1.5, lwd=2, ylim, xlim=NULL,
factor.names=TRUE, ci.style, band.transparency=0.15, band.colors=colors,
type=c("rescale", "response", "link"), ticks=list(at=NULL, n=5),
alternating=TRUE, rotx=0, roty=0, grid=FALSE, layout, rescale.axis,
transform.x=NULL, ticks.x=NULL,
key.args=NULL,
row=1, col=1, nrow=1, ncol=1, more=FALSE,
use.splines=TRUE, partial.residuals=c("adjusted", "raw"), show.fitted=FALSE,
residuals.color="blue", residuals.pch=1, residuals.cex=1,
smooth.residuals=TRUE, residuals.smooth.color=residuals.color, span=2/3, ...)
\method{plot}{effpoly}(x,
type=c("probability", "logit"),
x.var=which.max(levels),
rug=TRUE,
xlab,
ylab=paste(x$response, " (", type, ")", sep=""),
main=paste(effect, "effect plot"),
colors, symbols, lines, cex=1.5, lwd=2,
factor.names=TRUE, ci.style, band.colors, band.transparency=0.3,
style=c("lines", "stacked"),
confint=(style == "lines" && !is.null(x$confidence.level)),
transform.x=NULL, ticks.x=NULL, xlim=NULL,
ylim, rotx=0, alternating=TRUE, roty=0, grid=FALSE,
layout, key.args=NULL,
row=1, col=1, nrow=1, ncol=1, more=FALSE, use.splines=TRUE, ...)
\method{plot}{efflist}(x, selection, rows, cols, ask=FALSE, graphics=TRUE, ...)
\method{plot}{mlm.efflist}(x, ...)
setStrip(bg=3, fg="black", clip=c("off", "on"))
restoreStrip(saved)
\method{[}{efflist}(x, ...)
}
\arguments{
\item{x}{an object of class \code{"eff"}, \code{"effpoly"}, \code{"efflist"}, \code{"mlm.efflist"},
or \code{"summary.eff"}, as appropriate.}
\item{object}{an object of class \code{"eff"}, \code{"effpoly"}, \code{"efflist"}, or \code{"mlm.efflist"},
as appropriate.}
\item{type}{for printing or summarizing linear and generalized linear models,
if \code{"response"} (the default), effects are printed on the scale of the response
variable; if \code{"link"}, effects are printed on the scale of the linear predictor.
For plotting linear or genealized linearized models, \code{"rescale"} (the default) plots the vertical
axis on the link scale (e.g., the logit scale for a logit model) but labels the axis on the response
scale (e.g., the probability scale for a logit model);
\code{"response"} plots and labels the vertical axis on the scale of the response (e.g., the
probability scale for a logit model); and
\code{"link"} plots and labels the vertical axis
on the scale of the link (e.g., the logit scale for a logit model).
For polytomous logit models, this argument takes either \code{"probability"}
or \code{"logit"}, with the former as the default.}
\item{rescale.axis}{this argument is deprecated --- use the \code{type} argument instead. Setting
\code{rescale.axis=TRUE} is equivalent to \code{type="rescale"}; setting \code{rescale.axis=FALSE}
is equivalent to \code{type="response"}. If specified, \code{rescale.axis} will override \code{type}.}
\item{x.var}{the index (number) or quoted name of the covariate or factor to place on the
horizontal axis of each panel of the effect plot. The default is the
predictor with the largest number of levels or values.}
\item{z.var}{for linear, generalized linear or mixed models,
the index (number) or quoted name of the covariate or factor for which
individual lines are to be drawn in each panel of the effect plot. The default is the
predictor with the smallest number of levels or values. This argument is only
used if \code{multiline = TRUE}.}
\item{multiline}{for linear, generalized linear or mixed models,
if \code{TRUE}, each panel of the display represents combinations
of values of two predictors, with one predictor (corresponding to \code{x.var})
on the horzontal axis, and the other (corresponding to \code{z.var}) used to define
lines in the graph; defaults to \code{TRUE} if there are no standard errors in
the object being plotted, and \code{FALSE} otherwise.}
\item{confint}{plot point-wise confidence bands around fitted effects (for
multinomial and proportional-odds logit models); defaults to \code{TRUE},
in which case separate panels are used for different response levels.}
\item{rug}{if \code{TRUE}, the default, a rug plot is shown giving the \emph{marginal}
distribution of the predictor on the horizontal axis, if this predictor is
a covariate. The rug plot is suppressed if partial residuals are plotted.}
\item{xlab}{the label for the horizontal axis of the effect plot; if missing, the
function will use the name of the predictor on the horizontal axis.}
\item{ylab}{the label for the vertical axis of the effect plot; the default is
constructed from the name of the
response variable for the model from which the effect was computed.}
\item{main}{the title for the plot, printed at the top; the default title is constructed from the
name of the effect.}
\item{colors}{\code{colors[1]} is used to plot effects, \code{colors[2]} to plot
confidence limits when \code{ci.style} is not equal to \code{"bands"}. In a mulitline plot, the successive \code{colors} correspond
to the levels of the \code{z.var} covariate or factor. In a stacked plot or a plot
without confidence bands for a
multinomial or proportional-odds logit model, the successive \code{colors}
correspond to the levels of the response factor. In all but stacked plots,
\code{colors} defaults to \code{palette()}. If \code{colors} is
shorter than the number of levels, then it is recycled, so \code{colors="black"}
will use black for all levels.
For stacked multinomial-logit plots,
\code{colors} defaults to \code{rainbow_hcl(levels)}, where \code{levels} is
the number of levels of the response variable; for stacked proportional-odds model
plots, \code{colors} defautls to \code{sequential_hcl(levels)}. \code{colors}
does not recycle for stacked plots.
\bold{Warning:} This argument
\emph{cannot} be abbreviated to \code{col}, which is used for a different
purpose (see below).}
\item{symbols, lines}{corresponding to the levels of the \code{z.var} covariate
or factor on a multiline plot, or to the successive levels of the response factor
in a line plot for a polytomous logit model.
These arguments are used only if \code{multiline = TRUE}
or for polytomous logit models where the effects are plotted without confidence bands;
in these cases a legend is drawn at the top of the display. If these arguments are
too short they are recycled.}
\item{cex}{character expansion for plotted symbols; default is \code{1.5}.}
\item{lwd}{line width for fitted lines.}
\item{ylim}{2-element vector containing the lower and upper limits of the vertical axes;
if \code{NULL}, the default, then the vertical axes are scaled from the data.}
\item{xlim}{a named list of 2-element vectors, with the names corresponding to numeric
predictors; if a numeric predictor is in the list, then when it appears on the horizontal
axis, the axis limits will be taken from the corresponding vector; if a predictor is
not in the list, or if the argument is \code{NULL} (the default), then the horizontal
axis limits are computed from the data.}
\item{factor.names}{a logical value, default \code{TRUE}, that controls the inclusion of
factor names in conditioning-variable labels.}
\item{ci.style}{confidence bounds can be indicated using error bars, using lines or confidence bands,
depending on the plot type.
For single line plots the default is \code{"bars"} for factors and \code{"bands"}
for variates. Style \code{"lines"} can also be used for either of these.
For multiline plots, the default is \code{"none"} for no
confidence bounds, but style \code{"bars"} or \code{"bands"} can also be used. For a variate
the option \code{"bars"} displays the error bars at
each of the \code{levels} points for which the horizontal variable was evaluated.}
\item{band.colors}{A vector of colors for the color of the confidence band with \code{ci.style="bands"}.
The default is \code{band.colors=colors}. For plots with one line, the choice, setting
\code{band.colors="red"} produces a pleasing result, even if color provides no additional
information in this case. If this argument is too short it is recycled.}
\item{band.transparency}{For \code{ci.style="bands"}, the alpha transparency of the fill color. Not all
graphic devices support transparency.}
\item{style}{(for multinomial or proportional-odds logit models) \code{"lines"} (the default
for a line plot, or \code{"stacked"} for a stacked-bar or stacked-area plot. In the latter
case only fitted probabilities may be plotted and confidence envelopes cannot be shown.}
\item{ticks}{a two-item list controlling the placement of tick marks on the vertical axis,
with elements \code{at} and \code{n}. If \code{at=NULL} (the default), the program
attempts to find `nice' locations for the ticks, and the value of \code{n} (default,
\code{5}) gives the
approximate number of tick marks desired; if \code{at} is non-\code{NULL}, then the
value of \code{n} is ignored.}
\item{ticks.x}{a named list of two-item lists controlling the placement of tick marks
on the horizontal axis. Each list element is named for a numeric predictor in the model,
and each sublist has elements \code{at} or \code{n} are for the \code{ticks} argument.
If a predictor doesn't appear in the list, or if \code{ticks.x} is \code{NULL} (the default),
then the tick marks are computed by the function.}
\item{transform.x}{transformations to be applied to the horizontal axis, in the form of a named list,
each of whose elements is itself a list of two functions, with sublist element names \code{trans} and \code{inverse}.
The names of the list elements are numeric predictors in the model whose axes are to be transformed; the
\code{trans} function is applied to the values of the predictor, and \code{inverse} is used for computing
proper axis tick labels. If a numeric predictor is missing from \code{transform.x} then its axis is not
transformed; if the argument is \code{NULL} (the default), then no predictor axes are transformed.}
\item{alternating}{if \code{TRUE} (the default), the tick labels alternate by panels in
multi-panel displays from left to right and top to bottom; if \code{FALSE}, tick labels
appear at the bottom and on the left.}
\item{rotx, roty}{rotation angles for the horizontal and vertical tick marks,
respectively. Default is 0.}
\item{grid}{if \code{TRUE}, add grid lines to the plot. Default is FALSE.}
\item{layout}{the \code{layout} argument to the \pkg{lattice} function \code{\link{xyplot}}
(or, in some cases \code{\link{densityplot}}), which
is used to draw the effect display; if not specified, the plot will be formatted so that
it appears on a single page.}
\item{key.args}{additional arguments to be passed to the \code{key} trellis argument to
\code{\link{xyplot}} or \code{\link{densityplot}},
e.g., to position the key (legend) in the plotting region; may also be used to modify
the default behavior of the key.}
\item{row, col, nrow, ncol, more}{These arguments are used to graph an effect as part of an
array of plots; \code{row}, \code{col}, \code{nrow}, and \code{ncol} are used to compose
the \code{split} argument and \code{more} the \code{more} argument to \code{\link{print.trellis}}.
Normally these arguments are not set by the user, but by \code{plot.efflist}.
\bold{Warning:} Note that \code{col} is \emph{not} used to specify colors;
use \code{colors} instead (see above).}
\item{selection}{the optional index (number) or quoted name of the effect in an effect
list to be plotted; if not supplied, a menu of high-order terms is presented or all effects
are plotted.}
\item{rows, cols}{Number of rows and columns in the ``meta-array'' of plots produced for an \code{efflist} object;
if either argument is missing, then the meta-layout will be computed by the \code{plot} method.}
\item{ask}{if \code{selection} is not supplied and \code{ask} is \code{TRUE},
a menu of high-order terms is presented; if \code{ask} is \code{FALSE} (the default), effects for all
high-order terms are plotted in an array.}
\item{graphics}{if \code{TRUE} (the default), then the menu of terms to plot is presented
in a dialog box rather than as a text menu.}
\item{use.splines}{If \code{TRUE}, the default, then any lines drawn when the horizontal
axis is not a factor use interpolating splines computed by the \code{\link{spline}}
function. If FALSE, then linear interpoliation is used. This argument is ignored if
the horizontal axis is a factor.}
\item{partial.residuals}{use \code{"adjusted"} partial residuals, computed at the panel-rounded
values of the focal predictors not on the horizontal axis of each panel, or \code{"raw"}
partial residuals, computed at the actual values of all focal predictors; the default is
\code{"adjusted"}, and this argument is effective only when partial residuals are included
in the effect object to be plotted --- see \code{\link{Effect}}.}
\item{smooth.residuals}{whether to show a \code{\link{loess}} smooth of the partial residuals, if
they are present; the default is \code{TRUE}. For a non-Gaussian \code{glm} model,
a non-robust \code{loess} smooth is used; for a \code{lm} model or a Gaussian \code{glm} model,
a robust smooth is employed.}
\item{span}{of the \code{\link{xyplot}} smoother to be applied to partial residuals;
the default is \code{2/3}.}
\item{show.fitted}{if partial residuals are present in the effect object, also plot the partial
fitted values (which will be shown as filled circles).}
\item{residuals.color}{color for plotting partial residuals (default \code{"blue"}).}
\item{residuals.smooth.color}{color for plotting the smooth of the partial residuals; the default is the \code{residuals.color}.}
\item{residuals.pch}{plotting symbol for partial residuals (default \code{1}, open circles).}
\item{residuals.cex}{character expansion (relative size) for symbols plotting partial residuals (default is \code{1}).}
\item{bg}{if a single numeric value (the default is \code{3}), the color of the strips at the tops
of lattice panels are set to gray scale, with the number of graditions, if there is more than one
conditioning variable, corresponding to the value given (which will be rounded to a whole number).
This argument can also be a vector of colors, specified in any manner recognized in R (e.g, by name).}
\item{fg}{foreground color or colors for the strips at the top of lattice panels (the default is
\code{"black"}); can be a single value or a vector of values of the same length as \code{bg}.}
\item{clip}{\code{"off"} or \code{"on"}, determines whether or not conditioning values in the strips
at the top of lattice panels are clipped on the left and right. The normal lattice default is
\code{"on"}; the default in \code{setStrip} is \code{"off"}, allowing the lines representing numeric
conditioning values to be displayed more clearly at the extreme left and right of strips.}
\item{saved}{a set of lattice strip specifications returned by \code{setStrip}.}
\item{...}{arguments to be passed down.}
}
\details{
In a generalized linear model, by default, the \code{print} and \code{summary} methods for
\code{eff} objects print the computed effects on the scale of the
response variable using the inverse of the
link function. In a logit model, for example, this means that the effects are expressed on the probability
scale.
By default, effects in a GLM are plotted on the scale of the linear predictor, but the vertical
axis is labelled on the response scale. This preserves the linear structure of the model while permitting
interpretation on what is usually a more familiar scale.
This approach may also be used with linear models, for example to display effects on the scale of the
response even if the data are analyzed on a transformed scale, such as log or square-root.
When a factor is on the x-axis, the \code{plot} method for \code{eff} objects
connects the points representing the effect by line segments, creating a
response ``profile.'' If you wish to suppress these lines, add the argument
\code{lty=0} to the call to \code{plot} (see the examples).
In a polytomous (multinomial or proportional-odds) logit model, by default effects are plotted on the
probability scale; they may be alternatively plotted on the scale of the individual-level logits.
The \code{setStrip} and \code{restoreStrip} functions modify the strips that appear in subsequent
lattice plots, including those produced by functions in the \pkg{effects} package. The default call
\code{setStrip()} provides monochrome (rather than the lattice-default colored) strips with up to 3
gray-scale values corresponding to 3 conditioning variables; clipping at the left and right of strips
is also turned off by default by \code{setStrip}. \code{restoreStrip} may be used to reset
lattice strips to previously saved parameters returned by \code{setStrip}.
}
\value{
The \code{summary} method for \code{"eff"} objects returns a \code{"summary.eff"} object with the following components
(those pertaining to confidence limits need not be present):
\item{header}{a character string to label the effect.}
\item{effect}{an array containing the estimated effect.}
\item{lower.header}{a character string to label the lower confidence limits.}
\item{lower}{an array containing the lower confidence limits.}
\item{upper.header}{a character string to label the upper confidence limits.}
\item{upper}{an array containing the upper confidence limits.}
The \code{setStrip} function invisibly returns a list that can supply the argument of the
\code{restoreStrip} function to restore the previous lattice strip specification.
The \code{[} method for \code{"efflist"} objects is used to subset an \code{"efflist"} object and returns an object of the same class.
}
\author{John Fox \email{jfox@mcmaster.ca} and Jangman Hong.}
\seealso{\code{\link{effect}}, \code{\link{allEffects}}, \code{\link{xyplot}},
\code{\link{densityplot}}, \code{\link{print.trellis}}, \code{\link{loess}},
\code{\link[colorspace]{rainbow_hcl}}, \code{\link[colorspace:rainbow_hcl]{sequential_hcl}}}
\examples{
# also see examples in ?effect
mod.cowles <- glm(volunteer ~ sex + neuroticism*extraversion,
data=Cowles, family=binomial)
eff.cowles <- allEffects(mod.cowles, xlevels=list(extraversion=seq(0, 24, 6)))
eff.cowles
as.data.frame(eff.cowles[[2]]) # neuroticism*extraversion interaction
plot(eff.cowles, 'sex', ylab="Prob(Volunteer)", grid=TRUE, rotx=90, lty=0)
.save.strip <- setStrip()
plot(eff.cowles, 'neuroticism:extraversion', ylab="Prob(Volunteer)",
ticks=list(at=c(.1,.25,.5,.75,.9)))
\donttest{
# change color of the confidence bands to 'black' with .15 transparency
plot(eff.cowles, 'neuroticism:extraversion', ylab="Prob(Volunteer)",
ticks=list(at=c(.1,.25,.5,.75,.9)), band.colors="red", band.transparency=.3)
plot(eff.cowles, 'neuroticism:extraversion', multiline=TRUE,
ylab="Prob(Volunteer)", key.args = list(x = 0.75, y = 0.75, corner = c(0, 0)))
# use probability scale in place of logit scale, all lines are black.
plot(eff.cowles, 'neuroticism:extraversion', multiline=TRUE,
ylab="Prob(Volunteer)", key.args = list(x = 0.75, y = 0.75, corner = c(0, 0)),
colors="black", lines=1:8,
ci.style="bands", type="response", band.colors=palette())
plot(effect('sex:neuroticism:extraversion', mod.cowles,
xlevels=list(extraversion=seq(0, 24, 6))), multiline=TRUE)
plot(effect('sex:neuroticism:extraversion', mod.cowles,
xlevels=list(extraversion=seq(0, 24, 6))), multiline=TRUE,
type="response", ci.style="bands")
}
if (require(nnet)){
mod.beps <- multinom(vote ~ age + gender + economic.cond.national +
economic.cond.household + Blair + Hague + Kennedy +
Europe*political.knowledge, data=BEPS)
\donttest{
plot(effect("Europe*political.knowledge", mod.beps,
xlevels=list(political.knowledge=0:3)))
}
plot(effect("Europe*political.knowledge", mod.beps,
xlevels=list(political.knowledge=0:3),
given.values=c(gendermale=0.5)),
style="stacked", colors=c("blue", "red", "orange"), rug=FALSE)
}
if (require(MASS)){
mod.wvs <- polr(poverty ~ gender + religion + degree + country*poly(age,3),
data=WVS)
plot(effect("country*poly(age, 3)", mod.wvs))
\donttest{
plot(effect("country*poly(age, 3)", mod.wvs), style="stacked",
colors=c("gray75", "gray50", "gray25"))
plot(effect("country*poly(age, 3)", latent=TRUE, mod.wvs))
}
}
mod.pres <- lm(prestige ~ log(income, 10) + poly(education, 3) + poly(women, 2),
data=Prestige)
eff.pres <- allEffects(mod.pres, default.levels=50)
\donttest{
plot(eff.pres)
plot(eff.pres[1:2])
}
plot(eff.pres[1],
transform.x=list(income=list(trans=log10, inverse=function(x) 10^x)),
ticks.x=list(income=list(at=c(1000, 2000, 5000, 10000, 20000))))
restoreStrip(.save.strip)
remove(.save.strip)
}
\keyword{hplot}
\keyword{models}
effects/man/BEPS.Rd 0000644 0001762 0000144 00000003701 12441350057 013466 0 ustar ligges users \name{BEPS}
\alias{BEPS}
\docType{data}
\title{British Election Panel Study}
\description{
These data are drawn from the 1997-2001 British Election Panel Study (BEPS).
}
\usage{BEPS}
\format{
A data frame with 1525 observations on the following 10 variables.
\describe{
\item{\code{vote}}{Party choice: \code{Conservative}, \code{Labour}, or \code{Liberal Democrat}}
\item{\code{age}}{in years}
\item{\code{economic.cond.national}}{Assessment of current national economic conditions, 1 to 5.}
\item{\code{economic.cond.household}}{Assessment of current household economic conditions, 1 to 5.}
\item{\code{Blair}}{Assessment of the Labour leader, 1 to 5.}
\item{\code{Hague}}{Assessment of the Conservative leader, 1 to 5.}
\item{\code{Kennedy}}{Assessment of the leader of the Liberal Democrats, 1 to 5.}
\item{\code{Europe}}{an 11-point scale that measures respondents' attitudes
toward European integration. High scores represent `Eurosceptic'
sentiment.}
\item{\code{political.knowledge}}{Knowledge of parties' positions on European integration, 0 to 3.}
\item{\code{gender}}{\code{female} or \code{male}.}
}
}
\references{
J. Fox and R. Andersen (2006)
Effect displays for multinomial and proportional-odds logit models.
\emph{Sociological Methodology} \bold{36}, 225--255.
}
\examples{
summary(BEPS)
\donttest{
if (require(splines) && require(nnet)){ # for bs() and multinom()
beps <- multinom(vote ~ age + gender + economic.cond.national + economic.cond.household
+ Blair + Hague + Kennedy + bs(Europe, 3)*political.knowledge, data=BEPS)
europe.knowledge <- effect("bs(Europe, 3)*political.knowledge", beps,
xlevels=list(Europe=seq(1, 11, length=50), political.knowledge=0:3),
given.values=c(gendermale=0.5))
plot(europe.knowledge)
plot(europe.knowledge, style="stacked", colors=c("blue", "red", "orange"), rug=FALSE)
}
}
}
\keyword{datasets}
effects/man/Wells.Rd 0000644 0001762 0000144 00000003276 11163026512 014026 0 ustar ligges users \name{Wells}
\alias{Wells}
\docType{data}
\title{Well Switching in Bangladesh}
\description{
Data on whether or not households in Bangladesh changed the wells that
they were using.
}
\usage{Wells}
\format{
A data frame with 3020 observations on the following 5 variables.
\describe{
\item{\code{switch}}{whether or not the household switched to
another well from an unsafe well: \code{no} or \code{yes}.}
\item{\code{arsenic}}{the level of arsenic contamination in the
household's original well, in hundreds of micrograms per liter; all
are above 0.5, which was the level identified as ``safe''.}
\item{\code{distance}}{in meters to the closest known safe well.}
\item{\code{education}}{in years of the head of the household.}
\item{\code{association}}{whether or not any members of the household
participated in any community organizations: \code{no} or \code{yes}.}
}
}
\details{
The data are for an area of Arahazar upazila, Bangladesh.
The researchers labelled each well with its level of arsenic and an
indication of whether the well was ``safe'' or ``unsafe.'' Those using unsafe
wells were encouraged to switch. After several years, it was determined
whether each household using an unsafe well had changed its well.
These data are used by Gelman and Hill (2007) for a logistic-regression example.
}
\source{
\url{http://www.stat.columbia.edu/~gelman/arm/examples/arsenic/wells.dat}.
}
\references{
A. Gelman and J. Hill (2007)
\emph{Data Analysis Using Regression and Multilevel/Hierarchical Models.}
Cambridge: Cambridge University Press.
}
\examples{
summary(Wells)
}
\keyword{datasets}
effects/man/effects-deprecated.Rd 0000644 0001762 0000144 00000001001 11074677173 016455 0 ustar ligges users \name{effects-deprecated}
\alias{effects-deprecated}
\alias{all.effects}
\title{Deprecated Function in effects Package}
\description{
The \code{all.effects} function is provided only for compatibility with older versions of the effects package
and may be removed; use \code{\link{allEffects}} instead.
}
\usage{
all.effects(...)
}
\arguments{
\item{...}{arguments to be passed to \code{allEffects}.}
}
\author{John Fox \email{jfox@mcmaster.ca}.}
\seealso{\code{\link{allEffects}}}
effects/man/Prestige.Rd 0000644 0001762 0000144 00000002610 11065527636 014527 0 ustar ligges users \name{Prestige}
\alias{Prestige}
\docType{data}
\title{Prestige of Canadian Occupations}
\description{
The \code{Prestige} data frame has 102 rows and 6 columns.
The observations are occupations.
}
\format{
This data frame contains the following columns:
\describe{
\item{education}{
Average education (years) of occupational incumbents, in 1971.
}
\item{income}{
Average income (dollars) of incumbents, 1971.
}
\item{women}{
Percentage of incumbents who are women, 1971.
}
\item{prestige}{
Pineo-Porter prestige score for occupation, from a social survey
conducted in the mid-1960s.
}
\item{census}{
Canadian Census occupational code.
}
\item{type}{
Type of occupation.
A factor with levels (note: out of order):
\code{bc}, Blue Collar;
\code{prof}, Professional, Managerial, and Technical;
\code{wc}, White Collar.
}
}
}
\source{
Canada (1971)
\emph{Census of Canada}. Vol. 3, Part 6. Statistics Canada [pp. 19-1--19-21].
Personal communication from B. Blishen, W. Carroll, and
C. Moore, Departments of Sociology, York University and
University of Victoria.
}
\references{
Fox, J. (1997)
\emph{Applied Regression, Linear Models, and Related Methods.} Sage.
}
\usage{
Prestige
}
\keyword{datasets}
effects/man/Arrests.Rd 0000644 0001762 0000144 00000002577 11162233541 014367 0 ustar ligges users \name{Arrests}
\alias{Arrests}
\docType{data}
\title{Arrests for Marijuana Possession}
\description{
Data on police treatment of individuals arrested in
Toronto for simple possession of small quantities of marijuana. The data are part of a larger
data set featured in a series of articles in the Toronto Star newspaper.
}
\usage{Arrests}
\format{
A data frame with 5226 observations on the following 8 variables.
\describe{
\item{released}{Whether or not the arrestee was released with a summons;
a factor with levels:
\code{No};
\code{Yes}. }
\item{colour}{The arrestee's race; a factor with levels:
\code{Black};
\code{White}. }
\item{year}{1997 through 2002; a numeric vector.}
\item{age}{in years; a numeric vector.}
\item{sex}{a factor with levels:
\code{Female};
\code{Male}. }
\item{employed}{a factor with levels:
\code{No};
\code{Yes}. }
\item{citizen}{a factor with levels:
\code{No};
\code{Yes}. }
\item{checks}{Number of police data bases (of previous
arrests, previous convictions, parole status, etc. -- 6 in all) on which
the arrestee's name appeared; a numeric vector}
}
}
\source{
Personal communication from Michael Friendly, York University.
}
\examples{
summary(Arrests)
}
\keyword{datasets}
effects/man/WVS.Rd 0000644 0001762 0000144 00000003170 12441350057 013414 0 ustar ligges users \name{WVS}
\alias{WVS}
\docType{data}
\title{World Values Surveys}
\description{
Data from the World Values Surveys 1995-1997 for Australia, Norway, Sweden, and the United States.
}
\usage{WVS}
\format{
A data frame with 5381 observations on the following 6 variables.
\describe{
\item{\code{poverty}}{``Do you think that what the government is doing for people in poverty in
this country is about the right amount, too much, or too little?'' (ordered):
\code{Too Little}, \code{About Right}, \code{Too Much}}.
\item{\code{religion}}{Member of a religion: \code{no} or \code{yes}.}
\item{\code{degree}}{Held a university degree: \code{no} or \code{yes}.}
\item{\code{country}}{\code{Australia}, \code{Norway}, \code{Sweden}, or \code{USA}.}
\item{\code{age}}{in years.}
\item{\code{gender}}{\code{male} or \code{female}.}
}
}
\references{
J. Fox and R. Andersen (2006)
Effect displays for multinomial and proportional-odds logit models.
\emph{Sociological Methodology} \bold{36}, 225--255.
}
\examples{
summary(WVS)
\donttest{
if (require(splines) && require(MASS)){ # for bs()
wvs <- polr(poverty ~ gender + country*(religion + degree + bs(age, 4)), data=WVS)
plot(effect("country*bs(age,4)", wvs, xlevels=list(age=18:83),
given.values=c(gendermale=0.5)), rug=FALSE)
plot(effect("country*bs(age,4)", wvs, xlevels=list(age=18:83),
given.values=c(gendermale=0.5)), rug=FALSE, style="stacked")
plot(effect("country*bs(age,4)", wvs, xlevels=list(age=18:83),
given.values=c(gendermale=0.5), latent=TRUE), rug=FALSE)
}
}
}
\keyword{datasets}
effects/man/Hartnagel.Rd 0000644 0001762 0000144 00000003340 11507364001 014635 0 ustar ligges users \name{Hartnagel}
\alias{Hartnagel}
\docType{data}
\title{Canadian Crime-Rates Time Series}
\description{
The \code{Hartnagel} data frame has 38 rows and 7 columns.
The data are an annual time-series from 1931 to 1968. There are
some missing data.
}
\format{
This data frame contains the following columns:
\describe{
\item{year}{
1931--1968.
}
\item{tfr}{
Total fertility rate per 1000 women.
}
\item{partic}{
Women's labor-force participation rate per 1000.
}
\item{degrees}{
Women's post-secondary degree rate per 10,000.
}
\item{fconvict}{
Female indictable-offense conviction rate per 100,000.
}
\item{ftheft}{
Female theft conviction rate per 100,000.
}
\item{mconvict}{
Male indictable-offense conviction rate per 100,000.
}
\item{mtheft}{
Male theft conviction rate per 100,000.
}
}
}
\details{
The post-1948 crime rates have been adjusted to account for
a difference in method of recording. Some of your results will differ
in the last decimal place from those in Table 14.1 of Fox (1997) due
to rounding of the data. Missing values for 1950 were interpolated.
}
\source{
Personal communication from T. Hartnagel,
Department of Sociology, University of Alberta.
}
\references{
Fox, J., and Hartnagel, T. F (1979)
Changing social roles and female crime in Canada:
A time series analysis.
\emph{Canadian Review of Sociology and Anthroplogy},
\bold{16}, 96--104.
Fox, J. (2008)
\emph{Applied Regression Analysis and Generalized Linear Models},
Second Edition. Sage.
}
\usage{
Hartnagel
}
\keyword{datasets}
effects/man/Titanic.Rd 0000644 0001762 0000144 00000003243 12216200646 014327 0 ustar ligges users \name{TitanicSurvival}
\alias{TitanicSurvival}
\docType{data}
\title{Survival of Passengers on the Titanic}
\description{
Information on the survival status, sex, age, and passenger class of 1309
passengers in the Titanic disaster of 1912.
}
\usage{TitanicSurvival}
\format{
A data frame with 1309 observations on the following 4 variables.
\describe{
\item{\code{survived}}{\code{no} or \code{yes}.}
\item{\code{sex}}{\code{female} or \code{male}}
\item{\code{age}}{in years (and for some children, fractions of a year); age
is missing for 263 of the passengers.}
\item{\code{passengerClass}}{\code{1st}, \code{2nd}, or \code{3rd} class.}
}
}
\details{
This is part of a larger data set compiled by Thomas Cason.
Many additional details are given in the sources cited below.
}
\source{
Data set \code{titanic3} from
\url{http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/DataSets}.
}
\references{
\url{http://www.encyclopedia-titanica.org/}
F. E. Harrell, Jr. (2001)
\emph{Regression Modeling Strategies}
New York: Springer.
}
\examples{
summary(TitanicSurvival)
titanic <- glm(survived ~ (passengerClass + sex + age)^2,
data=TitanicSurvival, family=binomial)
titanic.all <- allEffects(titanic, typical=median,
given.values=c(passengerClass2nd=1/3, passengerClass3rd=1/3, sexmale=0.5))
plot(titanic.all, ticks=list(at=c(.01, .05, seq(.1, .9, by=.2), .95, .99)),
ask=FALSE)
plot(effect("passengerClass*sex*age", titanic, xlevels=list(age=0:65)),
ticks=list(at=c(.001, .005, .01, .05, seq(.1, .9, by=.2), .95, .99, .995)))
}
\keyword{datasets}
effects/man/effects-package.Rd 0000644 0001762 0000144 00000005435 12633371321 015753 0 ustar ligges users \name{effects-package}
\Rdversion{1.1}
\alias{effects-package}
\alias{effects}
\docType{package}
\title{
Effect Displays for Linear, Generalized Linear, and Other Models
}
\description{
Graphical and tabular effect displays, e.g., of interactions, for linear (including fit via \code{\link[nlme]{gls}}), multivariate-linear,
generalized linear, multinomial-logit, proportional-odds logit,
mixed-effect, polytomous latent-class, and some other models; (multidimensional) component+residual plots for linear and generalized linear models.
}
\details{
\tabular{ll}{
Package: \tab effects\cr
Version: \tab 3.0-5\cr
Date: \tab 2015/12/13\cr
Suggests: \tab pbkrtest (>= 0.4-4), nlme, MASS, poLCA, heplots, splines\cr
Imports: \tab lme4, nnet, lattice, grid, colorspace, graphics, grDevices, stats, utils\cr
LazyLoad: \tab yes\cr
LazyData: \tab yes\cr
License: \tab GPL (>= 2)\cr
URL: \tab http://www.r-project.org, http://socserv.socsci.mcmaster.ca/jfox/\cr
}
This package creates effect displays for various kinds of models, as partly explained in the references.
Typical usage is \code{plot(allEffects(model))},
where \code{model} is an appropriate fitted-model object.
Additional arguments to \code{allEffects} and \code{plot} can be used to customize the resulting
displays. The function \code{effect} can be employed to produce an effect display for a
particular term in the model, or to which terms in the model are marginal. The function \code{Effect}
may similarly be used to produce an effect display for any combination of predictors. For linear and
generalized linear models it is also possible to plot partial residuals to obtain (multidimensional)
component+residual plots.
See \code{?effect}, \code{?Effect}, and \code{?plot.eff} for details.
}
\author{
John Fox , Sanford Weisberg, Michael Friendly, and Jangman Hong.
We are grateful to Robert Andersen, David Firth, and for various suggestions.
Maintainer: John Fox
}
\references{
Fox, J. (1987)
Effect displays for generalized linear models.
\emph{Sociological Methodology}
\bold{17}, 347--361.
Fox, J. (2003)
Effect displays in R for generalised linear models.
\emph{Journal of Statistical Software}
\bold{8:15}, 1--27, <\url{http://www.jstatsoft.org/v08/i15/}>.
Fox, J. and R. Andersen (2006)
Effect displays for multinomial and proportional-odds logit models.
\emph{Sociological Methodology}
\bold{36}, 225--255.
Fox, J. and J. Hong (2009).
Effect displays in R for multinomial and proportional-odds logit models:
Extensions to the effects package.
\emph{Journal of Statistical Software}
\bold{32:1}, 1--24, <\url{http://www.jstatsoft.org/v32/i01/}>.
}
\keyword{ package }
effects/man/Cowles.Rd 0000644 0001762 0000144 00000001561 11162233541 014170 0 ustar ligges users \name{Cowles}
\alias{Cowles}
\docType{data}
\title{Cowles and Davis's Data on Volunteering}
\usage{Cowles}
\description{
The \code{Cowles} data frame has 1421 rows and 4 columns.
These data come from a study of the personality determinants
of volunteering for psychological research.
}
\format{
This data frame contains the following columns:
\describe{
\item{neuroticism}{scale from Eysenck personality inventory.}
\item{extraversion}{scale from Eysenck personality inventory.}
\item{sex}{a factor with levels: \code{female}; \code{male.}}
\item{volunteer}{volunteeing, a factor with levels: \code{no}; \code{yes}.}
}
}
\source{
Cowles, M. and C. Davis (1987)
The subject matter of psychology: Volunteers.
\emph{British Journal of Social Psychology} \bold{26}, 97--102.
}
\examples{
summary(Cowles)
}
\keyword{datasets}
effects/man/effect.Rd 0000644 0001762 0000144 00000073541 12511301532 014172 0 ustar ligges users \name{effect}
\alias{effect}
\alias{Effect}
\alias{Effect.default}
\alias{Effect.lm}
\alias{Effect.mer}
\alias{Effect.merMod}
\alias{Effect.lme}
\alias{Effect.gls}
\alias{Effect.multinom}
\alias{Effect.polr}
\alias{Effect.poLCA}
\alias{Effect.clm2}
\alias{Effect.mlm}
\alias{allEffects}
\alias{as.data.frame.eff}
\alias{as.data.frame.effpoly}
\alias{as.data.frame.efflatent}
\alias{vcov.eff}
\title{Functions For Constructing Effect Plots}
\description{
\code{effect} and \code{Effect} construct an \code{"eff"} object for a term (usually a high-order term)
in a linear (fit by \code{lm} or \code{gls}) or generalized linear model (fit by \code{glm}), or an
\code{"effpoly"} object for a term in a
multinomial or proportional-odds logit model (fit respectively by \code{multinom} or \code{polr}),
absorbing the lower-order terms marginal
to the term in question, and averaging over other terms in the model. For multivariate linear models
(\code{mlm}), the function constructs a list of \code{"eff"} objects separately for the various
response variables.
\code{effect} builds the required object by specifying explicity a focal term like \code{"a:b"}
for an \code{a} by \code{b} interaction. \code{Effect} requires specifying a the components of
the term, for example \code{c("a", "b")} rather than the term itself. \code{Effect} is consequently
more flexible and robust than
\code{effect}, and will work with some models for which \code{effect} fails, such as models with
nested terms (see the examples). The \code{effect} function
works by constructing a call to \code{Effect}.
The function can also be used with some mixed-effects models, including linear and generalized linear model
fits from \code{lmer} and \code{glmer} from the \pkg{lme4} package
and \code{lme} from the \pkg{nlme} package; ordinal logistic mixed effects fit with \code{clmm2} from the
\pkg{ordinal} package, and polytomous latent-class models fit by the \code{poLCA} function in
the \pkg{poLCA} package. The analysis in mixed effects is for the fixed effects only, not for random effects.
There is a default
method for \code{Effect} that should work with any model object that has a linear predictor and responds
to the \code{\link{coef}}, \code{\link{model.frame}}, \code{\link{formula}}, and \code{\link{vcov}} functions.
\code{allEffects} identifies all of the high-order terms in a model and returns
a list of \code{"eff"} or \code{"effpoly"} objects (i.e., an object of type \code{"efflist"}).
}
\usage{
effect(term, mod, vcov.=vcov, ...)
Effect(focal.predictors, mod, ...)
\method{Effect}{lm}(focal.predictors, mod, xlevels = list(), default.levels = NULL, given.values,
vcov.=vcov, se = TRUE, confidence.level = 0.95,
transformation = list(link = family(mod)$linkfun, inverse = family(mod)$linkinv),
typical = mean, offset = mean,
partial.residuals=FALSE, quantiles=seq(0.2, 0.8, by=0.2),
x.var=NULL, ...)
\method{Effect}{gls}(focal.predictors, mod, xlevels = list(), default.levels=NULL,
given.values, vcov.=vcov, se = TRUE, confidence.level = 0.95, transformation = NULL,
typical = mean, ...)
\method{Effect}{multinom}(focal.predictors, mod,
confidence.level=.95, xlevels=list(), default.levels=NULL,
given.values, vcov.=vcov, se=TRUE, typical=mean, ...)
\method{Effect}{polr}(focal.predictors, mod,
confidence.level=.95, xlevels=list(), default.levels=NULL,
given.values, vcov.=vcov, se=TRUE, typical=mean, latent=FALSE, ...)
\method{Effect}{clm2}(focal.predictors, mod, ...)
\method{Effect}{mer}(focal.predictors, mod,
KR=FALSE, ...)
\method{Effect}{merMod}(focal.predictors, mod,
KR=FALSE, ...)
\method{Effect}{lme}(focal.predictors, mod, ...)
\method{Effect}{poLCA}(focal.predictors, mod, ...)
\method{Effect}{mlm}(focal.predictors, mod, response, ...)
\method{Effect}{default}(focal.predictors, mod, xlevels = list(),
default.levels = NULL, given.values,
vcov. = vcov, se = TRUE, confidence.level = 0.95,
transformation = list(link = I, inverse = I),
typical = mean, offset = mean, ...)
allEffects(mod, ...)
\method{as.data.frame}{eff}(x, row.names=NULL, optional=TRUE,
transform=x$transformation$inverse, ...)
\method{as.data.frame}{effpoly}(x, row.names=NULL, optional=TRUE, ...)
\method{as.data.frame}{efflatent}(x, row.names=NULL, optional=TRUE, ...)
\method{vcov}{eff}(object, ...)
}
\arguments{
\item{term}{the quoted name of a term, usually, but not necessarily, a high-order
term in the model. The term must be given exactly as it appears in the printed
model, although either colons (\code{:}) or asterisks (\code{*}) may be used
for interactions.}
\item{focal.predictors}{a character vector of one or more predictors in the model.}
\item{mod}{an object of class \code{"lm"}, \code{"gls"}, \code{"glm"},
\code{"multinom"}, \code{"polr"}, \code{"mer"} (or \code{"merMod"}), \code{"lme"}
or \code{"poLCA"}. }
\item{xlevels}{this argument is used to set the number of levels for any
focal predictor that is not a factor. If \code{xlevels=NULL}, the default,
then the number and values of levels for any
numeric predictor is determined by \code{\link{grid.pretty}}. If \code{xlevels=n}
is an integer, then each numeric predictor is represented by \code{n} equally
spaced levels. More generally, \code{xlevels} can be a named list of values
at which to set each numeric predictor. For example, \code{xlevels=list(x1=c(2, 4, 7),
x2=5)} would use the values 2, 4 and 7 for the levels of \code{x1}, 5
equally spaced levels for the levels of \code{x2}, and use the default for
any other numeric predictors. If partial residuals are computed, then the focal
predictor that is to appear on the horizontal axis of an effect plot is
evaluated at 100 equally spaced values along its full range, and, by default,
other numeric predictors are evaluated at the quantiles specified in the
\code{quantiles} argument, unless their values are given explicitly in
\code{xlevels}.}
\item{default.levels}{ignored, but included for compatibility with pre-July 2013
versions of this package. Use \code{xlevels} instead.}
\item{given.values}{a numeric vector of named elements, setting particular
columns of the model matrix to specific values for predictors that are \emph{not}
focal predictors; if specified, this argument takes precedence over the
application of the function given in the \code{typical} argument
(below). Care must be taken in specifying these values --- e.g.,
for a factor, the values of all contrasts should be given and these
should be consistent with each other.}
\item{vcov.}{A function or the name of a function that will be used to get the estimated variance
covariance matrix of the estimated coefficients. This will ordinarily be the default,
\code{vcov}, which will result in the function call \code{vcov(mod)} to get the variance
covariance matrix. You can use the name of any function with \code{mod} as the value of
its first argument that returns an estimated sample covariance matrix, such as the \code{hccm}
function in the \pkg{car} package that returns a heteroscedasticity corrected estimate with
linear models.}
\item{se}{if \code{TRUE}, the default, calculate standard errors and
confidence limits for the effects. For \code{mer}, \code{merMod}, and \code{lme} objects, the
normal distribution is used to get confidence limits.}
\item{confidence.level}{level at which to compute confidence limits
based on the standard-normal distribution; the default is \code{0.95}.}
\item{KR}{if \code{TRUE} and the \pkg{pbkrtest} package is installed,
use the Kenward-Roger coefficient covariance
matrix to compute effect standard errors for linear mixed models fit with \code{lmer}
in the \pkg{lme4} package. The default is \code{FALSE} because the computation can be
very slow.}
\item{transformation}{a two-element list with elements \code{link} and
\code{inverse}. For a generalized linear model, these are by default
the link function and inverse-link (mean) function. For a linear model,
these default to \code{NULL}. If \code{NULL}, the identify function,
\code{I}, is used; this effect can also be achieved by setting the
argument to \code{NULL}. The inverse-link may be used to transform effects
when they are printed or plotted; the link may be used in positioning
axis labels (see below). If the link is not given, an attempt will be
made to approximate it from the inverse-link.}
\item{typical}{a function to be applied to the columns of the model matrix
over which the effect is "averaged"; the default is \code{mean}.}
\item{offset}{a function to be applied to the offset values (if there is an
offset) in a linear or generalized linear model, or a mixed-effects
model fit by \code{lmer} or \code{glmer}; or a numeric value, to which
the offset will be set. The default is the \code{mean} function, and thus
the offset will be set to its mean. \emph{Note:} Only offsets defined
by the \code{offset} argument to \code{lm}, \code{glm}, \code{lmer}, or \code{glmer} will be handled
correctly; use of the \code{offset} function in the model formula is
not supported.}
\item{partial.residuals}{if \code{TRUE}, partial residuals will be computed
for an effect in a linear or generalized linear model; if \code{FALSE}
(the default), partial residuals are suppressed.}
\item{quantiles}{quantiles at which to evaluate numeric focal predictors \emph{not} on the
horizontal axis, used only when partial residuals are displayed; superceded if the \code{xlevels} argument
gives specific values for a predictor.}
\item{x.var}{the name or index of the numeric predictor to define the horizontal axis of an effect
plot for a linear or generalized linear model; the default is \code{NULL}, in which case the first
numeric predictor in the effect will be used \emph{if} partial residuals are to be computed. This argument
is intended to be used when \code{partial.residuals} is \code{TRUE}; otherwise, the variable on the horizontal
axis can be chosen when the effect object is plotted: see \code{\link{plot.eff}}.}
\item{latent}{if \code{TRUE}, effects in a proportional-odds logit model
are computed on the scale of the latent response; if \code{FALSE}
(the default) effects are computed as individual-level probabilities
and logits.}
\item{x}{an object of class \code{"eff"}, \code{"effpoly"}, or \code{"efflatent"}.}
\item{transform}{a transformation to be applied to the effects and confidence limits,
by default taken from the inverse link function saved in the \code{"eff"} object.}
\item{row.names, optional}{not used.}
\item{response}{for an \code{mlm}, a vector containing the name(s) or indices of one or more response variable(s).
The default is to use all responses in the model.}
\item{object}{an object of class \code{"eff"} for which the covariance matrix of the effects is desired.}
\item{...}{arguments to be passed down.}
}
\details{
Normally, the functions to be used directly are \code{allEffects}, to return
a list of high-order effects, and the generic \code{plot} function to plot the effects.
(see \code{\link{plot.efflist}}, \code{\link{plot.eff}}, and \code{\link{plot.effpoly}}).
Alternatively, \code{Effect} can be used to vary a subset of predictors over their ranges,
while other predictors are held to typical values.
Plots are drawn using the \code{\link{xyplot}} (or in some cases,
the \code{\link{densityplot}}) function in the
\code{lattice} package. Effects may also be printed (implicitly or explicitly via
\code{print}) or summarized (using \code{summary})
(see \code{\link{print.efflist}}, \code{\link{summary.efflist}},
\code{\link{print.eff}}, \code{\link{summary.eff}}, \code{\link{print.effpoly}}, and \code{\link{summary.effpoly}}).
If asked, the \code{effect} function will compute effects for terms that have
higher-order relatives in the model, averaging over those terms (which rarely makes sense), or for terms that
do not appear in the model but are higher-order relatives of terms that do.
For example, for the model \code{Y ~ A*B + A*C + B*C}, one could
compute the effect corresponding to the absent term \code{A:B:C}, which absorbs the constant, the
\code{A}, \code{B}, and \code{C} main effects, and the three two-way interactions. In either of these
cases, a warning is printed.
The \code{as.data.frame} methods convert effect objects to data frames to facilitate the construction
of custom displays. In the case of \code{"eff"} objects, the \code{se} element in the data frame is always
on the scale of the linear predictor, and the transformation used for the fit and confidence limits is saved in
a \code{"transformation"} attribute.
}
\value{
For \code{lm}, \code{glm}, \code{mer} and \code{lme}, \code{effect} and \code{Effect} return
an \code{"eff"} object, and for \code{multinom},
\code{polr} and \code{clmm2}, an \code{"effpoly"} object, with the components listed below.
For \code{mlm} with one response specified, an \code{"eff"} object, otherwise a class \code{"efflist"} object,
containing one \code{"eff"} object for each \code{response}.
\item{term}{the term to which the effect pertains.}
\item{formula}{the complete model formula.}
\item{response}{a character string giving the name of the response variable.}
\item{y.levels}{(for \code{"effpoly"} objects) levels of the polytomous response variable.}
\item{variables}{a list with information about each predictor, including
its name, whether it is a factor, and its levels or values.}
\item{fit}{(for \code{"eff"} objects) a one-column matrix of fitted values, representing the effect
on the scale of the linear predictor; this is a ravelled table, representing all
combinations of predictor values.}
\item{prob}{(for \code{"effpoly"} objects) a matrix giving fitted probabilities for the effect
for the various levels of the the response (columns) and combinations of the focal predictors (rows).}
\item{logit}{(for \code{"effpoly"} objects) a matrix giving fitted logits for the effect
for the various levels of the the response (columns) and combinations of the focal predictors (rows).}
\item{x}{a data frame, the columns of which are the predictors in the effect, and the
rows of which give all combinations of values of these predictors.}
\item{model.matrix}{the model matrix from which the effect was calculated.}
\item{data}{a data frame with the data on which the fitted model was based.}
\item{discrepancy}{the percentage discrepancy for the `safe' predictions of the original fit; should be very close to 0.
Note: except for \code{gls} models, this is now necessarily 0.}
\item{offset}{value to which the offset is fixed; \code{0} if there is no offset.}
\item{model}{(for \code{"effpoly"} objects) \code{"multinom"} or \code{"polr"}, as appropriate.}
\item{vcov}{(for \code{"eff"} objects) a covariance matrix for the effect, on the scale of the linear predictor.}
\item{se}{(for \code{"eff"} objects) a vector of standard errors for the effect, on the scale of the linear predictor.}
\item{se.prob, se.logit}{(for \code{"effpoly"} objects) matrices of standard errors for the effect, on the probability and logit scales.}
\item{lower, upper}{(for \code{"eff"} objects) one-column matrices of confidence limits, on the
scale of the linear predictor.}
\item{lower.prob, upper.prob, lower.logit, upper.logit}{(for \code{"effpoly"} objects) matrices of confidence limits
for the fitted logits and probabilities; the latter are computed by transforming
the former.}
\item{confidence.level}{for the confidence limits.}
\item{transformation}{(for \code{"eff"} objects) a two-element list, with element \code{link} giving the
link function, and element \code{inverse} giving the inverse-link (mean) function.}
\item{fitted.rounded}{partial fitted values at the observed values of the predictor \code{x.var} and the values of the
other predictors that appear in the effect display; predictors not in the effect are held constant to typical values.
This and the following two elements are \code{NULL} if partial residuals aren't computed and pertain only to linear
or generalized linear models.}
\item{fitted}{partial fitted values for the observed values of all predictors that appear in the effect display;
predictors not in the effect are held constant to typical values.}
\item{partial.residuals.raw}{partial residuals for the effect computed at the actual values of all focal predictors.}
\item{partial.residuals.adjusted}{partial residuals for the effect computed at the panel-rounded values of focal predictors,
except for the predictor corresponding to \code{xvar}, which will appear on the horizontal axis of the plotted effect.}
\item{x.var}{the name of the predictor to appear on the horizontal axis of an effect plot made from the
returned object; will usually be \code{NULL} if partial residuals aren't computed.}
\item{family}{for a \code{"glm"} model, the name of the distributional family of the model;
for an \code{"lm"} model, this is \code{"gaussian"}; otherwise \code{NULL}. The \code{family} controls
how partial residuals are smoothed in plots.}
\code{effectList} returns a list of \code{"eff"} or \code{"effpoly"} objects
corresponding to the high-order terms of the model.
If \code{mod} is of class \code{poLCA} (from the \code{poLCA} package) to fit a
polytomous latent class model, effects are computed for the predictors given the
estimated latent classes.
The result is of class \code{eff} if the latent class model has 2 categories
and of class \code{effpoly} with more than 2 categories.
}
\section{Warnings and Limitations}{
The \code{Effect} function handles factors and covariates differently, and is likely to be confused if one is changed to the other
in a model formula. Consequently, formulas that include calls to \code{as.factor}, \code{factor}, or \code{numeric}
(as, e.g., in \code{y ~ as.factor(income)}) will cause errors. Instead, create the modified variables outside of the model
formula (e.g., \code{fincome <- as.factor(income)}) and use these in the model formula. Similarly variables of class \code{date} or \code{"times"}, which are usually differences between \code{"dates"} variables, should be converted to numeric variables outside the model formula.
Factors cannot have colons in level names (e.g., \code{"level:A"}); the \code{effect} function will confuse the
colons with interactions; rename levels to remove or replace the colons (e.g., \code{"level.A"}).
In addition, factors cannont be declared on the fly (e.g., using \code{y ~ a + factor(b)}.
The functions in the \pkg{effects} package work properly with predictors that are numeric or factors;
consequently, e.g., convert logical predictors to factors, and dates to numeric.
Empty cells in crossed-factors are now permitted for lm, glm and multinom models.
With multinom models with two or more crossed factors with an empty cell, the 'plot' command with \code{style="stacked"}
apparently does not work because of a bug in the \code{barchart} function in \code{lattice}. However, the default
\code{style="lines"} does work.
Offsets in linear and generalized linear models are supported, as are offsets in mixed models fit by
\code{lmer} or \code{glmer}, but must be supplied through the \code{offset}
argument to \code{lm}, \code{glm}, \code{lmer} or \code{glmer};
offsets supplied via calls to the \code{offset} function on the right-hand side
of the model formula are not supported.
Fitting ordinal mixed-models using \code{clmm2} permits many options, including a variety of link functions,
scale functions, nominal regressors, and various methods for setting thresholds. Effects are currently generated
only for the default values of the arguments \code{scale}, \code{nominal}, \code{link} and \code{threshold}, which is
equivalent to fitting an ordinal response mixed effects model with a logistic link. The effect methods can also be
used with objects created using \code{clm2} fitting ordinal response logistic models with no random effects, with
results similar to those from \code{polr} in the \pkg{MASS} package.
Calling any of these functions from within a user-written function may result in errors due
to R's scoping rules. See the vignette \code{embedding.pdf} for the \pkg{car} package
for a solution to this problem.
}
\references{
Fox, J. (1987).
Effect displays for generalized linear models.
\emph{Sociological Methodology}
\bold{17}, 347--361.
Fox, J. (2003)
Effect displays in R for generalised linear models.
\emph{Journal of Statistical Software}
\bold{8:15}, 1--27, <\url{http://www.jstatsoft.org/v08/i15/}>.
Fox, J. and R. Andersen (2006).
Effect displays for multinomial and proportional-odds logit models.
\emph{Sociological Methodology}
\bold{36}, 225--255.
Fox, J. and J. Hong (2009).
Effect displays in R for multinomial and proportional-odds logit models:
Extensions to the effects package.
\emph{Journal of Statistical Software}
\bold{32:1}, 1--24, <\url{http://www.jstatsoft.org/v32/i01/}>.
Hastie, T. J. (1992).
Generalized additive models.
In Chambers, J. M., and Hastie, T. J. (eds.)
\emph{Statistical Models in S}, Wadsworth.
Weisberg, S. (2014).
\emph{Applied Linear Regression}, 4th edition, Wiley,
\url{http://z.umn.edu/alr4ed}.
}
\author{John Fox \email{jfox@mcmaster.ca}, Sanford Weisberg \email{sandy@umn.edu}
and Jangman Hong.}
\seealso{\code{\link{print.eff}}, \code{\link{summary.eff}}, \code{\link{plot.eff}},
\code{\link{print.summary.eff}},
\code{\link{print.effpoly}}, \code{\link{summary.effpoly}}, \code{\link{plot.effpoly}},
\code{\link{print.efflist}}, \code{\link{summary.efflist}},
\code{\link{plot.efflist}}, \code{\link{xyplot}},
\code{\link{densityplot}}}
\examples{
# Note: Some of these examples are marked as "don't test"
# to reduce the execution times of the examples
# when the package is checked.
mod.cowles <- glm(volunteer ~ sex + neuroticism*extraversion,
data=Cowles, family=binomial)
eff.cowles <- allEffects(mod.cowles, xlevels=list(extraversion=seq(0, 24, 6)),
given.values=c(sexmale=0.5))
eff.cowles
as.data.frame(eff.cowles[[2]])
\donttest{
# the following are equivalent:
eff.ne <- effect("neuroticism*extraversion", mod.cowles)
Eff.ne <- Effect(c("neuroticism", "extraversion"), mod.cowles)
all.equal(eff.ne$fit, Eff.ne$fit)
plot(eff.cowles, 'sex', ylab="Prob(Volunteer)")
plot(eff.cowles, 'neuroticism:extraversion', ylab="Prob(Volunteer)",
ticks=list(at=c(.1,.25,.5,.75,.9)))
plot(eff.cowles, 'neuroticism:extraversion', multiline=TRUE,
ylab="Prob(Volunteer)")
plot(effect('sex:neuroticism:extraversion', mod.cowles,
xlevels=list(extraversion=seq(0, 24, 6))), multiline=TRUE)
}
# a nested model:
mod <- lm(log(prestige) ~ income:type + education, data=Prestige)
# does not work: effect("income:type", mod, transformation=list(link=log, inverse=exp))
plot(Effect(c("income", "type"), mod, transformation=list(link=log, inverse=exp),
ylab="prestige")) # works
if (require(nnet)){
mod.beps <- multinom(vote ~ age + gender + economic.cond.national +
economic.cond.household + Blair + Hague + Kennedy +
Europe*political.knowledge, data=BEPS)
\donttest{
plot(effect("Europe*political.knowledge", mod.beps,
xlevels=list(political.knowledge=0:3)))
}
plot(Effect(c("Europe", "political.knowledge"), mod.beps,
xlevels=list(Europe=1:11, political.knowledge=0:3),
given.values=c(gendermale=0.5)),
style="stacked", colors=c("blue", "red", "orange"), rug=FALSE)
\donttest{
plot(effect("Europe*political.knowledge", mod.beps, # equivalent
xlevels=list(political.knowledge=0:3),
given.values=c(gendermale=0.5)),
style="stacked", colors=c("blue", "red", "orange"), rug=FALSE)
}
}
if (require(MASS)){
mod.wvs <- polr(poverty ~ gender + religion + degree + country*poly(age,3),
data=WVS)
\donttest{
plot(effect("country*poly(age, 3)", mod.wvs))
}
plot(Effect(c("country", "age"), mod.wvs), style="stacked")
\donttest{
plot(effect("country*poly(age, 3)", mod.wvs), style="stacked") # equivalent
plot(effect("country*poly(age, 3)", latent=TRUE, mod.wvs))
}
}
mod.pres <- lm(prestige ~ log(income, 10) + poly(education, 3) + poly(women, 2),
data=Prestige)
eff.pres <- allEffects(mod.pres, xlevels=50)
plot(eff.pres)
plot(eff.pres[1],
transform.x=list(income=list(trans=log10, inverse=function(x) 10^x)),
ticks.x=list(income=list(at=c(1000, 2000, 5000, 10000, 20000))))
\donttest{
# linear model with log-response and log-predictor
# to illustrate transforming axes and setting tick labels
mod.pres1 <- lm(log(prestige) ~ log(income) + poly(education, 3) + poly(women, 2),
data=Prestige)
# effect of the log-predictor
eff.log <- Effect("income", mod.pres1)
# effect of the log-predictor transformed to the arithmetic scale
eff.trans <- Effect("income", mod.pres1, transformation=list(link=log, inverse=exp))
#variations:
# y-axis: scale is log, tick labels are log
# x-axis: scale is arithmetic, tick labels are arithmetic
plot(eff.log)
# y-axis: scale is log, tick labels are log
# x-axis: scale is log, tick labels are arithmetic
plot(eff.log, transform.x=list(income=c(trans=log, inverse=exp)),
ticks.x=list(income=list(at=c(1000, 2000, 5000, 10000, 20000))),
xlab="income, log-scale")
# y-axis: scale is log, tick labels are arithmetic
# x-axis: scale is arithmetic, tick labels are arithmetic
plot(eff.trans, ylab="prestige")
# y-axis: scale is arithmetic, tick labels are arithmetic
# x-axis: scale is arithmetic, tick labels are arithmetic
plot(eff.trans, type="response", ylab="prestige")
# y-axis: scale is log, tick labels are arithmetic
# x-axis: scale is log, tick labels are arithmetic
plot(eff.trans, transform.x=list(income=c(trans=log, inverse=exp)),
ticks.x=list(income=list(at=c(1000, 2000, 5000, 10000, 20000))),
xlab="income, log-scale", ylab="prestige, log-scale",
main="Both effect and X in log-scale")
# y-axis: scale is arithmetic, tick labels are airthmetic
# x-axis: scale is log, tick labels are arithmetic
plot(eff.trans, transform.x=list(income=c(trans=log, inverse=exp)),
ticks.x=list(income=list(at=c(1000, 2000, 5000, 10000, 20000))),
type="link",
xlab="income, log-scale", ylab="prestige")
}
if (require(nlme)){ # for gls()
mod.hart <- gls(fconvict ~ mconvict + tfr + partic + degrees, data=Hartnagel,
correlation=corARMA(p=2, q=0), method="ML")
plot(allEffects(mod.hart))
detach(package:nlme)
}
if (require(lme4)){
data(cake, package="lme4")
fm1 <- lmer(angle ~ recipe * temperature + (1|recipe:replicate), cake,
REML = FALSE)
plot(Effect(c("recipe", "temperature"), fm1))
\donttest{
plot(effect("recipe:temperature", fm1), grid=TRUE) # equivalent
}
if (any(grepl("pbkrtest", search()))) detach(package:pbkrtest)
detach(package:lme4)
}
\donttest{
if (require(nlme) && length(find.package("lme4", quiet=TRUE)) > 0){
data(cake, package="lme4")
cake$rep <- with(cake, paste( as.character(recipe), as.character(replicate), sep=""))
fm2 <- lme(angle ~ recipe * temperature, data=cake,
random = ~ 1 | rep, method="ML")
plot(Effect(c("recipe", "temperature"), fm2))
plot(effect("recipe:temperature", fm2), grid=TRUE) # equivalent
}
detach(package:nlme)
}
\donttest{
if (require(poLCA)){
data(election)
f2a <- cbind(MORALG,CARESG,KNOWG,LEADG,DISHONG,INTELG,
MORALB,CARESB,KNOWB,LEADB,DISHONB,INTELB)~PARTY*AGE
nes2a <- poLCA(f2a,election,nclass=3,nrep=5)
plot(Effect(c("PARTY", "AGE"), nes2a), style="stacked")
}
}
# mlm example
if (require(heplots)) {
data(NLSY, package="heplots")
mod <- lm(cbind(read,math) ~ income+educ, data=NLSY)
eff.inc <- Effect("income", mod)
plot(eff.inc)
eff.edu <- Effect("educ", mod)
plot(eff.edu, rug=FALSE, grid=TRUE)
\donttest{
plot(Effect("educ", mod, response="read"))
}
detach(package:heplots)
}
# component + residual plot examples
\donttest{
Prestige$type <- factor(Prestige$type, levels=c("bc", "wc", "prof"))
mod.prestige.1 <- lm(prestige ~ income + education, data=Prestige)
plot(allEffects(mod.prestige.1, partial.residuals=TRUE)) # standard C+R plots
mod.prestige.2 <- lm(prestige ~ type*(income + education), data=Prestige)
plot(allEffects(mod.prestige.2, partial.residuals=TRUE))
mod.prestige.3 <- lm(prestige ~ type + income*education, data=Prestige)
plot(Effect(c("income", "education"), mod.prestige.3, partial.residuals=TRUE),
span=1)
}
# artificial data
set.seed(12345)
x1 <- runif(500, -75, 100)
x2 <- runif(500, -75, 100)
y <- 10 + 5*x1 + 5*x2 + x1^2 + x2^2 + x1*x2 + rnorm(500, 0, 1e3)
Data <- data.frame(y, x1, x2)
mod.1 <- lm(y ~ poly(x1, x2, degree=2, raw=TRUE), data=Data)
# raw=TRUE necessary for safe prediction
mod.2 <- lm(y ~ x1*x2, data=Data)
mod.3 <- lm(y ~ x1 + x2, data=Data)
.save.strip <- setStrip() # change color of lattice strips
plot(Effect(c("x1", "x2"), mod.1, partial.residuals=TRUE)) # correct model
plot(Effect(c("x1", "x2"), mod.2, partial.residuals=TRUE)) # wrong model
plot(Effect(c("x1", "x2"), mod.3, partial.residuals=TRUE)) # wrong model
restoreStrip(.save.strip)
remove(.save.strip)
}
\keyword{hplot}
\keyword{models}