TeachingDemos/0000755000175100001440000000000012657277161013020 5ustar hornikusersTeachingDemos/NAMESPACE0000644000175100001440000000622512657235444014242 0ustar hornikusers export(bct,char2seed,chisq.detail,ci.examp,clipplot,clt.examp,cnvrt.coords, dice,dots,dots2,emp.hpd,faces,faces2,fagan.plot, flip.rgl.coin,gp.close,gp.open,gp.plot,gp.splot,gp.send,hpd, Pvalue.norm.sim,Pvalue.binom.sim,simfun, run.Pvalue.norm.sim,run.Pvalue.binom.sim, lattice.demo,loess.demo,mle.demo, digits, ms.arrows,ms.female,ms.filled.polygon,ms.male,ms.polygon,ms.polygram, ms.sunflowers,ms.image,my.symbols,panel.dice,plot.dice,rgl.coin, rgl.die,plot2script,plotFagan,plotFagan2,plotFagan.old,ms.face, plotFagan2.old,power.examp,updateusr,pairs2, prepanel.dice,put.points.demo,shadowtext, rgl.Map,roc.demo,roll.rgl.die,rotate.cloud,cor.rect.plot, rotate.persp,rotate.wireframe,run.ci.examp,run.cor.examp, run.cor2.examp,run.old.cor.examp,run.old.cor2.examp, run.hist.demo,run.power.examp,run.power.examp.old,slider, sliderv,squishplot,SensSpec.demo,spread.labs, subplot,TkListView,HWidentify,HTKidentify, tkBrush,tree.demo,triplot,vis.binom,vis.boxcox,vis.boxcoxu, vis.boxcox.old, vis.boxcoxu.old, sigma.test, vis.gamma,vis.normal,vis.t,z.test,zoomplot,oldzoomplot, tkexamp,col2grey,col2gray, TkApprox,TkSpline,txtStart,txtStop,txtComment,txtSkip,etxtStart, etxtStop,etxtComment,etxtSkip,etxtPlot,wdtxtStart,wdtxtStop, wdtxtComment,wdtxtSkip,wdtxtPlot,mdtxtStart,mdtxtStop,mdtxtComment, mdtxtSkip,mdtxtPlot, dynIdentify,TkIdentify, Predict.Plot, TkPredict, "%<%", "%<=%", panel.my.symbols, SnowsPenultimateNormalityTest,vis.test,vt.qqnorm,vt.normhist, vt.scatterpermute,vt.tspermute,vt.residpermute,vt.residsim, SnowsCorrectlySizedButOtherwiseUselessTestOfAnything,petals,cal, TkBuildDist,TkBuildDist2) importFrom("grDevices", "chull", "col2rgb", "colors", "dev.copy", "dev.copy2eps", "dev.cur", "dev.new", "dev.off", "getGraphicsEvent", "nclass.Sturges", "png", "recordPlot", "replayPlot", "rgb", "xy.coords") importFrom("graphics", "Axis", "abline", "arrows", "axis", "barplot", "box", "curve", "frame", "grconvertX", "grconvertY", "hist", "image", "layout", "legend", "lines", "locator", "mtext", "pairs", "par", "persp", "plot", "plot.new", "plot.window", "points", "polygon", "rect", "rug", "segments", "strheight", "strwidth", "symbols", "text", "title") importFrom("stats", "approxfun", "coef", "cor", "dbinom", "dchisq", "delete.response", "density", "dexp", "dgamma", "dnorm", "dpois", "dt", "fitted", "get_all_vars", "lm", "loess", "loess.control", "median", "optimize", "pbinom", "pchisq", "pnorm", "predict", "pt", "qchisq", "qgeom", "qnorm", "qqline", "qqnorm", "qqplot", "qt", "quantile", "rbinom", "resid", "rnorm", "runif", "scatter.smooth", "sd", "splinefun", "terms", "var") importFrom("utils", "capture.output", "file_test", "flush.console", "str", "tail", "write.table") S3method(plot, dice) TeachingDemos/NEWS0000644000175100001440000001767712657235444013537 0ustar hornikusersNew in TeachingDemos version 2.10 * Modified z.test so that you can provide a sample mean and sample size instead of the raw data. * Added digits function to compute digits of an integer * Fixed zoomplot to work with R 3.0 * Fixed subplot function to work better in multi frame plots with type='fig'. * Fixed minor (and potentially major) bugs in TkListView New in TeachingDemos version 2.9 * Removed sd.g, limits.g, and stats.g functions that work with the qcc package as they are now included in qcc and don't need to be here any more. * Added functions mdtxtStart, mdtxtStop, mdtxtComment, mdtxtSkip, and mdtxtPlot to create transcript files using MarkDown which can then be converted to common formats (pdf, MS Word, html, etc.) using the pandoc program. * Changed names of plot.rgl.coin and plot.rgl.die to rgl.coin and rgl.die to prevent confusion with S3 methods for plot generic function. * added function cor.rect.plot to demonstrate concept of correlation. * Added USCrimes dataset * Added linesfun argument to my.symbols so that the user can use functions like polygon in place of lines. * Added function simfun to help with creating simulated data sets. * Modified squishplot function to remove missing values in case the entire data is submitted as xlim and ylim. New in TeachingDemos version 2.8 * Changed many functions to no longer use partial match of arguments, this makes the newer versions happy and results in better code. * Internal changes to R2txt.R and gnuplot.R to use an environment rather than a list for storing package local variables, this eliminated the need for "<<-" and unlocking of bindings and makes the code cleaner. * arguments xsize and ysize added to my.symbols to allow setting the size of the symbols using the scale of the x or y variable. * new functions TkBuildDist and TkBuildDist2 to interactively create a (prior) distrbution. * new function cal to plot calendars * new 'animate' option for tkexamp * new function 'petals' to play the petals around the rose game (and demonstrate a simple code obscuration). * fixed bug in subplot when subplotting inside mfrow/mfcol figures. * Added ldsgrowth dataset * Modified subplot and other functions to no longer need cnvrt.coords. * cnvert.coords is now depricated, use grconvertX and grconvertY from the graphics package instead. * Functions identify.Map, identify.polylist, recenter.Map, and project.Map have been removed as there is now better functionality in the sp package. * The state.vbm object has been moved to the maptools package. New in TeachingDemos version 2.7 * new function ms.image for plotting images using my.symbols. * new functions wdtxtStart and friends to insert transcript into MS Word. * function vt.residsim to work with vis.test. * fixed several functions that depend on tcltk but did not load it. * Updated HWidentify and HTKidentify to give more control and clean up after. * Removed exaple in subplot using rimage package since it is not current and potentially causes problems. New in TeachingDemos version 2.6 * function vis.test and friends made available (was present before, but not in the Namespace). * Fixed bug in tkexamp with checkboxes. * Added 'outliers' dataset New in TeachingDemos version 2.5 * New functions HWidentify and HTKidentify to label points being hovered over. * Turned off clipping (par(xpd=TRUE)) inside of my.symbols so that subsequent points are plotted * New function sigma.test for testing a single variance. New in TeachingDemos version 2.4 * The squishplot function now calls plot.new before doing the calculations, fixs a bug when things have not been reset or if fig regions are not all the same size. There is an argument that will turn this off if needed. * New functions Pvalue.norm.sim, Pvalue.binom.sim, run.Pvalue.norm.sim, and run.Pvalue.binom.sim to simulate p-values. * The subplot function can now accept strings such as "topleft" or "bottom" as the x argument (and does the appropriate thing). * New function gp.splot to send surface plot info to gnuplot * Changed the write char commands in the etxtStart family to remove warnings in 2.8.0 * Changed par settings in my.symbols. Old way reset all pars which could cause some plotting in the wrong areas. Now it only resets the pars that it changes. * updated plot2script to use dput rather than deparse which does better line wrapping. Also fixed the problem with the "box" command (though other functions could still have the same problem). * Removed strip.shingle function as it no longer works and its intended purpose has been available in lattice for a while. * tkexamp now has a 'print' option (defaults to FALSE) that will automatically print the results of the function evaluation. This is useful for ggplot2 or lattice graphics that must be printed to be seen. * Function TkPredict for visualizing predicted values from a regression model adjusting for other terms in the model. * New datasets 'evap' and 'stork' * state.vbm updated to spatial polygon data frame. New in TeachingDemos version 2.3 * etxt* functions updated to use rawToChar(as.raw(0)) rather than '\000' * new function TkListView for interactively looking at list structures. * Removed strict dependence on the Tk packages, will only be loaded for functions that use them. * new function updateusr to update usr coordinate system. * new function pairs2 that works like the pairs function, but with 2 matricies and plots the pairwise scatterplots between the matricies. New in TeachingDemos version 2.2 * tkprogress was removed, use tkProgressBar in utils package (by Prof. Ripley) as a better version. * New function spread.labs to spread coordinates out for adding labels to a plot. For TeachingDemos version 2.1 * Removed dependence on rgl and tcltk2 packages New to TeachingDemos version 2.0 * TeachingDemos now has a NAMESPACE so you can access just parts of the package without loading everything. Fewer packages are now loaded with it, so it should load smaller and faster. * Some of the gui demonstrations (e.g. run.cor.examp) were rewritten using the tkrplot package so that the graph shows up in the same window as the controls. Old versions will remain, but with the word "old" inserted into the name. More will change eventually. * Many of the examples sections have replaced \dontrun with if(interactive()) so that the examples can be run using the "examples" function (recommended to use ask=FALSE). * clt.demo function will now allow you to specify parameters of the distributions and the exponential was replaced with a gamma (the defaults match the prior information). * New function "tkexamp" for creating interactive examples/demonstrations of the effect of changing parameter values on a graph. * New functions "dynIdentify" and "TkIdentify" which create a scatterplot, place labels on the points, then allow you to drag the labels to new locations. * New function "col2grey" for getting an idea of how a graph will look if printed or copied to greyscale. * New function "SensSpec.demo" to show how to move from Sensitivity and Specificity to predictive power positive and negative using an intuitive virtual population method rather than the explicit math of Bayes formula. * New functions "TkApprox" and "TkSpline" to interactivly interpolate on graphs and find values, differences, derivatives. * New function "tkprogress" for a popup progress bar window to show you how a loop is progressing. * New functions "txtStart", "etxtStart", etc to create transcript files and script files of your session. Final result is a text file or a text file that can be converted to postscript and others via the enscript program. The later version can include copies of graphs. TeachingDemos/data/0000755000175100001440000000000012657235444013727 5ustar hornikusersTeachingDemos/data/coin.faces.rda0000644000175100001440000000363312657235446016436 0ustar hornikusersuV XSW A `:Z2UJQTEǕeZ)F+AKQ2"J օU%B  Z{ӗ tޗ/9/--9crd8K88-ׄo[v1I D3O&W)Jwŧn (WT.r(?P|w47ޔ+/Z/ګ\y*yf@8v%^;7ne6fڐOKYthw^e-t)<ϢkCe O_ajJ̼;}pM&纬bZdr{T4*3 妞|{ `4^}5-ߏb\wo_h0eT ;ocZ7mQY.zԌ€HۿTb9I~+XLxk~ 78FxXq"5I4Gx\*b*DRȢ~ Jlb}X'ZBhK܃(_޵@\>Hr~=hiYO&~8!ggt$BIin/..1:驷@ if0^?>2֖ +8L<5ßʘGG)7~W;㷝tۗr1Zi{g@B lxkܒhnn؊&c~w A72|tϏWk>kpf09{`8f~% ~t c2lt>heTB]V9P%O[;TR=0:(_ݕG'U]֏0gz5YkQOmjzqjHKI&kіQ54>ڝhUhϗ٥.X;1yZ[c.CC53' \N~\@Gܰs׏m b}*ڽšܞtT]&U ^ţF"M>5B&?TBtzDRd4q4 umf!yN~#¼ˇ :0E><:ؤ(jx `(h%ûG+:A5& ſ.:-gh^z憮u+D܂aOraշ[Cfyڀ&S^I[^Ǝ:-eoN4/?X 2SCvAE mФlzq4 C=дɾ&dOBCT9iXuMu}T?mqҮPR>p©RthdB7 Q,ʞ?ү΀Bȍ: %f9d/Qs;]Ӱ?΂h_'&@L4_V&2Z ZQLXԪv/k1:Ck梡M7)=km۬-tAhޞR{jSFz<Ƴ o;sT8[ rWq~:s&fp+:&,ja]!;S^E3Ţ*T@6y^-u[uAz ݋'?EW"Ϟ8&xcQƪ,] _C^+%uf^z3Cy~-cRsӋ=㇯9gmr?[x|?32Lr#ֳ4 }k TeachingDemos/data/steps.rda0000644000175100001440000004265612657235444015572 0ustar hornikusers]]E[if$%=@@D!XEP˳CQD%EP,zx={&pߙ9Sk3gCOZzR1&4Q~!&6-'nX\c@i(tFx]Fww [[{]雅o~{'> _?$! X#G?&1 \Ÿ'SctCHx,<Oo*Ux6ۅw)S8w >^xO>QDᓄO>Yd; Ixn={O>Ex^SO>M4ӅO>CL3>Kl᳅"| Unw>Gs>O< ]=%|/{ [|#|}+|_ /PBዄ/XbK/TR˄/\r O~(@ ?Hx~EE+~" ?Tӄ?Ma~Å!G ?RӅ?]3?C3?SQ~#+~c'8, ?^ Ol~$$\' ?Y)O<|/J*᫅B/~SFZkHX&4 ?]KD~3%,넯~𳅯^KT9~soAy2/r/ J~_ *jZo:z~ A_$" XQIY%/o~KU[Mۄ_&2 \ۅ&c|zs]7iiu5*v~10b΂%Ǎƴ5cz0h1Ac&p]z ߃}T ˢVc#fe(f3SLXA;ThpY/$.( n $~߰1ݟCX=-0n_ By79s۝h't]=WBX*֭xS`ucO;n&3g&HXݳoG~6|8?4fcc}rG?@;;c格?;6rԃ6:6vݟAmaw߂4wYŠi 1fW2녷0hԘI4ڤ>Cub;ѿyh 1ޝS=`hB'@ ya]LA{>;@Z!}oڰVtNhw ƥWh,H))C}G;q́E>{~c<'~13J(^X@.X^hnHnegVh=hH)(c.M/VXB@XnI @2uzY>RkvC LM9;Tc7@h7X~%=dvNC7 醴z+֓Ù۳ҵ%w;Ƥ=x~ϧ! %ݐ^=,x S1 hs/V7;ZoMUK\:Pv4s7tL㼿}Üh1ke{߁rfu`l`uCОnHO9Ղ:ϩЪlpl<םAd"  ;D=gEnL ({"݂ĘwCStC?'`'daN67iFYfzrD+LEHnP uim;.(u`>OL-\M˥vaȇ"~A9-jʇk5I+yN}Hd:ю;7: jg{ut,wC9D}޵ 8|rZҺLtr9O<}c}}h0JiPƷh{u&ǐi|zk6򜨶r/ P<.*{ns[f8rgi [rkWI֝,.Ϯ}B+Wl[}6EܿZN+G":ڔ2_mG;'ӕnAi#W ~*OwF1[\MsdK`)=bdeRi3tqueʜYƫn?_ٖƧ󴘩22}`Dnޝ筩o|m_նwH^3Jgqc~g3>nH^nϼ?=n#b}nL檝+F>ҥv{]MyMֻ]:[SiUUz7( eNI!̓i ul!8;ߤd=KI}ncGz|Ҵa~ϑNN6r\ZuOϏ%2NU*'Uxmlv\y>/3 *_&`s,6B@ {% wi>n] %0 pAnOlAy "d }~DpQy wр@5M=5zFQ^H:>-h;ܬw?0@CFam 8~Ou_zI?!> wR|QEF˄R[A/cV}Dkܘ|S\Wie|.dz\ :6$ apoeC&7>": OT^`n3 _:M0BP2_#|І$FKT'l`F6&gd!lC1`s"lǓՎF_vljǨߣ6p gz~k'ٮ^Ol~ ; Cߜ(Ϝp~penZ`׷sIO8p(qE*5ĻjF&jNj4Oӻt}ٍyY#~Yqߥ&O |@NnWJp<3Oo5VX\ >\xzzle+ 'k{})xsc`(Wz_y)V1h=pտi-FIk-|zKɝ|wGx]LtAd;/݋+cYqc -??g3mAH>`_Wz{qբv\EYHł}P~s/P̹~ bnq`Eͩ|^޵ء<6s+W[uQ̹'_zZTKOI}Ttk}rن?,:ߧv38Amߩ_+_ƿ;߿VE|yi$?C9^ubo{~7}_t(NpħqT%Pjw8A|ӱSǯէW3?j8OP;^̉K=ּLhN)=<_^|P3ǿ=[jKk8qt-hܼϵ8^)_;צ?7I>=Kw_ByTK|Dr/]*/W2N<] ^.g>]S'4t%z~G-:rUf'珟^ި=]*Ur~o艂z4']D]3诎owE䑗c_۷[[5.^NdƭT_<'2r_N[3w.^gOqG?.9y97}+T_?[K~T~8^(Aߣv毧CH/OdkT#:0ť+V}_Caz_ϿXx 5u_r 7*_OO |חӯv;Pճ+C{ UˏuwE OE?N|վ*wϿďK_4ϟO yE~Kozʙ{/uWO7׳P|xy:-ό?ϣ%zߟrgOW?K=_{9{oە׿?+Ͽ ~j?ULwvU>^f_~.Q)o?/PlWŹ?*O?LG~ܔ/|>]?=<3qo=E?3|?dJ4<|?=_+Y?~Rg9[o%9i^~~fW?~~:ӿw~yzrv}\W{]uv/G_?yzw?}^9dq_LOvyv3廟|)#/辷}w Wo?Қ 5d[ؖ&lU[FFoߎRMل&4 CSf6 MhBДMhB84e!IKЄ&l)4eC7n4aB϶n Q- w',SaClS*|/?(OއSFe<̜\RUq*47R8ppN^AlpE>Hde c%glTVI{%?8ckC:6oXCraj_ aq.zq:e &Mlwf~^jۚT{^2X.:w~o'9@lG}y:VAigg!BC.vj@߂#23d?[|`7f>mwӍ^;bc_dJgtVz-~ ) l[C0ϐѹ]ɓթ4ڔ!hCW$yf=/!CM( :Hwǁw7f o`qvNE<g,wj)C~ |>0mSJgc_<ρg@WoU[ɯItL@yJy }aezFWa,`\?ˇ~h`ug y2GS!W Ey9ϳBxFcmCp/1l|ohGnW/0㧻v˒Mƞc ~<>ƞbL|Ϡ."߭6vf/.6_ޔ_?áEkyvI13nf=йLr|ܔԙOg\(.SO荐gVy߅&\N[ 3fWW_4I3iA:fUq3s띮'}O>;S%~t >juYO Bh7}wS |0?/h]،=S6Ne}2al7ʧӺw) iyy]@손rLKg lAtg |1ʥ[4<7EWo v)6Q;S<+Z<N&ZH;O%ᲁ!V^ʊX/ Rk՞H1~=G9uڵ4+8RE7 =H,}}7؍=) r\H;*JKj3uvxZa<ӎc,9yݼϤn OP~yp6!g|ROS.]d$͞cv oDҿ\|?Z0 9T8oڨ+ ᠥriû/RRƗ9*7]ܙUaPc΄ޖ\Wnt̙K:Vhl3TF|pʬ.E҄5}ewxg)?}`[̯@~-HyI mjPNҮ·iscP6>dzyΕ+L9PQx eT1nw1ukijOl2sQ :'Umlsdo@wҏtqS;ҿ<+řV{U)1ͦ.PKC`3tp=Stw9+e9ӿoSq&~]Eow^׿qgx3^mzh9t|rq}odfe71}fT2瓏AB~o{qm~~orV>I~OT33~gg;3|"ݠva1yU)d 'TJ\^:ϭ S2}N~*gs>|4_ʧ/bzX-+yGN{oOeِޠ2.c glpDGGo2\EF<;I o`)S)iwJfĘy|Nxjq<}۔ϒY;ٵ)9zrr bz+]Ꮬ hQw_~,ƙO?cw<'s;EXj4 6}3q}893v'Yשa!ыs8RQؖ]/[寒<{V߃>LK8ߗbU)J1ߜ6"F}A㊴qogo)Wk2L=ii3Kgz/$zS^6hs˱ږ7v$zdjV! m:2a'Ϙs1eM/dpy%Gu*i39w-NN,QU=ChsѶuR_1N7i AƢWKPBDCm[4֨# G~oT.l3({CC=jmr#7,ox5Fsg9R&G1\G\O]8ŵ;'mh}g 9?@<Vh?v]oMqm-\s\2CB} 1N `9AIs輐ŜM.QDp, J [_|(ŸSg9(~hJk1f-h2ӏ2uC%焍AfR`GBJit:p? ъsBh l/hxth;Nmln_hB+eYFhKtm9̡>{j/@ E%9PW./VدzmudĽ8_"mІ R\1u*(VBYi 1҆kYkA.1FB|'$Oߍ:>e|-VS}~5L >NwCI[2+ܚK;bw;SA VAq({EΣo} \!cp~^|Y|+VMy_ +fu;>s_ltقG;C^J)CcԻ=aǁ6ޓng|3uv΃A?~YoX'ke?q}d澇3r24F.}G9>#cG)f@ZC9˲hs}{CKGrſ?i1Qvy3~PΑtEۼo1شcƷX1nc(} e2+h1|r[;^yfݒ= X_eB>lײ'q#21/(I#=8~tHH$Oq=h+|l,:ŵƗhVO_qq.y ׊[;Ů}];> #C[#Onј$HBe mSRq7^^u82OIa߱!sqtd ύ>63u&VN^O.dhܫ9vk6JHS>'!"*5?F/}1f<1ѿ'~낟gK!}:JI[َ_Lv_AW5foÌb|^O[lD\]'f{ɮf#cNvqnq8wbM,Q̔,_ }Қ/yBcm͎9f@Y g9{[q.=Xt2>C$eX8Y>E'yth?= {(dkKlB2p= W} 𙍗> I9?&fҢϔ*?cI+\=!wA__=qݟ~:}wL2]#utkCDnH9C{4gֱkZJ$ds8a_ bϡStxBT>f_F9Yn(. msq/ iKDB1"õ~>l)+e_ڴQkaY/,9|rH,p6mFf-bi >l6?'PGOڗ덋]Qb1S}PAh`OܟI} zUGW;ng׹YѣL9HhuuC΅w4fc:]lc'p㛘k3ܫʸygpNP4|6}]|g2fdiFI rhcH5Xyk7_4 wPڜkGs3v=klѾ:vO$ݔP?clO3v'Sq?ZW1[LF]ɵorB_7aY'۟;gbLq4S}V^ߋ[!#u#A!5F_(W'_SҖe=v!ߵL}ԭ=(>@=17XWvgGٵVOVQX[x).FrK߹Xbђ4yڰAiDk^I>ʽ_"n19GEH{$vԷ]cN&#p?khGO (7qj]v۴@6-LW/RJ8dzɹJG/'s oO(f;ט(ckrQY~F~2L_ 1mGE{ ޶q8:My;rs[{~5C^z|HkQM?eۧ'ed)YBځWjf9iIyB=K{>њ?k/'q*v%׻3/v:j_hcsJZwy?_c^ciܵ`eC/CbcEGg8(7NY&tiR?W8>W,۔@_.hh+s(3ߞ*r>>^v1^}{m+}Sη>qY֐ / mmnrsո70Fg4;n!9ցlK9?iQԸ̔VK>㷕V1?h꿫W|~ ~ ~ڡ)+Ce>8SqM_4K^.GQ+x /ƮanvP~ W>u4=Ю\tfn0{#߅ O+;2#x7Vq-s_D*auQ\m+MYfB_=~/83^doWgX WʲT 6Bdy dA<{AD-lg\*|<;vuh H'>v6j'Qx7aˍS%K8s6O+>ëcc4+ԋAY 9b3.ktkyu?7\vrVԍٿvO ɽ,;#ssNΈg+W~2#@֝d@S4a_>F L|3,*qSQV)[]v_Qxe.aBeR^s LG;ggal5{fh/оΑD]u eGW^hsK'<^})Jʘ|eқ>2nj;e]1O:Lan_Kj<3j qn1J<>T.uw}_5n0oɬ)G] ]36Arm̊qxHOn]ܜ2ێJH}>?<@X~{c=n[.Yi$8ߔ{SyނִKkx@_?0Qc-*n?+!e-e_/>b,rkoL;Y?26@ƜsH&۳|r]eGsyoT̸_jЃfM:Eb3yfoG+On0e<~t:Pϋ➷l(g"́z4oHvf¶rЋ!"Zϳv*Ġc}7=+̎^Û}~6YhJ:6mOޣ~>Cb)0-O^PZ(CNy#ھErQ1cwOax{fy:/)n3-am[HCَgp{,o1m`9;R _M9)L23(_(s$|}bƏlLS^8p+3*8?oZ~9l/G]5ɂO[&:ltq]_|cR\NޠEo =OjMyA T(LUw9M;oxhAuY1E6\;lq<;@ ?Av|?O{ki]:vP$~kOcgM4v~f8`[_:ˊ{|o]oMрq \*iX2Ύfkkm[GU&6Sړ}ebc6e}v׌@Wl=~h6Pg+cs{c|=`ƴ0N9Ka/7FVs~їa_1G)Kh}.s4Ʀ|}i@^cu@ r#|e,iۑo徔6mvOi?p r،zMنE&/S;\ISz9צ{8>_I ]JWLt%m"4]W蹯}f0,vGvz)y^/SX (o5ʗ2:SzmK盤Y>_*2*8gszt).uNb;!@ZQ/(@q.~m+~Ғ2cqyY/Vk;urEۥ;aߘi}~\hLR=}zv9f2'#f zxl4:fϙ!Im}k[r`LJCW&Q?飓om!ͤz1|{`Xf@z͵T)WI0)ϯ,<`/GL]z/eo7{Nts8bvMt9VuyNL]>Ɲ*<)`~Z|UyNs5(lF䟃3(?Wy@~vP4{~}ƁħdӪ;:LڹTdKC؞ |7ϗӒW}<!V:L(}{X -;NHQ?_ӄAn[`AxLT#mS({MΑF[?O~x#NuJ+?.^=-qߌlۥz@~6 vu~d^V?x] z5\f!:5ƽ ~<ٖB*狆qXY?OyQjEOvp/wS),}r2Ku ѸMSu,9u֛+?Oniq!?oB"[yG skFZW:t6lԳT[4y.DؿF.>aPB~] HR}@aE< AFf*.3}O{An(0rS)JoG:gc⋷u Cr78&a4:Czӎun0> Vۛ:PֆG<1&oT?C[]N[o^pd:g wF!ƾ}3 ]4cZ?Z9-~f Uc?a1>hhoF !j]?O>Rya{t Ux5 0۹` 3Lnߐ%fK?[.~{rק~W7N^}I;<8F2cK 疗=^?ϠzxKUoɃy$뛏V1$3G r5yvThmZ-/)Oل&숐aTy6&4ad`kϥZ2sGr})H>}*A6mKd4ޭ$3kᴫzu#&+׮lڳl]hzcXI*^P 5R;Po4oףPo ZU{Vm~5:*YwZf֪^_-1F{ci*VPa8n}CPYPN[* 彡U-F-åw2GN;kZ4꘍VBSHѷ^zw*wKh6wo$۱%n#տt=[-(s4ڲ=\ڙҧVm=6f 4uv]ju}鴡+weΑ˘- Znk8}ؚ2sk{[63ef5mɖ_Djs5xS- ܧҘeT{[WSf62c ͫy2s[y5Zmޯ& Gj=\f a{FOqi2c ;52C۔;e@vv>Piݔk{o׎گj=\f y=Ժ2sMjzṋ7Fim^k,_fՔ[&uvk[h[TL>Re*m]5*3+յ UgL1PVCmPƵ<#1vUȳJeea(m4+ѧ{#73ʫWW=%^[L&-RPhZ;G jj6_#7^=>^'jՑ.R_X)o-ij}FJi)^Fhd M<@=:ZUgjCA ش[}s 1zzZn; Ϝ kןG+֞s O?uIቫsN_= ם[[a睳n=+ғ=>caKf,>X^z7ɾ,XN e,>X}4`Y򕃺3I0@zgR%T}caEWKXR-aieʣz_Ք}8Kj UXX-aQTKXZ-aYU9jJj&p5i*<0/3 4/eP>( 3 8/K3 1|Rÿкf_t^aTeachingDemos/data/ldsgrowth.rda0000644000175100001440000000475712657235444016451 0ustar hornikusers xTs$@ l!RD,Y ɢ"I!&BX X"* E\EPJeTDPh*łMi<ϛs;/cx$+C@4`jnф%3'J^P C Zµ 5 tNp|:ÍB77A6 zp   C60#`$}ca0r!a`I0TaPE0fA1]09p~sa|BXGRXO!X+a)U5(qxz?Ó6/`3<[ix`+qKx~;%xv+ vx^ka?p[ބ#x p6u'S5Fؼߥا;R7R::E_bc1~Y)%YalxqL2qy,௷ywXI12)O2\e:S&3@f\ Y|6wdVMfc2[d̖K̹/eWv`sɍdKˮ?# {iF^'-:$4ygOL~o%lr?*]t6sg5nIi BO()n^B#qg'E"* WхM=D1K\:uWb;+Y[%7-TeJ~񅈒/ܣ^WYUU7RU˖?/ZUV:YζQꬥJ=WCKkFJW+)v\fsnuLwh@ ='Ph3ۆT@ Zi uZԣ8xGnzGzĹ[۾=PqEW,:gZF[:a5R',s[ʦ;kK-hE-f3Y2%-mϰZ@}EQ3<]Z>9_B-:CԎz6 s!.6Ԭ0 a a4+:û$]ԫa,vyRHc??q%]fD#9MbW2vJFD_UAjTm5cz_ZU Ԧԡ&Ast֒Vo{}lIk6ĮYZ۔ԌZ㏶MvԈ#u;ז`nNF+N/}ϣFKo"q1 ݧ't? x׍D'!GؑF$o*K_ ; tsʪDÍM58/u68{WZ'"R}N G䒨X K>Q=G bO""D!rED j4]:@ w3!> 5ِ#g@68&^вj,9ag8=!t(D_ a0 _a05;|^=\CD#\ QǸ?ȓq`߉A<~[L'c<1vq_5aLqc(8o rOIyj [PEI̗q"|-x;깱~`"YAt\?iԞ|d?VE}v8)[jMy]f?#vv0A~qt{Ngr l"; دfsv[Ƌ/a1'}Dk{@DOn1)\8 -1a/<>xę%?@AK [O;e!,ŏ A' K"%_{J?L+rvy98޴; )̙̍?TT4iy;)ӎS6~133U~!+MጒV)i\倯9qt8TeachingDemos/data/evap.rda0000644000175100001440000000224212657235444015352 0ustar hornikusers ՘nELJH$U$VBȂ[' -i ycolWƭG#p>G ?dOIΉgW[ffsSnjfszxmjf΄97:{+r=8?o'SKx ~omx~?G#1YA Gr<?Nqte}ݾ-Wo,~1;]\\gdY}z AX e37t[O 4[{撉+{3E[;,؇RӹOr?sraw(stg} & }cXHΐa:؍)igL\zsکK'f=y#>:zXx)(E-qNX'9P.v"8:~#>M|Ҝo?}%uso4#&]^Ht?"zϤFOႡߺ+z_Ki5תSy|}^o-GC)uwvݤ7~8;(n-}3>xN * rѪrբt<]{f`3/emTkWm<{گU\ϾPTeachingDemos/data/stork.rda0000644000175100001440000000101212657235444015553 0ustar hornikusers =PAKω5™@D̩9a Rx3s9ZZ)SS2ZSSS1f;dg{}wo/?\2!D"R !1de{B ܟ@ :A40]A 7 R` 4P]Y0fÁGT<O;!H+O-e% pwJ8?))ExE-%S3 VXm iW`0 (UX `#l Rr|~UVW(0' q([35xIJZWJҵDy5!5S:BpJf- C švu\>[ }-)ԿE4E|(k*mx\[sszzIelܟ\\]~\KH#97 1Y%3P⫀^>%_0+j=˩WS!U#Nn)W1J;yXåp0A3U=xrL63cjR*OuNMγngZ[ KJ]-4ӭgP,wH.GxӴ^gh]JןN[<2~oJ]PXhN8l5մ28ӭgvCd6L[ϴ*s %Ze|52l.el9^f +awohz@>)]6'Lk$piM2~751bwk}1P9b[&!9qg1\?{yy.boN V4`ѳNM~bۺFVԚClqC G ,@}:<諻3Ub۟cDt8%vΘ9.,= q1/7+{u|ĝG>C J9[WF%ZwV bsKw\Jϊ5 w>xƣolS9_.=SpqĽwYBwkJL\ݍևMN4/#1pĉ^qj$\`?bcߥ~"Ėê}=4>/w(kI EW7jWN'[8b>Tt^,݉94J̸p'WY~7Z473ſ } j['׿9קT\BYl-!*5cQ&紸IOZz qɵ+^#.G# _"w28oZ8{rgDH =8WW/'/מȳg:r'[?LS>oMfL@s,Y"N\_P~bb#Gu/jNuyZ^&ӯ#hqbG/{*;YOغȻYfߔ.#8w_0Xl\@#gxa.ĆW[\$9Ħ9O_Fl} <Mvd 16Ճm\ۈ]`jGgzST(NĮba7#V裉8;[&OybW] Mp}ݢeEz-3b\ |ĸBM't]= 8re'+f5G3^@@x|Ho1UrO*97əx17쾒snHŋxq;\Ir|C-Fx $'+H@r V#Ꝓkgiɵh[xѹ.Um}/ߝ//>׿܀vn,"_2^&.R^Lmn$ D}7} ^xn~/^ Erk pۼ ^|oG?o?!~kPN mG};K(g v}}|%Ґ?YBh_T9~ځB)Hz"'^ "ޡx&: >@B|"g"c p1n(!y>&Bķ$_C=&ݖ|f'c>OBS7 휎vOG @=g^3q>Dffaɬ$ldF{g{KE\ ʛZa=5 ~)ɅBc{ڹc=Zg [upl_eRo}{H{Hw"!B9ǠKğDou1_+YKfE8'ye#k%B^|%.,+6w燼 0!A8K`m.WzM% };# ~ƒaUK!kOA<_9GxKAx-a̯;ޅ A9g]/C~#MoA~"|/!G?fz1Ϣz#\ !\0!"o=t / ߘ\t;_qR ,Rd?N Oqf|3 y >qN N0ORJ@MOē6 ~'įcL~ ,p:;dnw"Nr\pҎJJQLOR)^N0-b˅%cBlQ0w~ W'7ɧ{0;JxD0L!?s;}'vijam=Ɠ%SX3d3/0LlM!n *:zu{pJ˜1t m6s>kPn9aQ4˔2kQb3862tZz(k@fڳn9Nwl~K.;lk,H?vK=̍q:, ~sO:i7 w{i YQm=l崅u=«|HO9rWR[Z?·`Y`AkT^Ym] 0Y,_>˪?6~Gu"kY\֕ǜ˺D­tI}&2q%O2E`^>^\ 6Kꨵy贬 gux̡Hw^[JS#7wxӋKgW;m|9> KNEw\f2.w9^zTV~yy%(&Z"rK%\QIzlJ롖oWn)󫛪xq{A't%0WO~%U~%iN渲Jzśxryxxge%ī(t<|J:x?PgSUI8@-4Ƈ- Tҫ맺Y`8?ޜ_x3 4|~F2aj`d#EXüiL5=>n/x ou65xy^E7>~W=p1gt ɼJnc߄WGh?׮9YhSe|>eρ=wΧ3n*>;<2uOEAߥIvlj̗.zLiP^d|1F$2[x3粅-m~u E٫q{ iJ/"sw|P({H+2~M9WHfcۜʾ%Re'|~ ƞB]k{Is{Hn>]m/omwm;tyFyyr9淹ɔe$S>:}N?]^=ǝdʜp|l?n:bwZ62ulPm2ˬ{<~_H '46%oYV>*FtZ{qw8V qYt ]udNpdv ɬiiCu2qPl$ ӥBmwwk /UXJ=]>mj]vcMy~1=tеߣwYVWA9h}~Ci7tSV̰W̸+"H4NtdݗLsx/ykcs⵫2o(zd͗P1ӥ+Pxa27 /t,S1aOpU1*K>_1OٓmTƾk)tgOY33xv4#gDl;)Q򡘖|N&Ɇ#y$k}$a-+7Z?6 9o;A32Y@#e?qtBBHgC?e 7~DzӬLz0aG. Q) dR<^LiL֛mFLyϬxx|I<~Hx~' >]?wl@v~~4]G3(gkx{/Om b#Yv՟9~Q>[&Xw(xӝÁz7;~fƕ(A`;M<=w'Kj]Q7P͙ iE l[750}ՠ5. 9w%iBǟx(c(q_>{%0Rt;BZbO%Z~L,;u+L,\[/TvbeA,]n97TYW zēJ\UR%Kb F,9ZݯiN\`Qb'Nl@G䑻Z+̿vlsVDGڨL-=qwD޽[oZOh{ޫ{`W+݅~f7! 4յ`Sžh뼶s-~/g6Z'ւ>͓_ġc-JҬM`ӣ[nypѝ}e`{濜xnm~n:}t*[S{A6 bwģT`79v.5ո(sP)K #_ -MŰR=~ѣTQt+C;1V ~%(̜r^U#{Io _aڧɁn8?Ϯ܁_f<,#~՟#n8Ϧ{ڟ"Dy_}S,Axq(?islIs p[n Z7H-G1їkѿaZUq"7֢{zx}H焿}gܳ~$sm|{sy~?GeG|#;!_(IV}Az~OvϝԡM|Bϫ(wk %i GŮo4 !8ď;%9p4v&=Pƞ~)%,&I:O3`wT䛊LC{!~5 흎~z~|3mg*3MAs&f~,{Oq5gA}砽s?s0ss%A"\$zoHC= Xa 1aOk> p߻,leA"[x^U,Ʀ]q;;o4iߘ{uU.W8|2 4b8gX}'Rd)6^Ho/>C;񯑾F"28aIntLCtƢ-< CI$aZC,GƎnxsՙ&>Q2a`7{=7q} ),B>/#~)/Gx%\ }ބ|;HwHאx rizniz `&0+$%˝ C.=_],+!}W k!7@7[@z; .>7 A>ạӑM1/r/A_bs n@?@Lj?r>C}t@#?A3g>tn#ϋR 0̗'L'+˜yr_@SC^ !l=HW"@/!HWF7C%¯Nȇu&%`ȇ 0ȇ#~8ҍ|4䉈D_GiD:̯hcxטxms6%N?R9% #?0n9~LYSA62CLL٢Y)WYڗھb # KIS٘\EgVN0*Y+U]%jduP5jf)p77]6FjYr=!˹=A18? W44%G<{*lș@|vu8?a8 Mkc ~gtcVǟNt6<jGԸ֥?ߜD~H2ZI7ۢ|-żKDtZj\Kwxk͑9d0oIoVAܯ-Qj/6THgÒmӲJƮaaLd=^S^Wq"y"WmJG!Ƕ>y6 0lqù>%Wۥ։V땺>6lR\_&<^l׀뭮~uܹTyZ/zs?p=(,SOup}zFXl7^~/C΅I=/vx,<߲*azbAFwa!ot>#H8!mL|0S_٦9WW/r֣AnOTintDy/\QGvjJyth Aj3>]~UO|7Y󥫇ZO\ c4+ӕYkt|>^Fǃ̸.a^oxu>BI%l ^WXY!קZ:tJ=,;: _pyb_Lg5̶}#ndE?3-\ +1ʽj ^z$"ż.pYXm<6 $k{mP7FyzdNc~rrQO__y=j)DR?%?5(lj"tmNf Qs22!sUevOiA`)L3$gmJ2IŞ's)27l]6UfYʬ ,2ڟvu82o:N99a8d^+9]F]. nStzfY9lXm;Q&b^o'!h>Z1n\Gz:VN{]..V[c<пV{=n]|6ɽ^ZOm>{^els*b_%^]9B6׽~2r-eCi,sszmۼV;NaG`e^<{ >a{)2aciS6y;>k|<̡~;>Kk> rCӝ~ 2joZd>es݊ccw{U<{i$.c:J>Q,}梥Nk]B|>s9Cu;sV;.-Pd4+X+2aA]G w _A~EאY_eV<)u=4K(}tڭ ].B>2|Jz!?nE'Mݐ? _|gؾCvνV.?/a!_H_E W|%h4zRl2;4|n Xdy2Vfc^N/l+2Oorvڮzr~cHgid=otU79|!b$b_O80S}OezH!sZ Q|g>n J>U6.k=IrUd!e- Z28=P>?3OZɤd[Mk>SEȬ>G<&KN1c:wB2Z|KhL,2Za޴|(>x$ώҩhܡ9BuQ}+4~Ef9aC~v&2cv/+#P>-7+9}qWc)6R<WR|{ߘ(~[2$m:=͡g2nO׺Xen5_h܊E|n9ae/$! OZ+ʭ6/8ն[=pV)fNW^H% /g.t>-̗ߟI#AwOHot2Ut9ް2/OnV3%0o|Ts!36QL]Ń)~ج2w-4'ɵC2n0K/2_Tx>^r1|8~3iZ{"S|jzCI|vLwl;w$w췚|x~~70ij-53Taf(Ew7T}$1W%Yهǫd93pPNNor ǭ*p㤶Qx\=G{oG|3\Í{8d{~=*S'\-xH<;r`٧d?#w8N6E>&?QɑA 2ցo`[74k9ߢf}Qe}qh/O(0E0|%FmgcҶ պoցMO Oi.ffڤX)U7 ~(oYaCJrRiZ/˨=Q>g@٭|xqJ3 W5_8c%>q>;M-'8|T=WϣQ=jpOr5j9jߣ_~W'\xV5@jqЗ>ikCt³„@ŨN?cv3Nwn)f]ycf,nN\/Km _33Y^g/l; _Xz؆x7X4gHg:co$^?nʿs$V]9%t:?Iw1q#ݷ19E7͜Ցcf&r%ǯh;\;k Jf/*9?zrJNh!JhxcKk20Al5lyF|Z ᇈ[/gpf]M#lf(WbkWL<w?S -XnRhf #Nȶ{qZkZ«O=>^ V̲[Aby^ V_:n.>+iO#}nq-h+uNDgqw=*|DѼ!郆I :r~XE!{]+ciNƈzX'ӟm]~b9=sϭ-R ^}aZ$9H |K z}-{.z g_'ӡԿ#;zIExWUQť+מăYTti*ER'G^UفA _5&o,-Xl!?1#Y}ۖ?G-o﨧k[ٚ4>1vGZ0u~ ԟ;2kǮ{3;K\@Ԃ5' 'Zʩi{ &o6{1ͣMkc-Xǟv]׹>ΓW-Xo[ojqX>"geڥgVlp>Z7~w _O*ݸl1ӛlMx 7^Ȯ+W/&wTHW¹X_b+:G|'1yfYՂ-ř(}ˡ1?i|dGkVDZ vgJw`J{nzEiÎj*y4cC:_ZǿMe˵ZM_~h)ULgٮgh>oU$=NMJO|ޚG&.'7.q\. WΠĭDS]? n7;+Q?:fb'҉g0GB(\7vI]cQDw)cV5pڛ(Qwb59_L vŜB޽QI}bG'wDLA\SҸD}L!E춯&.rdZUp.K|/ַ){ʜwʣV]|*-L<]鈔iq[VngiTHWFnUޟg "`ʇ݉*-} VrN[pXsJ1D}=&.yK;rcZlijS8\/&RiQ)N{Mh6*|;''qFmonZ3qc%מqxʃEESSL7U΋;Tݬ"ݍ?%|x&ӕH UW$UoOOZ`Os aL9w>NŊzsP>]?V7T·^(\6g'ĺ`=v%vg7jh&٩%AS_XPq%~r~h+\~"}rR_ђ/w>_ia2cL,6&\Ay}Y:ܩ~ĒKw#oS?{]p*bHېΫ^u666K&~婺G.E#~uRA{2x$ߺkmzzMa‡2N8&-"e &|Kf_-ZL>!uvOqAQmO3CCx/N7fNm'΅Ϙ0~ a͜Z'rBYJ1uk$øF}(7jA ˆnlr^mI~rs^)I; hVIfAv>.+yr䷕%?,yʮw_t p,g?7OHHJ_K$7I%y~䅚!ɋ3%/-NJՂ3$J^{\,{MxQzN ސJQ\.y3 yX!y ΗSL|| <(y?oIzKD$ǁe.%'%B2OYeMETglgm$KCӲ迌v]C=~lG'H9Yl/)Vo'=v~@U^7gxnxDz'pTx&mS(p\$Ͳ'pR.^BI}֍׺Keot_~_hm Z5|Ͷk? ~ ?--x[0[]˴~|V \/ 歁{+kœC#¿B{c<-bxI˘]wE.oZP-.i?xNEx;Z+> >&*VDϷI+pQ=Y9G8Ax7@+^ojъ#8#@|IKZ4B2z7Z=~oVVʽ"E.#\AVH_z*"\JzZ%VQwFN~5~I=^uk{2rGM܉x'9_4h.jl-e؍x7yjJgyi^{E>ArEޯ{h~VYϷTVYכI˽Z2\=zZߓzB_U y5K=_]-Q tz9-9i%ċÚVMi-tʠi}@&iѴd?A xRkFWcM|5kh5Zǫ<-䙴uU-..x!wk1 &=JQ4e间N!ևOb]X 3B8Σ{Fi17/KxQ>KY$i1+z7Uy[yMywZNh1E3k1r9'ysZK-g،۶h{؂ҧrl!OKgD*DѮZlx4S-#0Ej/D9|S7L0bΉo؆ޱ-Zl+I-xT v>ɵ)_PƋZ|oHh{Z;&&_ =2`]/6IE=%$;BO'M3"_7 o^ $ے?7'P@&p(rF ~$~%}¹4|{ñH?CGxTO@ՉoBEIx"\ NFg Lh4gӡw:|NG=@7?3?Ls&|΄|&~Br̂OYp0 0oj ߬@ll6?4N_ ~.ͅ u:_  s:{ڵ_Y~\qX Ak!ڳ^~]Zyz1|.F*Y>K6Nm)|.EKG(g e2cs$'HIpʑ-IAwR'"Ixz&}yKH)D(zr8CYXrˡwEfYg:+п+0V`V 8Zv8VyJv+ѯ+GuԇЧG}/?V?z^E/?uQ_~7Oor_J18z䒤莬d{I_CIIc՝I9׽I?ݘ[23v  ;ـ~,iw$!<2){Ay%&OƯOCx~Mx;'y~yˮL׶ż/S]0bJ/XO13Յ>{(93=(([>.:DEIyɈ^ykN1&e1()?{AIݞ+}%yac 1^c61yZ~׸BkR^N=#\M=qCHS \qlewOMK?מtB}82|^nQveSO,s~㎮mgIggܠOǃ>}:{^rmqm*ʱO6&FAyo=xO~-_/)Ox&)ﮙ> )}3|ؤ>`j̿{ <]9K9oޤMcoֻF>fO :&ks0^Y6ƻ6)1c^={{'奟I>S⻲сw?zCBz/. uސ[~kJU#>xIyc9]eCl +_gg%e$e^E?|ϨӠzK1> ޞ1%)_|wg'=7GZS"}}!93?"eĸ}+n諲<ߧ[2;xėc~ړK> xT__|\嵿saDؙ\,_联>C/m ?b8:QY!Wc _2><>!'ļƞdz@ws;hM^zYaҪC5S>r~o 1ƽW=-Sr^c_9>W |:8{MA'>AnĸWv}tυ?ɊOю/Ÿ =G=W~bޗ.k}aqԨoޗU]|\pKA?cGEτ77":p̷b^Ssϸ_^}!Rl>| >*OI!A'~GW~崷_y>qs̠Y1χ^8,z4u ÎMGyDNs/E? K޷ x{ ~pT[Mq ,aW߈so^S$~u%wuK}=g[,s}BU^rUR^Ԓ[/x.ܤܶL8Ҭi .w|gR5 ~ϥϘ}fPB~6િM#^yv_M='2ucA(;_'B ~|_xq|4dO~ <-|=_Ob=˝%o_tWqiR^~I󄪘OEQURn?:Qٗ[R? /\9:acF2u;r'eGg燉C=ǸdwɁ)<<Y}!?e%5!Hv%ۣX^ſ_SoJƹXgV.X }6^"Q15a~FާnN}~\ssSN_ ?}Fg簎lrG:M?bܯw&'-8;ᬋ>(ǝ|}_>^Pk?޼$yW|6ʳ}~QnͿoRv[7?9@Iy߰Gܡ 蝊ĺa=$xn%\T)۩Ր[\aUc6?:b;3O੢)KB.(q%o ^D=4+\? ~RϿ6)^bܺג2 w ڂz3bQ |oȾ[g$E{/ן|7zd&b>}X_pe:Oy?b~IFx. gwck> _tYث}?yź8У=O\y5'Ssu2}-|+ f7Q?oYؑNZe̋uuX:n옘y1c> o]?cxJ臼GCy_4ʊa _yg|F?+}ގ'^^Խ[gj񲟊yWE'wuڴw~_vvnOӄOm/_'+!{tWw~')ޗ6u3-s?πewcVY/bGN¯{g%YƁ- >1Nvy/GY?slV'A!YdFqo'(rWrY_6λ({c=>󺀸ʴ_:nd{7{YU|5i~+oMgL㻉Uդӂ>?W3xsAc'3)9QN qU?PeWc=r_şnװS}&3=Q1UOwϣA1Ǻ_~|o}fD Y__>>=9)^ڒb+Kʞ&eyٓ'/+wW<9!٪^Yڄ>Oƕcoy~>5weu0^eִw3y$;V|v5?;ƻ('W?xPe9/ >/n x'^X;)@+_]>OܨA>5gWם(gߋx׎ox+gwoF} ~k_w?^Cߙ!ٴ%s8q?+?>i|7c>=N|y/|6no c_uЗEG-Y@|fȴO!1W};oҵߏs迍:2jeG>쏍6Q~ޫoؒ;y$S^쟔k`}rMh?y{l~o%esݨגrñN;=K#Pz} A}ۛ?8#)G\|K~~mhR|䬤ࣉ|#㐯ދ}bw /)ic/{|?tRRr?k²JƅA54%T? F4'l>?=+А[s9%~K^N_ܟ\qa?<>1C6M/K`F:߃}IʲX^vâ}Cÿqzؙ!(s=/d_XX~ā!gC<࢘Ǖg%e}GǾC~:g]Ӌ~_Gn ze/Ώ:?q{O胹M]S`W9E7r>+NCRB/N|a8ًB[kY݃>e? W>Nj}(sA>Φe7rUɰ%1q_{!3 ')/e/zt#ےx1NS~OsGv9ۆh7jAA;6}Gm/ݝe?ȹ,u-v)؟9{ScYdc_ϟo}yLCOC_J+}+~sueNM?Aq=W/`ʙ <)ӗ_>9}ypBIb]ًWk9lb3??ڨCn]_4,0%'>ƺeĀ!WsG_.۴>7TtvM>ϰ.^/n컻p /}vuK? >vgJ+MF_s_=a/g~}݃>}]!Zw1^%>? {f|7*'ZO?jk/|g|Tvo%e?⒗Z:*?ALqܼ{rY\|[{y_Rx O_.i( E5Jȷv|Y؃їƺ>G2n=]pUdkBB>.rk^˵wA/ʞfrj >o~suyFA *y|=~爻r/ >}coEx%u1/Îe]~..񙐇Aw?9ir;5؟{b=X'.b?+ۻ'/M|7{Kם<0QY'q_dbhO\-)H31jy衞&=FɷUp 4fkAq Bs?Dž_T~E-Kҧ%ƕ^T=3;4}|;{Arݣ #x%cƜrl^dުA^MM1go?KBo31ڏ >(<'`]w$eՃL@+?.Vԕ>+I+svEυgw,?`Mu张G?W|6)>nχzc^31[Cn{6sq }NQ}A7}6:qNc%uǚF!_}c58.AN+}Bw}_W~r?MngɾD'擿7ĩ;*3<+םvqJoEs|'^C*Ϗbځn37E}'sۙ4}>1k_ֆ濢 /~%!c .CKJ6$1#y>1_UL~&ϑC7>x"ߚЧINI븳9}&iͻ6,ޞc_NR?Vt<=?XF{׻N0PS} G2px^ȅeC\v?|hS}PB>U`C 8>ܕn zsuWF"ĤuUcc}QB'lz&)UڛKӧ,?y#z+g:sƳN2>tA<1cڠgȐK}5 >=nK+gaaJ|{Q=qD9scG=7H׍'3^U7gE||W/y׾[;3?̺g"=FF !>ٟ'8sYG9%?4_xTNo_r1t"y!%VCxyoy"aa~<灘Ǖ.,py3?_M˩B+?}#Uw ?_ u#~?@P`/|""ο" E5O>X%o{׺^<*S_khso/d?k=AK4 O =0aGKk"6s =B./<'vAA_6%ʙ߫ |=CE_$I>C{d^R.:}4מx:2uZAI9Kc>\8plYX[7+}pةi ٟ?Z6=E=ȯtzGw<~oGgGnEN(w ؅G9!:i_^L |'}$Wpv>nucAM".g\W{p-|,wacb޽t3a?iO^F^~#?q(mǿ?# ¾kqK>0u>ŀxוM y>3_\3nҁ>>+&g|gq?ޕ>WܛY06Um}Ї)ͱ^+<#_?:^NkWv{W]NO o }ox*;Nߘ!_p????(W A˻gTU?|؉ kbmߛg|ɾufJ΀_v0`K| ļ3b>?}XoϡSxF< ]yC\=Kqn cu!iqk? `/J郾)K롿tOK>-ߟ{ =1[N ǧz8)*/i?XON⽤g3wgwOMO6$wE~N7 ^雔&#ߦ~wV[>ުzK[{?W,NHiF T;㷄{VUIk8k }4AgzEI_qߙ,YÃsމa I?lfƫs"0')/ =q> /{7y?"? ~s`@c 8+}Ť< ?nsgE7G򺥱쏽.>/\֟fB}ٶ:gL~Ɯ^ԫ>|ϙ`_x/K.dg5zyQ%#soGA;{=>`ϢKuO=(ږw.LI?c^<`b]zy_O,DޑT>K1syp]LxG'(I5?Qvϓq9ZEO:g,ݤN }EC_A5ÞOԯ~LM9 }žlw_VAd5CNA kl|/$G>LΠϷ>kRЛo =YLϮy̽$IxpTa߉mo!wJ={/[S|KGA>15F>Ě^q#o5y/eG";?wq~#𻑿#_q3Σ>&?}+^?b3w&^ }jMvIAǢqN,H滿0I?>GiTq "[:1gîzJRO3iw߂>-/qu'ˆO˯;58wmAQzgߌEgm؜}q gMi/w/"?pleIj{~"sLW=-Z~J+^H {551I{l7'?U3剠ϵ/N/k{?1'$ >=skǷd}}wZ>SN77$X'`}sYg~`, Mo')ˆOXݤwu~1Cx٠ϵe%Ag&o?XW ]>>zjGW >\$~5g  Lq1MདXxrs>{sr%W}=&FR^vwߓq| y'; )yd^ְ;O ?Gr>~aδX0Q8mye '~X}_|+ϐp`/(}(/NLՒнgU葊_-K;!wMU=,tr^%qqk?j*Hh{z~<#orů烿|H̏yn+MCN_RHҮ};c qu~P\pO~w^y/YrC<-!דX[v/2oE?Ò좹?b ;B^}w,:=WT E$b1O.\л1;?\gϖ#bB?{Y{&όшƹ L 9%=_ <'suc>o#Ǻ>7 KK^6賺oo}־BBM="_?%o]7mA~'D,∃]pkI-AyWu }otĿ?+-!݇}}'xҧ_~'"haۘ[z[B/$t}IW{f?F68A=oz8\|~P|*|Oʋ<';yv l|%I Ɂqƽy/ jw%lѹw^o?/l;0d=mKʙ zM{T2_?ΰ7RзҁC??lg_yc*1=uSh\2_<+~q ?빑ƹ_^<Ϲ59П;68pXzr?.J*}9 GhĦݞ|eYw=ƲIk¾/J}٥'){77? Ɲ eow*y͠(3Ѯ(s^~WS~S|sR&ChW~{+?3˼zw%ߍ91^Ex^wt.[bj6|HrC9+ߎv}TguO5 0)/crk<\%˦içOn|<'2끻"<yС_ޱqfe)YO >9s2gxȸsQ|? VOc:>E8 ;y^ U?~a0WRWy=wqF]V os/>hof)ѻ9fp 7x>jr5׻gN|x>~ΣyMW0*>,=vs;;)Zڕ!97 8:ώѷq>p5nCtoT?ߏ^|BZ𖇞{~ ~*v)}^=5B_y;|U*VTj{?~1N)t}:W~(_\+x/{F>J?x? =\ g"η |΅jt}pETx?*y/G>5h%xDYPsϢW b~[ 0~Dgœx_ú 7'_^osi |_ URVZ }3'9<~[?π_¯Qԏ$ƙGoZ>_4^|~(.DVY :Vl9}|]vAW-#W9C u771jR F^*7׃g!׾KӘGg5 xjǒ_z֗D{iMg%gWK9v*J(jI<_>;+AK Da67F9<>lt1J}}gSxGE^ۣx3Z|h2\_b| xУKKhW= nyOtQ.Z=x?o;nz_Ѯ 9滙4V~ѾOQo86گ-Pe)~ U#uEKy~S z8I6z5@8-q6 e9!v`{,x#/eytZK_I0-s>09qK[88EjC=o /_IW#z-Q >,l!@ao/ѧq,}|ח?惟B\__W+kR,r=1Dx w2.?~}vVy>h`詸.}9o&[WOiυ襥#]oeqD>; ^ډ2r\<*'w=P[шף/Cj[H zkk6xRU?؆X?Z>Y)Y]S_]xouNKBBOC%J5'/BhGn=O.Q^%S=*wq5̇gP6~!x~^ ¯ev5tYֺ1<-_̫n7Uѣ蝥|[~e .;.)Fo]}]HkB/n"YN؉ucz!Cr55ɊQww5zl kDϫ37B<_ĺ݄^k})ڹ׊6˟S=q=k ur\wm3e+e78md_zm_ob_o &\5oF_zjӍyT~kDZѧ"蕛O o!^~\KЋogM ?^s#7#7W,TY߃_rpo?ڈ~-WxtNs}*nnXO-xZI+\DW͋~.ru pW~x@מ|cQn[,s v{Q9%7 @?sW-/@?X݄0zxr迁.зs㗣}U#-'CO܎?G}v8yDN箅6D>2<+=-ȑw|w?%O߭6~7_C 8"泘utR%kW;+jg}~|.?}#TU>W}ɺ :| 5Y/̅װ/~ /^JRh.7׳u /aOulZ+}J^}zv7"Kg}k~|7,o3?O#W#m ?eh&[ 9wEiJڬQ+Qe-zh7<-d=vcF ;w&xl펾Aϴ}1㗴`'+Zktx`6B877_yhpB[#P7~fD?7@9Il \hCOj-Zi?̓I+rJ#z}x3[ϣ|>o͐o6߹OY7!7>]Zە?eϭO 6?kuzr| 4`VG~c6ZS<=V(ÌþܭسEFZEQoG {|oka{OGގ~X ?-.ނ]o!?:⻵3g rufZu/۫wcaGV@Gkۖh_<j^^ՋQU;/|~Wދ|i)79QZK|x(rv`oZ-a)~"b}胾]'\{#H#~\ь2dvx~C;ۍ̷=R >S͏\X9\6Wݎ[q|F0f+72/_#/@ [Z+ ghoXԒ3~#/]mFnW9X3KꑛFmΤ7O.WJ;.g5xz-Ɵm$> w76V>Y G_ 1n1&qV+Kn5[jHZdn5n|giAoNG{S*jQϼ#ۓ[?|qScyRs|=;\::eؗtOkɎJ+?z-#KRu-zl5e^ yyM߻্Q#^]f<8_=xwr x*AO~n|5q7+cq%Fgl/.߄\ϗCEa|xrok5P}E 8]|WGBbG;>笶"'yQt!l.s,'mc9Ǽo߭ GNEnc 7WbB?̀/;7vK]>|_+џ} ;uا}K>rW_]N ͌{߱ |׎n+||'vz5xE?խϠrk -׮ =UyHFqVQVMUm}[UmCw_~B[Y7/kܰ>O1oE=]ϡgoN7HE?%*"Wm{CQxײ;?X\.ڋYACS04Wc{39[k~ -'^;؊l n np߼6s] _\\w<,9-d`C~hruq6ֱ bq16C1rpz~&e} -#q5}'F]m̫!-C~WNmIBGi >1_Ih}dm-;/OHj bZI< }wrBOpc,sF 7va5V_hu>_K艹Лu`ȏhEJw|viGǸM2 <xxY?uj/+sc71ѻ3~^wo/f"OMߎvsF{`/XE\?g`7g!vۣz{ yC\ބS6S,7w3X?4^3ް4߷83,Cݴ}.}Džߌb߽~^l{{Uݍ1;Wȳq&<"ᷮޛ/l]oa ?܀<2ou}B:9 փMkoǢt{1v_Ht_u{{_Zk̯}ڭQ_\Y4/%_bOYZoc =boߢ5 O;v}]:oAn#6н]w8zx 5[ _"ƛVG?K/g-~^m4#wk1u_q|㹗&'޷kSځw9qy㻩Qxcg.r`O=N"~tn&m\o^CKZ L3r?=Z >VdNMm&k_#ޗ3| >[v??~]C{Y|QyG߄=6=\ǼNjQe5KSuձk3ێDi*򩖲.p=';ZƼz_\||l^9~R=X<5"t58簔{yM.@_WХ}e9mgzW [Z ol%b1i)|_đb97.l\RQgq?x{@m'x3ˌ0tm"SO|(on.ݞ[y) wO=Uu+r:VG?-ǟǏhE^BYE?r'\9EOr[Ol%plwz1r n֝mi+X zD=>jG>g·#bwBT/߭~i6AOur}?๛Z辂xh-ҁYbU~x+ޛ;׫2ڎ:[]Y|; L׿RwyODluۼ!ڟt?_ B8ڝMy|< (oxo_wɀ~>J$|6.q~F{%~x݀87Ni)H[fxp>{^ HӃ~<5>CW;ϻ˗]ߧ~Gg8!dd#pByrw$ϟhwl}[*/s{ ދdzdS72|o穔gWk*?frkGQ}xgݻ;'wv1dޟxLW<)WK ~`>¯'fų+(33sRϸ=䃌y,3}ozWyʘg7cr S:C_$ONzHzN>k;IkJ3)-|RtrɌy޴;MT?ǹ{gx=1L{}R==csK3ӺEJJ|s } tN j>G?!՟¯Eݑ> 8| s-')?O],C?9Gw=zQ>|~S? gF⵫M ?Oy_SJ3_G~O髝=+c\y^AW+ʯz?yd_p[qiЙES;7w^i{ģ5姏g rI_z1O/w)ToO7KyI2[='#_QnGӎz-_WWIכ+GԏWn?r s#ٓCp>O̠ʠrҮ_/>!ʱz #ćh'+ʕk眮xH/ yT~/UW>O͘p^B?f[o#u7~7)I8{ 1XzDT<\ =OyK( 7\ת?祼R*7ʝgrEO_A7z ک8O(x[?eGQpjF~QQI'+pheQfʋTyP2CJ/?Nw \ȗCN 7uQ>/o\8s-C}W>}k?gKDQRƼӸ ,O?ʡ~qݦɏڿywϺW~ugУ勵vBKtu\r'>31{o臔{w>sx?O.)R>JGe3$+Q܈̸7S2Zd'euU?8)~}?1g|/ԧ~I*?8N[~ϘvL$`q5~ջ)<L]zy O_p)w弄wSQ94C|eMƑO''d|TN|:Nf\W{)}ħzy؏z\y6 gGz_CMߌT}{)#?3>T.K>U_RQS{*fAcJWϨORzgG}J}`W/; =ATA?&S#TW [Qy=3>ʣ/ S?!Cr)?P?zJ< }~uovIgW/u)奕_-+]gBڻnS)?iHsg1k'3sGT^fpeʏϕW-Q_πCXR?Ջ4C?Bqi,42R; 孟g5MFHj_G;{F-ď||~O˙}'?/}+ 7tT xS{H]{㴮tD_|)K g}ާݔfQ98>v53_)sG_q7u%_ʯt̀?s_?. oF>rCx3SOyG]>FH<_Bw.^yoy/ܩ\:RE~S~Jˌf䵦jO:+_Qnş/++\­]*?|w~\꫌_eQU$vO> x>|'?iG~]/­?owK7U?KyreS<;(9ګ:^W^>?S; >?%^/Gw'?/Tf>\L{RR~N<ާQJ*}пi qe1/xs]3M{?&c^So1o芷t_ʳΤ׷dgMUʌA4`| [+zgȅ꾴?*G+]<я GIz^>p> qMO(ʋ"_Qvi_,śdk+]bf\O)ʍ@=_'>RXOߕOy=fɗ=tWٿM:Kei;R} |.(秩u_;_kM=G͐F{O&?яxׯS]e'7џG4.]n4~ <ϥOID;R="ʕ+q o[OHf[of|ftL?9i\X~~÷]R_Iyz ?s+/uGj/o?-I;t| ٿERxKsVWOވhR?fp?z^t? h~3!>irs3Auԟ?yOm|B}!>]f77r.~FLoO/#?fʷʏ|1nFγVѿ|qB~r(]ԇ'ˤK'|&ğrrޤr\^q} 3ѯv֍|<];^}W{'N׸t/R3ϰׁC>*7syxHRi^oJ>ui\+uߟ1~W_yGK#K_|*/J ~ɤӰ]>3 _iE<2}2ϣj'Oe%ONʠqLϬK?S__})?'mo跮$|?`Ǭy7q>ʥRişRnջoЯ\$(?tz[}OH;#>9/HC~S] R:Iw]GoS63c.qY'瑙?!}? o<_tK3JOğ^~+}“׌so 3GWi%þ>='d 7?Gh_;Pg;2)Nπ[y<2Ɨ>]ʋp۝B&[}U/\{p^=ng)u}sMu 8\_tݜgūo~Q<ɐS0|/Xu]?v'g!vI]I!ʏ)>Sgxn;_2類ŻxP.zW/I =X_ t} z"_~Һr@rq/\fCȸuq4 0 ;~.x.9?]>ʀC)ds /CPj7ʡ[.뙡n^,i܇+_Jh>x~f?'3]0/'tߐ3/=;/҇x?ԿʑNsy旘_y4ʛOg3ry<ߕiWo^3_&E:Oԛ~ȼWW|ר{?,ޓ['<%eHY'}'o^>\dוW}to~wFyg|y~+O%Tϧyx!# hzq] rGs ~;!n)5|>Rջg3P7=ci;}Ky؏IG #Bd]:?υkף~2rv27~3|3?zgoEc\A~T|+>KZJU+҅瞏=3^(>Wzr\ ^fꗋ21~]s>gd)NZycvRHAtyҍfI9u*=sWȏԇ|5\1i{/*N;*7PuŃwh߇U}%9 Vzz_{b)}y~@? =Ϡe^^/`H>\Lw O{-׏WOgc~-'_Zy/u騝QoQ)ʟ{x G2O|wr]7/ʿ++t|*_krԷ<'O/z 3v2棽V__0E{ЗI"LzR1}wyFկڵHWK>_{wGҿE?ʗzY};>}_-Jk]9VK?zt5y<_ʧ}>h#_6>CUx}_ҟI?Mkhݐ/ ]+~]'\E{v*_KQv{ }~lpspkR; 1~ ={KW-ۏ[ ;?1>b*L=K{A?G8KS/d\$  Q^+ig~[U.~õG+_oɗޗb>W))HM$Q˯'+<ןKu?]?S|oylJ(ߍlLQevv~?ʋ|/='W<;GGkQO;saƇ\Oy?зƗK=A]xuhz1.<ԏ]~T#%=CA(?Vqnz8z1r=4,Cx~1:ډ/i/L Θ+ѯ[+÷8SRr(~;Y,; SϽ^J?#8>'lG:_?^8q8cċ~sGw5H)k_+ÐKe$vLV>G GSY?\kWx59~F*cr}F:~ x?. xMpk7q c}gΏr$~~U?ȹ*Wsş,}K1f<^|J?/Qp4_NWo:B9UF<+w廜Aϳq#r~#>7wlv]2 jSpo=q'zEylՈ7w88aW~Fx"}cr_hc;ī~S o"G:e<|'J˦581 ]~;_g/Ba(pO*gu;K}Qo0[9,uTYci=Wf|Q: }4퍏oҟ|C;6\HC?c5Cyʏq-~T΍vyP/?wW8?ǺrhmOhpޏXoڭ|8]ÙU}Rdɗ|i/k }xxp_L?uQ .z#Cvcθ@:\hnwr7Pvo2b~L`\嬷ʍ1A=s.ױl~JK~QEur_6q] Soc,'SP{[yPBJO ܶ3w]Sd}r㾏T[+???;Oo~EyaW'k /GA8vҸ꣡#Cqro+? Ic_?m|R<ԯNHo)1_כq95~%*ڕ\o(:6Q3Cvݯsd8O"߻b]S7O? ɺW{=GSS߃7rO"_.[zg:Yߩ=>%hsЛ#{w;DžI>fi\z5<Ň2ɽ+کܟHߠd奭+-(~˼G.vDzye}Lp׾NTow%11>lMS^҇GP~c>u?C}Q󮃔O]GZ };F~Ws~.}2~r%o<}#CkO/L>R9_#Uѯ~D~׍/vfGx>ttMo}z1GrCv;8/FC'W-]g/grwW}_8ʗƩ;O{sn3W8~3<ו?ڝt=H]SGK7"^C/r{cs ć뎓@?-((ό'W |˗2e~#tr']S@<WM}!|OʁqbT(Oʇ?>r=GϢJ[P]h%Xm<мFoYa1!ݼKWZH/Su9 //07q_ƷԳ[L5.ɒ^q}8wr\ ^C?:<_~"4<qOQH1ONJ|u;UNy~TR>Qt}n{S+oy=#?gug<02zi.J2_l~gXjvūq{*~ǂWraI1uDN~?89*;Iȕ|~;P*~\g s4NGz1o5|k7Q~Vތo럘?Ig\W|^R~rߤ,8}~ yzH|頛vxRꏦQ)}[/WYnI.~vE~zF9S_q/3G}T}PO#oO]:(wův]{t拁Oʠ_j3oӦq5?Q.GIډ4> #g|}||;W]Gw]|*p:tF|"Cںʃi cxKi|.]sr]e3x$>YθzMyyWhwokg3'ǸT0ovFO3 HejLv8NRN}lH6.;tw/qP)'g,Osv(J G#m^~,tc'?x+k]o~Ӽ ;i_x"}7e{vV$qM7w$h1oPkR7CϦ"vhscs7Y474IƩ;K4xscIQ/z|WGS6Q^{+Էc\{\HS[.x=s\GJ~:^Zy>5.)i1vJa?q|Qnߒ'OQq~Ͻ* qI{B>p:JGPh?C_=v5|3WcA{2~{Ѓ98 8?KKhg~ ¡}\ď~E_O} ty1_u yo+oowC=45>}DOu9y8vW_wsq܎ƽ|x>fRu}xa1uytwP3^_3k|Z<8o2%QQq1>pX])Kѿ?]`|R% ʽvhgI<6ͮ)+ˠʸG5xOF0^||?.zu4Cϔ +r~Zz#?ϥ}7_HVt*ҏ>:{{EQuWP|etcyeiv4W_YLQ?se|Ѹ4j3mwW\ BO@߉|gV歋v\7y{S=]ށހ?{*~ȵא?d ^ΤYW=Z+S~(gv; }(ڕ0Fyglv;cN OamAiMѾB깛YgONlcC3G3 #/k*?Ǻ>FO\)݋8b#ߕQ?POth z63R~]K*guw5>~g_!rlA.cwra"rx!umY5Х |43 W *nWEi~TƙL;[g2ϋ|0пHoֻ0YuWޕ?c5O1߲5\xρh7= 5'G==(=+j:. *ڛW[ egA7e[zjNx~\y%|h1/*?SC¿%7ޜo?'g%#kS^^SUKۡ'xE/.w p.弟-AϾ Ǒo*މ2~j}SQ_@}vC=aq C~^'7Bj૑ݣ\]j>ƕm~(g3CpNΩg L9Iʓ=1`1e ߗ{~4_ grیtM;›mQ*Ijy=%ȳ~J?Wo%OfJ 6c534ny] ]ofWs 7w>Q)olbs0-_1tP;T 2~$k*z88%FqUșr]^<akT4L-zvWK>1^Uɋ9h>ؕ/f2:_O ˘uwA|՟pn&`\3m>mU12&,U÷ӡ]oJ[fܯ7>nܼ(D_UẠHg>)ߋ|oC_hJi?M_t5s}ZV_E3z937 >(_k\{uM:Y ciS4?UgzuqR..O ^rWxo zïߤ֮>_33~o Ԏ?z~^ y&ߥ?J[3ͷ XeOWwah7=Q~srt}C_\ k k*t?[]o泸0\?|k 3=]h7~h5)ܷoJ ߼2h7Mb^++kܧ|e1r?`\oh|^])n}3ڵw_w36.wNNs}1}I}=,;ϫձ7Ŭhoy Ra:,OCנz{S龰r/hJЗƫˑײ61/b7v;~pAGx\4٨}%1An0;hAOϭԿ§v%c3R> W0}ZW(G:|`>34pŴo=3hwg$te-|xg}]BR<-G̷mCCQ׾8!G񾉱Ӏo_}nw byFRsC)Nu@/曕ƙ3A\kg/י݁/fرkkGtBȳU v{p.!oK h﹣ٯ?Kq]'*k Z'cwJȧ̠zиq ܯkf w -_78du~b֣M機G<^ϙWD|8F}ܶ|ۍ>nc>UTO-2?ռy2M#|aܧX]WV(Ua [^v]Weۮ#J۸prS(|\ne8~ziϨӏ?8\N!ύd\דe+7EG}&r%W/w9+EH䃯|蟚V-?yOU@QO2c~g1yNupY3xRq4|kQԃz)sWF>o9]'V/I郜 GJﯕy9ba|5%7y>[ҏq{"˂r˟O)"*WY_OzWރ9Iz~6x/z]ȼzSgqyμ]yˑRW_ vP [Pz>=]9qr|:>HZ#%g%*s~=X =yob>ߔAǁ>cU΀f"?߼uk96~;gܔ0BR.rV*; J vg%qpKWϟTj } x<㾜q2y|evk*tzc{ʐC]isxE)8姜ʑ˒Ur=͗UxP?%WyBe>3ބc'@i)Iy6_?_~#O_i¸-1i\ X*ߥ}cw]G_btNboESɸӡowy:/!o=2ޟZxi^׉lLF)_xiC.Oylw't=f{_n<X_nyYg%󬢿 ڻO>mza:xNs!?yl-,~3/}<`>S#ݷ+}N{\_5L|yeRNޓ5'~_/2V7Gug<_9̧rz(=P8oI/@9 ~0^cMj5,3+R.Nh>xo{^8]OW~$]@l*+U3o{A pzǼ"] 9Z8/A_?=lӡ!뿒3NJ zf ucNvDo_su!A,dg}*w} 9y_{?i|}5r<gG/xOqEzڼBӡFgOۛ3'=ShG_g_}!Gq#mlpz/o2ޯ~y_܏<8qUG!9or22x'z.{׌'BR<_)~'5U?<UWGt~橙 #.sg2;? OEh\Y4?sgp$rk{y1O1~i =0y}Tߖ=@S$Y})]}vY:?l\F6{;/}v{#2yW"z?OJu35g=3sBJ_qfW7p&V5NꧣgWgr][}S?޷?OwJ5N3~szמ1{j 0s,i^B}]gs)fok~Gpol0>1O0O$קYw7^cWɏ<ח#uqk5~ld zI]\yS)?5esʁ~vs0{{1s~ڋ]<7~꼽H=~y~׹=9o HE|d.ONa7տRj?-eKp.F7&ҏ!+\/'5Oϒ>1>_y/Jh~>~ܛjN\yy{B{uo!px|r+Gz/듙70H{P-w\i~xvޏT&>F{YG=Rx_O6=N{.~5͍ZƮgN׳7H?\|]MG~/TMG?~3.~4|=^~S=<a L^y$W=gYCe>,j/{_޼7h\fCӘ O+'Ǎ3a7|yY5ezs{.{}+y<>sts_3=z/v}t7suʠNy ^4zUȽy'?:y-u@/b*|5y4"A0=92~hgy΂s78ծl޻^q?[04k;hӀ=^ܨ~mkl7ڙ Gy[[o~!GoE}rynhfЏƅW-\3O\<,Oqk^@=ko^6Q7iB]5C5._Ρ?<=րSs0y?Xrz7!~LԮ˼W|O #!r>[~fύ6q~n Px _'@w|w_3F3=BާZ }\ͬ+o_ES>  ~G,9:Γ.h{Ѯ~y^/ ykwg?T'rc>zk깅u~gF%rWBgߖO mBOyͥ_'2O<+0>/y~gd]>qKyn>n.|݈ɚ.SW%O%Qz|21zyqAѾM3X|C~nKoq:i{oUeF{,ZGnR+rS|]ܷbWn lk(kco*mWk^uy 'o=z=b=YxDzW2^}Х*𷿗1ju࿜q=_׌g^E~krm\<޼/Ge/D?e:'? 1^R ky˓Or\,>m|} <^-A>6ޞWJkFq*:w ܇kk/b)xnB;Yzx7'X {Xߋ0x"p|KX@ΟcG=G ^̏o['m$,ʩZZjdӈ:x} ]{_~=n] /j!P 'W"#]7x>{ge=[-NQVݫSYCWrm>/gxsuMuRr zc.U?A4_qy"oi>/i׾:WB vsc ]66ClH}"1pxX蘆oݟkcv2z?V]>q˧"/CVT+qk\M'(W|#|?A/A7n 헝'"-]*/+Ar?jG۷E̸><CT ·m~W"|0<8.vۀ^\Ǯ' Ƨ_`V~YXL]sg/X5c'!w3eה/fw{~mTCCx;>XA&_wȓrs}C~i'>3+9g'#KׂN|9xV};hz'+C= MFOr]hF^ns]Wy>ߵg'Ҁjf]=7l>j'yHtj%nق}߮ 9EBwn}5dV9}_zrSyOX=[>\RХyQ 85 'i?*/G/`_=_zcпjA.Doz/qG!ッ&|4i߉qwy0^ƨ|12{ڰȟuޛ|c>rKGN%4z7+5Zzqm#S-zҠ:qÓQz"r1|]xn=q wއ=kv t,gV\ 5/8 ą\wuąqi2KR7e([|1gx%^R-t}l߽t ^F1|zJOĮXX|+}V=o?axSӈ¿+Wgm~?W=;,&ޏ_Q.wqyޣ; ;Y]g"dy$ oI[~jvv^Ic}EQVm _#iDV{vr+yg d.a}~Txtıݟ%k '/_5,Ÿ77'$/b?Js | Qޠ<=o:ZLY|=X)BO:5y*t Y:bg~,y2"~yڟJ)bm z?t_sa.}1:bc7 wIx }}M"׉+ڹMGcx0=\wsϯo ,y pbuovgUfyyo}*僷e ?y!>k.-nr>b7\j_we$xNw s_eւ]=|zfʶk+rߕe"O㚡,۾oׁ/خpBB =x<)>: [{\:'oug?yG]q{r(s =Me z1pˑ[o;n~\| ?c= GKSގk]{ެ {87ڛW;yc[xtYCYM_<#뢿Ja_wkdwGhM ^,+X6⧥]\P>bC%Ea ~vtz7_ˊWu`WuLRyuhtWr-ăw{dmͅȍq{⛠G#rҊ0~i\k d z]bhw'S_o'ߚfS_^lƛ߈;}K|\'?ގgfQ{Ϗ{>}g~m Ա=M kT=/7EY/(7x<W?zR? =?snggzu2z^rG={ :>{ӑ!i ~' \ȹV̫fZڵ2n 8ot?m[jY?y7 sWM層48/Κ_྘.7܎ϯTjO|-wQz>v|<>3s3rrxu r~Z[CxLVʉv?o7ѿ/Mc^5 Y?:<@O{ok ;?[L=?Ճ_y>q<i篎ֹQ\R*}B8h1v?|{j9tl/+ϟ<=!tQzB3Y%|;=Ae`mt }\|Rޏ2wq<ু`-~-*O-_ss'S§ m3|o~5y};24^ϾW)Z{K{"7s?oN>R{/\{MߓkٕbӍemzB'f<ـ6߿Rk}_9?nnz䬖3^wrTyaj5|XJak&\|onάM'u CgG;sQgEb"7?vPO'~h1뎛(oX-?.pEYkxzGe<hjXEX*;6oZ::[#7'םÍK!)}n/oe^G[Sm1 ?usbp<ֳq'~/knCwIE7Eyh`CWC݅|߉\?:emrs/xDN]9Q8tړދSxNokYݍ>zX]~|w#=?}_}.]wjuf1?Y|Dr~gfFyχI#-lm<߸:'O8=- VY6~N{7;w#CY|<ʵDyO-8=S+hoJEYУw{7/D'\?mj#8kG[.@Nq{w? },3_ǣV#ÍW7 |<^훉\&lSKsW?^|(G.3 u㋐{ y{ >Cw¯_ދth&7woG+^;?=qG:<<k.nS(=oGmoY=|'ퟏ[f÷ Qdaf=zv7ހ[oEO>1߀]?aȽun/]zoB=w ;+wrcI9Gcn=5:@^Y෭5ʝq:kxӛ!t88ECl&_Z!s.)Q3t}=n*s6/΋;q/۲ ~x'Oxxo{L|E{>zhz9z}ӡhw!ͬnD!b_'rs5׿v~9t]?'w[ Rwwݸ7B/ϊ9N'+kKPZԯ܊l]?>CO?}}.|eEom }A|n|/r+t0nh9C>؍ShIm(>9GnD^gۘ.ąYkYm<#pN;ͬ'10*x?:vsxmߍcv/}uzo_q|k/34mEF>?ڣ<Їud _~>q}?1=r xx{ rxu؁7'E}~/AAqapg}wуEG>١ډݹy܄߱>m{3:F'BHp̺g<؍Dp??PwQE(Q?dy+CGc>A{/Fno۟@mg,.&}w8g{Ywz^|=rvw|C9ϷZnn6[~.mDz^Ӯ_gHɺ{#p!Oω<Ybmw1g{S#găv< /[AAw'<}o|Ն۠s8䍼Gv| ~$ ztC s~ vnQn9~do{x^=رme^:lox|:t"ә~퟼;}SsO8ЖuppyW=yF2;?[e {:";{=6%ۂ1+yf^x[{|߆Mae1t;|]g~àcr2?sds3%>qp|K] XmGGy>_=}ao}?@CS߅]eGɺ|:4Gi7^xnN;i_h:| |C~>{bsOA/Kݾ{૽ۡ~~uvb5w=z`?rx/D]7wo3[՛NoK y^~/F7p/ >~ >:t[%;OӅ#w?~uCM؁Ǽ|D\{ q}GXcYj}m щb_ݟ:F77|88`(}c^ߌ~v y^ y >nˡz)k;-:c;2a\~hf|viOyz,ʍE/^;1un."[wاd=yxqADZ7Wgp XknnO"gYb?8~~[~gO|P{54??ط3Q޿*CS͊Ώqb} xHz}rOa k/~iԷCĹ;'_w@!?Xv__ >/ϑ[#=|7Ym~FqG?>?x MZ=zr$ق$=C>Sě</89!i3;~aH(Ky< }GN=0z7ߠX,?WOs~ہVao܊|ٟ~պo:o̠~a` ΰ0u}{ގ|1RW<І==跃=~v́nš E?7o8S~9z;rTy z};}9{_wxݦנegm xC>y;9N>qn8G9{cC w8泛8߁o|{#λiqn&t|R~ICvW~_rw߱\ `o?~Ȧnqv{]wOy6{;|/.lxHuԷ`O[nH;<{~ʂ>G?}>NǮbED]G <Bng=y ?bS DvOo x7o?$v >rT6?Ioҏ^U>oOxB~S8i-|Ǿc+yO|]/~~)Ѕaw?zrKn?fF}quNf?{E 9!|Y }/#O@mav?''s~&\Y{~\FAy>|8 y;퉘C?D}/z:z/Oe+z~|:GFalGu>=r/YAocdmq.~>04 E﵌wt}8z8O?vx;ٍ~|Ot|xՓߊo4pU77eQþ؁޿|¼v<7B8i|W:CgiFM8V'zsxDqN/0?:z/[IuQmeKUV= D8(w:xiQ*]=^ìkw;?!I;ߚ (b҄~.9~n8y{bpݓ'F8 8\;%)=_spgq`n·¿O!A=ⷲΣ᫧#G>`ߟ#p~_E<Ϻ| 1NgƧ~KkLJ +mqH: hîW'AG.'E??>~{C5\^GE~#NpI~Yg(~qX?&nvYoˏ/qmċǹYPwrν;vq}'o[ʁ8py/泅V*B{ژF;z}/gy>:ٿx!}|8'>W"靧@Qn%gzhP{./8g?vГ#fq^87'^X7aw+=]Էri 1CGy` zHɏ؍~3n78ɾsCO<sf?/}|R>:ewϐ{݉#ww/.NB^}.֧G݊~<~CwwD'ϟ x>E;_9ppUAYfzn7m^CŖCo[~.湍|NgI\V|oz{H1Ώ|NqR=H mSmoԣo>ȻEa7pN1w wriߣwx ͟E;m9y%?9Ĺʭ_A^^F x{7:F?2Aύ v, /qgU:Vz'qПuk'eޜ9>汍xN=?Ȟ<o Љ<=8s7?݆}=&qX釾|\<=y;~pqr#~ލ9Wv? ~^Gx>}2|s~>㖏33Џs4n?{xayX|ǘCsRcس)G=Yw|5-𺕸n6q~mUC-6q}rMc?u/ (ٗܰ)۲|OOiw- }[[z:'A7- l\2E +)9<v/^qA؇WIt^>8 ^8ߵ|m^n~=" 6.م_<='Oyt'yO%ra?o'ny own!V8xi9̏*gV|wQ;},n;{O~8 !n<Nx;~fwO= <y˱|>sc?[ ǍSuo):Ͼ&tw]߯ 1uo| >a|qmA}A2Շ;NΧwm滝{#؝Qb>[8󦞋Mt\ge\}A^v?&>};kǹGkߟKw׽;;::"}(-MѠ;ҍJoosP댝^fGO$չ<OE}dt+~>l<6&޽m۞E߱^ٻ~r&n8zRS#^n3t d#[9#W։GmW#x|D{rO|/'P'8[;{6c>q'Er /؅>M*ľ.6ΥAۻ̃}w<{q6v>}ݜ[܇9)[rxNwrQ'y'ImރSحg{92p~yyO{zbΣ=q}製Eb-qmͮn(fʾ?A_)-~ý<;5[/fhM~z[)mQ."u&yᐯq}ľ*E?1?>fi0~m*rI3 nƹMSDGܜW݀S;LW8YНF#'9=c+6Ov?>_]apx {n:Ovq^O;o¾oe_~gר{XmCn-4?Wy s׳݆ɼ7u={5C|r+|h{rr(j_qNb#;(m/[o&e)wzXO~ٍ~ymߴ~|߆K}poܡ}~ISՊ' ;[16#ɹBiڣfmn'v699s\m|6N7qfI7.] ;_;AwpNDM܋}}7y{nC37@f#nn77y 䑭Ÿ-߂~l'>R_+#uoۂx^o{?YfkjFLhxxKx^>E]zX]Swۯ=?/'/^<_j|9'2h_H^2gwc6pco=vxl@ __+ϥ?k_ez{^:;>^-}5l.DqVZ5{KI']3ll~b@^~lQ'}^Vqڸh!7?-K?̿xYlz7鯁[9NƇ?;@6 N Qp0%@Hx`i5o,Ώ/9WŞO\r<3NFINi؋>%'zM^+nb>-@X祧=jz,x=y:GkǮ:JQzPoЇ_ ?·+C'Snm5xfy_ B P?}} _6/,R \]3r%oa)r̷TਈRB%'^O Lݦ\A·/B>d"?RG])_\:cf݊Or ܪ޷Γ.TкnaE /})\~4W_^J&+A1eO*|R}/a 𸘺Е ꤖwssee 8c?+ č \K(#>(\~3{'{Y2\VB}_}Ϫ6!?GS~u!U2 :̝GY[yO `@Wt^꨻_zG*N<Գy,^,r5|-~CKc{^y%,[9QWAxc^z+\?R>槮KqmYkh߭:DFå| ;r֥ ~]]\wK~@ʒr{#nUU2WpsDsJjsTvߒIAs]Tw p\Nu̷qWp[uS+ JO#_S)~UO5{lo"S)W OT+O/y9q3^و^^ _GWM= cu<6?p^9 n\疞]//#u)/qtG&W_E~%-q:D]^/y^|16Z7El& t:}.S3^#{>[ɣbް|[J~BtK(?t:[^F pnBV= 8/vZzW<Ҍ's=RbЃjC3uKN5^;~~?J;rxo++G'T_]\Ff?rd)y!EG uUKYO?qtZ既gAot~5Z(R:\ b/s 4s(VWww~gwNqꀯ~vn#5I5rh]zsüJO-vJ-k] {&yu+G+"8bίL]FNx>[_4 g6z#^jy-p9gwVIhboj9nEO~|R }&xZP]ξq-a<^e%an<5w z<D Ђݷհ:V܆3u+|0z*sރ !x?\0ɮ;ɋl=߂  qB3FyƋOk+*54rBӫ^v j[5S*a❫fVZ8wO~4Et}PFꀴ"'#7},B._E=+?_82/y!zK[Л;9g>ԋ%WmۉqNV@k9SwTNRshc_/`giվ_2֩^+p8_ cs+6Rz gz/۩Ns~砓qK^*Z=]Cߛ -п8ǧ~~Q|.AhN\wф|R+{ =jC/{T zj&"\~:')%Z.Dlrj;}?gѻZc^bȍUo$v1y'҆\=U=SUy ;yz-ıuN/76:ॕ-ْ=އl%ċ<סs_{J5|FA&|ص{?gmvmԩSO>^ ^t</Pc 惽;@= 9~ns#qr]-ĕf+WHOy;Mz] ݂Չ= v*{KjA] Z`ghǾ xpH/#73-/౷M}w;m]ȯ胟v캖u;۰@Y6֑q6*[9P~&.zJd/zH=|>@~"~ˋC=%kSBV]mmyM\{ow74CO:s&؃8E^YfCm?kD_-f=ԍŮӄXЈoq<RmG*GnB!K}r?A;tۉs5}UuW;>FoS=]~z֯8*& 9@x9T`Oj}:'}IVM'jз}^JFk9?Џ';;} Tq{_xo;z5mti@2~_NAF?U$>de_~c.Tcκt 3O۹x[:#~k :܏^^=ub\lGMt̋T?*Sx|/4uG`ЅF}>шRgKI\DW){}=ڰ{i y|!:N\x!+>=&YJ.eoy7}yV.Q j`<]$Bt`@..f𫉸jB WH}:ɾ{+Co|V|ĝ5D@us~d5;{?M@u7s#TAO^15gg;a/){r``'+xkb`"؁|[<8׵9ƃ'h:Ow#p?%Y{/6SW) =þS<֍|BsVjOz' ǯ_9!U ɿL2 Л7~+}Ot 4fu?˱~#kiq'T\HCO߯҄?>SF 'Й u3 fq.orЉ [W.r|v O.e=vfjr 4qg pP:_-E^/X=v6tI~{C|?Xg]j?Q=)oA>݄un'ȇ|+|_ֱ}OcߚYb .Vco@Xz 2XC̗sk*S .Y^^|RsH)P~zIC|J'|o=W~!(ެzjȧU/vrRϱxzֿomAϹ.^m\"?QrݯK_#'BJ?̧*߂o)8*5c^;O]+?yqq/V)OfڹwTbNh+*Gv4)zWźbO|Ez|C/o+IobbY.O>Ov6HŻx_=˺bW^5.c>AJg <b?XzUZw.$*?+zQe%'b6p-'>_,K/S*`}+ٷ&h_zi^П:{uuWw*~JyeEإ rQ3Zz4!g(_4t,b\ a}g?|/u^kwUy#>d"r _Q~: R|Ǝx[[Tᗪ>:U?vXɛؗc_ZG^{>Sr&Jw#V ]ɟ @OJ/Q=_<&;R *O@R5aX^ .S콲qkW[~T ŌOvAr}1߫F^?3x|i(Qb఑<9JK*=x D~c]C׏|D"TeYJ=rR| zU_k-BOXN~J>~^:yW!BW}U+K*"νD/E*6z;#>X^<>nmS\ ex?S>rlς.W Gt@ x偷CPF'55@wVBVB?Rr-S'Y]-CXY 8 Eߩ/˂rg9t{|x('|RkoJV2/v<~Ͼ]7Gy8ijKJGwc (G0=_|>EaSA sU^z vR[,~ՃW2}~v]O1x.b6x2*FW>k N[l? Wd!!~Wa&(8[xwPr_9fŬg9&{V<@wU]: >R<+=Nx }\ξrQ)pS9nGu_ cZɺCs^~O\Lv!|C^+fkVP&cSGc9q\S.G}UO|A//C J>l لIZɏG)?1#]QF*UO_oهNլrRS!Ǹ" @O#ϽS*~>U yB%|G=:@|Iz{#t @pyEwسgr{3CuV^ڀ9x.5)YyY7nH~¿j=m~sޘv򾛈W n[MHs87!6Rէ *JEk;iuqU>[d]ɮ{϶I 4$xvhF΍'kQSQstR^n'y~ী}kClFV|e% o&٣ v+G 8kߨ}{f[ztG)xmîeg~yoaW݌'ȹu n>Ө˼7W5msQGh](ނ];o B㷐?DD?Cvß Ong]j'qa(ԣѹ Zo&)$y=᭲^&NhZ!ŋXf0D{.6kq}ą)OL~hy_v ?̿fHu?򇔏 `V3I\X;\--ďj ke_%ޠ %o|Gab৕z9a+Rׯ9Cyr~~q0| = j5~0tBWU^8MABw-ैI;у[1ιF.hAhmZ.qHmf~> :~@Nw7Q9awhG[Eta{:iAγ<{?sG?a:OtGv!ΏѶ}Z^1ΣR|,95įׇT $|F}KjC~ak"皐 OW\Z傫}C*?ҏ&uXubȇܱ~΍ysmswTsPt.:m}ALJ[[o}AlW76]};VUIn$./9_f7CAP[#?)¹܃äz`tH@?~꡴ev` PO^$pܦsoO T֓| ͞>UQާD?tǺm]5ͮe.o]y/~z4Mȝ1!Q>CD= YcWC:O$O y!#ng}8')B_"O(8iDm]ku_}+; 5!7Aٌ뛌?[W.b*3э?;_BD a~K~\^? ;W~5NcV9 my8 jp^VMcسCعw{9ze^Ĩ%/zQjùa WmYRנoszU*V>]Ndx^ }ΤI]{˶?=:<]v=xsWL?=.: ~"G?1>i97!lDuI}灏%%rT}̷u&!?z|챫Wu`#_3z.Ыm:;Qq$s2m{r}$}o7ȅ;#/!^T?u?{/uX}{?kǁ^bg#,Ju1Z'ס9Л#~ E_T/1C/P.ݲWıwׇ[A\y zc9޴9ajȁ!X=>N@;qgFN ziG'ȇ:Nq"?uߪ{r?!+6gME&Ul]%"$sぇwه}{G^7FЧ[ +`imKk[f_?Qc5}-rT8_ >KY[z߹ ^R7^uR?u*Gn~>=n0O+=od=wod`y1α Y7gΛ!EkـX!b?qkG?sK ܇ƿ?7QF*wa{>z Sk:}2R8]u@.5vܞaYmkiȏW!*k_>HqE a8'= |!Υ7;!JބN!gdw@EoSxG+m!O+X_}}mYˬ gGa9[c1{/vދD1wԃC C{/E 8>Wz?De#ﲎ.F .V@vN_=dN7<{!FK_~lb?fƖW_7'WcCϽ\h5|OOzGz7'BsG꠭ 7vū[N;us#9vC@"ee`/\uZԗ̸cWx9q]7{~Px~ G(琷?|Е/  a6^(p)j纜YÜ݆]87~vB<@݄)hdGeq$uuBS {<D.߉GX%ab~#{GxC׳^wcԋ w3>E~at§z/8p09y2wwa1:va(M]e?9>9C*ks4Vj뜽(vX'E#5%:IRF{nv*C_{"nCg<ם-vpň4OC1\w ;v/Q9&9i6›uͻufqփ0 C }uvt0v쳫Đv5yugƯ}>ɏ%|Ю ~7G=ݮ;_FleCodsZrOzy(zrt8v#OyzGuu;{CƉIx֏y[\Eri26"J\q|otRr]ՌqBOG?;Q:{0_8> )v(`ݡ99N\X"=|q9=[|t/1^9G1Јgߑ#o/yݞ#>Ktƞ5NA. @&~onMf"7AG1{glg=w ҏl.CtL|85'lŐbЛn! H ? %k[D'oq~ =|@*>n}Hv'-Cc'=D׺K1aүkh>W+8>to6_3>hG\@#A_#c<7*#'>c׃C؇"7 c}Kk[3*7'zP>.v#ۧ/Ĺ"ìcpMJuY;#ۧ(܏1C|g_^>0" xWS*~E^b;7:H@x1`7G!F󍆱/v' WD7>x# ʺg#ı/%cEODC>_=?ZG5C>C>qt p|i{=p jF-}}Mˆ/Žn;N^p v>!#ց/쬱ﳮ3șQοn0D??rzGq-<܄bG!y!ѧ62:e>۫?PAa#x!~#NgiK$#%}Į޷z,(%@/#U ANÇ&ygp5끿^}!!cxǘwQaI.0n7rF ؙ"~?CŏSS߂Q?裫ooo:H-]~';ꅾg:7x}?p_Ozs"w!۟ā ĿhŎC?tPƼV9:R1nc"^ }c#~~r=ⲃQ;\~=0( _B~圂ygƈ` ݈[>zQFO "uxx ~u[# g3~!9C7zX'a+ 'Яs Qzalwހ܁ <~O|k|hy'0~򕻤\Ͽ N ߯b:.5xȨ-Cď(yGvϡ. ~pĿG#:{:H\iD 06{Qt7 ?;WiםЍ(3!x'_S~OwM>xa+!\" ~d&Qܢ*z(~^޴0Sz<(^mz}&?5!ݱO?WQ#GF'"'؇ې0V pt==<4[C%ÜCEQ]]gGvf׻CH.(xo R |W9|9~ӏߦm/Ct<^ُ {o z^>b>?\sak9^e=/_{̛.t=}5}Ao{Cb%;|~Q' 96Bw;~ &O$v-ϓGcxک#nXqQg; Ы9P͇}xp /ǒ~!, F^A?_`޿W0+:tS~| |zķO~M%|{]x.%~ݰmFUQ:>pBjpK Wym?anE"OEGㆱ#c~GgtI t7?zJsy!to#:Nݸ>;C'?[7v =^d+pz W/.WϔvXL:)c&f=ēO$޹uc8Lty$ ?"?#} yZWx_q/3^>NBwv _{Qν˿-yY3jE> fNG y<\uTi}Kqy}U!Db_D{{|#?#/b'^QEU8vA{El_z!ZvanEkOu>u+ݪ.#El!2,>9={^F(E}{Y{K;t}}# <5pNGAo ĈQ~Q;w/]5yQy:ٗ߶rQ$B߻G`ol!f[ a' >ߝ؋c׍' }"ءۡ]`^3+DR\uz7T~L~ܯJԗ3\0eN]$7L\B8 qq]'Zc߷@9N",=$Lz2">6B.⹻θ K bBO]F~ſw79{;@w @ju%ϬsO?sDE=7wz{x@Cz-3ی>aA\#8 F/F0~g{}CqU7C+|:88 ։xpB{M+q!C;qet*{gTQw:0n:Y=QZoЎ?Yy FCĕ6׃oGg+ Iøzg:˾tqk7t6ΥuWhu^M֦|Ycζv^T|W9a},t#zs}=M3qo)?r]/_eSD}+u_hI͞ OsNss'z6#ly;㽟y~~>p]?z6Z5|]2c?6Qg-q&ns{- /352q73usǹI#ruc3ǃ_Yy#q+83+6C|CK?s?<|!z۾3ƽ~Cg.V2s>s YLƗyٻlBƣy0ι_^޿Fna<찵8)`z붔q < _w\1o-g.eݖ2^ѷ2{T]|eT0sփǸb=RkshwLơɞnmqoRγЁO*߹cs}gB? TRt] R`b<؃~K^?2i4>zw1Gog/N;?4]Kp~G->@g֊~gtO?3{ ƃ(8\zɼS.?wswNy[OO"ƛAlݚANe^Plo&6- .=㻠Ӆ#V-e}AS;~Fy마lK{4\>3ٿ4d$oX쫇}7B'4RُRNa6 ~0 w+3?{UWF|@ޏA=Էp=Jc}҈{_sT?xMgN㟛I|2(g~brBI?:e.t>%Uz˼GӁ{LbЩsX|rk8 `NN,9z3,쿙LམMJ'B7MO3Yz\\B9v-i3 d@X%i's8.bsELC[V"+S ϊ=еBQ۵|- g_w5g[e1;Y,bWE< An'=nϭ_#F/eR c'1Џ [ydЙ{M (Wȸt~xîY|]#,r9xFd)pG<Љz=VbB޼8Z ,b}yk1vB[u(@^WiM6t*j{N/^I_Lǿ+dޙЁ3EXcs)~> ^1S`Ur `s'g ݣ|=1!9?k~zN3ߥKEpYxujqVs ^ebo^$Y<> rovia\Q}])=K!KOa^9X7x&ͼ45zӅ{*TSuN!6Ǹt>6p,BƯ%,0,l>s0|y/&:5!<_gSh1ث=7fA7s':u}cK T.j>JgW<Y]`c?<esN<C/uz/{h6X.뵜D~~s~>ЏKrx 5kK' Q>j hv1(&8\ ܈~v!=oįW\(<}!/+6eJ^&za\:g0<ʅ/e5؛iLw\G?6z바Ӑ*?/@n}un/9t"`%sjR/=G=";$͂_ʞ/uE:xseOygyLQ.eSgq.\SŌ'm F?W <蜶oX?eos9KsZMT. >oK-!,_2Xl|2!'x{Ʉ̂O}x=㺈Ȁ]eZ*g{]nt- D.@_(2#/,>%8EDN, WWe+,sO[No˘o4{ZT78X^W9 ʏ~fO?+ {b6PN"s\ྒuO/u6YsL-sNEF΀a[p]A]!^kKr%i)xUz-ee;qH+d^֫tq.2 dm|x,@.Zĸe_X^]>j^sЇ"3Mv>4fiOyy< ;΋.=쐙[/<~bžy{oI ۀ]-ˁA\~ Jaϋܱ,.}[w,).9鲇 c䇙}OgË/a7K\?<]/~ {ԧ\Ev :08D!(c6 Me~w,a3<*y5q^NA ev$Asӹ2Sv+W>c_tFw'Cf_@d`ټWM 䀅7ʀJu7b3S)y<\B/ONC]| K<\nb..໲.J{QS+An/N2k_=Y4ܫ*Njp(?_w鋥-#;e6~BMg|Ye,a_"]@fJQ|£^t!+;o.nrHPATXCG~ߋ3YE|R9a{\cWl5Nu_vg)Os.ǼI{!M6"ewYB?G*x_+اX]L~tupx4nOϺuk Tb!]迳RSڟZ%j<~'_Q|C%2 9uYw^V ^ٌ84:cԹwR Q]< Z|_TA [?}i{ek(^m!/+|u[]ULQ[ݩHn_󑗖09"Xx\2/b_.&v9zKxXY5%߶ktpapȺ.;˜o J*d? vuG>Swҁ& 򬊠q_a߀92v=~ ُ:B7Y^/O 㖟2CK.Q8`Me@=KN?z~z*n:}J?eTkk cE?m*G[qzO-}X>zKZS*)n\zy aଖRG^W b< >sE<A <C2Dž394zӀ}4U[4_Wߨ ́N͉[[J?O ͅC7kW9>#|)kO Ro7uI^51+:<:W~V*{zI|X|6둏\9+hm6ycNe'^R#A_,GLW%|S\m}oȞ[~ x%|N; yr!}-~@t]+"\+ϕ蟹!/K_N@)t:. lO6\ R-tKJ;*o֯o6P\&p#]B>r֫9}>:?>.ÿ"y 8^+e{~]{ʾlߧSEq IYwӗGsYr5rs&rVk]ޚ bOq@ÊyЧLJc) n d_Ї"KK>ayĉT+ `1t\,Уbֻ }BzR/NQjp.l)}^s3|O)|kM-fN)}-о1OI#gV02ا ƕz{˟^!O8||f&;r1t==l@_Vbן ]@c/SoJS@7W|Y ?J+g ?bax);.:$|^q叄+|mpas3sVc6UHvv!=Zßȕص-c?7iJ98:O)Ⱥu_ɺWR=as=bc$kz3d= Gx_$=.h׊7PY~]P'2 :S ~"OgeE y}vw71;Þ[z"ȟN?>$?U&g!s 8dޏpZrf&*+}dCsgy}(/ϒ\R\[ qsiWs3#c*_ }}8]7r~i ye|+^5Wq+~ u/x| B,PKDC2^⨲kkT<) YB;_qУ7M]bl5+p~@"_zo'9ZƇgrk%4G:5l+|)Ur>Hv<{cY ~j ˭wi9(0 u<@wsgV 0mޞ:@$. <~֥x_OgoʣX{\ȟ: DPE/22]Z.!{tm>Ʉeؿ4Yח{ȷJf4u5ξ/Y`艹ƣl`_ Arr$rf]"{l] f3.g>+ 8(CT -wOw,a%Tp!(+9ϸY =//t=7Z05q-@4o$n*WpegfŁ].{0t_>9򏋯$a>o<{r8\o,U`.ϫ·!65csgekҸЏsKLv,_~W7ŵ>Cv-<Ұ;Kb|/#/z_04r#YЕGYL;%PJY_.t~W|KeW|\9/lD\ਘҫٌ? 8bwԟSKҁd1.rT:?, Tn9.e( yC~TơssoUuL&A7oClߩy*roC )pkv~,dT?BDNd <)Yu;T,C?EoO˾n/9afؾ'&IE> }Z̸҉R=+f`]nboQD/f]g'y Hԉ@>Kq3sE^)e!x2mWy=s97@Gȃ>/s7ƕdd=ZN<9&0ak.nmo'%L8}SǼ%_Qww{ygUx˗w:GG;{?^`mn%Зr# {Gt[){s̻>*H*yɟY/qOF#*~|x-C}{#\Xb?h1xfk7!Y8itr3F]j'sO} ~уaƟ)N|xw=dз_;[dmx+kWVUQuxv_uу\gn>OgX\Mw9ףa`ʸ}"{k&y ߛo֎rN~~{oYWks=ЕCO^ke/m/$_q/:;hߋrNG>N9|G;%}Bn\sxt ;y֎p牛zUy~ / xvݍ4e)1Qݷ~>lD^ NKOν<#b95Ó݋@ЛՌXWdѻN69ar}{#g|ڟ2om?=s[8FW&%DN3Nȑ[ V׬?}6ȕf;''v <|9~X1k>\ԢW>uc_^6;_:k{sh /ncjûwܒqkg^lDz rvrhN;00^xyo'mw?w۝vrg9x?gQ`_׫/ۼƊs$nx:}ډK=mݰ[lߏzy/=џc5};SKt{yKtu6zv]'k+Ž|O{O[:qc? '=JO[kr O0oeO7+݉;oA?ނ tcoyIg3s)gٟMvqqsUM>Х=j/\nvEϤ'~lD1޵8=ja^೛?kmwa_^mϝ{[GȩI=\r.F8hg[>bMwx:v;){eIklu9}G篷n?lo#s#g'l/z%i>pz 9-\Wܮſz}½ދvy0#/.0n㶫O&@:G{go۷2NS/yo5tg5tcS$ з,.:l\Q0rn`ϋ-a uZqV7mD~_SQ 6?6#xoЋN!rv|a7zO(31h/ŸoDSzґ!_©ǟ:z/\ܽ>wwhυR݅=ɿ_[Fy| ʴ#?vړ~c؍ ]/9nc~n3;ߏ>gmNlo.2?d{z θܑ\[M&>.vfw.M'3Et&`C/݊> ;ɩ>{.||:%'Rא#֦X{z1Џ\ F =(v?Ʒ=f~oOTqoϵ~N|_=b|u'km=lNMwЍ☻Zj>\ v%_s:߱-,2}g vjN 'qo`k>X!yЉla6@/l0Z;994>0t7&֟(pcEw|kߧOZY n)[? n [9 6k~.s`ܞ{ezm[{sНv}=7l^*P U] :; puG6(vÓ6%DZ?3Gl~e Oފw&kWlg{}cu5IMvcSmaߌ|Gzo]?zO]_}z~ v.GW)d>>ݞ{bk(tFY_&SAccv_ħ0rf~Ƕ8vZδykEzY7@CZma|s;Ꮣȷnn!l!Igyvkt~GmƝ=sn{y%9_f==v}䀄}أ־13wOqIvq<={ ٟyz⤒?6i0|x?ztm]޹%mA~^N#{m>vEv#w;v=y tғI6w*nq>y7Z{uv|!= AR"lyė9/ sX7%.uV'X\>_(9_a(|{1s:WmCy|ߏ9k/ml/&rD=—i??{q{n ?f3O=f֎7Bϛ/`W[Gi4rWtca'w#NM?N-.tF᳕qαۭ ۈrmvw8w4onZkߢvγqfg_zJI91Y~Iv <{>Dgx;z#-ξlFmm߲}0uΰE0a>JԀ~4Q;(ީb9^'z?m~N$g?s6|nUYt;k{s;Ocnu2WI~g7do `VC7CZDž6XלI{%v}x]_,wHç/rus$7{=?H臬Vډ ooOl޷<ه`(Q3K9[[}س{KO~8 6 ]Gnh/_ezD.< ˽gk:m|#;OW5k?nv\T"O 3;-ٓH8$'{oqǓw0ANHvzρsc%{S7xb?5l>d1[vsy/1v#ցw=Un7g/қ<^k_@_קyv䛿pƓlWg:ȯQ nvb/=Agѽ(~͟|uѸ|?o;ܞA揽9ɋ\ Yv} `_ nv{}?QS-ڗ?t8IyPMokkOB?|H\6{.~OHzK}C}乼;n_qm{N[?3/^wl/ ?6smMsNM^|?l0GskkW9=eFNvXspKLWIQktű=yi3uVa<؂>֎>< }ś613a|+#7<_Z}]w| L:fGh/0VK_ MwgLv0s)ڀ8q*/Oj0wW秹'_@fHg'科+V<o,>|]a뒯[29{>qK}6~;سXb;^DӅͷ zv}n%{jy-qk7|o?aӻ??/'r t/`YsO;m7Ͻ`y]k֑3~8{8$oA[ɟ }|o[nK>o8=Hr{3[U?/̮/LqK'zɛA`뼰sdmOb'sL0tl'e%}ovᲠOZ!t4v{i<܎"=K>`X4 qļ~|˞ r^?ø9mw`~[mܭϋkN[#`=G|b3rs&6!S_9Fxn;'xyƷoe񽛐T?>}`8~?'$o-9|YOn3_ Хu?v?|=kx>np.ږTk/8k_#-dFzy!Wy/u;6ݮѹoظY c{C^)Oa/{!8˾i ɟ[ 3>KwK0;T߽}uj<%}O?W#ޓ^'_bv%ev}n{BwNB#zx{I%?iCПv">M\f3C&Fm܎|bO@ޏ|R#DsuHNA::g$I8և~rx!i1a=58~?f81wΉ6n+-})_]&:8ǃڞ?za mϛ^}̾3d_9~kny H8nw]AY!WZ< ijW{䰽؛@v`^[{m^oX'rƶMvv}Tq.g3{u]n ;}Y YBx76;J|(_ 2/$~ X]mrZƧ<6;5#nq;H)o< k'o.ދ`7]þ&|wH?oyɾs/wĹe|3;_@7]|ug*S=$q]kq磲. 7'lۡsNn ĝ爍"v$? ݼ%8o{Kv}{u_E|:2;~ԡI~}^x:sž;@.t/:i?+Pv݃BOq[^gkY`OE٘b S6ǭQn Х7Şs3l|oCq_W?kEl3^[ϢOA||Ǚ8qؓzxc/]R:f~vm<5w,֋|fOsN"oYk/%85ϡ|MM`MFx]6!a%'q]{ɟ8Yz+ϟowa3Ig=;X3W׿-Xx䡿ov{[{g$n |窓tb̮G[`Wy%~Cg%չYW8m/ԸrؗU蛿x3Ϣ2IÝ3콗~e[[gY#EPLt[ yHQSK?>nn@M[}OXag=r!c4v6תpOߡUH]>o~ x[ܟAS{S~jnz:[ {8eq{_s|\3*qhuTuh4kj||M{7 kh:g>׷jLV;4NƟzm }ߡF;̰$Gv>ĸ|O{yOB kzc|+=+79_:}s&G:׹<I&C_;ݟfubrF2Y«^ϵOX+}?+yϠVX=\de{GVhNTN+p 'ӏq>Jo{iqkwGWw'?)?;-Qs\kRIɵ?ۢcR3kSCڢɩj{ZKS0<};+oS_2,S]xK+zhН3u>Wf3;:bqk<_n,W7չ зU_MG-8}Qw:ܩ[x_xlej/_GѹL=~IVBwg?赳pNGu=_͠Z[V:)?e>aS2.q%~ ?#~/8b'x+J06'iI>|WLwt/_H~1?4?nθM"%9IJF^}ȿW.-^KKr/̝'0ΥZO'rg$ n똗c|k4_4_G[9yNuR>FE]au8Wp-|иRôO ukZW߽kiu\'ՌKk}y'g<ٌ7/U{e[iG/g3>ʠ6>87@ a7= 0}St]UUJ=Ubv?Or꜏r_rp Y+.Z ܗ/W)>%<;ܯB_{ԱV|8SS{ZIJ?k&\߁|>w%7NZ[}>y#H/|,y$3Zz儵:ϡ?:/Y௜jq-;Oy .M}0f?G9ߟX+/,~^2i\go'GqU3@2njCѩBOZuDU@vD3j?EOp|u[*{*j*RD'^"=^q Dw<\Kި}4aY~tQ/])+~B(zݒK=k?ܓ{.+~a TdU=_ _?)>MXzO)E=':P/MB%J?Ly:oGp~SODwDg$Q=ۋ| {*PtWނǕ\ˎݓdmx+a^\W[z$hm/Gq /%h,c='~|ωM"S^/9Mʈo|Vz)Vx,y?wGŸJyCDuNvȗz.݂әWW{6Ѳ$/>ih4:UE}3Xo:Bo5!W)߬TkE x?1⮴Wg3n wq_DWDG䷬}cdL׹rw?`%Q[ĵ/_oW|W;u|:+wKya/gpJTvNs[jMVyK֠wk\~jd}Esu GT硫Kk]e9+AGIZ+y$?;0e^T |:;/=I߂cɵ ;f:SML}Vt &B/MZ g~3sb2)H#{J3H7Z%>9VDOK.r:IWyRv?4_sn}D x6eTY|AAӟ[\Gď_ K1t/!_N6aYʮ)o\ˎqIQ]١$k$xOɟj?%b*ײWI>Ncޓ-{})Y#q3W}M37 e}ۊ8_$|_R?zyW#>U/|.=~S.}Yz@r].:-:&D?PŌcϕ2])ү2y^vU+=k=A k?+hgK.-Ob>LdO?~.WW+'E|Wp%dxi_%sAD{Rȸ|}88a컲W$aOK'4*.8Zߊ/ӏ^Sų?"yͪ Q pORoCJ"߆S/YE7$o#q:]Mq4'e+M̿I"9I(/?sK.>_WĒ+::y_ZεâNQNGex% Zѷ!E4Ni6y?'G|4@~8~1o峨7uxN k}W|&a?2SXhdS>3$>g;vד {SeX-}JHbgfNs/u›+Cg'[ KP?T Y+_Kc&;{#Z7 ?ySQ\+.4Dr%BZ_ӊ[<#|LVqa]CrMWyg|c=Io?C)5>'.Yۈ]>*[t]ʓ| iAA;ыTZoJfX+~)9~%OK/VZ!P⃒Ӯ?/}_z^?ӯYd)R&=aGߞV%yFqg\ZMw#?D$YpV<*StOg+dHēMV~2㐿*~-o +:6a˲38+PCϣNxEAٓkϣ>yImdsLK ?+/wq_CC/⺗z#⳪g!z}A|+:ʎORUhoهqł[%BE 9.~۴J|n W܊+]Fr잉z89a yu^+!!Ge߹_!|$k'*%-qWK^|^ +N4Bq! 5O?Wgʛ~/UbLZҾ.-d<{s_/껨7ſ-yI~Ƨx[xNM߸$Q|J.8Ky$OwOX+;C_ OQZO oJ⻤8WM*Q1JQqZO%zceyN#+EO9: %ʯ%BT]S}oTuex%+F~ ?f^׾&[~D~ R>d]KQŅ E%9~"~(TqOW{տZO' pv\ >ZN&x'R<@ =g>V:={=W %bO27@B+||D]KS~+~Y|Iue'1ůK}zH ^O~ *7NMVv.W@׊`" h-_bd~3U#'JUs8jC3C&O˲,-T?ZwɅU|P}ң䧖|-yX)kӫ>#9V~ܟ}KߑQ>} ?(oVz??'[$WOVu'eT=ϕuIR ]=Q}(KxWI+Z{9Eq;c9XƧ:1g =kw" /=q 5N³SI嗐?3'nk?X[u|rZs/PJ;?.{1Z:Vt\r$#Fp%߆3<2O+'^([U>-[v9Q]S]4*:*ST|1.$?ٟ^>"}:ͤ|)}MŨs ׊Pf3xs`gV2 GrR"7TE=nmX+x`}Wq7VLo/n{۲C #ɱң#+cגzWB6Ϯ/z,\\uHOWR^z5?__osn_-&ySDu=ߑ M| ?U}8/^~S|a/Y+;GIP_q3'RU<]'U'J]&?~QG/O-?$U`G}}=_dGsE?3h&$)LKi>cn|"x+m_#/u܆U\.ǗK/::]}笕 -DHST_ύO7UTOsQ83?2A HǑ VZERIkЁOX+E"nO2)Ge{YQ`K_|7yЅ\}SfXuuɝn)XKS=&$k0[nFYW_s~g733kڿiλsj3IXIIGHV~a١J/߿(@8s*w+BI_km1'&;勈nƘ_3Tܿ1T??l.>8D`%=Q\~uޕe+]O_: A_/~}0G/9B+/LҺ kgr_z^DUm7PܓL? kU7Ryia൒V|i+;j'.M${}Xs='BC~ތg]y, 0W+]M' KT\q̾N +NJzHoe=B|/d~v/(}m?gŁcŷZKqCHs'YSWr yu30Lj:}=N$ץ؉ yF3?t_~[~<]_zZ__x?GN ƥ|]|_S yN0.F*nPviSXwɝ`1z}\j|W}0cov̾eܗ_][~s>p&9Cڸ/ՁީiZ 4cH؍[qͽ Kq}ԭ!ؗ<;籨o`"W﵀A;!(uS䀒Tk[}[uǭ A6Z#K-g|G͓ƑUy&(WP^/N^?_}4s%oӧ?^wؿǘ?p_H wWU~eϩc~[oUZX=I7a3P&쨪7*%`wXsZ9K'BƭvR_}#? v<\eoZE;qo$։H/T|i7pjJk<~t٩$NX/U\eq(O\UOtk7Opu,i#.!~,{C? =QIyWhzV~XI-<켊sLjo)9@F (y(_}|']b|?:|䶪$ko-~o@]\|Z3*Ey<: iq}gD&n1Kd߃0N\[RmOrK~ox8d6AtCbWSѵ!}'_NG/v?\N,Q7At >ݏ }@9ǠQ)Yr?U[!FdXPZ%O"w*Nc=| 8hOY+4}]w75{]+Ϭ z9V俄>1zCk<-Kα>8+x/H'\yD!Clst@~##h>תnm{,[oeٗ-OyֽΥnGDu%_0aKTP wmJ~S~s&o!DQKn_K }%'E㺠K^ 3]wz~NvIZ /`vκ7= A'Nr}DeQlG*]q~[ҷ2ƭzREnme|{N1(zv;)UU.(VycЙ^ALžȺ3kzaa~߿q[L79εjײ߻+)^T$o؋,{~4C `]q^l;tS2&9ݬRO{<(޷xQ_oaio;%e>8hEg⩚^o7OUSy 酟gG=/t~{jʏ\{̧}R|xqGS~8.7v-Χw,@#/::Uy;Ⱦ2^ptY73GnK?WV|(;%.i#\-NDre_-Ȯs!+^ ([؏F WNWvo%;;w<罌[kmه Kqkoe݂| )/Fzj*ݞ蛲(_];xyƪgn:7>ԋo!Eia A@QGekv{J.Fwɹ7Pz}_,Vi?< =m3t8Rq:>3N͌K?~gme9ֱ?<'AZɿd=WqĹ(nOv [[[yDJ>߭EC}ѹ᭬]7?wًO,Kvt)_&񌀗ldȲ7*~l{kgCi uyY;a|5PFq5`:jm_~mqkt|EraxXTz(}m/!wtpި1W#?.wx([)xҟ|sd>z;D_6ܢg~ ToOm:Y}6GqC+!Sžxu1駌cV|]gG`睏ݶqtD)Sf9l|ľDn^rlB a?PC0^[Y,Zwſdߐ>lSR$H^엾K<1-8Zȥo1y;:˼W( sTA - |&:A2/j|a#zk<)/GZ'u)Bb_L|S\t~$ٵ}cźr>Ÿ!Gh#V(y1_ny+o^6Cu{Cdz NRwd{o3X Ft ::g&Q8WU>j>ku ߲Jy$Y3cEy9O[DoߩսE|iX(PN+?P^ ?oTR~!T_瑩%(ڏ򇚦Y Vrs'@HOU5(. o"~Gqo{%{rNz_%uPTܾVCTDtW}ȉI$ѿµ!x#P_chuαv#p8K۰!Rym?R]m[*a=Yu8F3<Zr^?~w;DAeҫXU5iU/Aħ?|E׫їyWCxpl;'Qfc+~T~q#̎T*ޓZutN A~IΗĭjЍ:{'׆K?Wȩ^ŊQ]ڟҿEГc ,+J[pV>a'z+~L}vm{VꎳrTϕ7|BY{!w/u]3R޹%'݉&{T[~Y_Rd(i{:G', QNq;b [\lI>!]O{V'Bq ^(D+;Tv+dOz;mU(O|@uZOZ3+{X@cUWo[1؏e'}CHeTz=~^q>4as-;cgU\CgC[MNLK53E_Ϝ[ \(N\QO2n+wu0>< ZrA?o87I Z;SU1W¾'lm1[)٧/*o*][j]K&MSޗ䍝;־Tg n`ʛU]ϻn;ミS' ||)T _ mx >CڏhI/Ʃ'7SwN81I׊0a)U~=ߒ?30^ܚk' Hސ$B/r꙼dо /:kqlHP䳍9h*FN>@ځ~ZN>2n H"n H_ʛ>b ӈ\gRm~G֟-{QJ:!a }G;F~Bow7_93ʾ'؍VY ?ѹ}e?NM_z;k-?M8=7J^U>[/1;d`x~؛y6?8{0rIzֻBLq˗N $s_ҟC<|q_~mVa/P]ټ7#h?oYApx}ZLuAQ=]}||rx |aC|~ӱ1~[56'o$?A/9\yq_UwJSoU&nϰ?쮛7ƞ Wq[bOb_G!?OZaNg{ځ>.:z:qY\u#Wv/sAb*WZ7"7o/&wc=Geo> cnm:MGou/aݠ粳MwSWK Cyxʏ<@.#P w{;!{ݬ'y>]a/{_6 `{37?7.asj_NUꚴA^_.3!ހI+3uS\Yw3& T^ƧSm*_O}Q1qk}͛',C^ uț_r_%z"c'=g ߾iu~I#nq=s^d!ZYY =R왪|aqr߆=l~uկz 9fOCf:x}i; s'Z?P|s]`?]Zurƭ} ?vm?6sN#/0Uf=yZ;phIqO{:/=ܩ٧a)O|~c ǀA{lglYW@IX}\k.zU3FlBR]uϙف|ݚb =ihڝ_d>W ){7+AuOWay c(M Pq }pm y?aR{SA]K;7F"_J:3KtΗYQEG61Wڟ#U39hLBG"Rtp=rZbq浂~gv5tAutZ]cЃ5y?ЋǑkƭ=aOAg+TW./oqW9{n@玂?+ūSKn.apjYGg|O>IV/cvs ؄!{z1O[.p=qʿuU$ϸ~wǩԏ}\}A݌BFGlDX|8={_Qڟa{|ot KG,?cc裥ӭ~uwo]3Z{1CnfH]ϗ޷q+kU_Iu~YO 3l~%LI}I'0 |kr:蜴(L~ĽY6ԣPٱV#'sF6c}c_ل^u0X秭nS@]VcA7| '4*O"z:CNV]?r'31]re5$蜶zjq"]5-Uqщ8;UC7 Ωg\:?`+]x֡+h#pYz>>0|g |ykW݅pQ:w&ҿWG߇'~qً\|vUcS|ɝG:U^V9W7tk/춄7%s&{/zhmI܀N{xo.v>04[fH+[K_svynp6:zx0v0 :'̰aC/y~EUl\Ic(8}6B$.qǓOe[w uڀ}UO[+&.Ͻ'?~sڼLwoǐޟj}'v[ؕwƼ1λ;gmC3G<${oc ۲}N5:>2[Tb=Zg qQڄ؏=]##i!mD|Ɲ#//b܊sb0vνi)'atͶnkKcܢZ_Saom|Kn:aD8$)5Ivqߪ$$PTNK{'m|-|;Iw?6amA=L|f+R{;i5{Nd=j}ءTjy5Wr-{.~n]Dl8xq{??=w@* |F<OX⼳>6L~QU؁Np<|x勯B?ǟ|Gt}֪D'諳m~c(>-3nm_Yu=_[ t#}24??eoD?B@*gߖAUG׶"g(>^uT結yF;}ُ~9:7cn+:dz:gj&ER\FΝ_Ϻ*Pk;:7}~k*xO<cR]7xk?0þmî*xpwp |t{~ie>uECGcL.[6sO͗}v YQ%tu?t>:Z*珺/:#,;Ow:~~Md[6ߒ_ y_[#a3؜jUl :}(g/_⇕z4cm%GD뉝v_c_^:gM7dC Q0 hQS6(Jwtϴٻ'{擤It}=o}|{{yqi"Ԟ#te'[y6Z~ۊ IA"Y>$|zsyk.חp;t~sl![sa9|,ѿ>G}MȧnGFw?eeYx?3>;u|y,vǟx}ԩ9C\Efe?X^& /T? {;8vo;|?)lB_ݎ]xsj#汏&_aqގ"`?/fiL >8e/ہ sQ>u*,溇$_|>OF5wk6!wS#!W[}${^G' q0w{\/P|-au2^s֥=i) w3ܙ$Q|ج#6z}~}]]_g8]ǫ "GSv:;Kyg9}Pu{v ޏ!^ }埬t(y͞}PNŁٯÇz،vA_O5fry-!WN|FA/o_q7ۻc|׶O{<3|ˠn 7>OEss~9b|I[L<)r9OG7Ǟ}7wl>j@p3?vqۿ3 ߥ7NݟO|;'y /̟?J$tJY|NjgU{;?/h/3>`.&Lr3GSDGżF{?_񏍲ٳTϗWoCO:&p݆{kI{* gO?%j4)O1[}~AkabUa?,f\/3@SukTB{Fo^72ynVY|y{W V=|yqkYG3},7eR/{*#&>/T_gL~#<=Up^"ξ7 ;[\C 󼭇.\x_!J?}6N'V9Ia6_|'I\zyw.W>~Ec_\8yZ?/ l?_l>~cE`6 _yJU2s?J|>g}x_bց򡗷RCO|[M 'ٍOW;4nex9kk@3F_y6'֗<}y3Ny:{eW͛>o㘠_7>OK _>>WS+K|4,;ւOu2uǮ?X͞[{d{G)03cfOյ݌R,E%x} 9oy@?J?8wn ~<&=L|yo˱|wY>nw+.ϐW|*q^>~ #rώz~+~݆\*>/oǣU3|ގ.\$gx}߂ZX>{x1tأ~Wހ]!ϓWm{;2ES¼M+yk9DO[{c: ~s_z!`>,lG:}|Ϸ:} S^y,r@^qOCW=|PM ?χm#S䇷7ȟo>_jk=;۱g^v|~G|߆~0_+vtw} Ɨ+COB |*m/Zc\[?W"xM3_'s:>u/j9uD?U7> [9~H~vOB\6/;zx뮄. hG^ ÷$ |>5A-_$r+&oh u{vNa(oT`z9s7x/wÿq~<7r)喙c>h'UK粎>`+:ig9h#R9 "g;x<yiތy3B'tF C:y=x~vo=5`+cAK8>e~ zvUj7`Y8~'ug_/g枥Yum݈|cog)ka%{Jk}>Rȟmm l=/R:Q2˹N|Ͽ@>F|>tzix&~nvgf3}WWrbkv/gSGm=񫘷EosK~t[uφܵ?o}_L}2S8^A 2V~qx?xuY<[Lgu_dV=ߌvf".hf˼p,L%.68G[e02A^a}cṛ=*)CVp?政_'S//d~I%Q])nf#=]==⟰ <}=_k |]:牯C\]*TNoc$x`YWyurjOY_{+lǔs ٳp*C|>6;7QPra7[9/ֲxL.{}](3K_y%Q/ ~5 |ͨsϷ/d_oƋ^|޳s.T޵SE_XE'Kaߪsy<͟y/s`|圯>e=z=N|CUB;T% %=ϐVL*B Gc8O\i\:ۀ}q Г$t=sC`<Foc~~^+ݮr)yJ~)uL*u%R9?b,c?(z[oh)ym[\Ⱦ^?7|-Ass7/ |?fۋ="**_ܒ}s>g]W1)laqr{^H;_kf;hX빷)s>|;}L}m;,FCY?ɩx/[^OU@ qİsy9zcjX:ee;y47buZė7 _7B o7H~X/V y[ u>9jsq&GQڙ~#H\~[wrk~_>nxFDGqA%\?U)EIt⍊?'+AiuS7^{MAwz_cvLtY'd2>'n]o$bxvH߻ g}޶ΈTMr>Q{k;7e*]n|Wܾ=gʹ#]^%uFߡ8(Ĕ||Wկ|)ioM7ڋ_ = yܕ7ЯߕBf^3x~ }drHq9C3-ȧ7n fQޛϹS Pr:US"TRrSX+T{W ce~'I0ڵm ת,G?9]zy+y u qzo"^욪qO9[v^w/iQq[<.&XXaU>z+|^!;n)دTA^_:QL˿ӡO)?~K8; };ȃg<} {?"?I}Wj|;D7bM*f:ՏnXy~~!\ _?xs]RO]>~J%^_H{^.y}tƛ9F!^Y F㑔!f>oaxn%v6AqzoGqjIǷ0/÷{?i1!Σ EX9{.F=K.7D_Ճ^1||]cz/5J 'Ͽ}\CN'h$A'eෞ 6[\d|- >א9>/K!yal!C)oٟ$/ޯ}yk ‡z}iV;ϛr4/ _,G Qϫ7u?G+Gu:T\/(6nۣv۫D;~=<߹]oPyNUF1ڱ5TίFp eoƥ$19,ة f/ᷢݎNQ|~rT_v 9;l)|>AVUvRk4]5|vo{)g=y@f f2_s7z歜or^z󧬧"T_;; j}"}a .`D7_C̳O4}{|З5(Ai!oXI _`=? ~/C~"AfBW: j /ou^2kg}\ 0ފ4a_>%\^`/L|cHc2ymÏ`H M{ȗKwo$9X~Ƴ}pr뮾Y߿ >U_u1cwc7z2גv2S#d>޵}~*7b_HOؿJj7cfKpNzf>Y.vZKB;we|i??Hnm/Z:05]b=죥﫝1؅kJ֥\1|NAn(#ˬ-a'_+}CO V_|_޾]zk z7{ݭ4ѳ3( _|bJA 9/V!M~6ƐNgθϯvDwNa}4 r>/*R~uMnۑJ[VwN{4$.C2+jsk^ط*\>~g 8WbP{$~j Q[/B|öXNw(N|MW %;m r0_znν~A]s?Tm>/35ֱ,k煷So5[W0wF$t}T!O|v9goEߺ|ĻC;l_DZmoׅ7~|>۩"s*Nyva?}{>T-q}*$z=$Uc=~g;G&|D_qSVvjx%I;z|[9S| 2>u9u'ܸN&e-Em0A9'5n+o;gCɎ~W8٬`z:Q0y32scG{?Rp V_?q#Yih=Sk{6ӝ@)=n9hȍw (M8);\T܇DyCT*ЩAy΋||QxOkSU7:T_7uorl,E~(o͜DOS wuy8Gt+#.̿mw!oOソ@%yK[]hƿ {FRK9WO# "ڨS>2jP-} W|g3sW37fX>iᙁ汫_*֍_-a6?:<'κ݅|R^ue[|;<t{ }TΟGE).m«r2K_QKvo߯PjRb9rcƺ~=U}ujv3<4i*c4(،w{Js.%OFeYϫoD]Dt֗WσT<9V9U=X^ jg9W||^1vWϗ5I.&Ω/xT'ǽ/~##(n6<;ow 6t4o߆._Y'_3C_^&J]j#H><έjS|UOxszΑTwoyr[$x+z׷,EYя~ƾ8k޷Tvιcz _>.2"Nze Y> 9.}t]|3̻_s~גgۣCƆuYOZ=_ _n%Ed`6߂i]#-Nո|^eƣ;jmIݦ띩mo^Ƽ. ]){,qF.*w/3wլ/?u}ۣ+ ǎԷb^Q/ϣg^c GzH2b%'= }GnI=l6O~Fch7 F*ya7 KDxsgWH¯%X ?\Υt1Z*D/M3w< %ףo9ͬqMg مzo}:]g%y5h2KV*;XJFw}*Aw{7zMboo/[_ϿP,c?[T_C/oe|ԫD3,ok8c\ 1JyCχ~ 7J0gjw^蕃g^O$;>YgɖҎiLK#.<^S-,[*IpiÎ8FL>dKz< # OT~ʳ`#-Equ] ~-,?;~~k{˱@n얡BùԢf+qZ9ь=8(Ğ_[U^cNԸ:W\zx;qߙ7 B]Y.6܀EfhHtf&.y_!}흏9ה@߯ G?Ti61﫝,fs<ЁVgaG#ӿCKCUP4Q/6sk:hwtCn?JC[ѧu\|ӆUڨo].zHcSbS~Wfu0Jms2.gWئ-FChg6O?Q&F>S{c_&w% 5!Ώf6,7pN񺟷H GnKKohxt߿]|)Fߝ+nn޳/p 5zs;齭u'ʙk/609*vOz,KnйCx׺5`E>V}tvr;M,P\SA޵"ίm#NNTU]? /A«ZF>.ʤh0m/y*7*&=,z7^_~0t?_ !$v߆cY=.Ѯ1-S+{a%5g<)ư2slLlƯxsF~ڙX eJ/?^s5{'R5Z?<=yޡƎˮ^s+!:KWʹOvDKײ%+ og侎3ga{9,]/v"'fK_kLQ?WHAh"Ҵ3!]WGx4#zo,J^5!G(Oٯyfw݋JOx%1﫟9۔Kp]Wj׭Q(;%J!a`^Ӿ;яvw]H_^/C i j)ޓ;}PCrKDI3Uwע#hR'ڙ]9y\ bMQW{OV<"~8|qlP@*U;G܍xN&z׻L=)BKkAѡS텕s?齆/ٙ劎+b]lyc4ӣuގ()oe}vBCOv#;qo\a/СirӻKk_Bg{gHqj]"z݈Q_ oC >i29$5iv!TUy rW;)Ǹ1iwƪf+A Keoъ7?y)wT=[Ý0`Zr/D*RF'^"9O!k_hwO JLm$^::۸~kGگ'؉a)0͉SF}7^vں g-]{vj{vcv Me&:OL55|x9j=K16ߢ[Ut'bohL.QR^@<{U;Z[t5?j^4Uqg/8 vgC/5IOLDx.:ڸa⏂I[soSa'8~#:^Ltn9I՚gӏqoHHExv}EEӭt٫n?|[7FǢC$rz8;:lW49_ }}Uޛwwj(U|{Χ_>-]E7EU:~KV*҄;wnSp熍gxj5 S8f\\lIVvM_ڟ^ѡ ۃj3g<$~':N][ٸ^wk#u*a#C:/ʔʎx9cQNjWɏN{o>N#2i<&9::8 ;~fPKP;[Eÿ"Xd7*)^S(کgi͞PF̸7~Y'z~QF]¾(;= [LT];ISVo_|,uwz,v}` ŸԯZU^d(]-l8]c乀CjحLڴI!i_|{~@*/w <)]te+NΊ^i.ƜԸޮ}ysw]~y5 >؛/>:AqD6bYݻIHcw,]K]{FCP7qiL)%e]GWkҸ Sl<5xfE}V{ŝ{}X~:G\.z&y+vt_;M쯮.wU* ;?9Fן)\m}Ft}O)`e'N>iWŧNg_y͹Ҥ46n:ѱ\Q7#-T;Sns4MSVj[`z4/tΚ z%To^M_s/JqDX?/Zd߷Qwj1wa>e+SܱpN{]Jwx|+ZS}']y8}ͣ3GJjꈷkV\*QpgsMo}&N>eF䛒+?_*;N0z W;;sH"Thڛ}{%~g߯Uc.z|P_F:.+>ړ?;3jo?;qs ycp㳷W|ٸNWX~޻敧5D4ޮ~4'(za_INmϻu벀{0ă_OU݃bCFK::۫8;G.|vl\!DFwjOlbj{;9s\XtF?>YtFM*k)~0v ~CkGF+X W'qIfN_PL96oDGd]3_(;!gF6n G's=_z*H7.3WKMoPNLGd>C-~JjgL{7T]} ~mjXUȏҌ[WJ7Uac5io3qi<ѿ%5!wmOOuz?15ݠֱMONs3-Zllsqi ^德^w!A;L\x7{ȕ3֨b剱l}LYOwwg\}"eO>Nm~KG5NruS$o۩ysp..{Mb!)%GLQf"GgsB2#*pe'?v[vG?Ym'W&Z2=wOuwp^uRvY껠5fmA}^5QߏKJ7ioP"K6i dc6Ƅ9z{޸$)~NIۮ[g?M;r5t{~Mq1o7+O=Mv٪dc(MZ\罕 tYgU2^GG?|a^~OKyKjolYGvbWJ8lq戯33skwh>,|Ƌ0N1m셲 ғ?S:ER/]6%狎;>qMO |jߟAQ\xX~vR[> X W9]vE?YCs8lڙ^sdQ~AtT%~'[QOQ^q;-Qf=1wk~;vC_oZ%Ug%}6Y_Z}iV?q;$L~KߑX׾98@st|Ɵ)ٞ@Rs;ǤGSU;9 |%/ _Kӥgم轳FO<(\~ܗoGױb(3΍Ft{SgGxX;._/;_cڇ#~2{'|V;x^G>mW3cNGDKIo.K43$uO]W#Q5&Ë&C:U]3|Y޾p\]b2kgQP)S\cQ8+ydsEsǩ)E?:z'iLr9|M .v,Ѹɋڮ{}.؞wղ[e?gDG9&:F|hiMY_55_/Sa2߿/~38L{a곧;zYOI3gwilH%:4TIޏ_4GUj?M#;i?%Ezo^xοai<@[u^N2:=0ۚC:ޕ$:Ư)M sX%gָ&bɇЃ\5cN{Av.(o6߂].F9agr i1u?s:G'qtYt9'y}zGaKU:t?Gq7\$:Kz?ҸCJ`'٫W, sǹ9L 'zo$Otۀ}a رi;Ge~]ry!}Wvǯx*o:afUvLP0{vG6k v:?+܎+Q?E!CM.bߌ,P+IK4ߦ7J,+cu ӮS{IO6w I`/_+,"΅z!M9 ,Jb;BΞ1o~3oA9 qV/ll@u aXPjKj#%٨nvVɧ/-ީ'f9zګt2#s 3HeU?;"3;4E}ʿfMP3xY˄4%6͜oc{_<7vm;vD$奲mTg;jlMC|\T?ώy}bWX玹^9PM"9[X:sDૉC~v?Z&k\_*C=EwDvO_Ԗ KvH?{<ՅGٳ<&x{9? qFVԆ~a##jwQN駮IݹGIN3G4כ=yq{#3SeƋ%g\S?/:7G{{[(ϗrH*!]1/.g# ϧ5D4uuoG?hj g~x-)$OUĎ=_MT؟jG,׼P>Vtc[E}!ďcu/3c.rۚ]-;o>Ǯ5J5ߢ{NV\&F9<QwąN|G>. K|%yȿj'ORf C vp)6_WAz/XD> z \|w%.3&" O˥$^vW8oLyӏOۭxz{U5%'njT>d&yt^fh~dK~5ZJަ2IL1zu[H)'Ϲ߻ f7E^%__-jF ԋL[-Spn^uqԻg >G6: ul^M:̻S~MϗFׇrgF?ɣnK&W}܍ȩME»|wX9E^wߥϔ Q'jq\ݗ-S[sC̏lrO6ݟ;ৗKT?r~ R>~/+nZ&yD$|J?k_/rNoA }#*Ia?H%x>1=](^s>`VzSuKvy?R2c{7Z>޷7]c-/І9~sSE里t&#gt;"G}?i#W|5IZ)=I?<$:KfFaSPd_'s` '"GSކz^lRa"ÅkJ+ uL|8:@2Ԅ|DdWoz٭~d[y|p(?WIy 7 #yfm'I==V|yU_39 ȷ t]7{s_k|ۙ'Ԑ+'0_qN&s6'9_v%/h>t!~f{>''/ ϷJJC~x_ϣ\=Nަ<+niLxO{T,>9Ο.yd2~-?eVu & }wxG|5zql\ p.Ŀ/PN?^|k7mqncȟ$SJׇ ozAˏjcBعxq~SB=33_ Kٻ_穋t+i{9ԕɇ?GJ3 ~=Jݵ8{$ ̣E?~I'JQMyЯGr'>cO>KJ[$\MO>+e'6RByk!=O<*D,!{~};l\MᰃLd}%$8H<df#toۯ)jwy[yk`+zuE:\BR oO[q!|cޛOhJfH/fu4|Uk/NA_   )~lS]SFyʿkOy?uV緎*3ɘLcif}|EԳ)>߼YzRӕ$x8:ft wc>6d / 8NOv!G-\xU@4Aϗr*/eK$I@2F5Ĺ/H5P,oMx e9yt8=E^ 3gj\m V@V n/B=A9&^0vSO5@=mdr%_GG 7꽲_:O߭`OCCj?ԟd^'+QiU +\nO q8w÷갃mfm38y]:[ 9݉31}^6f齮X]o O|*u)#mhٯg>uVpbsO|7ۈPx.+/[دڔWղo`_ ANG}ϺGv,:F{pH5 r8;Y0UumL:z;Ͽ<tpP)w&f5GOmió iP< _;_12WeVAfM.:d:wRHS,AϞ!?<4NҵΧ0ǥ=z.vű4NQ{kj@OA}VS}-'wOy7mF.mf>`Pz;xCbMj!?~ ^uzX;٭;^;UuW?)=j1qqCЉ_Z2=+Qg1-pEF5?s6 /&Gnjk5Q_3_yZM$7h^,yIS|l<.vw_,q=5_ ?s8&iK;~%z|Y)}>v׮uaw?OfHuɯdi,Gk~E_]|mO~!3уރQt%:C_+Z[i^ Ϻɳ>{i= 3{Wϝ9W]=I?J 1u_*j_~-~`>PS_Fm|;;M9s&3W۸=6\/һ9I» 4Ϲkǜ1^\"I'򫲃7R.St- ym8Zk%Z&Lmȑ)D-638`/E'4Pߪ9agM%{13췶x#<7 F.gk޴}.uIx mh򯅗 bKo"|!uQkǞՍs`F =ꌖ?OoR/7CϘF=5Mޞ 2'35uW#ao`o:_~f_' uKaӛ$Dn}ʍlFz*nϭ@;f6s:&]K_E4^q_z?kW >;C䃈[J+tmlg_3vzdy ÿ~]7~K6}Ok!Z %8zwo_moa7~a^a7n{wdkk{]0Mk^ژg?ym4Pߟ)x>=b="zWݷj}A^蠯yىs6/8t_uu`t#<7;8[4 C؝Q${$wXW; 6u3ű`+Oc>?}xW'hǎvC':.KCN{RqѣP`W7g_';Xq׼[ϷWo\({Mȝ?rOu[L>z46<ŝz^MZϱuGFn!~.W;;O |Cu;}t8=c1p7~o&j|Suⷲ؉ċ3L+ՑW>QMZ.Cܪr`=l~P*oɗ?iK = }~z={mG`ΒގUR&4PD/ޡU5US{]wR+EfUM}s b]{EI7 ޘxbFmNjeɧt+FGmW?ꨛ\γ_=6<#\lpk .d|RvRCƟ/:}7j$ZFSuenw!S]sکNA}c)c;[㵊΍upzac5 u黔?N /[v~}@[G~pJɍߍު۱Od7w ,9W[YU1#Ê6xw;کw+ݵEOݍ|;z谏sW"SC^^}= .0|Htv\D5ctZ߹ f/~a$;x?mFۚ4΍;;T}?s;0M}߄,C6-;Gjg2DmڗԲƟƾ!?LsHPA}Vswta؎+ `㬹Nנ@vc]LTzu]ڤ8;P}VmwƗ<ٔ՞C@_\fhx+X7|\vSѥR򕘎y毩[9f`ܮvy < Ao1EO)}8XK~D1ۉݣcw8/5wft7\ ^[hGFM6j\+gwi\u3$f27?ne?ϑn-و;/J_DrD?TU`%ѱG"k|i fsx!W#nOZvB:O-Ÿ·&MC9&>Q?92vf;*=׊pƓ] 媗eZDYlAAjnC]ig o'ocUrznjya2Cw^^fXv hI- f''e?u pS#c¢#qx؇yH7xH~췞p?yc+qݡ( >n>G]?ӞIMEܟ+[k/8tTCNә+ :_*/b;+Wo Q96@6z}pWqjQ`P"cׄENQ&;76|1KNwvf3[+|%}ujOj:ffw=0us!]x-xv$G!F_{9vR~%6FyO. ܫ~C=+e*i7^@޳3oJ2EongsdR| ~_[sۥ*wg]m="Α#ʻn-T۾ɵc'Yd3̛-W.1YBE-_o ag>|Ş~MulCa'I? | t}IqBʛf?}i2Kra U vw'mobulU'Ȏ93]V~Gv1M!aӲu?uIo787`Ot}Exg"NoYʘ\EYʾpکSSr`_.^EiCTx[ST]u޺Inv'Gn>z{3΍)R&6Vi|ͱzU-L{WjwF^qpYvr ;oYx$.g?p{sƽs S)N;cj#b ŏNL:_'i<t }D L\t8ȍ ~'zgg݇ ZlԀ`7߮vo6kN?C/t|/Y^ӕ]q {.&njNC+۱$r_rӰ _}_צ?:bWlkʚm9Zg=vh_3B8֨v~#~_>o}u'v^O~e9*S={ Bc;;S&LֵYNC_{p{&>ېkߎ/N.L-sYizGdzS*0`:"~*608<3syO~3f [.KuoѰ ~= =ೝu-Lc Czy,跕k=Gh)tO)ۄQwk&j\)IlVc*9{8SeCnC>ky%NLݍךg42ύGv3g6"Mh\;NR]1vgx>vOQy7P:¯z ; ~F#Y|[5?$~G򆘍ЧϺ.87 ,s\| τϲd]wI/gc9w~!մ_:[MƞФf~'ʻo'?(B-+AZnbب8;}DMWfS4e5ôo~Cz^=䋌X謹'[7?zPvq{5зԎny^} K?co^A~t5ǡÏ[v0S|v껙3*Mv좠ÿSKg7xKkJoQ}EzΛ~o~=X/yjk#as%mP}Ù\Hޑ!C5 ӫ][R=%aͯ!oYy ZtxZ=h\w t]E),wEl|~AI;lovs~]wYZSol$`t)Vբl?k-qz^j=~-}%o>w.`~b@Fqz3e/rxډ_D8dONOq;-oj.Ϯl^j;uC[.$g1=\&##>=~ݯJ6 wDk/2s]8z FQJO~Mχ6%9tK}kp=6?~4@7*uAY>~:x?4~]zGwe ^sŽ9Wψ=>6-赋_]]M6oxUoY^skx k?ة\7qޕY?0DO|l rqn|u~}uqHۉ5݈]>_;Tl_\%][{eSWR6bSx|? ~d'v>75A숥_vsB6wGc=s z˖vmk|}4Mhd.`>;t1P{! ЮM K]1連5Ɋ?yxtpf!'躛uz<af* o5_ "/%.?]G[{JzɳN7ogOO eW5u'P!938v'yg8t?g% #O`.Gv?oc뿑塚9)BW;-ga֠GNCORNޟ6NT{ʗk---l/[}!Wfu2T BΡ 34NA f(Z{Og\i;m_AS:U<"X}Ez :m\۩K+b/ǽw*X[w5Z,T{{:H>LyV*ʜ \~C)c/=pƵr^T3^$t$Np WCyM=rYoؗSƾQx#wr·դz7i76HiA϶Џ_˟_^|WM~*Wn2W-C;o~_>F M&KC.), 뺖|;?=M|;|kW}j{Nfg`g!k|U`C_n*SlOkV{itui`p|[Y}`oEV8ڰ|NLh:8 Vגg-z d߲gye'@n] 6c.b{xjNuWۨd'~;8Tsb7'VrW؀izYsӎ11_v2;8J<' ]~ۆ]4z|zko[qosBx?#%n}<@|S5˳ۑ۱A}u`8'|J-=#ve{*3ԝ;_>?stDv[TsqctL|Ӂ&18@僂MzAH>Y=[$}M>l+iOEX ^ex=?NxPAލ j '1wEs x!WDx}{:l"GO;uSۄ\Ǧ9$-Qxxc:q@~ou ]Xq#>j ?1];*8b&/ ~6_zf|P !146K8E#aGįg/qiiG؈u^i}{U{ʳb'<-_tt[{SU'&clBs5.G (+O޾~@ߥb /_b4LFp3獃wh~5n)ץ87 Gj{8=4ojA?*_oO'gnAGww?䦑w=%pkne."~9h^w;kvtb7y̏F}Ej=Ao?N!3~Vq62R햽4`ϫ9WxS ^dR5o&|?IDs;x] P2  hcTGי!)}I/}{o`j;·?T|>Cx[gu^Fr|C`_UZ6QAH_2c ߌ.ѭ}L#cߖg'f6j|x {3U^@34ݟ?P-5zRw_6D~~W#?_Ğ>,z棟P{V;)@_e4ՓOԑ=j}O ;עo>GnaYE`W!G:ParѱfJKDyԼ:ϰ?q.e1KQ])go=1w@68_dүDC8&i=K_Q&;xdS?B?{ 囉W{MT*%G+JM{ᓮs8cȫm.έw/qyrPx5W-xχnE>M_%o3'}UƑʼnK}joUg^.iѾ FUW?Pԅjw#nW??'<,|?د|fh9ȚV쪵go ÿD>~^Q9@3N(@S}׀站Um귐fHXGWNB>q}GVkDqO"|Qw򫳑}~0/Aߧ^G򃉊8n#OPsNh$ 6CcG~&ip")O=;C'R;ݻ}oDxDJNu7q?F G|S'gc~9؈ϑyz>ߘ=t1fgȇ;c͗5^{K L;lWD?ͼXZtiW|)Md~mY(AGhAcQ\ԣ5?Lr۪qT6oBNR;sD hkᜰ> |`9cqyyZ;}<vec—tr^@vr&`\5P{#.| U@~6Rz6;&ZQ^Kyۋ~$Cت+_gKӪ)ոuNwC}yXqZ仺ĕag:C7E&Gf?vRuŗsKDzŊ~_Ix#CfOY5C^>0y.wZK\ "|N3GkxNcOx[oW>e{U:'>`|_Jh 97~Y㭖yDǾx#{؇N]ڙ.Ȍ(_i?R5 kLCI'9]pQQ«j엵 *P 9{_iu]<\6V*=^rOw7 ="r+ɯ6(ڏ^GȯTC{4ڟ|P&/T jJ^5 }I+(ܪ\.IpR:,X6nׅ,}U= ;MxGheIS~-WgT'FFSq8G}M^e2JtڮtvvWD*;9ʛ M gjDi|Gw{}1ǯu6Grum~7wh|Un'V]}scW$.Pz#o?a_KqxڇO}O@kۛCj/ˑiNy+u}H5J`N~OpTu:L?gPnmjQ&w"Y#j~?;ЏvqϏNS~dJB5g<&->qkʳfoxrpX~ivQݧ#Q4)M/}9cghńEj3?(|S1 c'jݍ^3Qxyd)\O^8Q|h-ָjlgiD_Oe${O]ڧ^4vqg/]j%?}qTѷTu#~?~B郚Gc0ᅥ1' .M8;m{A}q-oLO6؏U%:=F sF|A z*i/|1vmN+4wD޻󨳅F޵Q,|NJ7i#`g4Vj'y?噰q: ;qU@ݣЛa5jWC|q'f6 ]E\}wLv~7u?Tg{,kgqɿs͛koΡJW>BNԳĿ'\/}?^_}︾'OGYFNw-^Xvv4?E]s_jNi歹7 .8WPqvwuNjI>13;);dO,Ս< qJd'x6OZ%@_ӡ ܟꜘXu_[viz-Ӵ cr6{Oq}9B^Pj;Nysj/7 Bߩq'y7$φ =7=)#Ou}|ډ}liѯh|]%cb4?j1NHvTktS{nhFS_:N/)_~$:)tTox`l+h/K;4Fxٯh?+aGG|E|PUa?_{mEw?sn6-`vҟJg#x82X_?$!/w__4KsR^ ;AdMzHP{3cu}]۱ucoz>ڳwŻ1%':/DOۘGyB|~۴S?V?ũ\C.>_O/1?>9)/x_ݯE~ e"=,|#H`/XDlaO )nih &0;tFuAmE]Ԉ7nm/wjcw?}')3|΅wƺ嫱 LH햝Hb{6E=8bǍ 88LO'o/+`_=g}O#?AꍙJε T˞v?__3~, u\t}'^MWW0_kQ|=.,#=WK/dڱϵŅ,gӬqvղL<s4=x5>y2 oFMw^]$oxr1Lj (|Ei,Ӻ*N\|ڽ@fg:]G/OګOp~|瑿8/ܩ'~=~A<-=NNOihl'^N~%OGT$=)Bkzsyz/Rr(>-|7_8{Py8:~qq߫\r=%o꫘O|kDkjoe~DNz4#3D5jģ{eC>**:Rgk~f'?tJxP;&gޑ <M4LъK1~ D<w&:X yK? i4aK*^Ϋg!w%$HQy+|zCw:\'?uֻx,]m'<2Lj_ cޡ wNco#]h}ӮV\0yJ;:ى5?GpXOeD%HypSG{SQ۴b^~I9vcȳq"^)[8{=SgsfYx4?N];LuI?$y 8+= Lˌ'C4ן__9DZ1_KFΖdw=Nڡ}"]y4߇TpS]8;gݓ#OkXg>qSt|Wt*xƣG_*235Ӡ,۱< ZⲊWM!\ ON^3y?]l䣨jcFQIQ eusi'lPE_'8}/3ž&>;ډ{qc~%|._?aTrh\<?Kdw7>/^z/B\#Δa) ~[IѹBNw7_>]nS)SsbScɯ0?}F^JߚF[<1'6N 9Ø(;Iǿp? q~%8N=o@{]9_ZQ5K?~ᚣd>MQ:LՅJyE^hWz&q'RI)Hr0b6cȿtpNJvp͠ƣ3I#G/ůYMy$evG'Dz4کNK4΁nb·o®YH޸^coȍ\+63c]gsw\Oב/;}ʀK< -{/T 6r{  }]pO'GY. n|I\!/IhKX0m/B[_ޑ]Hz%1ZBޢ zv8w>KFGo.+tYO\od_xOC?֪m/i| /l:UrY (3hh? =څȍ2/ޏg` >+C|7'*8ˈo}>ۋ1m n&^q#q.@R-v;Vo׸^}yv|!`#uc|Jiy 3;<3 ɗP?3|^:<8x[ЋO2B7~.5y1=;/a#tx՜-O*v"4!y~e |3;[%ԛ*&/&-_'XvM,)(tg #Ot1J}1Np+b{AϠMx}o ^cބ_' }|߂\Xl3c҅/_~CK'}zt~o.eSFsO6bJf^=|)AHbOQ:NWW<66:ߩx`~cA)ܦ#Nα- {<؝$FB&y.g'Ftm&N?T `7YF_d}zf}_I؏7{{iQ?y,WVދP?R+کByLv)U0{}::}ݝ-CsY3pyK?leΧ)o_r׹Ё o8p!PQ~l>Px~}mwS_uƾɃP~~f13_o\C|,|%~ O6+S>S8wuAY&qwt ;=U珯GK|@&<}i^^x_Ӹa @4Tgr'Ab4ݺ]ylҟ b/_3EZˏgw{KT=?Ok?Gu/0y~&|Â/ҨC,Vٻ!|q uڲ+9 >uګ̳6e97'd~>BF))=~G3W1AwSH:ɻ>8wp#ug$/= -Fc;MFaO\oDp~` |=8[roGYOTk] ~^#uH}wJs6I6?$>{;?-qHz[V>ỵtw2N湯gP)c.D5w[:L35 7[XY SzQ:Xa\HqզD/u&}~wbSهM`A\ cw~n>^8w-Mu?:<χ\4#l7Iks\Q&sfg2o;OXƾ>t3"~V`W@tl9\ 8 Κ: q'GNO|]k7礯ߵ~DG٫{zM?{pgWCT/`#(@X^e)ΣjBV׼:mUԅ~px:2/N/]ǖ1z:]8hd]ތ{6}ƹ?}٣B/<[wugS<?Aבe.Z|>8uD0/3O?D=T4qWtHbȉ-uk߿M\^<_?g9{w3v+J/e#/_> W8z[Ӥp@3lawլԵl["~p~MsI~H:}wl'+c/Ab>,*;M\cTσ| E)uqp y=?8Kz_mN'x$VnGV\ ?"fzs8l_?<Aᘵ+LJ9Ռ .K;$ݗ=TХԭXb<-K؊h!JqS9YBO }l%$?o'aҳ[c_>~3FL߯?1˚߹~{T+~$&؎rJ0JD~;{Nb6$I9Ẹu̫lvzy4keW (nOXkgZC(o ? ;=IJT}c!zog.x&YT?BJFE//?lMRP-4䚖_oK/x>9C/#~]7 0kjw?Xd1xaʃjJɺ_j1gЧsJ=`gU)%OF|6no߂EC[zu7zr2ϟ$UDB63=ei" x_iGG2X~jkc_sF~3/,V=˧.ڀ`#_o ;'uݖ`uckWe-5>Yst~- =KM[~n&hZǏ8@;DG/<{%Y03^dO\/|}97Ёhf~7r~N9|r)>$C{}Ti3= ~3N=__~7,oj)Yx?D%iCy:55%_gil  Bϊ$?$}/sY99s!7^c˺.@_zS)bG~u/몚ݫ9>^ /6BS/u%EGPݟ`vu?[\e F7ƿ{F5GCJ`2,A7zt#"AXGֺެ|D`.A ~vW"x= ra&br#z{ݙO9Wg].x;B^rD(djŝau=8DF!Y2O|AWx9>'9w7 ̋>o,f5?FMk19c^"^n&66PL~>e>·=4P?!*~͔~Ep=rkgSz1_@?B.߫>N׶1OG-}~ei.j1Duםa?kȓzg0 ?-Ŝӥ//czG$&,;fX<+q^W5&~C^?} = 䍅̷ $`<渚xV.O܎R^K6x=ґ9Y~~GCzs;g$ݯ|J-g{Џ)-}WRo.䳪B#}6"+޻;&G%K;?ޝj Vɏ%wj^ecjJCs^N|VU;D=J{)R-m~_x/ /3p);#WA5hMZz}o586ǥv`?,Oُwizf "|ëCO6>eR*bƽʗf6j|.)U zׄOh7|W#XOoKϼ}\z:9>?{AyV>v%xy4_Op)"N_\}GW!z=O o|Y\Tw'I\}+Yg鼗҃|`cue9$L\S=|s}x]7}?5?9eg_BpN4OU_t)T"'opěTG)j>=m;ﻟ}aJc_=dMmobogz]R3.bwGKoį O'o~t=|K!Clε؁[nwN/RˑR/SwF޵yag62?R78I\zOy\~ݠs;qz|G5#XGщ~7 Jf Ԑb%t򛛗ѷ櫽mHdxc/heR,~GˡK3g O &i\į`!znTV݌6oWA_O꺘AwXn&: w͂q*i}7@v%yn}w?m>0:?Ȱ滽 0_U zJ΋b{/ÿt)hy!h?+Ix_>*o/}{䪀G}mL=UԳy7Zẏ:'4tj҅q6=~fsKaa^3G}j *C?jPסk|CnƕNeo7a;p_sbu =Wz@~ȷix욐1Яlsw Mom|uЅɂi~9 9?u]C;[yGk?A?{ w?j}`W'[,Q|Q_Uĥ *P^;.ez6ZA"-AK-|@o}n`z;y~@Kl6GAG˯s>@\O-vo/vtcƱ=s!|j$oNhms^4Ҽ@j›B]{kc~7~L_ p7ye*cαC翝tX,Y7˽={wtB[C-wǤﬔ!TO9{Q{Gy^@l(}Sg *Z ~꿚\A;_?`#eo˧Wƺlv2` ~SVW/ys12U^;/uy37842`m<͸Rz=?UTu~筢[>z4?a ^赀0NW;5ԣHoyȱ% aZڇΟժkqWVi^H,~S5F._p.)\cD[SEJgVx*|Aӂ~(p)~M[Eyz󸤢_Jc,UܳyESξOF?[m!h|Oy9Uj?r_yaMOWvcuU/;x$wCkؤOR{-9:fgeYh:.iVKfb]E}HTbLeеV/\ ?ιF0-o7"Ɵ&4Νt~G#?M.}|A HUQS?G'7~n{ęwA{}慽 BSRhg^SX9?n'n .b9،m(kC,~+0{7 ~uuqTQxm6iZRo$6i}˚M&!M ^2;wm"ZHPR im41]MHc"J*RԙΞ!aιs;s̹wKY{u{3SWO+ط3qrKHb\XӽDG{o{;Sӈ9=X^{ 9ڧn:Lu|octg߆}#Pa{| Nr}|_(}ü:}ȧا|q'Wun=Lq=|).`=#ć~5տ_ޞCsڻ  f/nGLgi,>~9c'Mc^z~NwM#}ȑ%wzo[OϏߟ _v[s[VW'X?C]]4aݪxouy9_nqE!, f) ~z_` c?#7 ְ25 b Ή\g(ܾ쏼ssc!sGd[SX_eCka{g t]yD@pA?oNA~z30.t=B, ".\;C0El(JԎm~Sc(6;!›zNۆ a#,5[9z7hۖYOe˞+-1) ^zz1=󋗋cauM\>!6Q \C_N nϲ)6OOMWNT7?eE2BFhF8K9[2uEPvUfT6Uf'L3uRIʸ.;oh۫ c~yPݴ_Nvb-[=qed!յj'c3~kvBG8MS}+Z *e`G6צҶ݊uPfMPAde]u.6އ<,tijð<h~[y2 Oۇrz' GSشaD&a˨;{a;J׋m<ܬ]er5Vt/E w`t'y.F'dtF'n&n&n&n&n&n&n&n&n&nnnnnn*`t'w0z'w1 F'p;kfR nۈҖzUC093e''%cN'}WF@9Vu@ }`p$\@.XC>G@R/_@Zsq ̼+@=%9|@nm 4<p@_ ψ7c@eO˶V@ CY9b !s@#yFD$`QL@(:vb(w$@*+&#@-. +gL@-r/$W@0 I^0aO@0= <0J@1يjMj0sR q@1& g0dːt@1wӃ0@3CN21DO^@3Y 1Q}@<@2w1բx@3u1t2N@4'C/2!@52T=47rjI@45T*칯@7x8?Nm@8@q9I,@;!uP9Q @;8UBl>'@10){ pplines[3] <- paste( 'NPV = ',mat[2,2], '/', mat[2,4], ' = ', round(mat[2,2]/mat[2,4], 4), sep='') } print(mat, na.print='') cat(paste(pplines, collapse='\n'),"\n\n") invisible(mat[-3,-3]) } TeachingDemos/R/range.R0000644000175100001440000000202112657235445014432 0ustar hornikusers`%<%` <- function(x,y) { xx <- attr(x,'orig.y') yy <- attr(y,'orig.x') if(is.null(xx)) { xx <- x x <- rep(TRUE, length(x)) } if(is.null(yy)) { yy <- y y <- rep(TRUE, length(y)) } out <- x & y & (xx < yy) attr(out, 'orig.x') <- xx attr(out, 'orig.y') <- yy out } `%<=%` <- function(x,y) { xx <- attr(x,'orig.y') yy <- attr(y,'orig.x') if(is.null(xx)) { xx <- x x <- rep(TRUE, length(x)) } if(is.null(yy)) { yy <- y y <- rep(TRUE, length(y)) } out <- x & y & (xx <= yy) attr(out, 'orig.x') <- xx attr(out, 'orig.y') <- yy out } x <- -3:3 -2 %<% x %<% 2 c( -2 %<% x %<% 2 ) x[ -2 %<% x %<% 2 ] x[ -2 %<=% x %<=% 2 ] x <- rnorm(100) y <- rnorm(100) x[ -1 %<% x %<% 1 ] range( x[ -1 %<% x %<% 1 ] ) cbind(x,y)[ -1 %<% x %<% y %<% 1, ] cbind(x,y)[ (-1 %<% x) %<% (y %<% 1), ] cbind(x,y)[ ((-1 %<% x) %<% y) %<% 1, ] cbind(x,y)[ -1 %<% (x %<% (y %<% 1)), ] cbind(x,y)[ -1 %<% (x %<% y) %<% 1, ] # oops TeachingDemos/R/dots2.R0000644000175100001440000000112612657235444014375 0ustar hornikusers"dots2" <- function( x, y, colx='green', coly='blue', lab1 = deparse(substitute(x)), lab2 = deparse(substitute(y)), ... ){ sx1 <- sort(x) sy1 <- unlist(lapply(table(sx1),seq)) sx2 <- sort(y) sy2 <- unlist(lapply(table(sx2),seq)) sy1 <- sy1/ (max(sy1,sy2)+2) sy2 <- sy2/ (max(sy1,sy2)+2) + 1 plot( c(sx1,sx2), c(sy1,sy2), xlab="", ylab="", yaxt="n",ylim=c(0,2), type="n",...) points( sx1, sy1, col=colx,...) points( sx2, sy2, col=coly,...) axis(2, at=c(0.5,1.5), labels= c(lab1,lab2),srt=90,tick=FALSE) } TeachingDemos/R/mle.demo.R0000644000175100001440000000607512657235444015052 0ustar hornikusers"mle.demo" <- function(x=rnorm(10, 10, 2), start.mean = mean(x)-start.sd, start.sd = 1.2* sqrt(var(x)) ){ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package.') if(!exists('slider.env')) slider.env <<- new.env() mu <- start.mean; assign('mu',tcltk::tclVar(mu),envir=slider.env) sig <- start.sd; assign('sig',tcltk::tclVar(sig),envir=slider.env) .mu <- .sig <- .ll <- numeric(0) mle.refresh <- function(...){ mu <- as.numeric(evalq(tcltk::tclvalue(mu), envir=slider.env)) sig <- as.numeric(evalq(tcltk::tclvalue(sig), envir=slider.env)) old.par <- par(no.readonly=T) on.exit(par(old.par)) par(mar=c(5,4,0,2)+.1) .mu <<- c(.mu, mu) .sig <<- c(.sig, sig) ll <- sum( dnorm(x, mu, sig, TRUE) ) .ll <<- c(.ll,ll) layout( matrix( 1:3, ncol=1 ), heights=c(2,1,1)) xx <- seq( min(x) - 1.2 * (max(x)-min(x)), max(x) + 1.2 * (max(x)-min(x)), length=250) plot(xx, dnorm(xx, mu, sig), type='l', ylim=c(0,dnorm(0,0,0.5*sqrt(var(x)))),xlab='x', ylab='Likelihood') segments(x, 0, x, dnorm(x, mu, sig)) points(x,dnorm(x, mu, sig)) points(x,rep(0,length(x))) text(xx[1], dnorm(0,0,0.5*sqrt(var(x)))*.9, paste("Log Likelihood =", format(ll, digit=5)), adj=0,cex=3) plot(.mu, .ll, xlab=expression(mu), ylab='Log Likelihood') points(mu,ll, pch=16, col='red') plot(.sig, .ll, xlab=expression(sigma), ylab='Log Likelihood') points(sig, ll, pch=16, col='red') } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'Maximum Likelihood Estimation') tcltk::tkwm.geometry(m, '+0+0') # mu tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='mu', width='10'), side='right') tmp <- pretty( c( start.mean - 2*start.sd, start.mean + 3*start.sd), 100) tcltk::tkpack(sc <- tcltk::tkscale(fr, command=mle.refresh, from=min(tmp), to=max(tmp), orient='horiz', resolution=tmp[2] - tmp[1],showvalue=T), side='left') assign('sc',sc, envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=mu), envir=slider.env) # sigma tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='sigma', width='10'), side='right') tmp <- pretty( c( 0.5*start.sd, 2*start.sd), 100) tcltk::tkpack(sc <- tcltk::tkscale(fr, command=mle.refresh, from=min(tmp), to=max(tmp), orient='horiz', resolution=tmp[2]-tmp[1], showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sig), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=mle.refresh), side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') return(invisible(x)) } TeachingDemos/R/slider.R0000644000175100001440000000704212657235445014630 0ustar hornikusersslider <- function (sl.functions, sl.names, sl.mins, sl.maxs, sl.deltas, sl.defaults, but.functions, but.names, no, set.no.value, obj.name, obj.value, reset.function, title) { # slightly modified by J. Fox from the TeachingDemos package requireNamespace('tcltk', quietly = TRUE) if (!missing(no)) return(as.numeric(tcltk::tclvalue(get(paste("slider", no, sep = ""), envir = slider.env)))) if (!missing(set.no.value)) { try(eval(parse(text = paste("tcltk::tclvalue(slider", set.no.value[1], ")<-", set.no.value[2], sep = "")), envir = slider.env)) return(set.no.value[2]) } if (!exists("slider.env")) slider.env <<- new.env() if (!missing(obj.name)) { if (!missing(obj.value)) assign(obj.name, obj.value, envir = slider.env) else obj.value <- get(obj.name, envir = slider.env) return(obj.value) } if (missing(title)) title <- "slider control widget" nt <- tcltk::tktoplevel() tcltk::tkwm.title(nt, title) tcltk::tkwm.geometry(nt, "+0+0") if (missing(sl.names)) sl.names <- NULL if (missing(sl.functions)) sl.functions <- function(...) { } for (i in seq(sl.names)) { eval(parse(text = paste("assign('slider", i, "',tcltk::tclVar(sl.defaults[i]),envir=slider.env)", sep = ""))) tcltk::tkpack(fr <- tcltk::tkframe(nt)) lab <- tcltk::tklabel(fr, text = sl.names[i], width = "25") sc <- tcltk::tkscale(fr, from = sl.mins[i], to = sl.maxs[i], showvalue = T, resolution = sl.deltas[i], orient = "horiz") tcltk::tkpack(lab, sc, side = "right") assign("sc", sc, envir = slider.env) eval(parse(text = paste("tcltk::tkconfigure(sc,variable=slider", i, ")", sep = "")), envir = slider.env) sl.fun <- if (length(sl.functions) > 1) sl.functions[[i]] else sl.functions if (!is.function(sl.fun)) sl.fun <- eval(parse(text = paste("function(...){", sl.fun, "}"))) tcltk::tkconfigure(sc, command = sl.fun) } assign("slider.values.old", sl.defaults, envir = slider.env) tcltk::tkpack(f.but <- tcltk::tkframe(nt), fill = "x") tcltk::tkpack(tcltk::tkbutton(f.but, text = "Exit", command = function() tcltk::tkdestroy(nt)), side = "right") if (!missing(reset.function)){ if (!is.function(reset.function)) reset.function <- eval(parse(text = paste("function(...){", reset.function, "}"))) tcltk::tkpack(tcltk::tkbutton(f.but, text = "Reset", command = function() { for (i in seq(sl.names)) eval(parse(text = paste("tcltk::tclvalue(slider", i, ")<-", sl.defaults[i], sep = "")), envir = slider.env) reset.function() }), side = "right") } if (missing(but.names)) but.names <- NULL for (i in seq(but.names)) { but.fun <- if (length(but.functions) > 1) but.functions[[i]] else but.functions if (!is.function(but.fun)) but.fun <- eval(parse(text = paste("function(...){", but.fun, "}"))) tcltk::tkpack(tcltk::tkbutton(f.but, text = but.names[i], command = but.fun), side = "left") cat("button", i, "eingerichtet") } invisible(nt) } TeachingDemos/R/TkBuildDist.R0000644000175100001440000001450712657235445015534 0ustar hornikusersTkBuildDist <- function( x=seq(min+(max-min)/nbin/2, max-(max-min)/nbin/2, length.out=nbin), min=0, max=10, nbin=10, logspline=TRUE, intervals=FALSE) { if(logspline) logspline <- requireNamespace('logspline', quietly=TRUE) requireNamespace('tkrplot', quietly = TRUE) xxx <- x brks <- seq(min, max, length.out=nbin+1) nx <- seq( min(brks), max(brks), length.out=250 ) lx <- ux <- 0 first <- TRUE replot <- if(logspline) { if(intervals) { function() { hist(xxx, breaks=brks, probability=TRUE,xlab='', main='') xx <- cut(xxx, brks, labels=FALSE) fit <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ) lines( nx, logspline::doldlogspline(nx,fit), lwd=3 ) if(first) { first <<- FALSE lx <<- grconvertX(min, to='ndc') ux <<- grconvertX(max, to='ndc') } } } else { function() { hist(xxx, breaks=brks, probability=TRUE,xlab='', main='') fit <- logspline::logspline( xxx ) lines( nx, logspline::dlogspline(nx,fit), lwd=3 ) if(first) { first <<- FALSE lx <<- grconvertX(min, to='ndc') ux <<- grconvertX(max, to='ndc') } } } } else { function() { hist(xxx, breaks=brks, probability=TRUE,xlab='',main='') if(first) { first <<- FALSE lx <<- grconvertX(min, to='ndc') ux <<- grconvertX(max, to='ndc') } } } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Distribution Builder") img <- tkrplot::tkrplot(tt, replot, vscale=1.5, hscale=1.5) tcltk::tkpack(img, side='top') tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)), side='right') iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image'))) mouse1.down <- function(x,y) { tx <- (as.numeric(x)-1)/iw ux <- (tx-lx)/(ux-lx)*(max-min)+min xxx <<- c(xxx,ux) tkrplot::tkrreplot(img) } mouse2.down <- function(x,y) { if(length(xxx)) { tx <- (as.numeric(x)-1)/iw ux <- (tx-lx)/(ux-lx)*(max-min)+min w <- which.min( abs(xxx-ux) ) xxx <<- xxx[-w] tkrplot::tkrreplot(img) } } tcltk::tkbind(img, '', mouse1.down) tcltk::tkbind(img, '', mouse2.down) tcltk::tkbind(img, '', mouse2.down) tcltk::tkwait.window(tt) out <- list(x=xxx) if(logspline) { if( intervals ) { xx <- cut(xxx, brks, labels=FALSE) out$logspline <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ) } else { out$logspline <- logspline::logspline(xxx) } } if(intervals) { out$intervals <- table(cut(xxx, brks)) } out$breaks <- brks return(out) } TkBuildDist2 <- function( min=0, max=1, nbin=10, logspline=TRUE) { if(logspline) logspline <- requireNamespace(logspline, quietly=TRUE) requireNamespace('tkrplot', quietly=TRUE) xxx <- rep( 1/nbin, nbin ) brks <- seq(min, max, length.out=nbin+1) nx <- seq( min, max, length.out=250 ) lx <- ux <- ly <- uy <- 0 first <- TRUE replot <- if(logspline) { function() { barplot(xxx, width=diff(brks), xlim=c(min,max), space=0, ylim=c(0,0.5), col=NA) axis(1,at=brks) xx <- rep( 1:nbin, round(xxx*100) ) capture.output(fit <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )) lines( nx, logspline::doldlogspline(nx,fit)*(max-min)/nbin, lwd=3 ) if(first) { first <<- FALSE lx <<- grconvertX(min, to='ndc') ly <<- grconvertY(0, to='ndc') ux <<- grconvertX(max, to='ndc') uy <<- grconvertY(0.5, to='ndc') } } } else { function() { barplot(xxx, width=diff(brks), xlim=range(brks), space=0, ylim=c(0,0.5), col=NA) axis(at=brks) if(first) { first <<- FALSE lx <<- grconvertX(min, to='ndc') ly <<- grconvertY(0, to='ndc') ux <<- grconvertX(max, to='ndc') uy <<- grconvertY(0.5, to='ndc') } } } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Distribution Builder") img <- tkrplot::tkrplot(tt, replot, vscale=1.5, hscale=1.5) tcltk::tkpack(img, side='top') tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)), side='right') iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image'))) ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image'))) md <- FALSE mouse.move <- function(x,y) { if(md) { tx <- (as.numeric(x)-1)/iw ty <- 1-(as.numeric(y)-1)/ih w <- findInterval(tx, seq(lx,ux, length=nbin+1)) if( w > 0 && w <= nbin && ty >= ly && ty <= uy ) { xxx[w] <<- 0.5*(ty-ly)/(uy-ly) xxx[-w] <<- (1-xxx[w])*xxx[-w]/sum(xxx[-w]) tkrplot::tkrreplot(img) } } } mouse.down <- function(x,y) { md <<- TRUE mouse.move(x,y) } mouse.up <- function(x,y) { md <<- FALSE } tcltk::tkbind(img, '', mouse.move) tcltk::tkbind(img, '', mouse.down) tcltk::tkbind(img, '', mouse.up) tcltk::tkwait.window(tt) out <- list(breaks=brks, probs=xxx) if(logspline) { xx <- rep( 1:nbin, round(xxx*100) ) out$logspline <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ) } return(out) } TeachingDemos/R/roll.rgl.die.R0000644000175100001440000000166212657235445015643 0ustar hornikusersroll.rgl.die <- function( side=sample(6,1), steps=250 ) { rgl::rgl.viewpoint(45,45) tmp <- seq(45, by=90, length=4) tmp2 <- c(-1,1,-1,1) for (j in 1:4) { for (i in seq(0,90,length=steps)) { rgl::rgl.viewpoint(tmp[j]+i, -tmp2[j]*45+tmp2[j]*i) } } if( side==1 ){ for(i in seq(0,45, length=steps/2)) { rgl::rgl.viewpoint(45+i, 45+i) } } else if( side==6 ) { for(i in seq(0,90, length=steps)) { rgl::rgl.viewpoint(45+i, 45-i) } for(i in seq(0,45, length=steps/2)) { rgl::rgl.viewpoint(135+i, -45-i) } } else { tmp3 <- c(NA,3,0,2,1)[side] for(j in seq(1,length=tmp3)){ for(i in seq(0,90,length=steps)) { rgl::rgl.viewpoint(tmp[j]+i, -tmp2[j]*45+tmp2[j]*i) } } for(i in seq(0,45, length=steps/2)) { rgl::rgl.viewpoint(tmp[tmp3+1]+i, -tmp2[tmp3+1]*45+tmp2[tmp3+1]*i) } } return(side) } TeachingDemos/R/dots.R0000644000175100001440000000023312657235444014311 0ustar hornikusers"dots" <- function(x,...){ sx <- sort(x) sy <- unlist(lapply(table(sx),seq)) plot(sx,sy, xlab=deparse(substitute(x)), ylab="Count",...) } TeachingDemos/R/spread.labs.R0000644000175100001440000000172012657235445015541 0ustar hornikusersspread.labs <- function(x, mindiff, maxiter=1000, stepsize=1/10, min=-Inf, max=Inf) { unsort <- order(order(x)) x <- sort(x) df <- x[-1] - x[ -length(x) ] stp <- mindiff * stepsize i <- 1 while( any( df < mindiff ) ) { tmp <- c( df < mindiff, FALSE ) if( tmp[1] && (x[1] - stp) < min ) { # don't move bottom set tmp2 <- as.logical( cumprod(tmp) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp ] - stp tmp <- c( FALSE, df < mindiff ) if( tmp[length(tmp)] && (x[length(x)] + stp) > max ) { # don't move top tmp2 <- rev( as.logical( cumprod( rev(tmp) ) ) ) tmp <- tmp & !tmp2 } x[ tmp ] <- x[ tmp] + stp df <- x[-1] - x[-length(x)] i <- i + 1 if( i > maxiter ) { warning("Maximum iterations reached") break } } x[unsort] } TeachingDemos/R/ineq.R0000644000175100001440000000303112657235444014273 0ustar hornikusers#Here are a couple of function definitions that may be more intuitive for some people (see the examples below the function defs). They are not perfect, but my tests showed they work left to right, right to left, outside in, but not inside out. `%<%` <- function(x,y) { xx <- attr(x,'orig.y') yy <- attr(y,'orig.x') if(is.null(xx)) { xx <- x x <- rep(TRUE, length(x)) } if(is.null(yy)) { yy <- y y <- rep(TRUE, length(y)) } out <- x & y & (xx < yy) attr(out, 'orig.x') <- xx attr(out, 'orig.y') <- yy out } `%<=%` <- function(x,y) { xx <- attr(x,'orig.y') yy <- attr(y,'orig.x') if(is.null(xx)) { xx <- x x <- rep(TRUE, length(x)) } if(is.null(yy)) { yy <- y y <- rep(TRUE, length(y)) } out <- x & y & (xx <= yy) attr(out, 'orig.x') <- xx attr(out, 'orig.y') <- yy out } # # x <- -3:3 # # -2 %<% x %<% 2 # c( -2 %<% x %<% 2 ) # x[ -2 %<% x %<% 2 ] # x[ -2 %<=% x %<=% 2 ] # # # x <- rnorm(100) # y <- rnorm(100) # # x[ -1 %<% x %<% 1 ] # range( x[ -1 %<% x %<% 1 ] ) # # # cbind(x,y)[ -1 %<% x %<% y %<% 1, ] # cbind(x,y)[ (-1 %<% x) %<% (y %<% 1), ] # cbind(x,y)[ ((-1 %<% x) %<% y) %<% 1, ] # cbind(x,y)[ -1 %<% (x %<% (y %<% 1)), ] # cbind(x,y)[ -1 %<% (x %<% y) %<% 1, ] # oops TeachingDemos/R/tkBrush.R0000644000175100001440000001175212657235445014773 0ustar hornikuserstkBrush <- function(mat,hscale=1.75,vscale=1.75,wait=TRUE,...){ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') first <- TRUE bp <- FALSE cols <- character(0) colhist <- function(x,...){ tmp <- hist(x,plot=F) br <- tmp$breaks w <- as.numeric(cut(x,br,include.lowest=TRUE)) sy <- unlist(lapply(tmp$counts,function(x)seq(length=x))) my <- max(sy) sy <- sy/my my <- 1/my sy <- sy[order(order(x))] tmp.usr <- par('usr'); on.exit(par(usr=tmp.usr)) par(usr=c(tmp.usr[1:2],0,1.5)) rect(br[w], sy-my, br[w+1], sy, col=cols, border=NA) rect(br[-length(br)], 0, br[-1], tmp$counts*my) if(first){ # tmp <- cnvrt.coords((br[w]+br[w+1])/2,sy-my/2,'usr')$tdev tmp <- list( x=grconvertX((br[w]+br[w+1])/2, to='ndc'), y=grconvertY( sy-my/2, to='ndc') ) dx <<- c(dx,tmp$x) dy <<- c(dy,tmp$y) di <<- c(di,seq(along=tmp$x)) } } pcols <- rep('black',nrow(mat)) tcols <- rep(NA,nrow(mat)) ppch <- rep(1,nrow(mat)) tpch <- rep(NA,nrow(mat)) dx <- dy <- di <- numeric(0) rx <- ry <- 0.5 rw <- rh <- 0.05 epch<-tcltk::tclVar(16) ecol<-tcltk::tclVar('red') devlims <- c(0.05,0.95,0.05,0.95) replot <- function(){ if(first){ cols <<- pcols pairs(mat, #upper.panel=NULL, panel=function(x,y,...){ points(x,y,...) # tmp <- cnvrt.coords(x,y,'usr')$tdev tmp <- list( x=grconvertX(x,to='ndc'), y=grconvertY(y,to='ndc') ) dx <<- c(dx,tmp$x) dy <<- c(dy,tmp$y) di <<- c(di,seq(tmp$x)) }, diag.panel=colhist) first <<- FALSE } else { cols <<- ifelse(is.na(tcols),pcols,tcols) pairs(mat, #upper.panel=NULL, diag.panel=colhist, pch=ifelse(is.na(tpch),ppch,tpch), col=ifelse(is.na(tcols),pcols,tcols)) par(fig=c(0,1,0,1),plt=c(0,1,0,1),usr=c(0,1,0,1),xpd=TRUE) rect(rx-rw,ry,rx,ry+rh,border='green') } } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt,"Tk Brush") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img,side='left') tcltk::tkpack( tcltk::tklabel(tt,text='pch:'),side='top') tcltk::tkpack(tcltk::tkentry(tt,textvariable=epch),side='top') tcltk::tkpack( tcltk::tklabel(tt,text='Color:'),side='top') tcltk::tkpack( tcltk::tkentry(tt,textvariable=ecol),side='top') tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function()tcltk::tkdestroy(tt)), side='bottom') iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image'))) ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image'))) mm <- function(x,y){ tx <- (as.numeric(x)-1)/iw ty <- 1-(as.numeric(y)-1)/ih if(tx-rw < devlims[1]) tx <- devlims[1]+rw if(tx > devlims[2]) tx <- devlims[2] if(ty < devlims[3]) ty <- devlims[3] if(ty+rh > devlims[4]) ty <- devlims[4] - rh rx <<- tx ry <<- ty tmp <- di[ dx >= rx-rw & dx <= rx & dy >= ry & dy <= ry+rh ] tmpc <- rep(NA,nrow(mat)) tmpcol <- as.character(tcltk::tclvalue(ecol)) if( !( tmpcol %in% colors() ) ) tmpcol <- 'black' tmpc[tmp] <- tmpcol tcols <<- tmpc tmpp <- rep(NA,nrow(mat)) tmppch <- as.numeric(tcltk::tclvalue(epch)) if(is.na(tmppch)) tmppch <- as.character(tcltk::tclvalue(epch)) tmpp[tmp] <- tmppch tpch <<- tmpp if(bp){ ppch <<- ifelse(is.na(tpch),ppch,tpch) pcols <<- ifelse(is.na(tcols),pcols,tcols) } tkrplot::tkrreplot(img) } mmm <- function(){ tmp <- di[ dx >= rx-rw & dx <= rx & dy >= ry & dy <= ry+rh ] tmpc <- rep(NA,nrow(mat)) tmpcol <- as.character(tcltk::tclvalue(ecol)) if( !( tmpcol %in% colors() ) ) tmpcol <- 'black' tmpc[tmp] <- tmpcol tcols <<- tmpc tmpp <- rep(NA,nrow(mat)) tmppch <- as.numeric(tcltk::tclvalue(epch)) if(is.na(tmppch)) tmppch <- as.character(tcltk::tclvalue(epch)) tmpp[tmp] <- tmppch tpch <<- tmpp if(bp){ ppch <<- ifelse(is.na(tpch),ppch,tpch) pcols <<- ifelse(is.na(tcols),pcols,tcols) } tkrplot::tkrreplot(img) } tcltk::tkbind(img, '', mm) tcltk::tkbind(img, '', function() {bp<<-TRUE;mmm()}) tcltk::tkbind(img, '', function() bp<<-FALSE) tcltk::tkbind(tt, '',function(){rh <<- rh+0.01;mmm()}) tcltk::tkbind(tt, '',function(){rh <<- rh-0.01;mmm()}) tcltk::tkbind(tt, '',function(){rw <<- rw+0.01;mmm()}) tcltk::tkbind(tt, '',function(){rw <<- rw-0.01;mmm()}) if(wait){ tcltk::tkwait.window(tt) return(list(col=pcols, pch=ppch)) } else { return(invisible(NULL)) } } TeachingDemos/R/dice.R0000644000175100001440000000133012657235444014243 0ustar hornikusers"dice" <- function(rolls=1, ndice=2, sides=6, plot.it=FALSE, load=rep(1,sides)) # Simulate the tossing of some dice. # rolls is the number of times to roll the dice # ndice is the number of dice to roll each time # sides is the number of sides to the dice # load is how the dice are loaded, can be though of as odds { temp <- matrix( sample(sides, ndice*rolls, TRUE, load), ncol=ndice ) temp <- as.data.frame(temp) names(temp) <- c("Red","Green","Blue","Black","Yellow","Purple", "Orange","Brown","Grey","White")[1:ndice] #if(ndice==1) return(temp$Red) oldClass(temp) <- c("dice","data.frame") if(plot.it){ plot.dice(temp) return(invisible(temp)) } temp } TeachingDemos/R/vis.normal.R0000644000175100001440000001146312657235445015440 0ustar hornikusers"vis.normal" <- function(){ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package') if(!exists('slider.env')) slider.env<<-new.env() #library(tcltk) mu <- 0; assign('mu',tcltk::tclVar(mu),envir=slider.env) sd <- 1; assign('sd',tcltk::tclVar(sd),envir=slider.env) s2 <- 1; assign('s2',tcltk::tclVar(s2),envir=slider.env) xmin <- -5; assign('xmin',tcltk::tclVar(xmin),envir=slider.env) xmax <- 5; assign('xmax',tcltk::tclVar(xmax),envir=slider.env) ymin <- 0; assign('ymin',tcltk::tclVar(ymin),envir=slider.env) ymax <- round(dnorm(0,0,.5),2); assign('ymax',tcltk::tclVar(ymax),envir=slider.env) sd.old <- sd s2.old <- s2 norm.refresh <- function(...){ mu <- as.numeric(evalq(tcltk::tclvalue(mu), envir=slider.env)) sd <- as.numeric(evalq(tcltk::tclvalue(sd), envir=slider.env)) s2 <- as.numeric(evalq(tcltk::tclvalue(s2), envir=slider.env)) if(sd != sd.old) { s2 <- round(sd^2,5); # assign('s2',tclVar(s2),envir=slider.env) try(eval(parse(text=paste("tcltk::tclvalue(s2)<-", s2,sep="")),envir=slider.env)); sd.old <<- sd; s2.old <<- s2 } if(s2 != s2.old) { s2 <- as.numeric(evalq(tcltk::tclvalue(s2), envir=slider.env)) sd <- round(sqrt(s2),5); # assign('sd',tclVar('sd'), envir=slider.env) try(eval(parse(text=paste("tcltk::tclvalue(sd)<-", sd,sep="")),envir=slider.env)); sd.old <<- sd; s2.old <<- s2 } xmin <- as.numeric(evalq(tcltk::tclvalue(xmin), envir=slider.env)) xmax <- as.numeric(evalq(tcltk::tclvalue(xmax), envir=slider.env)) ymin <- as.numeric(evalq(tcltk::tclvalue(ymin), envir=slider.env)) ymax <- as.numeric(evalq(tcltk::tclvalue(ymax), envir=slider.env)) xx <- seq(xmin,xmax, length=500) yy <- dnorm(xx,mu,sd) plot(xx,yy,type='l', xlim=c(xmin,xmax), ylim=c(ymin,ymax), ylab='',xlab='x') lines(c(mu,mu),c(par('usr')[3],dnorm(0,0,sd)), lty=2, col='blue') lines(c(mu,mu+sd), dnorm(sd,0,sd)*c(1,1), lty=2, col='blue') } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'Visualizing the Normal Distribution') tcltk::tkwm.geometry(m,'+0+0') # mean tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Mean', width='20'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=norm.refresh, from=-3, to=3, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=mu),envir=slider.env) # sd tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Standard Deviation', width='20'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=norm.refresh, from=.5, to=3, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sd),envir=slider.env) # variance tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Variance', width='20'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=norm.refresh, from=.25, to=9, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=s2),envir=slider.env) # xmin tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Xmin:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=xmin), envir=slider.env) # xmax tcltk::tkpack(tcltk::tklabel(fr, text='Xmax:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=xmax), envir=slider.env) # ymin tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Ymin:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=ymin), envir=slider.env) # ymax tcltk::tkpack(tcltk::tklabel(fr, text='Ymax:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=ymax), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=norm.refresh),side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } TeachingDemos/R/cal.R0000644000175100001440000000650612657235444014110 0ustar hornikuserscal <- function(month, year) { yyy <- FALSE if(missing(year) && missing(month)) { # no args, use current month tmp <- as.POSIXlt(Sys.time()) year <- tmp$year+1900 month <- tmp$mon+1 } else if( missing(year) && is.numeric(month) && month > 12 ) { # switch month to year year <- month yyy <- TRUE } else if( missing(year) ) { # use current year tmp <- as.POSIXlt(Sys.time()) year <- tmp$year+1900 } else if( missing(month) ) { # no month do year yyy <- TRUE } if(yyy) { # year calendar par(mfrow=c(4,3),oma=c(0,0,3.5,0)) tmp <- seq( from=ISOdate(year,1,1), to=ISOdate(year,12,31), by='days' ) tmp2 <- as.POSIXlt(tmp) wd <- tmp2$wd par(mar=c(1.5,1.5,2.5,1.5)) for(i in 1:12){ w <- (tmp2$mon+1) == i cs <- cumsum(wd[w]==0) if(cs[1] > 0) cs <- cs - 1 nr <- max( cs ) + 1 plot.new() plot.window( xlim=c(0,6), ylim=c(0,nr+1) ) text( wd[w], nr - cs -0.5 , tmp2$mday[w] ) title( main=month.name[i] ) text( 0:6, nr+0.5, c('S','M','T','W','T','F','S') ) mtext( year, outer=TRUE, line=1, cex=2 ) } } else { # month calendar if( is.character(month) ) { tmp <- pmatch( tolower(month), tolower(month.name) ) if( is.na(tmp) ) { tmp <- pmatch( month, as.character(1:12)) } if( is.na(tmp) ) { warning('Unable to match month, using current month') tmp <- as.POSIXlt(Sys.time()) month <- tmp$mon+1 } else { month <- tmp } } ld <- seq( from=ISOdate(year,month,1), length=2, by='months')[2]-86400 days <- seq( from=ISOdate(year,month,1), to=ld, by='days') tmp <- as.POSIXlt(days) wd <- tmp$wday cs <- cumsum(wd == 0) if(cs[1] > 0) cs <- cs - 1 nr <- max(cs) + 1 par(oma=c(0.1,0.1,4.6,0.1)) par(mfrow=c(nr,7)) par(mar=c(0,0,0,0)) for(i in seq_len(wd[1])){ plot.new() # box() } day.name <- c('Sun','Mon','Tues','Wed','Thur','Fri','Sat') for(i in tmp$mday){ plot.new() box() text(0,1, i, adj=c(0,1)) if(i < 8) mtext( day.name[wd[i]+1], line=0.5, at=grconvertX(0.5,to='ndc'), outer=TRUE ) } mtext(month.name[month], line=2.5, at=0.5, cex=1.75, outer=TRUE) #box('inner') #optional invisible(function(day) { day <- day + wd[1] - 1 rr <- day %/% 7 + 1 cc <- day %% 7 + 1 par(mfg=c(rr,cc)) }) } } ### cal(10,2011) ### par(mfg=c(3,2)) # monday oct 10 ### text(.5,.5, 'Some\nText', cex=2) ### ### par(mfg=c(2,3)) #Tues oct 4 ### text(1,1, 'Top Right', adj=c(1,1)) ### ### par(mfg=c(2,4)) # Wed oct 5 ### text(0,0, 'Bottom Left', adj=c(0,0)) ### ### par(mfg=c(6,2)) # oct 31 ### tmp.x <- runif(25) ### tmp.y <- rnorm(25,tmp.x,.1) ### par(usr=c( range(tmp.x), range(tmp.y) ) ) ### points(tmp.x,tmp.y) ### TeachingDemos/R/run.cor2.examp.R0000644000175100001440000001212012657235445016120 0ustar hornikusers"run.old.cor2.examp" <- function(n=100,seed) { if (!missing(seed)){ set.seed(seed) } if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')} x <- scale(matrix(rnorm(2*n,0,1), ncol=2)) x <- x %*% solve( chol( cor(x) ) ) xr <- range(x,-x) r.old <- 0 r2.old <- 0 cor.refresh <- function(...) { r <- slider(no=1) r2 <- slider(no=2) if (r!=r.old){ slider(set.no.value=c(2,r^2)) r.old <<- r r2.old <<- r^2 } else { slider(set.no.value=c(1, ifelse(r<0, -sqrt(r2), sqrt(r2)))) r.old <<- ifelse(r<0, -sqrt(r2), sqrt(r2)) r2.old <<-r2 r <- r.old } if ( r == 1 ) { cmat <- matrix( c(1,0,1,0),2 ) } else if (r == -1) { cmat <- matrix( c(1,0,-1,0),2 ) } else { cmat <- chol( matrix( c(1,r,r,1),2) ) } new.x <- x %*% cmat plot(new.x, xlab='x',ylab='y', xlim=xr, ylim=xr) title(paste("r = ",round(cor(new.x[,1],new.x[,2]),3), "\nr^2 = ",round(r^2,3))) } slider( cor.refresh, c('Correlation','r^2'), c(-1,0), c(1,1), c(0.01,0.01), c(0,0), title="Correlation Demo") } run.cor2.examp <- function(n=100,seed,vscale=1.5,hscale=1.5,wait=FALSE) { if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') if(!missing(seed) ) set.seed(seed) x <- scale(matrix(rnorm(2*n,0,1), ncol=2)) x <- x %*% solve( chol( cor(x) ) ) xr <- range(x) hsc <- tcltk::tclVar() tcltk::tclvalue(hsc) <- hscale vsc <- tcltk::tclVar() tcltk::tclvalue(vsc) <- vscale r <- tcltk::tclVar() tcltk::tclvalue(r) <- 0 r2 <- tcltk::tclVar() tcltk::tclvalue(r2) <- 0 update.r <- function(...) { tmp <- as.numeric(tcltk::tclvalue(r)) tmp2 <- as.numeric(tcltk::tclvalue(r2)) tcltk::tclvalue(r) <- ifelse( tmp < 0, -1,1) * sqrt(tmp2) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) } update.r2 <- function(...) { tmp <- as.numeric(tcltk::tclvalue(r)) tcltk::tclvalue(r2) <- tmp^2 tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) } replot <- function(...) { tmp.r <- as.numeric(tcltk::tclvalue(r)) if( tmp.r == 1 ) { cmat <- matrix( c(1,0,1,0),2 ) } else if( tmp.r == -1 ) { cmat <- matrix( c(1,0,-1,0),2 ) } else { cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) ) } new.x <- x %*% cmat plot(new.x, xlab='x', ylab='y', xlim=xr, ylim=xr) title(paste("r =", round( tmp.r, 3), "\nr^2 =",round(tmp.r^2,3))) } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Cor2 Example") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(fr <- tcltk::tkframe(tfr), side='top',fill='x') tcltk::tkpack(tcltk::tklabel(fr,text='r: '), side='left',anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=r, orient='horizontal', command=update.r2, from=-1, to=1, resolution=0.01), side='right') tcltk::tkpack(fr <- tcltk::tkframe(tfr), side='top',fill='x') tcltk::tkpack(tcltk::tklabel(fr,text='r^2: '),side='left',anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=r2, orient='horizontal', command=update.r, from=0, to=1, resolution=0.01), side='right') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)), side='right',anchor='s') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left') tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait){ tcltk::tkwait.window(tt) tmp.r <- as.numeric(tcltk::tclvalue(r)) if( tmp.r == 1 ) { cmat <- matrix( c(1,0,1,0),2 ) } else if( tmp.r == -1 ) { cmat <- matrix( c(1,0,-1,0),2 ) } else { cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) ) } new.x <- x %*% cmat return( list(x=new.x[,1], y=new.x[,2]) ) } else { return(invisible(NULL)) } } TeachingDemos/R/gp.splot.R0000644000175100001440000000106212657235444015107 0ustar hornikusersgp.splot <- function(x, y, z, add= FALSE, title=deparse(substitute(z)), pipe=gpenv$gp, datafile=tempfile()) { tmp <- datafile gpenv$gp.tempfiles <- c(gpenv$gp.tempfiles, tmp) tmp2 <- data.frame(x=x, y=y, z=z) tmp2 <- tmp2[ order(x,y), ] tmp3 <- split(tmp2, tmp2$x) con <- file(tmp, open='w') sapply( tmp3, function(d) { write.table( d, con, row.names=FALSE, col.names=FALSE ) cat( "\n", file=con ) } ) close(con) cat( ifelse(add, "replot", "splot"), " '", tmp, "' title '", title, "'\n", sep="", file=pipe ) invisible() } TeachingDemos/R/squishplot.R0000644000175100001440000000211212657235445015552 0ustar hornikuserssquishplot <- function(xlim,ylim,asp=1, newplot=TRUE){ if(length(xlim) < 2) stop('xlim must be a vector of length 2') if(length(ylim) < 2) stop('ylim must be a vector of length 2') if(newplot) plot.new() tmp <- par(c('plt','pin','xaxs','yaxs')) if( tmp$xaxs == 'i' ){ # not extended axis range xlim <- range(xlim, na.rm=TRUE) } else { # extended range tmp.r <- diff(range(xlim, na.rm=TRUE)) xlim <- range(xlim, na.rm=TRUE) + c(-1,1)*0.04*tmp.r } if( tmp$yaxs == 'i' ){ # not extended axis range ylim <- range(ylim, na.rm=TRUE) } else { # extended range tmp.r <- diff(range(ylim, na.rm=TRUE)) ylim <- range(ylim, na.rm=TRUE) + c(-1,1)*0.04*tmp.r } tmp2 <- (ylim[2]-ylim[1])/(xlim[2]-xlim[1]) tmp.y <- tmp$pin[1] * tmp2 * asp if(tmp.y < tmp$pin[2]){ # squish vertically par(pin=c(tmp$pin[1], tmp.y)) par(plt=c(tmp$plt[1:2], par('plt')[3:4])) } else { # squish horizontally tmp.x <- tmp$pin[2]/tmp2/asp par(pin=c(tmp.x, tmp$pin[2])) par(plt=c(par('plt')[1:2], tmp$plt[3:4])) } return(invisible(tmp['plt'])) } TeachingDemos/R/TkListView.R0000644000175100001440000001231712657235445015414 0ustar hornikusersTkListView <- function(list) { if( !requireNamespace('tcltk', quietly = TRUE) ) { stop('This function is dependent on the tcltk package') } if( !have.ttk() ) { stop('this function depends on having tcl 8.5 or higher') } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, deparse(substitute(list))) fr1 <- tcltk::tkframe(tt) tcltk::tkpack(fr1, '-side', 'left', '-fill', 'both', '-expand', 0) Sys.sleep(.1) ## needed for some strange reason. tree <- tcltk::ttktreeview(fr1, '-selectmode','browse','-columns',1,height=21) scrtree1 <- tcltk::tkscrollbar(fr1, command=function(...)tcltk::tkyview(tree,...)) scrtree2 <- tcltk::tkscrollbar(fr1, command=function(...)tcltk::tkxview(tree,...), orient='horizontal') tcltk::tkconfigure(tree, yscrollcommand=function(...)tcltk::tkset(scrtree1,...), xscrollcommand=function(...)tcltk::tkset(scrtree2,...)) # tkpack(scrtree1, side='right', fill='y',expand=1) # tkpack(tree, side='right',fill='both',expand=1) tcltk::tkgrid(tree,scrtree1,sticky='nsew') tcltk::tkgrid(scrtree2,sticky='nsew') tcltk::tkgrid.columnconfigure(fr1, 0, weight=1) tcltk::tkgrid.rowconfigure(fr1,0,weight=1) fr2 <- tcltk::tkframe(tt) tcltk::tkpack(fr2, '-side','top','-fill','both','-expand',1) txt <- tcltk::tktext(fr2, bg="white", font="courier", wrap='none', width=40) scrtxt1 <- tcltk::tkscrollbar(fr2, command=function(...)tcltk::tkyview(txt,...)) scrtxt2 <- tcltk::tkscrollbar(fr2, command=function(...)tcltk::tkxview(txt,...), orient='horizontal') tcltk::tkconfigure(txt, yscrollcommand=function(...)tcltk::tkset(scrtxt1,...), xscrollcommand=function(...)tcltk::tkset(scrtxt2,...)) tcltk::tkgrid(txt,scrtxt1, sticky='nsew') tcltk::tkgrid(scrtxt2,sticky='nsew') tcltk::tkgrid.columnconfigure(fr2, 0, weight=1) tcltk::tkgrid.rowconfigure(fr2, 0, weight=1) buildtree <- function(list, tree, parent) { str.info <- capture.output( str(list, max.level=1, give.attr=FALSE, no.list=TRUE) ) str.info <- gsub(' |\t','\\\\ ',str.info) n <- length(list) nms <- names(list) if( is.null(nms) ) nms <- rep('', n) if( n < length(str.info) ) { str.info <- tail(str.info, n) } for( i in seq(length.out=n) ){ id <- paste(parent, '.', i, sep='') nm <- nms[i] if(is.na(nm) || nm == '') nm <- paste0('[[',i,']]') tcltk::tkinsert(tree, parent, 'end', '-id', id, '-text', nm, '-values', str.info[i]) if( is.list(list[[i]]) ){ Recall( list[[i]], tree, id ) } else if( !is.null(attributes(list[[i]])) ) { tcltk::tkinsert(tree, id, 'end','-id', paste(id,'.a',sep=''), '-text', '<>') Recall( attributes(list[[i]]), tree, paste(id,'.a',sep='') ) } } tmp <- as.list(attributes(list)) tmp$names <- NULL if( length(tmp) ) { tcltk::tkinsert(tree, parent, 'end', '-id', paste(parent,'.aa',sep=''), '-text', '<>') Recall( tmp, tree, paste(parent,'.aa',sep='') ) } } tmpvals <- capture.output(str(list,max.level=0)) tmpvals <- gsub(' ','\\\\ ',tmpvals) tcltk::tkinsert(tree,'','end','-id', 0, '-text', deparse(substitute(list)), '-values', tmpvals) buildtree(list, tree, '0') getx <- function(list){ tmp <- tcltk::tclvalue(tcltk::tkselect(tree)) tmp2 <- strsplit(tmp, '\\.')[[1]][-1] if(length(tmp2)==0) return(list) sb <- function(y, list) { if (any( y %in% c('a','aa') ) ) { a <- which(y %in% c('a','aa'))[1] tmp <- if( a==1 ) { as.list(attributes( list ) ) } else { y1 <- y[ seq(length.out=a-1) ] as.list(attributes( list[[ as.numeric(y1) ]] )) } if( a == length(y) ) return(tmp) y2 <- y[ seq( from=a+1, length.out = length(y) - a) ] if( y[a] == 'aa' ) tmp$names <- NULL Recall(y2,tmp) } else { tmp <- as.numeric(y) list[[tmp]] } } sb(tmp2,list) } pr <- tcltk::tkbutton(tt, text='print', command=function(...) { tmp <- capture.output(print(getx(list))) tcltk::tkdelete(txt, '1.0','end') tcltk::tkinsert(txt, 'end', paste(tmp, collapse='\n')) } ) st <- tcltk::tkbutton(tt, text='str', command=function(...) { tmp <- capture.output(print(str(getx(list)))) tcltk::tkdelete(txt, '1.0','end') tcltk::tkinsert(txt, 'end', paste(tmp, collapse='\n')) } ) tcltk::tkpack(pr, side='top', anchor='w') tcltk::tkpack(st, side='top', anchor='w') fr3 <- tcltk::tkframe(tt) tcltk::tkpack(fr3, side='top', expand=1, fill='x') cmd <- tcltk::tclVar('summary(x)') eve <- tcltk::tkentry(fr3, textvariable=cmd) ev <- tcltk::tkbutton(fr3, text='Eval:', command=function(...) { tmp <- capture.output( eval(parse(text=tcltk::tclvalue(cmd)), list(x=getx(list)))) tcltk::tkdelete(txt, '1.0', 'end') tcltk::tkinsert(txt, 'end', paste(tmp, collapse='\n')) } ) tcltk::tkpack(ev, side='left') tcltk::tkpack(eve, side='left') tcltk::tkpack(tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)), side='bottom', anchor='e') invisible(NULL) } TeachingDemos/R/run.old.cor.examp.R0000644000175100001440000000142712657235445016623 0ustar hornikusers"run.old.cor.examp" <- function(n=100,seed) { if (!missing(seed)){ set.seed(seed) } if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')} x <- scale(matrix(rnorm(2*n,0,1), ncol=2)) x <- x %*% solve( chol( cor(x) ) ) xr <- range(x) cor.refresh <- function(...) { r <- slider(no=1) if ( r == 1 ) { cmat <- matrix( c(1,0,1,0),2 ) } else if (r == -1) { cmat <- matrix( c(1,0,-1,0),2 ) } else { cmat <- chol( matrix( c(1,r,r,1),2) ) } new.x <- x %*% cmat plot(new.x, xlab='x',ylab='y', xlim=xr, ylim=xr) title(paste("r = ",round(cor(new.x[,1],new.x[,2]),3))) } slider( cor.refresh, 'Correlation', -1, 1, 0.01, 0, title="Correlation Demo") cor.refresh() } TeachingDemos/R/mysymbols.R0000644000175100001440000002733612657235444015413 0ustar hornikusersmy.symbols <- function(x, y=NULL, symb, inches=1, xsize, ysize, add=TRUE, vadj=0.5, hadj=0.5, symb.plots=FALSE, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), main=NULL, xlim=NULL, ylim=NULL, linesfun=lines, ..., MoreArgs ) { if(!add){ plot(x,y, type='n', xlab=xlab,ylab=ylab, xlim=xlim,ylim=ylim,main=main) } xy <- xy.coords(x,y,recycle=TRUE) pin <- par('pin') usr <- par('usr') usr.x <- usr[2] - usr[1] usr.y <- usr[4] - usr[3] # tmp <- cnvrt.coords(xy,input='usr')$plt tmp <- list() tmp$x <- grconvertX(xy$x, to='npc') tmp$y <- grconvertY(xy$y, to='npc') tmp.xlen <- length(tmp$x) if( (length(inches) != 1) && (length(inches) != tmp.xlen) ) { inches <- rep(inches, length.out=tmp.xlen) } if( (length(hadj) != 1) && (length(hadj) != tmp.xlen) ) { hadj <- rep(hadj, length.out=tmp.xlen) } if( (length(vadj) != 1) && (length(vadj) != tmp.xlen) ) { vadj <- rep(vadj, length.out=tmp.xlen) } if( missing(xsize) ) { if( missing(ysize) ) { # use inches x.low <- tmp$x - hadj *inches/pin[1] x.high <- tmp$x + (1-hadj)*inches/pin[1] y.low <- tmp$y - vadj *inches/pin[2] y.high <- tmp$y + (1-vadj)*inches/pin[2] } else { # ysize only y.low <- tmp$y - vadj*ysize/usr.y y.high <- tmp$y + (1-vadj)*ysize/usr.y x.low <- tmp$x - hadj/pin[1]*pin[2]/usr.y*ysize x.high <- tmp$x + (1-hadj)/pin[1]*pin[2]/usr.y*ysize } } else { if( missing(ysize) ) { # xsize only x.low <- tmp$x - hadj*xsize/usr.x x.high <- tmp$x + (1-hadj)*xsize/usr.x y.low <- tmp$y - vadj/pin[2]*pin[1]/usr.x*xsize y.high <- tmp$y + (1-vadj)/pin[2]*pin[1]/usr.x*xsize } else { # both xsize and ysize x.low <- tmp$x - hadj*xsize/usr.x x.high <- tmp$x + (1-hadj)*xsize/usr.x y.low <- tmp$y - vadj*ysize/usr.y y.high <- tmp$y + (1-vadj)*ysize/usr.y } } # xy.low <- cnvrt.coords(x.low, y.low, 'plt')$fig # xy.high <- cnvrt.coords(x.high, y.high, 'plt')$fig xy.low <- list() xy.low$x <- grconvertX(x.low, from='npc', to='nfc') xy.low$y <- grconvertY(y.low, from='npc', to='nfc') xy.high <- list() xy.high$x <- grconvertX(x.high, from='npc', to='nfc') xy.high$y <- grconvertY(y.high, from='npc', to='nfc') plotfun <- if( is.function(symb) ) { if(symb.plots) { function(xlow,xhigh,ylow,yhigh,symb, ...) { op <- par(c('plt','usr','xpd')) on.exit(par(op)) par(xpd=TRUE) par(plt=c(xlow,xhigh,ylow,yhigh), new=TRUE) par(usr=c(-1,1,-1,1)) symb(...) } } else { function(xlow,xhigh,ylow,yhigh,symb, ...) { op <- par(c('plt','usr','xpd')) on.exit(par(op)) par(xpd=TRUE) par(plt=c(xlow,xhigh,ylow,yhigh)) par(usr=c(-1,1,-1,1)) suppressWarnings( linesfun( symb(...), ... ) ) } } } else { function(xlow,xhigh,ylow,yhigh,symb, ...) { op <- par(c('plt','usr','xpd')) on.exit(par(op)) par(xpd=TRUE) par(plt=c(xlow,xhigh,ylow,yhigh)) par(usr=c(-1,1,-1,1)) linesfun(symb, ...) } } funargs <- list(xlow=xy.low$x, xhigh=xy.high$x, ylow=xy.low$y, yhigh=xy.high$y) if( length(list(...)) ) { funargs <- c(funargs, lapply(list(...), function(x) rep(x,length.out=tmp.xlen) ) ) } funargs$FUN <- plotfun if (missing(MoreArgs)) { funargs$MoreArgs <- list(symb=symb) } else { funargs$MoreArgs <- c(MoreArgs, list(symb=symb)) } do.call(mapply, funargs) invisible(NULL) } ms.male <- structure(c(0, 0.022, 0.0439, 0.0657, 0.0874, 0.109, 0.1303, 0.1514, 0.1722, 0.1926, 0.2127, 0.2324, 0.2516, 0.2703, 0.2885, 0.3062, 0.3233, 0.3397, 0.3555, 0.3706, 0.385, 0.3986, 0.4115, 0.4236, 0.4348, 0.4453, 0.4548, 0.4635, 0.4713, 0.4782, 0.4841, 0.4891, 0.4932, 0.4964, 0.4985, 0.4997, 0.5, 0.4992, 0.4976, 0.4949, 0.4913, 0.4868, 0.4813, 0.4748, 0.4675, 0.4593, 0.4501, 0.4401, 0.4293, 0.4176, 0.4052, 0.3919, 0.3779, 0.3631, 0.3477, 0.3316, 0.3148, 0.2974, 0.2795, 0.261, 0.242, 0.2226, 0.2027, 0.1824, 0.1618, 0.1409, 0.1197, 0.0982, 0.0766, 0.0548, 0.0329, 0.011, -0.011, -0.0329, -0.0548, -0.0766, -0.0982, -0.1197, -0.1409, -0.1618, -0.1824, -0.2027, -0.2226, -0.242, -0.261, -0.2795, -0.2974, -0.3148, -0.3316, -0.3477, -0.3631, -0.3779, -0.3919, -0.4052, -0.4176, -0.4293, -0.4401, -0.4501, -0.4593, -0.4675, -0.4748, -0.4813, -0.4868, -0.4913, -0.4949, -0.4976, -0.4992, -0.5, -0.4997, -0.4985, -0.4964, -0.4932, -0.4891, -0.4841, -0.4782, -0.4713, -0.4635, -0.4548, -0.4453, -0.4348, -0.4236, -0.4115, -0.3986, -0.385, -0.3706, -0.3555, -0.3397, -0.3233, -0.3062, -0.2885, -0.2703, -0.2516, -0.2324, -0.2127, -0.1926, -0.1722, -0.1514, -0.1303, -0.109, -0.0874, -0.0657, -0.0439, -0.022, 0, NA, 0.3536, 1, 0.6, NA, 1, 1, 0.5, 0.4995, 0.4981, 0.4957, 0.4923, 0.488, 0.4827, 0.4765, 0.4694, 0.4614, 0.4525, 0.4427, 0.4321, 0.4206, 0.4083, 0.3953, 0.3814, 0.3669, 0.3516, 0.3357, 0.3191, 0.3018, 0.284, 0.2657, 0.2468, 0.2275, 0.2077, 0.1875, 0.167, 0.1461, 0.125, 0.1036, 0.082, 0.0603, 0.0384, 0.0165, -0.0055, -0.0274, -0.0494, -0.0712, -0.0928, -0.1143, -0.1356, -0.1566, -0.1773, -0.1977, -0.2176, -0.2372, -0.2563, -0.2749, -0.293, -0.3105, -0.3274, -0.3437, -0.3593, -0.3743, -0.3885, -0.4019, -0.4146, -0.4265, -0.4375, -0.4477, -0.4571, -0.4655, -0.4731, -0.4797, -0.4855, -0.4903, -0.4941, -0.497, -0.4989, -0.4999, -0.4999, -0.4989, -0.497, -0.4941, -0.4903, -0.4855, -0.4797, -0.4731, -0.4655, -0.4571, -0.4477, -0.4375, -0.4265, -0.4146, -0.4019, -0.3885, -0.3743, -0.3593, -0.3437, -0.3274, -0.3105, -0.293, -0.2749, -0.2563, -0.2372, -0.2176, -0.1977, -0.1773, -0.1566, -0.1356, -0.1143, -0.0928, -0.0712, -0.0494, -0.0274, -0.0055, 0.0165, 0.0384, 0.0603, 0.082, 0.1036, 0.125, 0.1461, 0.167, 0.1875, 0.2077, 0.2275, 0.2468, 0.2657, 0.284, 0.3018, 0.3191, 0.3357, 0.3516, 0.3669, 0.3814, 0.3953, 0.4083, 0.4206, 0.4321, 0.4427, 0.4525, 0.4614, 0.4694, 0.4765, 0.4827, 0.488, 0.4923, 0.4957, 0.4981, 0.4995, 0.5, NA, 0.3536, 1, 1, NA, 1, 0.6), .Dim = as.integer(c(151, 2))) ms.female <- structure(c(0, 0.022, 0.0439, 0.0657, 0.0874, 0.109, 0.1303, 0.1514, 0.1722, 0.1926, 0.2127, 0.2324, 0.2516, 0.2703, 0.2885, 0.3062, 0.3233, 0.3397, 0.3555, 0.3706, 0.385, 0.3986, 0.4115, 0.4236, 0.4348, 0.4453, 0.4548, 0.4635, 0.4713, 0.4782, 0.4841, 0.4891, 0.4932, 0.4964, 0.4985, 0.4997, 0.5, 0.4992, 0.4976, 0.4949, 0.4913, 0.4868, 0.4813, 0.4748, 0.4675, 0.4593, 0.4501, 0.4401, 0.4293, 0.4176, 0.4052, 0.3919, 0.3779, 0.3631, 0.3477, 0.3316, 0.3148, 0.2974, 0.2795, 0.261, 0.242, 0.2226, 0.2027, 0.1824, 0.1618, 0.1409, 0.1197, 0.0982, 0.0766, 0.0548, 0.0329, 0.011, -0.011, -0.0329, -0.0548, -0.0766, -0.0982, -0.1197, -0.1409, -0.1618, -0.1824, -0.2027, -0.2226, -0.242, -0.261, -0.2795, -0.2974, -0.3148, -0.3316, -0.3477, -0.3631, -0.3779, -0.3919, -0.4052, -0.4176, -0.4293, -0.4401, -0.4501, -0.4593, -0.4675, -0.4748, -0.4813, -0.4868, -0.4913, -0.4949, -0.4976, -0.4992, -0.5, -0.4997, -0.4985, -0.4964, -0.4932, -0.4891, -0.4841, -0.4782, -0.4713, -0.4635, -0.4548, -0.4453, -0.4348, -0.4236, -0.4115, -0.3986, -0.385, -0.3706, -0.3555, -0.3397, -0.3233, -0.3062, -0.2885, -0.2703, -0.2516, -0.2324, -0.2127, -0.1926, -0.1722, -0.1514, -0.1303, -0.109, -0.0874, -0.0657, -0.0439, -0.022, 0, NA, 0, 0, NA, -0.25, 0.25, 0.5, 0.4995, 0.4981, 0.4957, 0.4923, 0.488, 0.4827, 0.4765, 0.4694, 0.4614, 0.4525, 0.4427, 0.4321, 0.4206, 0.4083, 0.3953, 0.3814, 0.3669, 0.3516, 0.3357, 0.3191, 0.3018, 0.284, 0.2657, 0.2468, 0.2275, 0.2077, 0.1875, 0.167, 0.1461, 0.125, 0.1036, 0.082, 0.0603, 0.0384, 0.0165, -0.0055, -0.0274, -0.0494, -0.0712, -0.0928, -0.1143, -0.1356, -0.1566, -0.1773, -0.1977, -0.2176, -0.2372, -0.2563, -0.2749, -0.293, -0.3105, -0.3274, -0.3437, -0.3593, -0.3743, -0.3885, -0.4019, -0.4146, -0.4265, -0.4375, -0.4477, -0.4571, -0.4655, -0.4731, -0.4797, -0.4855, -0.4903, -0.4941, -0.497, -0.4989, -0.4999, -0.4999, -0.4989, -0.497, -0.4941, -0.4903, -0.4855, -0.4797, -0.4731, -0.4655, -0.4571, -0.4477, -0.4375, -0.4265, -0.4146, -0.4019, -0.3885, -0.3743, -0.3593, -0.3437, -0.3274, -0.3105, -0.293, -0.2749, -0.2563, -0.2372, -0.2176, -0.1977, -0.1773, -0.1566, -0.1356, -0.1143, -0.0928, -0.0712, -0.0494, -0.0274, -0.0055, 0.0165, 0.0384, 0.0603, 0.082, 0.1036, 0.125, 0.1461, 0.167, 0.1875, 0.2077, 0.2275, 0.2468, 0.2657, 0.284, 0.3018, 0.3191, 0.3357, 0.3516, 0.3669, 0.3814, 0.3953, 0.4083, 0.4206, 0.4321, 0.4427, 0.4525, 0.4614, 0.4694, 0.4765, 0.4827, 0.488, 0.4923, 0.4957, 0.4981, 0.4995, 0.5, NA, -0.5, -1, NA, -0.8, -0.8), .Dim = as.integer(c(150, 2))) ms.polygon <- function(n, r=1, adj=pi/2, ...) { tmp <- seq(0,2*pi, length.out=n+1) + adj cbind(cos(tmp), sin(tmp)) * r } ms.filled.polygon <- function(n, r=1, adj=pi/2, fg=par('fg'), bg=par('fg'), ... ) { tmp <- seq(0,2*pi, length.out=n+1) + adj polygon(cos(tmp)*r,sin(tmp)*r, col=bg, border=fg, ...) NULL } ms.polygram <- function(n, r=1, adj=pi/2, ...) { if (n == 1) { return(rbind( c(0,0), c(cos(adj),sin(adj))*r)) } if (n == 2) { return(rbind( c(cos(adj),sin(adj)), c(cos(adj+pi),sin(adj+pi))) * r) } if (n == 3) { return(rbind( c(0,0), c(cos(adj),sin(adj)), NA, c(0,0), c(cos(adj+2*pi/3), sin(adj+2*pi/3)), NA, c(0,0), c(cos(adj+4*pi/3), sin(adj+4*pi/3)))*r) } if (n == 4) { return(rbind( c(cos(adj),sin(adj)), c(cos(adj+pi),sin(adj+pi)), NA, c(cos(adj+pi/2), sin(adj+pi/2)), c(cos(adj+3*pi/2), sin(adj+3*pi/2))) * r ) } if (n == 6) { tmp <- c( 0, 2*pi/3, 4*pi/3, 2*pi ) tmp <- c(tmp, NA, tmp+pi/3)+adj return( cbind( cos(tmp), sin(tmp) )*r ) } skp <- floor( n/2 - 0.1 ) tmp <- seq( 0, skp*2*pi, length.out=n+1 ) + adj tmp2 <- cbind(cos(tmp), sin(tmp))*r while( any( duplicated( round( tmp2[-1,], 5 ) ) ) ){ skp <- skp - 1 tmp <- seq( 0, skp*2*pi, length.out=n+1 ) + adj tmp2 <- cbind( cos(tmp), sin(tmp))*r } return(tmp2) } ms.arrows <- function(angle, r=1, adj=0.5, length=0.1, ...) { fr <- c( cos(angle), sin(angle) ) * (-r) * adj to <- c( cos(angle), sin(angle) ) * r * (1-adj) arrows(fr[1],fr[2],to[1],to[2], length=length, ...) NULL } ms.sunflowers <- function(n,r=0.3,adj=pi/2, ...) { tmp <- seq(0,2*pi, length.out=36) tmp2 <- cbind( cos(tmp), sin(tmp) ) * r tmp <- seq( 0, 2*pi, length.out=n+1 )[-(n+1)] + adj tmp.x <- c(rbind(NA,cos(tmp)*r, cos(tmp))) tmp.y <- c(rbind(NA,sin(tmp)*r, sin(tmp))) rbind(tmp2, cbind(tmp.x, tmp.y) ) } ms.image <- function(img, transpose=TRUE, ...) { d <- dim(img) cols <- if(d[3] == 3) { rgb(img[,,1], img[,,2], img[,,3]) } else if(d[3] == 4) { rgb(img[,,1], img[,,2], img[,,3], img[,,4]) } else { stop('image must be array with 3rd dimension equal to 3 or 4') } if(transpose) { tmp <- matrix( seq(length=d[1]*d[2]), ncol=d[1], byrow=TRUE) tmp <- tmp[ , rev(seq(length=d[1])) ] } else { tmp <- matrix( seq(length=d[1]*d[2]), ncol=d[2] ) tmp <- tmp[ , rev(seq(length=d[2])) ] } image(tmp, col=cols, axes=FALSE, xlab='', ylab='') } # do ms.raster that uses rasterImage TeachingDemos/R/simfun.R0000644000175100001440000000143412657235445014646 0ustar hornikuserssimfun <- function(expr, drop, ...) { dots <- list(...) expr <- substitute(expr) has.drop <- !missing(drop) char2seed <- TeachingDemos::char2seed force(char2seed) function(data,seed) { if(!missing(seed)) { if(is.character(seed)) { char2seed(seed) } else { set.seed(seed) } } data.is.df <- FALSE if(!missing(data) && is.data.frame(data)) { data.is.df <- TRUE df.rn <- row.names(data) dots <- c(as.list(data),dots) } else if(!missing(data)) { dots <- c(as.list(data),dots) } outlist <- within(dots,eval(expr)) if(has.drop) outlist[drop] <- NULL out.df <- as.data.frame(outlist) if(data.is.df) { row.names(out.df) <- df.rn } out.df } } TeachingDemos/R/char2seed.R0000644000175100001440000000062012657235444015200 0ustar hornikuserschar2seed <- function(x,set=TRUE,...){ tmp <- c(0:9,0:25,0:25) names(tmp) <- c(0:9,letters,LETTERS) x <- gsub("[^0-9a-zA-Z]","",as.character(x)) xsplit <- tmp[ strsplit(x,'')[[1]] ] seed <- sum(rev( 7^(seq(along=xsplit)-1) ) * xsplit) seed <- as.integer( seed %% (2^31-1) ) if(set){ set.seed(seed,...) return(invisible(seed)) } else { return(seed) } } TeachingDemos/R/gnuplot.R0000644000175100001440000000176112657235444015037 0ustar hornikusersgpenv <- new.env() gpenv$gp <- numeric(0) gpenv$gp.tempfiles <- character(0) gp.open <- function(where='c:/progra~1/GnuPlot/bin/pgnuplot.exe'){ gpenv$gp <<- pipe(where,'w') gpenv$gp.tempfiles <<- character(0) invisible(gpenv$gp) } gp.close <- function(pipe=gpenv$gp){ cat("quit\n",file=pipe) close(pipe) if(exists('gpenv$gp.tempfiles')){ unlink(gpenv$gp.tempfiles) gpenv$gp.tempfiles <- character(0) } gpenv$gp <<- numeric(0) invisible() } gp.send <- function(cmd='replot',pipe=gpenv$gp){ cat(cmd, file=pipe) cat("\n",file=pipe) invisible() } gp.plot <- function(x,y,type='p',add=FALSE, title=deparse(substitute(y)), pipe=gpenv$gp){ tmp <- tempfile() gpenv$gp.tempfiles <<- c(gpenv$gp.tempfiles, tmp) write.table( cbind(x,y), tmp, row.names=FALSE, col.names=FALSE ) w <- ifelse(type=='p', 'points', 'lines') r <- ifelse(add, 'replot', 'plot') cat( paste(r," '",tmp,"' with ",w," title '",title,"'\n",sep=''), file=pipe) invisible() } TeachingDemos/R/plot.rgl.die.R0000644000175100001440000000473312657235444015652 0ustar hornikusersrgl.die <- function(x = 1:6, col.cube='white',col.pip='black',sides=x, ...) { if(!requireNamespace('rgl', quietly = TRUE)) stop("This function depends on the 'rgl' package wich is not available") rgl::rgl.viewpoint(45,45) pip.coords <- function( x,y ) { xc <- yc <- numeric(0) for(i in 0:39){ xc <- c(xc, x, 0.05*cos(pi/20*i)+x, 0.05*cos(pi/20*(i+1))+x) yc <- c(yc, y, 0.05*sin(pi/20*i)+y, 0.05*sin(pi/20*(i+1))+y) } cbind(xc,yc) } pip.loc <- list(matrix( 0.5, ncol=2, nrow=1), cbind( c(.25, .75), c(.25, .75)), cbind( c(.25, .5, .75), c(.25, .5, .75)), cbind( c(.25, .25, .75, .75), c(.25, .75, .75, .25)), cbind( c(.25, .25, .75, .75, .5), c(.25, .75, .75, .25, .5)), cbind( c(.25, .25, .25, .75, .75, .75), c(.25, .5, .75, .75, .5, .25))) rgl::rgl.quads( c(0,0,1,1), c(0,1,1,0), c(0,0,0,0), col=col.cube) rgl::rgl.quads( c(0,0,1,1), c(0,1,1,0), c(1,1,1,1), col=col.cube) rgl::rgl.quads( c(0,0,0,0), c(0,1,1,0), c(0,0,1,1), col=col.cube) rgl::rgl.quads( c(1,1,1,1), c(0,1,1,0), c(0,0,1,1), col=col.cube) rgl::rgl.quads( c(0,0,1,1), c(0,0,0,0), c(0,1,1,0), col=col.cube) rgl::rgl.quads( c(0,0,1,1), c(1,1,1,1), c(0,1,1,0), col=col.cube) tmp <- pip.loc[[ sides[1] ]] for( i in 1:nrow(tmp) ){ xy <- pip.coords( tmp[i,1], tmp[i,2] ) rgl::rgl.triangles(xy[,1], rep(1.001, nrow(xy)), xy[,2], col=col.pip,lit=FALSE) } tmp <- pip.loc[[ sides[2] ]] for( i in 1:nrow(tmp) ){ xy <- pip.coords( tmp[i,1], tmp[i,2] ) rgl::rgl.triangles(xy[,1], xy[,2], rep(1.001, nrow(xy)), col=col.pip,lit=FALSE) } tmp <- pip.loc[[ sides[3] ]] for( i in 1:nrow(tmp) ){ xy <- pip.coords( tmp[i,1], tmp[i,2] ) rgl::rgl.triangles( rep(1.001, nrow(xy)), xy[,1], xy[,2], col=col.pip,lit=FALSE) } tmp <- pip.loc[[ sides[4] ]] for( i in 1:nrow(tmp) ){ xy <- pip.coords( tmp[i,1], tmp[i,2] ) rgl::rgl.triangles( rep(-0.001, nrow(xy)), xy[,1], xy[,2], col=col.pip,lit=FALSE) } tmp <- pip.loc[[ sides[5] ]] for( i in 1:nrow(tmp) ){ xy <- pip.coords( tmp[i,1], tmp[i,2] ) rgl::rgl.triangles(xy[,1], xy[,2], rep(-0.001, nrow(xy)), col=col.pip,lit=FALSE) } tmp <- pip.loc[[ sides[6] ]] for( i in 1:nrow(tmp) ){ xy <- pip.coords( tmp[i,1], tmp[i,2] ) rgl::rgl.triangles(xy[,1], rep(-0.001, nrow(xy)), xy[,2], col=col.pip,lit=FALSE) } } TeachingDemos/R/subplot.R0000644000175100001440000000411212657235445015031 0ustar hornikuserssubplot <- function(fun, x, y=NULL, size=c(1,1), vadj=0.5, hadj=0.5, inset=c(0,0), type=c('plt','fig'), pars=NULL){ # old.par <- par(no.readonly=TRUE) type <- match.arg(type) old.par <- par( c(type, 'usr', names(pars) ) ) on.exit(par(old.par)) if(missing(x)) x <- locator(2) if(is.character(x)) { if(length(inset) == 1) inset <- rep(inset,2) x.char <- x tmp <- par('usr') x <- (tmp[1]+tmp[2])/2 y <- (tmp[3]+tmp[4])/2 if( length(grep('left',x.char, ignore.case=TRUE))) { x <- tmp[1] + inset[1]*(tmp[2]-tmp[1]) if(missing(hadj)) hadj <- 0 } if( length(grep('right',x.char, ignore.case=TRUE))) { x <- tmp[2] - inset[1]*(tmp[2]-tmp[1]) if(missing(hadj)) hadj <- 1 } if( length(grep('top',x.char, ignore.case=TRUE))) { y <- tmp[4] - inset[2]*(tmp[4]-tmp[3]) if(missing(vadj)) vadj <- 1 } if( length(grep('bottom',x.char, ignore.case=TRUE))) { y <- tmp[3] + inset[2]*(tmp[4]-tmp[3]) if(missing(vadj)) vadj <- 0 } } xy <- xy.coords(x,y) if(length(xy$x) != 2){ pin <- par('pin') # tmp <- cnvrt.coords(xy$x[1],xy$y[1],'usr')$plt tmpx <- grconvertX( xy$x[1], to='npc' ) tmpy <- grconvertY( xy$y[1], to='npc' ) x <- c( tmpx - hadj*size[1]/pin[1], tmpx + (1-hadj)*size[1]/pin[1] ) y <- c( tmpy - vadj*size[2]/pin[2], tmpy + (1-vadj)*size[2]/pin[2] ) # xy <- cnvrt.coords(x,y,'plt')$fig xyx <- grconvertX(x, from='npc', to='nfc') xyy <- grconvertY(y, from='npc', to='nfc') } else { # xy <- cnvrt.coords(xy,,'usr')$fig xyx <- grconvertX(x, to='nfc') xyy <- grconvertY(y, to='nfc') } par(pars) if(type=='fig'){ xyx <- grconvertX(xyx, from='nfc', to='ndc') xyy <- grconvertY(xyy, from='nfc', to='ndc') par(fig=c(xyx,xyy), new=TRUE) } else { par(plt=c(xyx,xyy), new=TRUE) } fun tmp.par <- par(no.readonly=TRUE) return(invisible(tmp.par)) } TeachingDemos/R/run.ci.examp.R0000644000175100001440000000445112657235445015656 0ustar hornikusers"run.ci.examp" <- function(reps=100,seed, method='z',n=25) { if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')} if (!missing(seed)){ set.seed(seed) } data <- matrix( rnorm( n*reps, 100, 10), ncol=n) rmeans <- rowMeans(data) ci.refresh <- function(...) { conf.level=slider(no=1) switch(method, Z=,z={ lower <- qnorm( (1-conf.level)/2, rmeans, 10/sqrt(n)) upper <- qnorm( 1-(1-conf.level)/2, rmeans, 10/sqrt(n)) }, T=,t= { cv.l <- qt((1-conf.level)/2, n-1) cv.u <- qt(1-(1-conf.level)/2, n-1) rsds <- sqrt(apply(data,1,var))/sqrt(n) lower <- rmeans+cv.l*rsds upper <- rmeans+cv.u*rsds }, BOTH=, Both=, both={ lz <- qnorm( (1-conf.level)/2, rmeans, 10/sqrt(n)) uz <- qnorm( 1-(1-conf.level)/2, rmeans, 10/sqrt(n)) cv.l <- qt((1-conf.level)/2, n-1) cv.u <- qt(1-(1-conf.level)/2, n-1) rsds <- sqrt(apply(data,1,var))/sqrt(n) lt <- rmeans+cv.l*rsds ut <- rmeans+cv.u*rsds lower <- c(rbind(lt,lz,100)) upper <- c(rbind(ut,uz,100)) reps <- reps*3 rmeans <- rep(rmeans, each=3) rmeans[c(F,F,T)] <- NA }, stop("method must be z, t, or both") ) xr <- 100 + 4.5*c(-1,1)*10/sqrt(n) plot(lower,seq(1,reps), type="n", xlim=xr, xlab="Confidence Interval", ylab="Index") abline( v= qnorm(c((1-conf.level)/2,1-(1-conf.level)/2), 100, 10/sqrt(n)), col='lightgreen') if( method=="both" || method=="Both" || method=="BOTH"){ title( main="Confidence intervals based on both distributions", sub="Upper interval is Z in each pair") } else { title( main=paste("Confidence intervals based on",method,"distribution")) } colr <- ifelse( lower > 100, 'blue', ifelse( upper < 100, 'red', 'black') ) abline(v=100) segments(lower,1:reps,upper,1:reps, col=colr) points( rmeans, seq(along=rmeans), pch='|', col=colr ) invisible(NULL) } slider( ci.refresh, 'Confidence Level', 0.5, 0.995, 0.005, 0.95, title="Confidence Interval Demo") } TeachingDemos/R/roc.demo.R0000644000175100001440000000570512657235445015060 0ustar hornikusers"roc.demo" <- function(x=rnorm(25,10,1), y=rnorm(25,11,1.5) ){ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')} if(!exists('slider.env')) slider.env <<- new.env() range.min <- min(x,y) - 0.1 * diff(range(x,y)) range.max <- max(x,y) + 0.1 * diff(range(x,y)) cutoff <- range.max; assign('cutoff', tcltk::tclVar(cutoff), envir=slider.env) .sens <-c(0,1) .spec <-c(0,1) dx <- density(x) dy <- density(y) roc.refresh <- function(...){ cutoff <- as.numeric(evalq(tcltk::tclvalue(cutoff), envir=slider.env)) old.par <- par(no.readonly=T) on.exit(par(old.par)) sens <- mean( y > cutoff ) spec <- mean( x > cutoff ) .sens <<- c(.sens, sens) .spec <<- c(.spec, spec) par(mar=c(5,4,0,1)+.1) layout( matrix(c(1,2), ncol=1), heights=c(2,1)) op <- par(pty="s") plot(.spec,.sens, xlab="1-Specificity",ylab="Sensitivity", xlim=c(0,1),ylim=c(0,1)) par(pty="m") tmp <- chull(c(1,.spec),c(0,.sens)) lines(c(NA,.spec)[tmp],c(NA,.sens)[tmp]) points(spec,sens, col='red',pch=16) specdiff <- diff( c(NA,.spec)[tmp] ) specdiff <- specdiff[!is.na(specdiff)] sensmean <- (c(c(NA,.sens)[tmp][-1],NA) + c(NA,.sens)[tmp])/2 sensmean <- sensmean[!is.na(sensmean)] auc <- sum( specdiff*sensmean ) text(1,0.1, paste("Area Under Curve =", round(auc,3)), cex=1.7, adj=1) d <- (1-.sens)^2 + (.spec)^2 dd <- which.min(d) lines(c(0,.spec[dd]),c(1,.sens[dd]), col='purple') plot( dx$x, dx$y, type='l', col='red', xlim=c(range.min,range.max), xlab=paste("Sensitivity = ",round(sens,3),", Specificity = ",round(1-spec,3),sep=''), ylab="Densities",ylim=c(0,max(dx$y,dy$y))) if(any(x <= cutoff)) rug(x[x<=cutoff], col='red', ticksize=.3) if(any(x > cutoff)) rug(x[x>cutoff], col='red', ticksize=.3, side=3) lines( dy$x, dy$y, col='blue') if(any(y<=cutoff)) rug(y[y<=cutoff], col='blue',ticksize=.3) if(any(y>cutoff)) rug(y[y>cutoff], col='blue',ticksize=.3, side=3) abline(v=cutoff, col='green') } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'ROC curve demo') tcltk::tkwm.geometry(m, '+0+0') # cutoff tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='cutoff', width='10'), side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=roc.refresh, from=range.min, to=range.max, orient='horiz', resolution = (range.max-range.min)/100, showvalue=T), side='left') assign('sc',sc, envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=cutoff), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=roc.refresh), side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } TeachingDemos/R/clipplot.R0000644000175100001440000000112412657235444015166 0ustar hornikusersclipplot <- function(fun, xlim=par('usr')[1:2], ylim=par('usr')[3:4] ){ old.par <- par(c('plt','xpd')) if( length(xlim) < 2 ) stop('xlim must be a vector with at least 2 elements') if( length(ylim) < 2 ) stop('ylim must be a vector with at least 2 elements') xl <- range(xlim) yl <- range(ylim) pc <- cnvrt.coords(xl,yl)$fig box(col='#00000000') # works better with this, don't know why par(plt=c(pc$x,pc$y),xpd=FALSE) box(col='#00000000') # same fun par(old.par) box(col='#00000000') # need to plot something to reset invisible(NULL) } TeachingDemos/R/slideRule.R0000644000175100001440000000357712657235445015307 0ustar hornikusers slideRule <- function( slide=1, rule=1 ) { sr.tks <- c( seq(1,2,.1), seq(2.2,3,.2), seq(3.5,10,.5), seq(11,20,1), seq(22,30,2), seq(35,100,5) ) sr.tks2 <- c( 1, 2:10, seq(20,100,10) ) sr.tl <- c( 1, 2:9, 1, 2:9, 1 ) op <- par(plt=c(0.03, 0.97, 0.49, 0.51), xpd=TRUE ) on.exit(par(op)) plot.new() plot.window( xlim=c(0.1, 100), ylim=c(0,1), log='x' ) axis(3, at=sr.tks, labels=FALSE, tcl=-0.3) axis(3, at=sr.tks2, labels=sr.tl, cex.axis=0.4 ) axis(1, at=sr.tks/slide, labels=FALSE, tcl=-0.3) axis(1, at=sr.tks2/slide, labels=sr.tl, cex.axis=0.4, mgp=c(3,.5,0) ) segments( rule, grconvertY(0.4, from='nfc'), rule, grconvertY(0.6, from='nfc'), col='blue') points(1, grconvertY(0.52, from='nfc', to='user'), pch=6) points(1/slide, grconvertY(0.48, from='nfc', to='user'), pch=2) } slideRule2 <- function( slide=1, rule=1 ) { sr.tks <- c( seq(1,2,.1), seq(2.2,3,.2), seq(3.5,10,.5), seq(11,20,1), seq(22,30,2), seq(35,100,5) ) sr.tks2 <- c( 1, 2:10, seq(20,100,10) ) sr.tl <- c( 1, 2:9, 1, 2:9, 1 ) op <- par(plt=c(0.03, 0.97, 0.49, 0.51), xpd=TRUE ) on.exit(par(op)) plot.new() plot.window( xlim=c(0.1, 100), ylim=c(0,1), log='x' ) axis(3, at=sr.tks, labels=FALSE, tcl=-0.5) axis(3, at=sr.tks2, labels=sr.tl, cex.axis=2, line=3 ) axis(1, at=sr.tks/slide, labels=FALSE, tcl=-0.5) axis(1, at=sr.tks2/slide, labels=sr.tl, cex.axis=2, mgp=c(3,.5,0) ) segments( rule, grconvertY(0.4, from='nfc'), rule, grconvertY(0.6, from='nfc'), col='blue') points(1, grconvertY(0.52, from='nfc', to='user'), pch=6) points(1/slide, grconvertY(0.48, from='nfc', to='user'), pch=2) } TkSlideRule <- function() { sl.list <- list( slide=list('slider',init=1, from=0.1, to=9.9, resolution=0.1), rule=list('slider',init=1, from=0.1, to=9.9, resolution=0.1)) tkexamp( slideRule2, sl.list ) } TeachingDemos/R/fagan.R0000644000175100001440000002710312657235444014421 0ustar hornikusersfagan.plot<-function(probs.pre.test, LR, test.result="+") { opar <- par(no.readonly = T) on.exit(par(opar)) par(mar = c(1.5, 6, 2, 6)) stato <- ifelse(test.result == "+", "disease", "no disease") if (probs.pre.test > 1 | probs.pre.test < 0 | LR < 0 | is.infinite(LR) | is.nan(LR) | test.result %in% c("+", "-") == F) { stop("wrong values !!") } else { logits <- function(p) log(p/(1 - p)) } logits.pre <- logits(probs.pre.test) logits.post <- log(LR) + logits.pre probs.post.test <- exp(logits.post)/(1 + exp(logits.post)) compl.logit.pre <- logits(1 - probs.pre.test) LR.vec <- c(0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50, 100, 200, 500, 1000) prob.vec <- c(0.001, 0.002, 0.003, 0.005, 0.007, 0.01, 0.02, 0.03, 0.05, 0.07, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 0.93, 0.95, 0.97, 0.98, 0.99, 0.993, 0.995, 0.997, 0.998, 0.999) plot(0, 0, type = "n", ylim = range(logits(prob.vec)), axes = F, xlab = "", ylab = "") axis(2, rev(logits(prob.vec)), 100 * prob.vec, pos = -1, las = 1, cex.axis = 0.7) axis(2, rev(logits(prob.vec)), 100 * prob.vec, pos = -1, tck = 0.03, labels = F) axis(4, logits(prob.vec), 100 * prob.vec, pos = 1, las = 1, cex.axis = 0.7) axis(4, logits(prob.vec), 100 * prob.vec, pos = 1, tck = 0.03, labels = F) axis(2, log(LR.vec[1:10])/2, LR.vec[1:10], pos = 0, las = 1, cex.axis = 0.7) axis(2, log(LR.vec[1:10])/2, LR.vec[1:10], pos = 0, tck = 0.03, labels = F) axis(4, log(LR.vec[10:19])/2, LR.vec[10:19], pos = 0, las = 1, cex.axis = 0.7) axis(4, log(LR.vec[10:19])/2, LR.vec[10:19], pos = 0, tck = 0.03, labels = F) text(0, 4.5, "Likelihood ratio", cex = 1.2) segments(-1, compl.logit.pre, 1, logits.post, lwd = 1.5, col = 2) mtext(side = 2, text = "Pre test probability(%)", line = 2, cex = 1.2) mtext(side = 4, text = "Post test probability(%)", line = 2, cex = 1.2, las = 3) title(main = "Fagan's nomogram") text(0, -6.3, paste("Pre test prob. of disease =", round(100 * probs.pre.test, 2), "% \n", "Likelihood ratio ", "=", round(LR, 2), "\n", "Post test prob. of", stato, "=", ifelse(test.result == "+", round(100 * probs.post.test, 2), round(100 * (1 - probs.post.test), 2)), "%"), cex = 0.7) } plotFagan.old<-function(){ refresh.code <- function(...) { probs.pre.test <- slider(no = 1) LR <- slider(no = 2) test.result <- slider(obj.name = "test.result") fagan.plot(probs.pre.test, LR, test.result) } slider(refresh.code, sl.names = c("pre test probability", "Likelihood Ratio"), sl.mins = c(0, 0.01), sl.maxs = c(1, 100), title = "Bayes nomogram", sl.defaults = c(0.5, 1), sl.deltas = c(0.01, 0.01), but.functions = list(function(...) { slider(obj.name = "test.result", obj.value = "+") refresh.code() }, function(...) { slider(obj.name = "test.result", obj.value = "-") refresh.code() }), but.names = c("positive result", "negative result")) slider(obj.name = "test.result", obj.value = "+") invisible(NULL) } plotFagan2.old<-function(){ refresh.code <- function(...) { probs.pre.test <- slider(no = 1) LR <- slider(no=2)/(1-slider(no=3)) test.result <- slider(obj.name = "test.result") fagan.plot(probs.pre.test, LR, test.result) } slider(refresh.code, sl.names = c("pre test probability", "Sensitivity","Specificity"), sl.mins = c(0, 0, 0), sl.maxs = c(1, 1, 1), title = "Bayes nomogram", sl.defaults = c(0.5, 0.95, 0.95), sl.deltas = c(0.01, 0.001, 0.001), but.functions = list(function(...) { slider(obj.name = "test.result", obj.value = "+") refresh.code() }, function(...) { slider(obj.name = "test.result", obj.value = "-") refresh.code() }), but.names = c("positive result", "negative result")) slider(obj.name = "test.result", obj.value = "+") invisible(NULL) } plotFagan <- function(hscale=1.5, vscale=1.5, wait=FALSE) { if( !requireNamespace('tkrplot', quietly=TRUE) ) stop('This function depends on the tkrplot package being available') ppt <- tcltk::tclVar() tcltk::tclvalue(ppt) <- 0.5 lr <- tcltk::tclVar() tcltk::tclvalue(lr) <- 1 tr <- tcltk::tclVar() tcltk::tclvalue(tr) <- '+' hsc <- tcltk::tclVar() tcltk::tclvalue(hsc) <- hscale vsc <- tcltk::tclVar() tcltk::tclvalue(vsc) <- hscale replot <- function(...) { probs.pre.test <- as.numeric(tcltk::tclvalue(ppt)) LR <- as.numeric(tcltk::tclvalue(lr)) test.result <- tcltk::tclvalue(tr) fagan.plot(probs.pre.test, LR, test.result) } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Fagan Plot Demo") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Pre Test Probability: '), side='left', anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=ppt, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Likelihood Ratio: '), side='left', anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=lr, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=0.01, to=100, resolution=.01), side='right') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tkcheckbutton(fr, text='Positive Test Result', variable=tr, onvalue='+', offvalue='-', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)), side='right',anchor='s') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left') tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tcltk::tkwait.window(tt) return( list(ppt = as.numeric(tcltk::tclvalue(ppt)), lr = as.numeric(tcltk::tclvalue(lr)), tr = tcltk::tclvalue(tr) )) } else { return(invisible(NULL)) } } plotFagan2 <- function(hscale=1.5, vscale=1.5, wait=FALSE) { if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') ppt <- tcltk::tclVar() tcltk::tclvalue(ppt) <- 0.5 sens <- tcltk::tclVar() tcltk::tclvalue(sens) <- 0.5 spec <- tcltk::tclVar() tcltk::tclvalue(spec) <- 0.5 tr <- tcltk::tclVar() tcltk::tclvalue(tr) <- '+' hsc <- tcltk::tclVar() tcltk::tclvalue(hsc) <- hscale vsc <- tcltk::tclVar() tcltk::tclvalue(vsc) <- hscale replot <- function(...) { probs.pre.test <- as.numeric(tcltk::tclvalue(ppt)) sns <- as.numeric(tcltk::tclvalue(sens)) spc <- as.numeric(tcltk::tclvalue(spec)) test.result <- tcltk::tclvalue(tr) fagan.plot(probs.pre.test, sns/(1-spc), test.result) } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Fagan Plot Demo") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Pre Test Probability: '), side='left', anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=ppt, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Sensitivity: '), side='left', anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=sens, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Specificity: '), side='left', anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=spec, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tkcheckbutton(fr, text='Positive Test Result', variable=tr, onvalue='+', offvalue='-', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)), side='right',anchor='s') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left') tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tcltk::tkwait.window(tt) return( list(ppt = as.numeric(tcltk::tclvalue(ppt)), sens = as.numeric(tcltk::tclvalue(sens)), spec = as.numeric(tcltk::tclvalue(spec)), tr = tcltk::tclvalue(tr) )) } else { return(invisible(NULL)) } } TeachingDemos/R/z.test.R0000644000175100001440000000262712657235445014601 0ustar hornikusersz.test <- function(x, mu=0, stdev, alternative = c("two.sided", "less", "greater"), sd=stdev, n=length(x), conf.level = 0.95, ... ) { if(missing(stdev) && missing(sd)) stop("You must specify a Standard Deviation of the population") alternative <- match.arg(alternative) z <- (mean(x)-mu)/(sd/sqrt(n)) out <- list(statistic=c(z=z)) class(out) <- 'htest' out$parameter <- c(n=n,"Std. Dev." = sd, "Std. Dev. of the sample mean" = sd/sqrt(n)) out$p.value <- switch(alternative, two.sided = 2*pnorm(abs(z),lower.tail=FALSE), less = pnorm(z), greater = pnorm(z, lower.tail=FALSE) ) out$conf.int <- switch(alternative, two.sided = mean(x) + c(-1,1)*qnorm(1-(1-conf.level)/2)*sd/sqrt(n), less = c(-Inf, mean(x)+qnorm(conf.level)*sd/sqrt(n)), greater = c(mean(x)-qnorm(conf.level)*sd/sqrt(n), Inf) ) attr(out$conf.int, "conf.level") <- conf.level out$estimate <- c("mean of x" = mean(x)) out$null.value <- c("mean" = mu) out$alternative <- alternative out$method <- "One Sample z-test" out$data.name <- deparse(substitute(x)) names(out$estimate) <- paste("mean of", out$data.name) return(out) } TeachingDemos/R/tdspinner.R0000644000175100001440000000067712657235445015363 0ustar hornikusers# these are utility functions, possibly will be replaced by true internals tdspinner <- function(parent, ...) { # this is a quick hack to provide spinboxes without loading tcltk2 tcltk::tkwidget(parent, "spinbox", ...) } have.ttk <- function() { # based on e-mail from Prof. Brian Ripley # will work until version 8.10 or 10.0, then may need to update as.character(tcltk::tcl("info","tclversion")) >= "8.5" } TeachingDemos/R/sliderv.R0000644000175100001440000000326212657235445015016 0ustar hornikusers"sliderv" <- function(refresh.code,names,minima,maxima,resolutions,starts, title="control",no=0, set.no.value=0) { if(no!=0) return(as.numeric(tcltk::tclvalue(get(paste("slider",no,sep=""),envir=slider.env)))) if(set.no.value[1]!=0){ try(eval(parse(text=paste("tcltk::tclvalue(slider",set.no.value[1],")<-", set.no.value[2],sep="")),envir=slider.env)); return(set.no.value[2]) } if(!exists("slider.env")) slider.env<<-new.env() #library(tcltk); nt<-tcltk::tktoplevel(); tcltk::tkwm.title(nt,title); tcltk::tkwm.geometry(nt,"+0+0") for(i in seq(names)) eval(parse(text=paste("assign(\"slider",i,"\",tcltk::tclVar(starts[i]),envir=slider.env)",sep=""))) for(i in seq(names)){ tcltk::tkpack(fr<-tcltk::tkframe(nt),side='left'); lab<-tcltk::tklabel(fr, text=names[i], width="1") sc<-tcltk::tkscale(fr, command=refresh.code, from=minima[i], to=maxima[i], showvalue=T, resolution=resolutions[i]) assign("sc",sc,envir=slider.env); tcltk::tkpack(lab,sc,side="top") eval(parse(text=paste("tcltk::tkconfigure(sc,variable=slider",i,")",sep="")), envir=slider.env) } tcltk::tkpack(fr<-tcltk::tkframe(nt),fill="x") tcltk::tkpack(tcltk::tkbutton(fr, text="Exit", command=function()tcltk::tkdestroy(nt)), side="right") tcltk::tkpack(tcltk::tkbutton(fr, text="Reset", command=function(){ for(i in seq(starts)) eval(parse(text=paste("tcltk::tclvalue(slider",i,")<-",starts[i],sep="")),envir=slider.env) refresh.code() } ),side="left") } TeachingDemos/R/clt.examp.R0000644000175100001440000000521312657235444015236 0ustar hornikusers"clt.examp" <- function( n=1, reps=10000, nclass=16, norm.param=list(mean=0,sd=1), gamma.param=list(shape=1, rate=1/3), unif.param=list(min=0,max=1), beta.param=list(shape1=0.35, shape2=0.25) ) { # this function demonstrates the central limit theorem # by generating reps samples of size n from 4 different # distributions old.par <- par(oma=c(0,0,2,0), mfrow=c(2,2) ) on.exit( par(old.par) ) # Normal norm.param$n <- n*reps norm.mat <- matrix( do.call('rnorm',norm.param), ncol=n ) norm.mean <- rowMeans(norm.mat) x <- seq( min(norm.mean), max(norm.mean), length=50) normmax <- max( dnorm(x,mean(norm.mean),sd(norm.mean)) ) tmp.hist <- hist( norm.mean, plot=FALSE , nclass=nclass) normmax <- max( tmp.hist$density, normmax )*1.05 hist( norm.mean, main="Normal",xlab="x",col='skyblue' ,freq=FALSE,ylim=c(0,normmax), nclass=nclass) lines( x, dnorm(x,mean(norm.mean),sd(norm.mean)) ) # gamma gamma.param$n <- n*reps exp.mat <- matrix( do.call('rgamma',gamma.param), ncol=n ) exp.mean <- rowMeans(exp.mat) x <- seq( min(exp.mean), max(exp.mean), length=50) expmax <- max( dnorm(x,mean(exp.mean),sd(exp.mean)) ) tmp.hist <- hist( exp.mean, plot=FALSE, nclass=nclass) expmax <- max( tmp.hist$density, expmax)*1.05 hist( exp.mean, main="Gamma",xlab="x",col='skyblue', freq=FALSE,ylim=c(0,expmax), nclass=nclass) lines( x, dnorm(x,mean(exp.mean),sd(exp.mean)) ) # Uniform unif.param$n <- n*reps unif.mat <- matrix( do.call('runif',unif.param), ncol=n ) unif.mean <- rowMeans(unif.mat) x <- seq( min(unif.mean), max(unif.mean), length=50) unimax <- max( dnorm(x,mean(unif.mean),sd(unif.mean)) ) tmp.hist <- hist( unif.mean, plot=FALSE, nclass=nclass) unimax <- max( tmp.hist$density, unimax)*1.05 hist( unif.mean, main="Uniform", xlab="x",col='skyblue', freq=FALSE,ylim=c(0,unimax), nclass=nclass) lines( x, dnorm(x,mean(unif.mean),sd(unif.mean)) ) # Beta beta.param$n <- n*reps beta.mat <- matrix( do.call('rbeta',beta.param), ncol=n ) beta.mean <- rowMeans(beta.mat) x <- seq( min(beta.mean), max(beta.mean), length=50) betamax <- max( dnorm(x,mean(beta.mean),sd(beta.mean)) ) tmp.hist <- hist( beta.mean, plot=FALSE, nclass=nclass) betamax <- max( tmp.hist$density, betamax) hist( beta.mean, main="Beta", xlab="x",col='skyblue', freq=FALSE, ylim=c(0,betamax), nclass=nclass) lines( x, dnorm(x,mean(beta.mean),sd(beta.mean)) ) mtext( paste("sample size =",n), outer=TRUE ,cex=2) invisible(NULL) } TeachingDemos/R/tkexamp.R0000644000175100001440000005225112657235445015021 0ustar hornikusers tkexamp <- function(FUN, param.list, vscale=1.5, hscale=1.5, wait=FALSE, plotloc='top', an.play=TRUE, print=FALSE,...) { if(!requireNamespace("tkrplot", quietly = TRUE)) { stop('The tkrplot package is needed') } tke.tmp.env <- environment() ocl <- cl <- substitute(FUN) exargs <- as.list(quote(list())) PlotYet <- FALSE replot <- if(print){ function() { if(PlotYet){ print(eval(cl)) } } } else { function() { if(PlotYet){ eval(cl) } } } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt,'Tk Example') img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side=plotloc) hsc <- tcltk::tclVar() tcltk::tclvalue(hsc) <- hscale vsc <- tcltk::tclVar() tcltk::tclvalue(vsc) <- vscale fillframe <- function(frame,lst,pkdir,prfx) { for(i in seq_along(lst)) { vname <- paste(prfx, '.', i, sep='') el <- lst[[i]] eln <- names(lst)[i] if( is.list(el[[1]]) ){ fr <- tcltk::tkframe(frame,relief='ridge',borderwidth=3) tcltk::tkpack(fr, side=pkdir) if(length(eln) && nchar(eln)){ tcltk::tkpack(tcltk::tklabel(fr, text=eln), side='top',anchor='nw') } Recall(fr,el,ifelse(pkdir=='top','left','top'),vname) next } if( tolower(el[[1]]) == 'numentry' ){ tcltk::tkpack(fr <- tcltk::tkframe(frame),side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top')) tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if ('init' %in% names(el)) el$init else 1 alist <- list(fr, textvariable=tmp) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tcltk::tkpack(do.call(tcltk::tkentry,alist),side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) next } if( tolower(el[[1]]) == 'entry' ){ tcltk::tkpack(fr <- tcltk::tkframe(frame),side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top')) tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if ('init' %in% names(el)) el$init else "" alist <- list(fr, textvariable=tmp) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tcltk::tkpack(do.call('tkentry',alist),side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(tcltk::tclvalue(VNAME), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) next } if( tolower(el[[1]])== 'slider' ){ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln), side='left', anchor='s', pady=4) tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else if( 'from' %in% names(el) ) { el$from } else { 1 } alist <- list(fr, variable=tmp, orient='horizontal', command=function(...)tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tcltk::tkpack( do.call('tkscale',alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) next } if( tolower(el[[1]])== 'vslider' ){ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln), side='left') tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else if( 'from' %in% names(el) ) { el$from } else { 1 } alist <- list(fr, variable=tmp, orient='vertical', command=function(...)tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tcltk::tkpack( do.call('tkscale',alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) next } if( tolower(el[[1]])== 'spinbox' ){ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top'),anchor='nw') tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else if( 'from' %in% names(el) ) { el$from } else { 1 } tmp2 <- tcltk::tclvalue(tmp) # fix strange resetting on first alist <- list(fr, textvariable=tmp, command=function(...)tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tcltk::tkpack( do.call('tdspinner',alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) tcltk::tclvalue(tmp) <- tmp2 # rest of fix for reset next } if( tolower(el[[1]])== 'checkbox' ){ tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else { "F" } alist <- list(frame, variable=tmp,text=eln, onvalue="T", offvalue="F", command=function(...)tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL tmpvars <- if('values' %in% names(el)){ el$values } else { "" } el2$values <- NULL alist <- c(alist,el2) tcltk::tkpack( do.call(tcltk::tkcheckbutton,alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.logical(tcltk::tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) next } if( tolower(el[[1]])== 'combobox' ){ if( !have.ttk() ) stop('The combobox depends on having tcl 8.5 or higher, either install tcl 8.5 or rerun the function with a different control') tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top')) tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else { "" } alist <- list(fr, textvariable=tmp) el2 <- el[-1] el2$init <- NULL tmpvars <- if('values' %in% names(el)){ el$values } else { "" } el2$values <- NULL alist <- c(alist,el2) tcltk::tkpack( cb <-do.call(tcltk::ttkcombobox,alist), side=pkdir) tcltk::tkconfigure(cb, values=tmpvars) tcltk::tkconfigure(cb, textvariable=tmp) tmpcl <- as.list(cl) tmpl <- list(substitute(tcltk::tclvalue(VNAME), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) next } if( tolower(el[[1]])== 'radiobuttons' ){ tcltk::tkpack(fr <- tcltk::tkframe(frame,relief='groove',borderwidth=3), side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln), side='top', anchor='nw') tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else { el$values[1] } el2 <- el[-1] tmp.vals <- el2$values el2$values <- NULL el2$init <- NULL alist <- list(fr, variable=tmp, command=function()tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) ) pkdir2 <- ifelse( pkdir=='top', 'left', 'top' ) for( v in tmp.vals ){ tcltk::tkpack( do.call(tcltk::tkradiobutton, c(alist, value=v, text=v)), side=pkdir2 ) } tmpcl <- as.list(cl) tmpl <- list(substitute(tcltk::tclvalue(VNAME), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) next } if( tolower(el[[1]])=='animate' ) { if(an.play && requireNamespace('tcltk2',quietly = TRUE)) { tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln),side='left',anchor='s',pady=4) tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else if( 'from' %in% names(el) ) { el$from } else { 1 } alist <- list(fr, variable=tmp, orient='horizontal', command=function(...)tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) ) el2 <- el[-1] tke.tmp.env$an.delay <- if('delay' %in% names(el) ) { el$delay } else {100} el2$delay <- NULL el2$init <- NULL alist <- c(alist,el2) tcltk::tkpack( do.call(tcltk::tkscale,alist), side='left') tke.tmp.env$an.inc <- an.inc <- if('resolution' %in% names(el)) { el$resolution } else { 1 } tke.tmp.env$tke.tmp <- tmp tke.tmp.env$an.to <- an.to <- el$to tke.tmp.env$img <- img tke.tmp.env$hsc <- hsc tke.tmp.env$vsc <- vsc #tmpc <- as.character(tmp) # fname <- paste('tmp.tke.an.',eln, sep='') # tmp.expr <- bquote( { # tcl("set", .(as.character(tmp)), as.numeric(tclvalue(.(as.character(tmp)))) + an.inc) # tkrreplot( img, # hscale=as.numeric(tclvalue(hsc)), # vscale=as.numeric(tclvalue(vsc))) # }) # tke.tmp.env$tmp.tke.an <- function() { # print(sys.frames()) # print(sys.calls()) # n <- ( an.to - as.numeric(tclvalue(tke.tmp)) )/an.inc # tclTaskSchedule(an.delay, tmp.expr, redo=n) # tclvalue(tke.tmp) <- as.numeric(tclvalue(tke.tmp)) + an.inc # tkrreplot( img, # hscale=as.numeric(tclvalue(hsc)), # vscale=as.numeric(tclvalue(vsc))) # }, redo=n) # } tmpc <- as.character(tmp) tmp.tke.an <- function() { n <- (an.to - as.numeric(tcltk::tclvalue(tmp)))/an.inc seq.val <- seq( as.numeric(tcltk::tclvalue(tmp)), an.to, by=an.inc ) seq.wait <- seq( an.delay, by=an.delay, length=n+1) for( i in seq_len(n+1) ) { tmpfun <- eval(bquote(function(){ tcltk::tcl("set", .(tmpc), .(seq.val[i])) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) })) tcltk2::tclAfter(seq.wait[i], tmpfun) } } tcltk::tkpack( tcltk::tkbutton(fr, text="Play", command=tmp.tke.an), side='left') tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs,tmpl) } else { # using button hold tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir) tcltk::tkpack(tcltk::tklabel(fr,text=eln),side='left',anchor='s',pady=4) tmp <- tcltk::tclVar() tcltk::tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else if( 'from' %in% names(el) ) { el$from } else { 1 } alist <- list(fr, variable=tmp, orient='horizontal', command=function(...)tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) ) el2 <- el[-1] tke.tmp.env$an.delay <- an.delay <- if('delay' %in% names(el) ) { el$delay } else {100} el2$delay <- NULL el2$init <- NULL alist <- c(alist,el2) tcltk::tkpack( do.call(tcltk::tkscale,alist), side='left') tke.tmp.env$an.inc <- an.inc <- if('resolution' %in% names(el)) { el$resolution } else { 1 } tke.tmp.env$an.to <- an.to <- el$to tke.tmp.env$tke.tmp <- tmp tke.tmp.env$img <- img tke.tmp.env$hsc <- hsc tke.tmp.env$vsc <- vsc tke.tmp.env$tmp.tke.an <- function() { if( as.numeric(tcltk::tclvalue(tke.tmp)) < an.to ) { tcltk::tclvalue(tke.tmp) <- as.numeric(tcltk::tclvalue(tke.tmp)) + an.inc tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) } } tcltk::tkpack( tcltk::tkbutton(fr, text='Inc', command=tmp.tke.an, repeatdelay=1, repeatinterval=an.delay ), side='left') tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs,tmpl) } next } } } tcltk::tkpack(tfr <- tcltk::tkframe(tt),side='bottom', fill='x') tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function(){tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)))} ), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Print Call", command=function(){ tmp <- c(as.list(ocl),eval(as.call(exargs))) cat(deparse(as.call(tmp)),"\n") flush.console() }), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)), side='right',anchor='s') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left') tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left') fillframe(tt, param.list, plotloc, 'tkv') PlotYet <- TRUE tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc))) if(wait){ tcltk::tkwait.window(tt) return(eval(as.call(exargs))) } else { return(invisible(NULL)) } } # tke.test <- list(Parameters=list( # pch=list('spinbox',init=1,values=c(0:25,32:255),width=5), # cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1), # type=list('radiobuttons',init='b', # values=c('p','l','b','o','c','h','s','S','n'), # width=5), # lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5), # lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5), # xpd=list('checkbox') # )) # # # tke.test3 <- list(Parameters=list( # pch=list('spinbox',init=1,from=0,to=255,width=5), # cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1), # type=list('combobox',init='b', # values=c('p','l','b','o','c','h','s','S','n'), # width=5), # lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5), # lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5) # )) # # # # tke.test2 <- list(pch=list('numentry',init=1,width=3), # cex=list('slider',init=1,from=0.2,to=2.5,resolution=0.1), # type=list('entry',init='p', width=5)) # # # # tke.test1 <- list(pch=list('numentry',init=1,width=3), # cex=list('numentry',init=1), # type=list('entry',init='p', width=5)) # # # TeachingDemos/R/flip.rgl.coin.R0000644000175100001440000000025412657235444016007 0ustar hornikusersflip.rgl.coin <- function(side=sample(2,1), steps=150) { for (i in seq(0,(5+side)*180, length=steps*(5+side)) ){ rgl::rgl.viewpoint(i,0) } return(side) } TeachingDemos/R/power.refresh.R0000644000175100001440000000022412657235444016131 0ustar hornikusers"power.refresh" <- function(...) { power.examp(n=slider(no=1), stdev=slider(no=2), diff=slider(no=3), alpha=slider(no=4) ) } TeachingDemos/R/HWidentify.R0000644000175100001440000000453212657235444015420 0ustar hornikusersHWidentify <- function(x,y,label=seq_along(x), lab.col='darkgreen', pt.col='red', adj=c(0,0), clean=TRUE, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), ...) { plot(x,y,xlab=xlab, ylab=ylab,...) dx <- grconvertX(x,to='ndc') dy <- grconvertY(y,to='ndc') mm <- function(buttons, xx, yy) { d <- (xx-dx)^2 + (yy-dy)^2 if ( all( d > .01 ) ){ plot(x,y,xlab=xlab,ylab=ylab,...) return() } w <- which.min(d) plot(x,y,xlab=xlab,ylab=ylab,...) points(x[w],y[w], cex=2, col=pt.col) text(grconvertX(xx,from='ndc'),grconvertY(yy,from='ndc'), label[w], col=lab.col, adj=adj) return() } md <- function(buttons, xx, yy) { if (any(buttons=='2')) return(1) return() } getGraphicsEvent('Right Click to exit', onMouseMove = mm, onMouseDown=md) if(clean) mm( , Inf, Inf ) invisible() } # tmpx <- runif(25) # tmpy <- rnorm(25) # HWidentify(tmpx,tmpy,LETTERS[1:25], pch=letters) HTKidentify <- function(x,y,label=seq_along(x), lab.col='darkgreen', pt.col='red', adj=c(0,0), xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), ...) { if( !requireNamespace("tkrplot", quietly=TRUE) ) stop ('tkrplot package is required') dx <- numeric(0) dy <- numeric(0) xx <- yy <- 0 replot <- function() { d <- (xx-dx)^2 + (yy-dy)^2 if ( all( d > .01 ) ) { plot(x,y,xlab=xlab,ylab=ylab,...) if( length(dx)==0 ) { dx <<- grconvertX(x, to='ndc') dy <<- grconvertY(y, to='ndc') } return() } w <- which.min(d) plot(x,y,xlab=xlab,ylab=ylab,...) points(x[w],y[w], cex=2, col=pt.col) text(grconvertX(xx,from='ndc'),grconvertY(yy,from='ndc'), label[w], col=lab.col, adj=adj) } tt <- tcltk::tktoplevel() img <- tkrplot::tkrplot(tt, replot, hscale=1.5, vscale=1.5) tcltk::tkpack(img, side='top') iw <- as.numeric(tcltk::tcl("image","width", tcltk::tkcget(img, "-image"))) ih <- as.numeric(tcltk::tcl("image","height", tcltk::tkcget(img, "-image"))) cc <- function(x,y) { x <- (as.double(x) -1)/iw y <- 1-(as.double(y)-1)/ih c(x,y) } mm <- function(x, y) { xy <- cc(x,y) xx <<- xy[1] yy <<- xy[2] tkrplot::tkrreplot(img) } tcltk::tkbind(img, "", mm) invisible() } TeachingDemos/R/face2.plot.R0000644000175100001440000000657712657235444015316 0ustar hornikusers"face2.plot" <- function(x, size=480){ arc1 <- function(x1, y1, r, l) { sign <- ifelse(l > 0, -1, 1) theta <- sign*acos(x1/r) y1 <- y1-sign*sqrt(r^2-x1^2) if (l <= 0) { arc(0, y1, r, theta, pi-theta) } else { arc(0, y1, r, pi-theta, pi*2+theta) } } arc <- function(ox, oy, r, theta.start, theta.end) { step <- min(0.1, (theta.end-theta.start)*0.1) x <- y <- interval <- c(seq(theta.start, theta.end, step), theta.end) i <- 0 for (theta in interval) { i <- i+1 x[i] <- cos(theta) y[i] <- sin(theta) } lines(r*x+ox, r*y+oy) } elips <- function(ox, oy, r.a, r.b, theta.axis, theta.start, theta.end) { theta.end <- theta.end+(theta.end <= theta.start)*pi*2 temp1 <- r.a*r.b temp2 <- 30/(r.a+r.b) k <- (theta.end-theta.start)/temp2+2 x <- y <- rep(NULL, k) for (i in 1:(k-1)) { factor <- temp1/sqrt((r.a*sin(theta.start))^2+(r.b*cos(theta.start))^2) x[i] <- factor*cos(theta.axis+theta.start) y[i] <- factor*sin(theta.axis+theta.start) theta.start <- theta.start+temp2 } factor <- temp1/sqrt((r.a*sin(theta.end))^2+(r.b*cos(theta.end))^2) x[k] <- factor*cos(theta.axis+theta.end) y[k] <- factor*sin(theta.axis+theta.end) lines(ox+x, oy+y) } pi2 <- 2*pi plot(c(-500, 500), c(-500, 500), type="n", xlab="", xaxt="n", ylab="", yaxt="n", bty="n") size2 <- size*(1+x[1])/2 theta <- (pi/4)*(2*x[2]-1) h <- size*(1+x[3])/2 x1 <- size2*cos(theta) y1 <- size2*sin(theta) # ????? ak <- 1-x[4]^2 oy1 <- (ak*x1^2+y1^2-h^2)/(2*(y1-h)) r.a1 <- (r.b1 <- h-oy1)/sqrt(ak) theta.end <- pi-(theta.start <- atan((y1-oy1)/x1)) elips(0, oy1, r.a1, r.b1, 0, theta.start, theta.end) # ????? ak <- 1-x[5]^2 oy2 <- (ak*x1^2+y1^2-h^2)/(2*(y1+h)) r.a2 <- (r.b2 <- h+oy2)/sqrt(ak) theta.start <- pi-(theta.end <- atan((y1-oy2)/x1)) elips(0, oy2, r.a2, r.b2, 0, theta.start, theta.end) # ? y <- h*x[6] lines(c(0, 0), c(y, -y)) # ? pm <- -h*(x[7]+(1-x[7])*x[6]) wm <- sqrt(r.a2^2*(1-(pm-oy2)^2/r.b2^2)) if (x[8] == 0) { lines(c(-wm/2, wm/2), c(pm, pm)) } else { r <- h/abs(x[8]) am <- x[9]*r x1 <- ifelse(am > wm, x[9]*wm, am) l <- ifelse(x[8] <= 0, -1, 1) y1 <- pm-l*(r-sqrt(r^2-x1^2)) arc1(x1, y1, r, l) } # ? ye <- h*(x[10]+(1-x[10])*x[6]) we <- sqrt(r.a1^2*(1-(ye-oy1)^2/r.b1^2)) xe <- we*(1+2*x[11])/4 theta <- (2*x[12]-1)*pi/5 r.a3 <- x[14]*min(xe, we-xe) r.b3 <- sqrt(r.a3^2*(1-x[13]^2)) elips(xe, ye, r.a3, r.b3, theta, 0, pi2) elips(-xe, ye, r.a3, r.b3, pi-theta, 0, pi2) # ? re <- r.a3/sqrt(cos(theta)^2+sin(theta)^2/x[13]^2) shift <- re*(2*x[15]-1) sapply(c(xe, -xe)-shift, function(arg) arc(arg, ye, 3, 0, pi2)) # ? theta2 <- 2*(1-x[17])*(pi/5) theta3 <- ifelse(theta >= 0, theta+theta2, theta-theta2) len <- re*(2*x[18]+1)/2 x0 <- len*cos(theta3) x1 <- xe-c(x0, -x0) y0 <- len*sin(theta3) y1 <- ye+2*(x[16]+0.3)*r.a3*x[13]-c(y0, -y0) lines(x1-shift, y1) lines(-x1-shift, y1) } TeachingDemos/R/rgl.Map.R0000644000175100001440000000127112657235445014644 0ustar hornikusers"rgl.Map" <- function(Map,which,...) { if (missing(which)) which <- TRUE if(!requireNamespace('rgl', quietly = TRUE)) stop("This function depends on the 'rgl' package which is not available") lapply(Map$Shapes[which], function(shape) { long <- shape$verts[,1] * pi/180 lat <- pi/2 - shape$verts[,2] * pi/180 z <- cos(long)*sin(lat) y <- cos(lat) x <- sin(long)*sin(lat) mapply(function(pfrom, pto) { tmp.i <- rep( seq(along=x[pfrom:pto]), each=2 ) tmp.i <- c(tmp.i[-1], 1) rgl::rgl.lines(x[tmp.i], y[tmp.i], z[tmp.i], ...) }, shape$Pstart + 1, c(shape$Pstart[-1], shape$nVerts + 1)) }) invisible() } TeachingDemos/R/Pvalue.sim.R0000644000175100001440000001112512657235444015365 0ustar hornikusersPvalue.norm.sim <- function(n=50, mu=0, mu0=0, sigma=1, sigma0=sigma, test=c('z','t'), alternative=c('two.sided', 'less', 'greater', '<>','!=','<','>'), alpha=0.05, B=1e4) { test <- match.arg(test) alternative <- match.arg(alternative) x <- matrix(rnorm( n*B, mu, sigma ), nrow=n) xbar <- colMeans(x) if( is.na(sigma0) ) sigma0 <- apply(x, 2, sd) ts <- (xbar - mu0)/sigma0*sqrt(n) pdist <- switch(test, z=function(x, lower.tail) pnorm(x, lower.tail=lower.tail), t=function(x, lower.tail) pt(x, df=n-1, lower.tail=lower.tail) ) p.vals <- switch(alternative, '!='=,'<>'=, two.sided = 2*pmin( pdist(ts,TRUE), pdist(ts,FALSE) ), '<'=, less = pdist(ts, TRUE), '>'=, greater = pdist(ts, FALSE) ) op <- par(mfrow=c(2,1)) hist(p.vals, main='', xlab='P-Values') if( !is.na(alpha) ) { abline(v=alpha, col='red') title(sub=paste( round(mean(p.vals <= alpha)*100, 1), '% <= ', alpha)) } qqplot( seq(along=p.vals)/(B+1), p.vals, xlab='Theoretical quantiles of Uniform', ylab='P-values') abline(0,1, col='grey') par(op) invisible(p.vals) } Pvalue.binom.sim <- function(n=100, p=0.5, p0=0.5, test=c('exact','approx'), alternative=c('two.sided', 'less', 'greater', '<>','!=','<','>'), alpha=0.05, B=1e3) { test <- match.arg(test) alternative <- match.arg(alternative) x <- rbinom(B,n,p) pdist <- switch(test, exact=function(x, lower.tail) { if(lower.tail) { pbinom(x, n, p0) } else { pbinom(pmax(0,x-1), n, p0, lower.tail=FALSE) } }, approx=function(x, lower.tail) { xbar <- x/n ts <- (xbar - p0)/sqrt( p0*(1-p0)/n ) pnorm(ts, lower.tail=lower.tail) } ) p.vals <- switch(alternative, '!='=,'<>'=, two.sided = pmin(1,2*pmin( pdist(x,TRUE), pdist(x,FALSE) ) ), '<'=, less = pdist(x, TRUE), '>'=, greater = pdist(x, FALSE) ) op <- par(mfrow=c(2,1)) hist(p.vals, main='', xlab='P-Values') #, col='grey', prob=TRUE) # lines( hist(p.vals, breaks=c(0,pbinom(0:n,n,p0)), plot=FALSE), # border='green') if( !is.na(alpha) ) { abline(v=alpha, col='red') title(sub=paste( round(mean(p.vals <= alpha)*100, 1), '% <= ', alpha)) } qqplot( seq(along=p.vals)/(B+1), p.vals, xlab='Theoretical quantiles of Uniform', ylab='P-values') abline(0,1, col='grey') par(op) invisible(p.vals) } run.Pvalue.norm.sim <- function() { lst <- list( Sim=list( n=list('numentry', init=50), mu=list('numentry', init=0), sigma=list('numentry',init=1), B=list('numentry',init=10000), alpha=list('numentry', init=0.05) ), Test=list( test=list('radiobuttons', values=c('z','t'), init='z'), mu0=list('numentry', init=0), sigma0=list('numentry', init=1), alternative=list('radiobuttons', values=c('!=','<','>'), init='!=')) ) tkexamp(Pvalue.norm.sim(), lst, plotloc='left') } run.Pvalue.binom.sim <- function() { lst <- list( Sim=list( n=list('numentry', init=100), p=list('numentry', init=0.5), B=list('numentry',init=1000), alpha=list('numentry', init=0.05) ), Test=list( test=list('radiobuttons', values=c('exact','approx'), init='exact'), p0=list('numentry', init=0.5), alternative=list('radiobuttons', values=c('!=','<','>'), init='!=')) ) tkexamp(Pvalue.binom.sim(), lst, plotloc='left') } TeachingDemos/R/correct.R0000644000175100001440000000214212657235444015002 0ustar hornikuserscor.rect.plot <- function(x,y, corr=TRUE, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), col=c('#ff000055','#0000ff55'), ... ) { xy <- xy.coords(x,y,xlab=xlab, ylab=ylab) xm <- mean(xy$x) ym <- mean(xy$y) op <- par(mar=c(5,4,4,4)) on.exit(par(op)) plot(xy$x, xy$y, xlab=xlab, ylab=ylab, pty='s') xt <- scale(xy$x, scale=corr) yt <- scale(xy$y, scale=corr) xtt <- pretty(xt) ytt <- pretty(yt) xut <- if(corr) { xtt * attr(xt, 'scaled:scale') + attr(xt, 'scaled:center') } else { xtt + attr(xt, 'scaled:center') } yut <- if(corr) { ytt * attr(yt, 'scaled:scale') + attr(yt, 'scaled:center') } else { ytt + attr(yt, 'scaled:center') } axis(3,at=xut, labels=xtt) axis(4,at=yut, labels=ytt) abline(h=ym) abline(v=xm) ord <- order( xt^2+yt^2, decreasing=TRUE ) w <- xt[ord]*yt[ord] > 0 rect(xm, ym, xy$x[ord][w], xy$y[ord][w], col= col[1] ) rect(xm, ym, xy$x[ord][!w], xy$y[ord][!w], col= col[2] ) points(xy$x,xy$y) } TeachingDemos/R/panel.dice.R0000644000175100001440000000156212657235444015350 0ustar hornikusers"panel.dice" <- function(x,y){ tmp.cols <- c("Red","Green","Blue","Black","Yellow", "Purple","Orange","Brown","Grey","White") box.x <- c( 0.1, 0.9, 0.9, 0.1, 0.1 ) box.y <- c( 0.1, 0.1, 0.9, 0.9, 0.1 ) pips.x <- c( 0.5, 0.3, 0.7, 0.3, 0.7, 0.3, 0.7 ) pips.y <- c( 0.5, 0.7, 0.3, 0.3, 0.7, 0.5, 0.5 ) xx <- ceiling(sqrt(length(x))) yy <- ceiling( length(x)/xx ) for( i in seq(along=x) ){ xo <- y[i] %% xx yo <- yy-1-(y[i] %/% xx) lattice::llines( box.x+xo, box.y+yo,col=tmp.cols[i] ) which <- c( x[i] %%2 == 1, x[i] > c(1,1,3,3,5,5) ) tmp.x <- pips.x[which] tmp.y <- pips.y[which] if( runif(1) < 0.5 ) { tmp.x <- 1-tmp.x } if( runif(1) < 0.5 ) { tmp <- tmp.x tmp.x <- tmp.y tmp.y <- tmp } lattice::lpoints( tmp.x+xo, tmp.y+yo, pch=16,col='black') } } TeachingDemos/R/power.examp.R0000644000175100001440000000343412657235444015613 0ustar hornikuserspower.examp <- function(n=1, stdev=1, diff=1, alpha=0.05, xmin=-2, xmax=4) { old.par <- par(mfrow=c(2,1), oma=c(0,0,3.1,0) ) on.exit(par(old.par)) n<-as.integer(n) stdev<-as.numeric(stdev) diff<-as.numeric(diff) alpha<-as.numeric(alpha) xmin<-as.numeric(xmin) xmax<-as.numeric(xmax) se <- stdev/sqrt(n) x <- seq( xmin, xmax, length=100 ) # null hypothesis plots plot( x, dnorm(x,0,se), type="n", ylim=c(0, dnorm(0,0,se)*7/6), ylab="", main="Null Distribution") r <- qnorm(1-alpha,0,se) polygon( c(r, r, x[ x>r ]), c(0, dnorm(c(r,x[x>r]),0,se)), col='pink') abline(h=0) lines(x, dnorm(x,0,se), col='red' ) abline(v=r) text(r,dnorm(0,0,se)*15/14, "--> rejection region", adj=0) axis(1,at=r, line=-0.75, cex=0.7) legend( par('usr')[2],par('usr')[4],xjust=1,bty='n', fill='pink',legend=expression(alpha)) # Alternative hypothesis plots plot( x, dnorm(x,0,se), type="n", ylim=c(0, dnorm(0,0,se)*7/6), ylab="", main="Alternative Distribution") polygon( c(r, r, x[ x>r ], max(x)), c(0, dnorm(c(r,x[x>r]),diff,se),0), col='lightblue') abline(h=0) lines(x, dnorm(x,diff,se), col='blue' ) abline(v=r) text(r,dnorm(0,0,se)*15/14, "--> rejection region", adj=0) axis(1,at=r, line= -0.75, cex=0.7) legend( par('usr')[2],par('usr')[4],xjust=1,bty='n', fill='lightblue',legend="Power") mtext(paste("se =",format(signif(se,3),nsmall=2), " z* =",format(signif(r,3),nsmall=2), " power =", format(round( 1-pnorm(r,diff,se), 3 ),nsmall=2), "\n n =",format(n,width=3)," sd =",format(stdev,nsmall=2), " diff =",format(diff,nsmall=2), " alpha =",format(alpha,nsmall=3) ), outer=TRUE, line=0, cex=1.5 ) invisible( 1-pnorm(r,diff,se) ) } TeachingDemos/R/TkApprox.R0000644000175100001440000000733012657235445015116 0ustar hornikusersTkApprox <- function(x, y, type='b', snap.to.x=FALSE, digits=4, cols=c('red','#009900','blue'), xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), hscale=1.5, vscale=1.5, wait=TRUE, ...) { if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') snap.x <- tcltk::tclVar() tcltk::tclvalue(snap.x) <- ifelse(snap.to.x,"T","F") xxx <- as.numeric(x) ax <- min(x) cx <- max(x) bx <- (ax+cx)/2 xx <- c(ax,bx,cx) af <- approxfun(x,y) ay <- af(ax) by <- af(bx) cy <- af(cx) yy <- c(ay,by,cy) txtvar <- tcltk::tclVar() tcltk::tclvalue(txtvar) <- " \n \n " first <- TRUE ul <- ur <- 0 replot <- function() { par(mar=c(5,4,4,4)+0.1) plot(x, y, type=type, xlab=xlab, ylab=ylab, ...) u <- par('usr') lines( c(xx[1],xx[1],u[1]), c(u[3],yy[1],yy[1]), col=cols[1] ) lines( c(xx[2],xx[2],u[1]), c(u[3],yy[2],yy[2]), col=cols[2] ) lines( c(xx[3],xx[3],u[1]), c(u[3],yy[3],yy[3]), col=cols[3] ) mtext( format( xx, digits=digits), side=3, at=xx, line=1:3, col=cols) mtext( format( yy, digits=digits), side=4, at=yy, line=1:3, col=cols) tcltk::tclvalue(txtvar) <<- paste( c('A:B ','B:C ','A:C '), format(pmax( xx[c(1,2,1)], xx[c(2,3,3)] ), digits=digits), '-', format(pmin( xx[c(1,2,1)], xx[c(2,3,3)] ), digits=digits), '=', format(abs( xx[c(1,2,1)] - xx[c(2,3,3)] ), digits=digits), ' ', format(pmax( yy[c(1,2,1)], yy[c(2,3,3)] ), digits=digits), '-', format(pmin( yy[c(1,2,1)], yy[c(2,3,3)] ), digits=digits), '=', format(abs( yy[c(1,2,1)] - yy[c(2,3,3)] ), digits=digits), collapse="\n" ) if(first) { first <<- FALSE tmpx <- grconvertX(c(0,1), from='ndc') ul <<- tmpx[1] ur <<- tmpx[2] } } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "TkApprox") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack(tcltk::tklabel(tt, textvariable=txtvar), side='top') tcltk::tkpack(tcltk::tkcheckbutton(tt,variable=snap.x, onvalue="T", offvalue="F", text="Snap to points"), side='left') tcltk::tkpack(tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)), side='right') md <- FALSE iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image'))) ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image'))) ccx <- ccy <- 0 ci <- 0 mouse.move <- function(x,y) { if(md) { tx <- (as.numeric(x)-1)/iw ccx <<- tx*ur + (1-tx)*ul if(as.logical(tcltk::tclvalue(snap.x))) { ccx <<- xxx[ which.min( abs(ccx-xxx) ) ] } xx[ci] <<- ccx ccy <<- af(ccx) yy[ci] <<- ccy tkrplot::tkrreplot(img) } } mouse.down <- function(x,y) { tx <- (as.numeric(x)-1)/iw txx <- tx*ur + (1-tx)*ul ci <<- which.min( abs( txx - xx ) ) md <<- TRUE mouse.move(x,y) } mouse.up <- function(x,y) { md <<- FALSE } tcltk::tkbind(img, '', mouse.move) tcltk::tkbind(img, '', mouse.down) tcltk::tkbind(img, '', mouse.up) if(wait) { tcltk::tkwait.window(tt) out <- list( x=xx, y=yy ) } else { out <- NULL } invisible(out) } TeachingDemos/R/ms.face.R0000644000175100001440000001141312657235444014656 0ustar hornikusers#16: #1: ms.face<-function(features,...){ xy <- unlist(features) #21: spline<-function(a,y,m=200,plot=FALSE){ n<-length(a) h<-diff(a) dy<-diff(y) sigma<-dy/h lambda<-h[-1]/(hh<-h[-1]+h[-length(h)]) mu<-1-lambda d<-6*diff(sigma)/hh tri.mat<-2*diag(n-2) tri.mat[2+ (0:(n-4))*(n-1)] <-mu[-1] tri.mat[ (1:(n-3))*(n-1)] <-lambda[-(n-2)] M<-c(0,solve(tri.mat)%*%d,0) x<-seq(from=a[1],to=a[n],length=m) anz.kl <- hist(x,breaks=a,plot=FALSE)$counts adj<-function(i) i-1 i<-rep(1:(n-1),anz.kl)+1 S.x<- M[i-1]*(a[i]-x )^3 / (6*h[adj(i)]) + M[i] *(x -a[i-1])^3 / (6*h[adj(i)]) + (y[i-1] - M[i-1]*h[adj(i)]^2 /6) * (a[i]-x)/ h[adj(i)] + (y[i] - M[i] *h[adj(i)]^2 /6) * (x-a[i-1]) / h[adj(i)] if(plot){ plot(x,S.x,type="l"); points(a,y) } return(cbind(x,S.x)) } #:21 #4: n.char<-15 xy<-rbind(xy) n<-1 #:4 #5: face.orig<-list( eye =rbind(c(12,0),c(19,8),c(30,8),c(37,0),c(30,-8),c(19,-8),c(12,0)) ,iris =rbind(c(20,0),c(24,4),c(29,0),c(24,-5),c(20,0)) ,lipso=rbind(c(0,-47),c( 7,-49),lipsiend=c( 16,-53),c( 7,-60),c(0,-62)) ,lipsi=rbind(c(7,-54),c(0,-54)) # add lipsiend ,nose =rbind(c(0,-6),c(3,-16),c(6,-30),c(0,-31)) ,shape =rbind(c(0,44),c(29,40),c(51,22),hairend=c(54,11),earsta=c(52,-4), earend=c(46,-36),c(38,-61),c(25,-83),c(0,-89)) ,ear =rbind(c(60,-11),c(57,-30)) # add earsta,earend ,hair =rbind(hair1=c(72,12),hair2=c(64,50),c(36,74),c(0,79)) # add hairend ) lipso.refl.ind<-4:1 lipsi.refl.ind<-1 nose.refl.ind<-3:1 hair.refl.ind<-3:1 shape.refl.ind<-8:1 shape.xnotnull<-2:8 nose.xnotnull<-2:3 #:5 #6: for(ind in 1:n){ #7: factors<-xy[ind,] face <- face.orig #:7 #9: m<-mean(face$lipso[,2]) face$lipso[,2]<-m+(face$lipso[,2]-m)*(1+0.7*factors[4]) face$lipsi[,2]<-m+(face$lipsi[,2]-m)*(1+0.7*factors[4]) face$lipso[,1]<-face$lipso[,1]*(1+0.7*factors[5]) face$lipsi[,1]<-face$lipsi[,1]*(1+0.7*factors[5]) face$lipso["lipsiend",2]<-face$lipso["lipsiend",2]+20*factors[6] #:9 #10: m<-mean(face$eye[,2]) face$eye[,2] <-m+(face$eye[,2] -m)*(1+0.7*factors[7]) face$iris[,2]<-m+(face$iris[,2]-m)*(1+0.7*factors[7]) m<-mean(face$eye[,1]) face$eye[,1] <-m+(face$eye[,1] -m)*(1+0.7*factors[8]) face$iris[,1]<-m+(face$iris[,1]-m)*(1+0.7*factors[8]) #:10 #11: m<-min(face$hair[,2]) face$hair[,2]<-m+(face$hair[,2]-m)*(1+0.2*factors[9]) m<-0 face$hair[,1]<-m+(face$hair[,1]-m)*(1+0.2*factors[10]) m<-0 face$hair[c("hair1","hair2"),2]<-face$hair[c("hair1","hair2"),2]+50*factors[11] #:11 #12: m<-mean(face$nose[,2]) face$nose[,2]<-m+(face$nose[,2]-m)*(1+0.7*factors[12]) face$nose[nose.xnotnull,1]<-face$nose[nose.xnotnull,1]*(1+factors[13]) #:12 #13: m<-mean(face$shape[c("earsta","earend"),1]) face$ear[,1]<-m+(face$ear[,1]-m)* (1+0.7*factors[14]) m<-min(face$ear[,2]) face$ear[,2]<-m+(face$ear[,2]-m)* (1+0.7*factors[15]) #:13 #8: face<-lapply(face,function(x){ x[,2]<-x[,2]*(1+0.2*factors[1]);x}) face<-lapply(face,function(x){ x[,1]<-x[,1]*(1+0.2*factors[2]);x}) face<-lapply(face,function(x){ x[,1]<-ifelse(x[,1]>0, ifelse(x[,2] > -30, x[,1], pmax(0,x[,1]+(x[,2]+50)*0.2*sin(1.5*(-factors[3])))),0);x}) #face$shape[,2]<-face$shape[,2]*(1+0.2*factors[1]) #face$shape[,1]<-face$shape[,1]*(1+0.2*factors[2]) #face$shape[,1]<-face$shape[,1]<-ifelse(face$shape[,1]>0, # ifelse(face$shape[,2] > -30, face$shape[,1], # pmax(0,face$shape[,1]+(face$shape[,2]+50)*0.2*sin(1.5*(-factors[3])))),0) #:8 #14: invert<-function(x) cbind(-x[,1],x[,2]) face.obj<-list( eyer=face$eye ,eyel=invert(face$eye) ,irisr=face$iris ,irisl=invert(face$iris) ,lipso=rbind(face$lipso,invert(face$lipso[lipso.refl.ind,])) ,lipsi=rbind(face$lipso["lipsiend",],face$lipsi, invert(face$lipsi[lipsi.refl.ind,,drop=FALSE]), invert(face$lipso["lipsiend",,drop=FALSE])) ,earr=rbind(face$shape["earsta",],face$ear,face$shape["earend",]) ,earl=invert(rbind(face$shape["earsta",],face$ear,face$shape["earend",])) ,nose=rbind(face$nose,invert(face$nose[nose.refl.ind,])) ,hair=rbind(face$shape["hairend",],face$hair,invert(face$hair[hair.refl.ind,]), invert(face$shape["hairend",,drop=FALSE])) ,shape=rbind(face$shape,invert(face$shape[shape.refl.ind,])) ) #:14 #15: #plot(1,type="n",xlim=c(-105,105)*1.1, axes=FALSE, # ylab="",ylim=c(-105,105)*1.3) tmp <- list(x=numeric(0),y=numeric(0)) for(ind in seq(face.obj)) { x <-face.obj[[ind]][,1]; y<-face.obj[[ind]][,2] xx<-spline(1:length(x),x,40,FALSE)[,2] yy<-spline(1:length(y),y,40,FALSE)[,2] # lines(xx,yy) xx <- xx/105 yy <- yy/105 tmp$x <- c(tmp$x,NA,xx) tmp$y <- c(tmp$y,NA,yy) } #:15 } #:6 return(tmp) } #:1 #:16 TeachingDemos/R/plot.rgl.coin.R0000644000175100001440000000275312657235444016041 0ustar hornikusersrgl.coin <- function(x, col='black', heads=x[[1]], tails=x[[2]], ... ) { if(!requireNamespace('rgl', quietly = TRUE)) stop("This function depends on the 'rgl' library which is not available") if(missing(x)) x <- TeachingDemos::coin.faces rgl::rgl.viewpoint(0,0) for(i in 0:39) { rgl::rgl.triangles(c(.5, cos(pi/20*i)/2+0.5, cos(pi/20*(i+1))/2+0.5), c(.5, sin(pi/20*i)/2+0.5, sin(pi/20*(i+1))/2+0.5), c(0,0,0)) rgl::rgl.triangles(c(.5, cos(pi/20*i)/2+0.5, cos(pi/20*(i+1))/2+0.5), c(.5, sin(pi/20*i)/2+0.5, sin(pi/20*(i+1))/2+0.5), c(0.03,0.03,0.03)) rgl::rgl.quads( c(cos(pi/20*i)/2+0.5, cos(pi/20*i)/2+0.5, cos(pi/20*(i+1))/2+0.5, cos(pi/20*(i+1))/2+0.5), c(sin(pi/20*i)/2+0.5, sin(pi/20*i)/2+0.5, sin(pi/20*(i+1))/2+0.5, sin(pi/20*(i+1))/2+0.5), c(0,0.03,0.03,0) ) } tmp <- rep( 1:nrow(heads), each=2 ) tmp <- c(tmp[-1],1) rgl::rgl.lines( heads[tmp,1], heads[tmp,2], rep(0.035, length(tmp) ), col=col, lit=FALSE) tmp <- rep( 1:nrow(tails), each=2 ) tmp <- c(tmp[-1],1) rgl::rgl.lines( tails[tmp,1], tails[tmp,2], rep(-0.005, length(tmp) ), col=col, lit=FALSE) } #coin.faces <- list( qh=cbind( c(.5,.5), c(.75,.25) ), # qt=cbind( c(.5, .25, .5, .75, .5), # c(.75, .5, .25, .5, .75)) ) TeachingDemos/R/00vars.R0000644000175100001440000000003312657235444014451 0ustar hornikusersslider.env <- new.env() TeachingDemos/R/put.points.demo.R0000644000175100001440000000503412657235444016412 0ustar hornikusers"put.points.demo" <- function( x=NULL, y=NULL, lsline=TRUE) { old.par <- par(no.readonly=T) on.exit(par(old.par)) options(locatorBell=FALSE) mode='add' layout( matrix( c(2,1), nrow=1), widths=c(3,1) ) repeat { ## right panel par(mar=c(0,0,0,0),usr=c(0,1,0,1)) frame() box() abline(h=c(0.8,0.6)) text( rep(0.5, 5), c(0.9, 0.725, 0.525, 0.325, 0.125), lab=c('End','LS Line','Add Point','Delete Point','Move Point') ) lines( c(0.25,0.25,0.75,0.75,0.25), c(0.85,0.95,0.95,0.85,0.85) ) points( rep(0.5,4), c(0.675,0.475,0.275,0.075), pch=c( ifelse(lsline,7,0), ifelse(mode=='add', 16, 1), ifelse(mode=='del', 16, 1), ifelse(mode=='mov', 16, 1)), cex=2.5 ) ## left panel par(mar=c(5,4,4,1)+0.1) if(length(x) == 0) { plot(5,5,type='n', xlim=c(0,10), ylim=c(0,10), xlab='x', ylab='y') } else { plot(x,y, xlim=range(x,0,10), ylim=range(y,0,10), xlab='x', ylab='y') if( lsline && length(x) > 1 ){ tmp.fit <- lm(y~x) abline(tmp.fit) title( paste( "r =", round(cor(x,y),2), "r^2 =", round(cor(x,y)^2,2), "\nSlope =",round(coef(tmp.fit)[2],2), "Intercept =",round(coef(tmp.fit)[1],2)) ) } else { title( paste( "r =", round(cor(x,y),4), "r^2 =", round(cor(x,y)^2,4))) } } # get point pnt <- locator(1) if (pnt$x > par('usr')[2]) { ## clicked in left panel # pnt2 <- cnvrt.coords(pnt)$fig pnt2 <- list() pnt2$y <- grconvertY(pnt$y, to='nfc') if( pnt2$y > .8 ){ break } if( pnt2$y > .6 ){ lsline <- !lsline next } if( pnt2$y > .4 ){ mode <- 'add' next } if( pnt2$y > .2 ){ mode <- 'del' next } mode <- 'mov' next } else { ## clicked in right panel if( mode=='add' ) { x <- c(x,pnt$x) y <- c(y,pnt$y) next } if( mode=='del' ) { min.i <- which.min( (x-pnt$x)^2+(y-pnt$y)^2 ) x <- x[-min.i] y <- y[-min.i] next } if( mode=='mov' ) { mov.i <- which.min( (x-pnt$x)^2+(y-pnt$y)^2 ) points( x[mov.i], y[mov.i], pch=16 ) pnt <- locator(1) x[mov.i] <- pnt$x y[mov.i] <- pnt$y next } } } ## end repeat } TeachingDemos/R/prepanel.dice.R0000644000175100001440000000024612657235444016055 0ustar hornikusers"prepanel.dice" <- function(x,y){ xx <- ceiling(sqrt(length(x))) yy <- ceiling( length(x)/xx ) return(list(ylim=c(-0.1,yy+0.1),xlim=c(-0.1,xx+0.1)) ) } TeachingDemos/R/manipulate.cor.examp.R0000644000175100001440000000155112657235444017376 0ustar hornikusersmanipulate.cor.examp <- function(n=100, seed) { if(!requireNamespace('manipulate', quietly = TRUE)) stop("This function depends on the manipulate package within Rstudio") if(!missing(seed)) set.seed(seed) x <- scale(matrix(rnorm(2*n,0,1), ncol=2)) x <- x %*% solve( chol( cor(x))) xr <- range(x,-x) replot <- function(r) { if( r >= 1 ) { cmat <- matrix( c(1,0,1,0), 2 ) } else if( r <= -1 ) { cmat <- matrix( c(1,0,-1,0), 2 ) } else { cmat <- chol( matrix(c(1,r,r,1),2) ) } new.x <- x %*% cmat plot(new.x, xlab='x',ylab='y', xlim=xr,ylim=xr) title(paste("r =", round(r,3))) } r <- NA # so that following function does not complain about global var manipulate::manipulate(replot(r),r=manipulate::slider(-1,1,0,step=0.005)) }TeachingDemos/R/vis.test.R0000644000175100001440000001004712657235445015124 0ustar hornikusersvis.test <- function(..., FUN, nrow=3, ncol=3, npage=3, data.name='', alternative) { dots <- list(...) if(missing(FUN)) { m <- sapply( dots, mode ) mm <- m == 'function' if(any(mm)){ mm <- min(which(mm)) } else { stop('A function to create the plot must be specified') } FUN <- dots[[mm]] dots[[mm]] <- NULL } seeds <- sample(1024, (nrow*ncol - 3)*npage+2) cseeds <- seeds[1:2] seeds <- seeds[ -(1:2) ] seeds <- matrix(seeds, ncol=npage) seeds <- lapply( 1:npage, function(i) { sample( c(NA, cseeds, seeds[,i] ) ) } ) sel <- integer(npage) dev.new() par(mfrow=c(nrow,ncol)) for(i in 1:npage) { for( j in seeds[[i]] ) { if (is.na(j)) { dots$orig <- TRUE do.call(FUN, dots) } else { set.seed(j) dots$orig <- FALSE do.call(FUN, dots) } } loc <- locator(1) csel <- 1 x <- grconvertX(loc$x, from='user', to='ndc') for ( k in seq_len(ncol-1)/ncol ) { if( x > k ) csel <- csel + 1 } y <- 1-grconvertY(loc$y, from='user', to='ndc') for ( k in seq_len(nrow-1)/nrow ) { if( y > k ) csel <- csel + ncol } sel[i] <- csel } cnt <- sum( sapply( seq_len(npage), function(i) is.na(seeds[[i]][ sel[i] ]) ) ) names(cnt) <- 'Number Correct' p.value <- pbinom( npage-cnt, npage, 1-1/(ncol*nrow) ) out <- list( method='Visual Test', data.name=data.name, statistic=cnt, p.value=p.value, npage=npage, ncol=ncol, nrow=nrow) if( !missing(alternative) ) out$alternative <- alternative out$seeds <- seeds out$selected <- sel dev.off() class(out) <- 'htest' return(out) } vt.qqnorm <- function(x, orig=TRUE) { par(mar=c(2.5,2.5,1,1)+0.1) if(orig) { qqnorm(x,xlab='',ylab='',main='') qqline(x) } else { y <- rnorm( length(x), mean(x), sd(x) ) qqnorm(y,xlab='',ylab='',main='') qqline(y) } } vt.normhist <- function(x, ..., orig=TRUE) { par(mar=c(2.5,2.5,1,1)+0.1) if(orig) { hist(x, main='', xlab='', ylab='', prob=TRUE, ...) curve(dnorm(x, mean(x), sd(x)), add=TRUE, col='blue') } else { y <- rnorm( length(x), mean(x), sd(x) ) hist(y, main='', xlab='', ylab='', prob=TRUE, ...) curve(dnorm(x, mean(y), sd(y)), add=TRUE, col='blue') } } vt.scatterpermute <- function(x, y, ..., orig=TRUE) { par(mar=c(2.5,2.5,1,1)+0.1) if(orig) { plot(x, y, xlab='', ylab='', ...) } else { plot(x, sample(y), xlab='', ylab='', ...) } } vt.tspermute <- function(x, type='l', ..., orig=TRUE) { par(mar=c(2.5,2.5,1,1)+0.1) if(orig) { plot(x, type=type, xlab='', ylab='', ...) } else { plot(sample(x), type=type, xlab='', ylab='', ...) } } vt.residpermute <- function(model, ..., orig=TRUE) { par(mar=c(2.5,2.5,1,1)+0.1) if(orig) { scatter.smooth( fitted(model), resid(model), xlab='', ylab='', col='blue' ) abline(h=0, col='green') } else { scatter.smooth( fitted(model), sample(resid(model)), xlab='', ylab='', col='blue') abline(h=0, col='green') } } vt.residsim <- function(model, ..., orig=TRUE) { par(mar=c(2.5,2.5,1,1)+0.1) if(orig) { scatter.smooth( fitted(model), resid(model), xlab='', ylab='', col='blue' ) abline(h=0, col='green') } else { scatter.smooth( fitted(model), rnorm( length(resid(model)), 0, sd(resid(model)) ), xlab='', ylab='', col='blue') abline(h=0, col='green') } } TeachingDemos/R/prob.axis.R0000644000175100001440000000012212657235444015242 0ustar hornikusersprob.axis <- function(side, dist, dist.args, at=NULL, labels=TRUE, ...) { } TeachingDemos/R/shadowtext.R0000644000175100001440000000076412657235445015544 0ustar hornikusersshadowtext <- function(x, y=NULL, labels, col='white', bg='black', theta= seq(pi/4, 2*pi, length.out=8), r=0.1, ... ) { xy <- xy.coords(x,y) xo <- r*strwidth('A') yo <- r*strheight('A') for (i in theta) { text( xy$x + cos(i)*xo, xy$y + sin(i)*yo, labels, col=bg, ... ) } text(xy$x, xy$y, labels, col=col, ... ) } #plot(1:10, 1:10, bg='aliceblue') #rect(3,3,5,8, col='navy') #text(5,6, 'Test 1', col='lightsteelblue') #shadowtext(5,4, 'Test 2', col='lightsteelblue') TeachingDemos/R/dynIdentify.R0000644000175100001440000002114012657235444015626 0ustar hornikusersdynIdentify <- function(x,y,labels=seq_along(x), corners = cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) ), ...) { lx <- x # label positions ly <- y lx[ is.na(labels) ] <- NA ly[ is.na(labels) ] <- NA llx <- lx # line end positions lly <- ly replot <- function() { plot(x,y,...) segments(x,y, llx,lly) text(lx,ly,labels) } replot() # tmp <- cnvrt.coords(x,y, input='usr')$dev dx <- grconvertX(x, to='ndc') dy <- grconvertY(y, to='ndc') # device coordinates of points widths <- strwidth(labels)/2 heights <- strheight(labels)/2 ci <- 0 # current label mouse.down <- function(buttons, x, y){ if( any(buttons==2) ){ out <- list( labels=list(x=lx, y=ly), lineends=list(x=llx, y=lly) ) return(out) } # tmp <- cnvrt.coords(lx,ly, input='usr')$dev i <- which.min( (grconvertX(lx,to='ndc')-x)^2 + (grconvertY(ly,to='ndc')-y)^2 ) ci <<- i NULL } mouse.up <- function(buttons, x, y){ # tmp <- cnvrt.coords(x,y, input='dev')$usr cx <- grconvertX(x, from='ndc') cy <- grconvertY(y, from='ndc') tmpx <- cx + corners[,1]*widths[ci] tmpy <- cy + corners[,2]*heights[ci] # tmp <- cnvrt.coords(tmpx,tmpy, input='usr')$dev i <- which.min( (dx[ci] - grconvertX(tmpx,to='ndc'))^2 + (dy[ci] - grconvertY(tmpy, to='ndc'))^2 ) # tmp <- lx; tmp[ci] <- cx; lx <<- tmp # tmp <- ly; tmp[ci] <- cy; ly <<- tmp # tmp <- llx; tmp[ci] <- tmpx[i]; llx <<- tmp # tmp <- lly; tmp[ci] <- tmpy[i]; lly <<- tmp lx[ci] <<- cx ly[ci] <<- cy llx[ci] <<- tmpx[i] lly[ci] <<- tmpy[i] replot() NULL } out <- getGraphicsEvent( prompt= "Click on points and drag label to position. \nRight click to exit\n", onMouseDown=mouse.down, onMouseUp=mouse.up) invisible(out) } TkIdentify <- function(x,y,labels=seq_along(x), hscale=1.75, vscale=1.75, corners = cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) ), ...) { if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') md <- FALSE lx <- x # label positions ly <- y lx[ is.na(labels) ] <- NA ly[ is.na(labels) ] <- NA llx <- lx # line end positions lly <- ly first <- TRUE dx <- dy <- dlx <- dly <- widths <- heights <- numeric(0) ul <- ur <- ut <- ub <- 0 replot <- function() { plot(x,y,...) segments(x,y, llx,lly) text(lx,ly,labels) if(first) { first <<- FALSE # tmp <- cnvrt.coords(x,y, input='usr')$dev dx <<- grconvertX(x, to='ndc') dy <<- grconvertY(y, to='ndc') widths <<- strwidth(labels)/2 heights <<- strheight(labels)/2 # tmp <- cnvrt.coords(c(0,1),c(0,1), input='dev')$usr ul <<- grconvertX(0, from='ndc') ur <<- grconvertX(1, from='ndc') ub <<- grconvertY(0, from='ndc') ut <<- grconvertY(1, from='ndc') } # tmp <- cnvrt.coords(lx,ly, input='usr')$dev dlx <<- grconvertX(lx, to='ndc') dly <<- grconvertY(ly, to='ndc') } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "TkIdentify") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)), side='right') corners <- cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) ) ci <- 0 # current label cx <- cy <- 0 iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image'))) ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image'))) mouse.move <- function(x,y) { if(md){ tx <- (as.numeric(x)-1)/iw ty <- 1-(as.numeric(y)-1)/ih cx <<- tx*ur + (1-tx)*ul cy <<- ty*ut + (1-ty)*ub # tmp <- lx; tmp[ci] <- cx; lx <<- tmp # tmp <- ly; tmp[ci] <- cy; ly <<- tmp lx[ci] <<- cx ly[ci] <<- cy tmpx <- cx + corners[,1]*widths[ci] tmpy <- cy + corners[,2]*heights[ci] tmpxx <- (tmpx - ul)/(ur-ul) tmpyy <- (tmpy - ub)/(ut-ub) i <- which.min( (dx[ci] - tmpxx)^2 + (dy[ci] - tmpyy)^2 ) # tmp <- lx; tmp[ci] <- cx; lx <<- tmp # tmp <- ly; tmp[ci] <- cy; ly <<- tmp # tmp <- llx; tmp[ci] <- tmpx[i]; llx <<- tmp # tmp <- lly; tmp[ci] <- tmpy[i]; lly <<- tmp lx[ci] <<- cx ly[ci] <<- cy llx[ci] <<- tmpx[i] lly[ci] <<- tmpy[i] tkrplot::tkrreplot(img) } } mouse.down <- function(x,y){ tx <- (as.numeric(x)-1)/iw ty <- 1-(as.numeric(y)-1)/ih ci <<- which.min( (tx - dlx)^2 + (ty - dly)^2 ) md <<- TRUE mouse.move(x,y) } mouse.up <- function(x,y){ md <<- FALSE } tcltk::tkbind(img, '', mouse.move) tcltk::tkbind(img, '', mouse.down) tcltk::tkbind(img, '', mouse.up) tcltk::tkwait.window(tt) out <- list( labels=list(x=lx, y=ly), lineends=list(x=llx, y=lly) ) invisible(out) } ### old version, possibilities for the Tk version ## dynIdentify <- function(x,y,labels=seq_along(x), ...) { ## plot(x,y,...) ## ## tmp <- cnvrt.coords(x,y, input='usr')$dev ## dx <- tmp$x ## dy <- tmp$y # device coordinates of points ## ## print(dx) ## print(dy) ## ## lx <- rep(NA, length(x) ) # label positions ## ly <- rep(NA, length(y) ) ## llx <- lx # line end positions ## lly <- ly ## ## widths <- strwidth(labels)/2 ## heights <- strheight(labels)/2 ## ## corners <- cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) ) ## ## md <- FALSE # mouse button down ## ## cx <- 0 # current ## cy <- 0 ## ci <- 0 ## ## replot <- function() { ## if(!md){return()} ## plot(x,y,...) ## segments(x,y, llx,lly) ## text(lx,ly,labels) ## } ## ## mouse.move <- function(buttons, x, y){ ## ## tmp <- cnvrt.coords(x,y, input='dev')$usr ## cx <<- tmp$x ## cy <<- tmp$y ## if(md){ ## ## tmpx <- cx + corners[,1]*widths[ci] ## tmpy <- cy + corners[,2]*heights[ci] ## tmp <- cnvrt.coords(tmpx,tmpy, input='usr')$dev ## i <- which.min( (dx[ci] - tmp$x)^2 + ## (dy[ci] - tmp$y)^2 ) ## tmp <- lx; tmp[ci] <- cx; lx <<- tmp ## tmp <- ly; tmp[ci] <- cy; ly <<- tmp ## tmp <- llx; tmp[ci] <- tmpx[i]; llx <<- tmp ## tmp <- lly; tmp[ci] <- tmpy[i]; lly <<- tmp ## replot() ## } ## NULL ## } ## ## mouse.down <- function(buttons, x, y){ ## ## if( any(buttons==2) ){ ## out <- list( labels=list(x=lx, y=ly), ## lineends=list(x=llx, y=lly) ) ## return(out) ## } ## i <- which.min( (dx-x)^2 + (dy-y)^2 ) ## ci <<- i ## md <<- TRUE ## mouse.move(buttons, x, y) ## NULL ## } ## ## mouse.up <- function(buttons, x, y){ ## ## tmp <- dx; tmp[ci] <- NA; dx <<- tmp ## tmp <- dy; tmp[ci] <- NA; dy <<- tmp ## ## if(all(is.na(dx))) { ## out <- list( labels=list(x=lx, y=ly), ## lineends=list(x=llx, y=lly) ) ## return(out) ## } ## ## md <<- FALSE ## ci <<- 0 ## NULL ## } ## ## out <- getGraphicsEvent( prompt= "Click on points and drag label to position.\nRight click to exit\n", ## onMouseDown=mouse.down, ## onMouseMove=mouse.move, ## onMouseUp=mouse.up) ## ## invisible(out) ## } TeachingDemos/R/chisq.detail.R0000644000175100001440000000301112657235444015705 0ustar hornikusers"chisq.detail" <- function(tab){ d <- dim(tab) ct <- colSums(tab) rt <- rowSums(tab) tt <- sum(rt) ev <- ( rt %o% ct )/ tt ch2 <- (tab - ev)^2 / ev out1 <- matrix( "", ncol = d[2] + 1, nrow = d[1]*3 + 1) if( is.null( dimnames(tab) ) ){ dimnames(out1) <- list( c( rep("",d[1]*3), "Total"), c( rep("", d[2]), "Total") ) } else { dimnames(out1) <- list( c( rbind(dimnames(tab)[[1]],"",""), "Total" ), c( dimnames(tab)[[2]], "Total" ) ) } out1[ 3*(1:d[1])-2, 1:d[2] ] <- paste(tab," ", sep="") out1[ 3*(1:d[1])-1, 1:d[2] ] <- format(round(ev,2), nsmall=2) out1[ 3*(1:d[1])-2, d[2]+1] <- rt out1[ 3*d[1]+1, 1:d[2] ] <- paste(ct," ",sep="") out1[ 3*d[1]+1, d[2]+1 ] <- tt cat("\n\nobserved\nexpected\n\n") print(out1, quote=FALSE, right=TRUE) out2 <- matrix("", nrow=d[1], ncol= 2*d[2]+1) if( is.null( dimnames(tab) ) ){ dimnames(out2) <- list( rep("",d[1]), rep("", d[2]*2+1) ) } else { dimnames(out2) <- list( dimnames(tab)[[1]], c( rbind(dimnames(tab)[[2]],""), "" ) ) } out2[ 1:d[1], 2*(1:d[2])-1 ] <- format(round(ch2,2), nsmall=2) out2[ 1:d[1], 2*(1:d[2]) ] <- "+" out2[ d[1], 2* d[2] ] <- "=" out2[ d[1], 2* d[2] +1 ] <- round( sum( ch2 ),2 ) cat("\n\nCell Contributions\n") print(out2, quote=FALSE, right=TRUE) cat("\ndf =", (d[1]-1)*(d[2]-1), " P-value =", round( 1 - pchisq(sum(ch2), (d[1]-1)*(d[2]-1)), 3), "\n\n" ) invisible(list( obs = tab, expected = ev, chi.table = ch2, chi2 = sum(ch2) ) ) } TeachingDemos/R/run.hist.demo.R0000644000175100001440000000304212657235445016037 0ustar hornikusers"run.hist.demo" <- function(x) { if(!requireNamespace('tcltk', quietly=TRUE)){stop('The tcltk package is needed')} pr <- pretty(x) xr <- range(pr) xr[1] <- 4*xr[1] - 3*min(x) xr[2] <- 4*xr[2] - 3*max(x) hist.refresh <- function(...) { hist(x,seq( slider(no=2), slider(no=3), length=slider(no=1)+1), xlim=xr) } slider(hist.refresh, c('Number of bins','Minimum','Maximum'), c(1, xr[1], max(x)), c(length(x),min(x),xr[2]), c(1, (min(x)-xr[1])/50, (xr[2]-max(x))/50), c(nclass.Sturges(x),min(pr),max(pr)), title="Histogram Demo") } ## # create new version using tkrplot changing min, max, and nbins, include rug ## ## hist.demo <- function(x,xmin,xmax,n,xlab=deparse(substitute(x))) { ## br <- seq(xmin,xmax, length.out=n+1) ## print(range(x)) ## hist(x,br, xlab=xlab, main='') ## } ## ## ## run.hist.demo <- function(xx,...) { ## if(!require(tkrplot)) { stop('The tkrplot package is needed')} ## ## xlab <- deparse(substitute(xx)) ## ## pr <- pretty(xx) ## h1 <- hist(xx, plot=FALSE) ## plist <- list( xmin = list('spinbox', from=min(pr), to=min(x), ## increment=(min(x)-min(pr))/10 ), ## xmax = list('spinbox', from=max(x), to=max(pr), ## increment=(max(pr)-max(x))/10, init=max(pr) ), ## n = list('slider', from=1, to=length(x), resolution=1, ## init=length(h1$breaks)-1)) ## tkexamp( hist.demo(xx,xlab=xlab), plist ) ## } ## ## TeachingDemos/R/digits.R0000644000175100001440000000060312657235444014624 0ustar hornikusersdigits <- function(x, n=NULL, simplify = FALSE) { if(length(x) > 1) { if(is.null(n) & simplify) { n <- floor(max(log10(x))) + 1 } sapply(x,digits, simplify=simplify, n=n) } else { if(is.null(n)) { n <- floor(log10(x)) } else { n <- n - 1 } x %/% 10^seq(n,0) %% 10 } } TeachingDemos/R/vis.gamma.R0000644000175100001440000002445312657235445015235 0ustar hornikusers"vis.gamma" <- function(){ if(!exists('slider.env')) slider.env<<-new.env() if(!requireNamespace('tcltk', quietly = TRUE)) { stop('This function needs the tcltk package') } shape <- 1; assign('shape',tcltk::tclVar(shape),envir=slider.env) rate <- 1; assign('rate',tcltk::tclVar(rate),envir=slider.env) scale <- 1; assign('scale',tcltk::tclVar(scale),envir=slider.env) mean <- 1; assign('mean', tcltk::tclVar(mean), envir=slider.env) sd <- 1; assign('sd',tcltk::tclVar(sd), envir=slider.env) se <- 0; assign('se', tcltk::tclVar(se), envir=slider.env) sc2 <- 0; assign('sc2', tcltk::tclVar(sc2), envir=slider.env) sg <- 1; assign('sg', tcltk::tclVar(sg), envir=slider.env) xmin <- 0; assign('xmin',tcltk::tclVar(xmin),envir=slider.env) xmax <- 5; assign('xmax',tcltk::tclVar(xmax),envir=slider.env) ymin <- 0; assign('ymin',tcltk::tclVar(ymin),envir=slider.env) ymax <- 1; assign('ymax',tcltk::tclVar(ymax),envir=slider.env) old.shape <- shape old.rate <- rate old.scale <- scale old.mean <- mean old.sd <- sd gamma.refresh <- function(...){ shape <- as.numeric(evalq(tcltk::tclvalue(shape), envir=slider.env)) rate <- as.numeric(evalq(tcltk::tclvalue(rate), envir=slider.env)) scale <- as.numeric(evalq(tcltk::tclvalue(scale), envir=slider.env)) mean <- as.numeric(evalq(tcltk::tclvalue(mean), envir=slider.env)) sd <- as.numeric(evalq(tcltk::tclvalue(sd), envir=slider.env)) if ( shape != old.shape ) { mean <- shape * scale sd <- round( sqrt(shape)*scale, 6 ); try(eval(parse(text=paste("tcltk::tclvalue(mean)<-", mean,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(sd)<-", sd,sep="")),envir=slider.env)); old.shape <<- shape; old.mean <<- mean; old.sd <<- sd } if ( rate != old.rate ) { scale <- round(1/rate, 6) mean <- shape * scale sd <- round( sqrt(shape)*scale, 6 ); try(eval(parse(text=paste("tcltk::tclvalue(scale)<-", scale,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(mean)<-", mean,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(sd)<-", sd,sep="")),envir=slider.env)); old.rate <<- rate; old.scale <<- scale; old.mean <<- mean; old.sd <<- sd } if ( scale != old.scale ) { rate <- round(1/scale, 6) mean <- shape * scale sd <- round( sqrt(shape)*scale, 6 ); try(eval(parse(text=paste("tcltk::tclvalue(rate)<-", rate,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(mean)<-", mean,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(sd)<-", sd,sep="")),envir=slider.env)); old.rate <<- rate; old.scale <<- scale; old.mean <<- mean; old.sd <<- sd } if ( mean != old.mean ) { shape <- round( (mean/sd)^2, 6 ) scale <- round( mean/shape, 6 ) rate <- round(1/scale, 6) try(eval(parse(text=paste("tcltk::tclvalue(rate)<-", rate,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(shape)<-", shape,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(scale)<-", scale,sep="")),envir=slider.env)); old.shape <<- shape; old.rate <<- rate; old.scale <<- scale; old.mean <<- mean; old.sd <<- sd } if ( sd != old.sd ) { shape <- round( (mean/sd)^2, 6 ) scale <- round( mean/shape, 6 ) rate <- round(1/scale, 6) try(eval(parse(text=paste("tcltk::tclvalue(rate)<-", rate,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(shape)<-", shape,sep="")),envir=slider.env)); try(eval(parse(text=paste("tcltk::tclvalue(scale)<-", scale,sep="")),envir=slider.env)); old.shape <<- shape; old.rate <<- rate; old.scale <<- scale; old.mean <<- mean; old.sd <<- sd } se <- as.numeric(evalq(tcltk::tclvalue(se), envir=slider.env)) sc2 <- as.numeric(evalq(tcltk::tclvalue(sc2), envir=slider.env)) sg <- as.numeric(evalq(tcltk::tclvalue(sg), envir=slider.env)) xmin <- as.numeric(evalq(tcltk::tclvalue(xmin), envir=slider.env)) xmax <- as.numeric(evalq(tcltk::tclvalue(xmax), envir=slider.env)) ymin <- as.numeric(evalq(tcltk::tclvalue(ymin), envir=slider.env)) ymax <- as.numeric(evalq(tcltk::tclvalue(ymax), envir=slider.env)) xx <- seq(xmin,xmax, length=500) plot(xx,xx, xlim=c(xmin,xmax),ylim=c(ymin,ymax), xlab='x', ylab='y',type='n') if(se) { yye <- dexp(xx,1/mean) lines(xx,yye, lwd=3, col='green') lines(c(mean,mean),c(ymin,dexp(mean,1/mean)), lty=2, col='green') lines(c(mean,mean*2), dexp(mean*2, 1/mean)*c(1,1), lty=2, col='green') } if(sc2) { yyc <- dchisq(xx,mean) lines(xx,yyc, lwd=3, col='blue') lines(c(mean,mean),c(ymin,dchisq(mean,mean)), lty=2, col='blue') lines(c(mean,mean+sqrt(2*mean)), dchisq(mean+sqrt(2*mean), mean)*c(1,1), lty=2, col='blue') } if(sg) { yyg <- dgamma(xx,shape,rate) lines(xx,yyg, lwd=2) lines(c(mean,mean),c(ymin,dgamma(mean,shape,rate)), lty=2) lines(c(mean,mean+sd), dgamma(mean+sd, shape, rate)*c(1,1), lty=2) } } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'Visualizing the Gamma Distribution') tcltk::tkwm.geometry(m,'+0+0') # shape tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Shape', width='10'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=10, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=shape),envir=slider.env) # rate tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Rate', width='10'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=10, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=rate),envir=slider.env) # scale tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Scale', width='10'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=10, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=scale),envir=slider.env) # mean tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Mean', width='10'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=100, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=mean),envir=slider.env) # sd tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='S.D.', width='10'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=40, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sd),envir=slider.env) # show exponential tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=gamma.refresh), side='left') tcltk::tkpack(tcltk::tklabel(fr, text='Show Exponential Distribution', width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=se),envir=slider.env) # show chisquared tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=gamma.refresh), side='left') tcltk::tkpack(tcltk::tklabel(fr, text='Show Chi-squared Distribution', width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sc2),envir=slider.env) # show gamma tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=gamma.refresh), side='left') tcltk::tkpack(tcltk::tklabel(fr, text='Show Gamma Distribution', width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sg),envir=slider.env) # xmin tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Xmin:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=xmin), envir=slider.env) # xmax tcltk::tkpack(tcltk::tklabel(fr, text='Xmax:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=xmax), envir=slider.env) # ymin tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Ymin:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=ymin), envir=slider.env) # ymax tcltk::tkpack(tcltk::tklabel(fr, text='Ymax:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=ymax), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=gamma.refresh),side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } TeachingDemos/R/updateusr.R0000644000175100001440000000110312657235445015352 0ustar hornikusersupdateusr <- function(x1,y1=NULL,x2,y2=NULL) { xy1 <- xy.coords(x1,y1) xy2 <- if( missing(x2) && missing(y2) ) { xy.coords(y1) } else { xy.coords(x2,y2) } cur.usr <- par('usr') xslope <- diff(xy2$x)/diff(xy1$x) yslope <- diff(xy2$y)/diff(xy1$y) new.usr.x <- xslope * ( cur.usr[1:2] - xy1$x ) + xy2$x new.usr.y <- yslope * ( cur.usr[3:4] - xy1$y ) + xy2$y invisible(par(usr=c(new.usr.x, new.usr.y))) } # need to add options for dealing with fewer than 2 points, more than 2 points, and NA values. TeachingDemos/R/vis.boxcoxu.R0000644000175100001440000001130112657235445015626 0ustar hornikusersvis.boxcoxu.old <- function(lambda = sample( c(-1, -0.5, 0, 1/3, 1/2, 1, 2), 1)) { if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') y <- rnorm(1000, 7, 2) if( min(y) <= 0 ) y <- y - min(y)+0.05 if (lambda==0) { y <- exp(y) } else { y <- y^(1/lambda) } if(!exists('slider.env')) slider.env <<-new.env() #library(tcltk) lam <- 1 ; assign('lam',tcltk::tclVar(lam), envir=slider.env) bc.refresh <- function(...){ lam <- as.numeric(evalq(tcltk::tclvalue(lam), envir=slider.env)) old.par <- par(mfcol=c(2,2)) on.exit(par(old.par)) ty <- bct(y,lam) hist(y, prob=T, xlab='x', main='Histogram of x') xx <- seq(min(y),max(y), length=250) lines(xx, dnorm( xx, mean(y), sqrt(var(y)) )) qqnorm(y, xlab='x') qqline(y) hist(ty, prob=T, xlab='Transformed x', main = 'Histogram of Transformed x') xx <- seq(min(ty),max(ty), length=250) lines(xx,dnorm(xx, mean(ty), sqrt(var(ty)) ) ) qqnorm(ty, xlab='Transformed x') qqline(ty) } m <- tcltk::tktoplevel() tcltk::tkwm.title(m, 'Box Cox Transform') tcltk::tkwm.geometry(m,'+0+0') tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='lambda', width='10'), side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=bc.refresh, from=-2, to=3, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=lam), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=bc.refresh), side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } vis.boxcoxu <- function(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1), y, xlab=deparse(substitute(y)), hscale=1.5, vscale=1.5, wait=FALSE) { if( missing(y) ) { if(missing(xlab)) xlab <- 'y' y <- rnorm(1000, 7, 2) if( min(y) <= 0 ) y <- y - min(y) + 0.05 if(lambda==0) { y <- exp(y) } else { y <- y^(1/lambda) } } lam <- tcltk::tclVar() tcltk::tclvalue(lam) <- 1 hsc <- tcltk::tclVar() tcltk::tclvalue(hsc) <- hscale vsc <- tcltk::tclVar() tcltk::tclvalue(vsc) <- hscale replot <- function(...) { tmp.l <- as.numeric(tcltk::tclvalue(lam)) par(mfcol=c(2,2)) ty <- bct(y,tmp.l) hist(y, prob=TRUE, xlab=xlab, main = paste('Histogram of',xlab)) xx <- seq(min(y),max(y), length=250) lines(xx, dnorm(xx, mean(y), sd(y)) ) qqnorm(y, xlab=xlab) qqline(y) hist(ty, prob=TRUE, xlab=paste("Transformed",xlab), main=paste("Histogram of Transformed",xlab)) xx <- seq(min(ty),max(ty), length=250) lines(xx,dnorm(xx, mean(ty), sd(ty))) qqnorm(ty, xlab=paste("Transformed",xlab)) qqline(ty) } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Box Cox Demo") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='lambda: '), side='left', anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=lam, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=-2, to=4, resolution=.05), side='right') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)), side='right',anchor='s') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left') tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tcltk::tkwait.window(tt) return( list(lambda = as.numeric(tcltk::tclvalue(lam)), y = y, ty = bct(y,as.numeric(tcltk::tclvalue(lam))) ) ) } else { return(invisible(NULL)) } } TeachingDemos/R/petals.R0000644000175100001440000000325712657235444014641 0ustar hornikuserspetals <- function(plot=TRUE, txt=TRUE) { ####### Don't Cheat ####### tmpstr <- " " tmpstr2 <- c( " O "," O O ","O O O","O O O O","O O O O O","O O O O O O") ans <- eval(parse(text=rawToChar(packBits( unlist(strsplit(tmpstr,''))==' ')))) resp <- TRUE while(resp) { roll <- unlist(dice(1,5,plot.it=plot)) if(txt) { cat("\n---\n") cat(tmpstr2[roll], sep='\n---\n') cat("---\n") } petals <- ans(roll) resp <- readline('How many petals around the rose? ') if(nchar(resp)==0) { cat("There were", petals, "petals around the rose\n") resp <- FALSE } else { if(as.numeric(resp)==petals) { cat("correct, there were", petals,"petals around the rose\n", sep=' ') } else { cat("No, there were", petals, "petals around the rose\n", sep=' ') } resp <- TRUE } } ####### Don't Cheat ################ } ## The following lines hid the source code from casual inspection in R 2.13 ## but from 2.14 on this is no longer likely to work, see the R-help archives ## for a possible alternative. #.onAttach <- function(...) { # petals <- petals # attr(petals,'source') <- "Don't Cheat!" # assign('petals',petals,'package:TeachingDemos') #} TeachingDemos/R/R2txt.R0000644000175100001440000004527412657235444014401 0ustar hornikusers### consider adding option to include errors Can implement by using ### options(error=newfunction) and newfunction would use the ### savehistory command to get the expression and geterrmessage to get ### the error message. Warnings can be included by checking to see if ### last.warning has changed, use print.warnings to format. R2txt.vars <- new.env() R2txt <- function(cmd,res,s,vis) { if(R2txt.vars$first) { R2txt.vars$first <- FALSE if( R2txt.vars$res ) { sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } else { if( R2txt.vars$cmd ){ cmdline <- deparse(cmd) cmdline <- gsub(' ', paste("\n",R2txt.vars$continue, sep=''), cmdline) cmdline <- gsub('}', paste("\n",R2txt.vars$continue,"}", sep=''), cmdline) cat(R2txt.vars$prompt, cmdline, "\n", sep='', file=R2txt.vars$con) } if( R2txt.vars$cmdfile ) { cmdline <- deparse(cmd) cmdline <- gsub(' ', "\n ", cmdline) cmdline <- gsub('}', "\n}", cmdline) cat(cmdline,"\n", file=R2txt.vars$con2) } if( R2txt.vars$res ) { tmp <- textConnectionValue(R2txt.vars$outcon) if(length(tmp)) { cat(tmp,sep='\n',file=R2txt.vars$con) sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } } TRUE } txtStart <- function(file, commands=TRUE, results=TRUE, append=FALSE, cmdfile, visible.only=TRUE) { tmp <- TRUE if(is.character(file)){ if(append){ con <- file(file,open='a') } else { con <- file(file,open='w') } tmp <- FALSE } else if( any( class(file) == 'connection' ) ) { con <- file } else { stop('file must be a character string or connection') } if( tmp && isOpen(con) ) { R2txt.vars$closecon <- FALSE } else { R2txt.vars$closecon <- TRUE if(tmp){ if(append) { open(con, open='a') } else { open(con, open='w') } } } R2txt.vars$vis <- visible.only R2txt.vars$cmd <- commands R2txt.vars$res <- results R2txt.vars$con <- con R2txt.vars$first <- TRUE if(results) { R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } if( !missing(cmdfile) ) { tmp <- TRUE if(is.character(cmdfile)) { con2 <- file(cmdfile, open='w') tmp <- FALSE } else if( any( class(cmdfile) == 'connection' ) ) { con2 <- cmdfile } if( tmp && isOpen(con2) ) { R2txt.vars$closecon2 <- FALSE } else { R2txt.vars$closecon2 <- TRUE if(tmp) { open(con2, open='w') } } R2txt.vars$con2 <- con2 R2txt.vars$cmdfile <- TRUE } else { R2txt.vars$cmdfile <- FALSE } R2txt.vars$prompt <- unlist(options('prompt')) R2txt.vars$continue <- unlist(options('continue')) options(prompt= paste('txt',R2txt.vars$prompt,sep=''), continue= paste('txt',R2txt.vars$continue,sep='') ) cat('Output being copied to text file,\nuse txtStop to end\n') addTaskCallback(R2txt, name='r2txt') invisible(NULL) } txtStop <- function() { removeTaskCallback('r2txt') if( R2txt.vars$closecon ) { close( R2txt.vars$con ) } if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) { close( R2txt.vars$con2 ) } options( prompt=R2txt.vars$prompt, continue=R2txt.vars$continue ) if(R2txt.vars$res) { sink() close(R2txt.vars$outcon) } evalq( rm(list=ls()), envir=R2txt.vars ) invisible(NULL) } txtComment <- function(txt,cmdtxt) { R2txt.vars$first <- TRUE if(!missing(txt)) { cat("\n",txt,"\n\n", file=R2txt.vars$con) } if(!missing(cmdtxt)) { cat("# ",cmdtxt,"\n", file=R2txt.vars$con2) } } txtSkip <- function(expr) { R2txt.vars$first <- TRUE expr } ######### etxt extended or enscriptable R2etxt <- function(cmd,res,s,vis) { if(R2txt.vars$first) { R2txt.vars$first <- FALSE if( R2txt.vars$res ) { sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } else { if( R2txt.vars$cmd ) { cmdline <- deparse(cmd) cmdline <- gsub(' ', "\n", cmdline) cmdline <- gsub('}', "\n}", cmdline) writeChar("",R2txt.vars$con) cat(R2txt.vars$cmdbg,file=R2txt.vars$con) writeChar("",R2txt.vars$con) cat(R2txt.vars$cmdcol,file=R2txt.vars$con) cat(R2txt.vars$prompt, cmdline, "\n", sep='', file=R2txt.vars$con) } if( R2txt.vars$cmdfile ) { cmdline <- deparse(cmd) cmdline <- gsub(' ', "\n ", cmdline) cmdline <- gsub('}', "\n}", cmdline) cat(cmdline,"\n", file=R2txt.vars$con2) } if( R2txt.vars$res ) { tmp <- textConnectionValue(R2txt.vars$outcon) if(length(tmp)) { writeChar("",R2txt.vars$con) cat(R2txt.vars$resbg, file=R2txt.vars$con) writeChar("",R2txt.vars$con) cat(R2txt.vars$rescol,file=R2txt.vars$con) cat(tmp,sep='\n',file=R2txt.vars$con) sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } } TRUE } etxtStart <- function(dir=tempfile('etxt'), file='transcript.txt', commands=TRUE, results=TRUE, append=FALSE, cmdbg='white',cmdcol='red', resbg='white', rescol='navy',combg='cyan',comcol='black', cmdfile, visible.only=TRUE) { if( !file_test("-d", dir) ) { dir.create(dir) } tmp <- TRUE if(is.character(file)){ file2 <- file.path(dir,file) if(append){ con <- file(file2,open='a') } else { con <- file(file2,open='w') } tmp <- FALSE R2txt.vars$file2 <- file2 } else if( any( class(file) == 'connection' ) ) { con <- file } else { stop('file must be a character string or connection') } if(tmp && isOpen(con)) { R2txt.vars$closecon <- FALSE } else { R2txt.vars$closecon <- TRUE if(tmp) { if(append) { open(con, open='a') } else { open(con, open='w') } } } R2txt.vars$dir <- dir R2txt.vars$vis <- visible.only R2txt.vars$cmd <- commands R2txt.vars$res <- results R2txt.vars$con <- con R2txt.vars$first <- TRUE tmp <- round( col2rgb( c(cmdbg,cmdcol,resbg,rescol,combg,comcol) )/255, 3) tmp2 <- paste( rep(c('bgcolor{','color{'),3), tmp[1,], ' ', tmp[2,], ' ', tmp[3,], '}', sep='' ) R2txt.vars$cmdbg <- tmp2[1] R2txt.vars$cmdcol <- tmp2[2] R2txt.vars$resbg <- tmp2[3] R2txt.vars$rescol <- tmp2[4] R2txt.vars$combg <- tmp2[5] R2txt.vars$comcol <- tmp2[6] if(results) { R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } tmp3 <- TRUE if( !missing(cmdfile) ) { if(is.character(cmdfile)) { con2 <- file(cmdfile, open='w') tmp3 <- FALSE } else if( any( class(cmdfile) == 'connection' ) ) { con2 <- cmdfile } if( tmp3 && isOpen(con2) ) { R2txt.vars$closecon2 <- FALSE } else { R2txt.vars$closecon2 <- TRUE if(tmp3) { open(con2, open='w') } } R2txt.vars$con2 <- con2 R2txt.vars$cmdfile <- TRUE } else { R2txt.vars$cmdfile <- FALSE } R2txt.vars$prompt <- unlist(options('prompt')) R2txt.vars$continue <- unlist(options('continue')) options(prompt= paste('etxt',R2txt.vars$prompt,sep=''), continue= paste('etxt',R2txt.vars$continue,sep='') ) cat('Output being copied to text file,\nuse etxtStop to end\n') addTaskCallback(R2etxt, name='r2etxt') invisible(NULL) } etxtStop <- function() { removeTaskCallback('r2etxt') if( R2txt.vars$closecon ) { close( R2txt.vars$con ) } if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) { close( R2txt.vars$con2 ) } options( prompt=R2txt.vars$prompt, continue=R2txt.vars$continue ) if(R2txt.vars$res) { sink() close(R2txt.vars$outcon) } if( 'file2' %in% names(R2txt.vars) ) { out <- R2txt.vars$file2 } else { out <- invisible(NULL) } evalq( rm(list=ls()), envir=R2txt.vars ) out } etxtComment <- function(txt,cmdtxt) { R2txt.vars$first <- TRUE if(!missing(txt)) { writeChar("",R2txt.vars$con) cat(R2txt.vars$combg,file=R2txt.vars$con) writeChar("",R2txt.vars$con) cat(R2txt.vars$comcol,file=R2txt.vars$con) cat("\n",txt,"\n\n", file=R2txt.vars$con) } if(!missing(cmdtxt)) { cat("# ",cmdtxt,"\n", file=R2txt.vars$con2) } } etxtSkip <- function(expr) { R2txt.vars$first <- TRUE expr } etxtPlot <- function(file=paste(tempfile('plot',R2txt.vars$dir),'.eps',sep=''), width=4, height=4) { dev.copy2eps(file=file, height=height, width=width) writeChar("",R2txt.vars$con) cat('epsf{',file,'}\n', sep='', file=R2txt.vars$con) R2txt.vars$first <- TRUE invisible(NULL) } #### version for sending output to MSword R2wdtxt <- function(cmd,res,s,vis) { requireNamespace('R2wd', quietly = TRUE) if(R2txt.vars$first) { R2txt.vars$first <- FALSE if( R2txt.vars$res ) { sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } else { if( R2txt.vars$cmd ){ cmdline <- deparse(cmd) cmdline <- gsub(' ', paste("\n",R2txt.vars$continue, sep=''), cmdline) cmdline <- gsub('}', paste("\n",R2txt.vars$continue,"}", sep=''), cmdline) R2wd::wdVerbatim( paste(R2txt.vars$prompt, cmdline, sep=''), fontsize=R2txt.vars$fontsize ) } if( R2txt.vars$cmdfile ) { cmdline <- deparse(cmd) cmdline <- gsub(' ', "\n ", cmdline) cmdline <- gsub('}', "\n}", cmdline) cat(cmdline,"\n", file=R2txt.vars$con2) } if( R2txt.vars$res ) { tmp <- textConnectionValue(R2txt.vars$outcon) if(length(tmp)) { R2wd::wdVerbatim(paste(tmp,sep='\n'), fontsize=R2txt.vars$fontsize) sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } } TRUE } wdtxtStart <- function(commands=TRUE, results=TRUE, fontsize=9, cmdfile, visible.only=TRUE) { if( !requireNamespace('R2wd', quietly = TRUE) ) stop('the R2wd package is required') R2wd::wdGet() R2txt.vars$vis <- visible.only R2txt.vars$cmd <- commands R2txt.vars$res <- results R2txt.vars$first <- TRUE R2txt.vars$fontsize <- fontsize if(results) { R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } if( !missing(cmdfile) ) { tmp <- TRUE if(is.character(cmdfile)) { con2 <- file(cmdfile, open='w') tmp <- FALSE } else if( any( class(cmdfile) == 'connection' ) ) { con2 <- cmdfile } if( tmp && isOpen(con2) ) { R2txt.vars$closecon2 <- FALSE } else { R2txt.vars$closecon2 <- TRUE if(tmp) { open(con2, open='w') } } R2txt.vars$con2 <- con2 R2txt.vars$cmdfile <- TRUE } else { R2txt.vars$cmdfile <- FALSE } R2txt.vars$prompt <- unlist(options('prompt')) R2txt.vars$continue <- unlist(options('continue')) options(prompt= paste('wdTxt',R2txt.vars$prompt,sep=''), continue= paste('wdTxt',R2txt.vars$continue,sep='') ) cat('Output being copied to text file,\nuse wdtxtStop to end\n') addTaskCallback(R2wdtxt, name='r2wdtxt') invisible(NULL) } wdtxtStop <- function() { removeTaskCallback('r2wdtxt') if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) { close( R2txt.vars$con2 ) } options( prompt=R2txt.vars$prompt, continue=R2txt.vars$continue ) if(R2txt.vars$res) { sink() close(R2txt.vars$outcon) } evalq( rm(list=ls()), envir=R2txt.vars ) invisible(NULL) } wdtxtComment <- function(txt,cmdtxt) { requireNamespace('R2wd', quietly = TRUE) R2txt.vars$first <- TRUE if(!missing(txt)) { R2wd::wdParagraph() R2wd::wdBody(txt) R2wd::wdParagraph() } if(!missing(cmdtxt)) { cat("# ",cmdtxt,"\n", file=R2txt.vars$con2) } } wdtxtSkip <- function(expr) { R2txt.vars$first <- TRUE expr } wdtxtPlot <- function(height=5, width=5, pointsize=10) { requireNamespace('R2wd', quietly = TRUE) R2txt.vars$first <- TRUE tmp <- recordPlot() R2wd::wdPlot(tmp, plotfun=replayPlot, height=height, width=width, pointsize=pointsize) } ########## mdtxt Use markdown R2mdtxt <- function(cmd,res,s,vis) { if(R2txt.vars$first) { R2txt.vars$first <- FALSE if( R2txt.vars$res ) { sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } else { if( R2txt.vars$cmd ){ cmdline <- deparse(cmd) cmdline <- gsub(' ', "\n", cmdline) cmdline <- gsub('}', "\n}", cmdline) cat("```r\n",file=R2txt.vars$con) cat(R2txt.vars$prompt, cmdline, "\n", sep='', file=R2txt.vars$con) cat("```\n\n", file=R2txt.vars$con) } if( R2txt.vars$cmdfile ) { cmdline <- deparse(cmd) cmdline <- gsub(' ', "\n ", cmdline) cmdline <- gsub('}', "\n}", cmdline) cat(cmdline,"\n", file=R2txt.vars$con2) } if( R2txt.vars$res ) { tmp <- textConnectionValue(R2txt.vars$outcon) if(length(tmp)) { cmdline <- deparse(cmd) if( grepl("^\\s*pand(er|oc)", cmdline)[1] ) { cat("\n",file=R2txt.vars$con) cat(tmp,sep='\n',file=R2txt.vars$con) cat("\n\n",file=R2txt.vars$con) sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } else { cat("```\n",file=R2txt.vars$con) cat(tmp,sep='\n',file=R2txt.vars$con) cat("```\n\n",file=R2txt.vars$con) sink() close(R2txt.vars$outcon) R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } } } } TRUE } mdtxtStart <- function(dir=tempfile('mdtxt'), file='transcript.md', commands=TRUE, results=TRUE, append=FALSE, cmdfile, visible.only=TRUE) { if( !file_test("-d", dir) ) { dir.create(dir) } tmp <- TRUE if(is.character(file)){ file2 <- file.path(dir,file) if(append){ con <- file(file2,open='a') } else { con <- file(file2,open='w') } tmp <- FALSE R2txt.vars$file2 <- file2 } else if( any( class(file) == 'connection' ) ) { con <- file } else { stop('file must be a character string or connection') } if(tmp && isOpen(con)) { R2txt.vars$closecon <- FALSE } else { R2txt.vars$closecon <- TRUE if(tmp) { if(append) { open(con, open='a') } else { open(con, open='w') } } } R2txt.vars$dir <- dir R2txt.vars$vis <- visible.only R2txt.vars$cmd <- commands R2txt.vars$res <- results R2txt.vars$con <- con R2txt.vars$first <- TRUE if(results) { R2txt.vars$outcon <- textConnection(NULL, open='w') sink(R2txt.vars$outcon, split=TRUE) } tmp3 <- TRUE if( !missing(cmdfile) ) { if(is.character(cmdfile)) { con2 <- file(cmdfile, open='w') tmp3 <- FALSE } else if( any( class(cmdfile) == 'connection' ) ) { con2 <- cmdfile } if( tmp3 && isOpen(con2) ) { R2txt.vars$closecon2 <- FALSE } else { R2txt.vars$closecon2 <- TRUE if(tmp3) { open(con2, open='w') } } R2txt.vars$con2 <- con2 R2txt.vars$cmdfile <- TRUE } else { R2txt.vars$cmdfile <- FALSE } R2txt.vars$prompt <- unlist(options('prompt')) R2txt.vars$continue <- unlist(options('continue')) options(prompt= paste('mdtxt',R2txt.vars$prompt,sep=''), continue= paste('mdtxt',R2txt.vars$continue,sep='') ) cat('Output being copied to text file,\nuse mdtxtStop to end\n') addTaskCallback(R2mdtxt, name='r2mdtxt') invisible(NULL) } mdtxtStop <- function() { removeTaskCallback('r2mdtxt') if( R2txt.vars$closecon ) { close( R2txt.vars$con ) } if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) { close( R2txt.vars$con2 ) } options( prompt=R2txt.vars$prompt, continue=R2txt.vars$continue ) if(R2txt.vars$res) { sink() close(R2txt.vars$outcon) } if( 'file2' %in% names(R2txt.vars) ) { out <- R2txt.vars$file2 } else { out <- invisible(NULL) } evalq( rm(list=ls()), envir=R2txt.vars ) out } mdtxtComment <- function(txt,cmdtxt) { R2txt.vars$first <- TRUE if(!missing(txt)) { cat("\n",txt,"\n\n", file=R2txt.vars$con) } if(!missing(cmdtxt)) { cat("# ",cmdtxt,"\n", file=R2txt.vars$con2) } } mdtxtSkip <- function(expr) { R2txt.vars$first <- TRUE expr } mdtxtPlot <- function(file=tempfile('plot',R2txt.vars$dir,'.png'), width=4, height=4) { file <- gsub("\\\\","/",file) dev.copy(png, file=file, height=height, width=width, units='in', res=300) dev.off() cat('![plot ',file,'](',file,') \\\n\n', sep='', file=R2txt.vars$con) R2txt.vars$first <- TRUE invisible(NULL) } TeachingDemos/R/tree.demo.R0000644000175100001440000000151212657235445015224 0ustar hornikusers"tree.demo" <- function(x,y){ old.opt <- options(locatorBell = FALSE) on.exit( options(old.opt) ) cuts <- range(x) repeat { cut2 <- numeric(0) repeat { plot(x,y,xlab=deparse(substitute(x)), ylab=deparse(substitute(y))) abline( v=cuts, col='blue' ) abline( v=cut2, col='red' ) cuts3 <- sort( c(cuts,cut2) ) cats <- cut( x, cuts3, include.lowest=T) means <- tapply(y, cats, mean ) index <- tapply(y, cats ) segments(cuts3[-length(cuts3)], means, cuts3[-1], means, col='green' ) resid <- y-means[index] ss <- round(resid %*% resid) title( paste( "Residual sum of squares =", ss ) ) tempx <- locator(1)$x if (length(tempx) < 1) break cut2 <- tempx } if(length(cut2) < 1) break cuts <- sort( c(cuts,cut2) ) } } TeachingDemos/R/plot.dice.R0000644000175100001440000000130112657235444015216 0ustar hornikusers"plot.dice" <- function(x,...){ if(!requireNamespace('lattice', quietly = TRUE)) stop('The lattice package is needed') old.trellis.par <- lattice::trellis.par.get() on.exit(lattice::trellis.par.set(old.trellis.par)) lattice::trellis.par.set(theme=lattice::col.whitebg()) df <- as.matrix(x) x <- c(df) y <- c(col(df)) - 1 g <- factor(c(row(df))) xx <- ceiling(sqrt(dim(df)[2])) yy <- ceiling( dim(df)[2]/xx ) invisible(print(lattice::xyplot( y~x|g, prepanel=prepanel.dice, panel=panel.dice, scales=list(draw=FALSE), aspect=yy/xx, strip=FALSE, as.table=TRUE, xlab="", ylab="",...))) } TeachingDemos/R/vis.t.R0000644000175100001440000000714112657235445014411 0ustar hornikusers"vis.t" <- function(){ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package') if(!exists('slider.env')) slider.env<<-new.env() df <- 1; assign('df',tcltk::tclVar(df),envir=slider.env) sn <- 0; assign('sn',tcltk::tclVar(sn),envir=slider.env) xmin <- -5; assign('xmin',tcltk::tclVar(xmin),envir=slider.env) xmax <- 5; assign('xmax',tcltk::tclVar(xmax),envir=slider.env) ymin <- 0; assign('ymin',tcltk::tclVar(ymin),envir=slider.env) ymax <- round(dnorm(0,0,1),2); assign('ymax',tcltk::tclVar(ymax),envir=slider.env) t.refresh <- function(...){ df <- as.numeric(evalq(tcltk::tclvalue(df), envir=slider.env)) sn <- as.numeric(evalq(tcltk::tclvalue(sn), envir=slider.env)) xmin <- as.numeric(evalq(tcltk::tclvalue(xmin), envir=slider.env)) xmax <- as.numeric(evalq(tcltk::tclvalue(xmax), envir=slider.env)) ymin <- as.numeric(evalq(tcltk::tclvalue(ymin), envir=slider.env)) ymax <- as.numeric(evalq(tcltk::tclvalue(ymax), envir=slider.env)) xx <- seq(xmin,xmax, length=500) yyt <- dt(xx,df) if(sn){ yyn <- dnorm(xx) plot(xx,yyn, lwd=3, col='skyblue', type='l', xlim=c(xmin,xmax), ylim=c(ymin,ymax), xlab='x', ylab='') lines(xx,yyt,lwd=2) } else { plot(xx,yyt,type='l', xlim=c(xmin,xmax), ylim=c(ymin,ymax), ylab='',xlab='x',lwd=2) } } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'Visualizing the t-Distribution') tcltk::tkwm.geometry(m,'+0+0') # df tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='d.f.', width='5'),side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=t.refresh, from=1, to=50, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=df),envir=slider.env) # show normal tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Show Normal Distribution', width='25'),side='right') tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=t.refresh), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sn),envir=slider.env) # xmin tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Xmin:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=xmin), envir=slider.env) # xmax tcltk::tkpack(tcltk::tklabel(fr, text='Xmax:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=xmax), envir=slider.env) # ymin tcltk::tkpack(fr <- tcltk::tkframe(m),side='top') tcltk::tkpack(tcltk::tklabel(fr, text='Ymin:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=ymin), envir=slider.env) # ymax tcltk::tkpack(tcltk::tklabel(fr, text='Ymax:', width=6), side='left') tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e, textvariable=ymax), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=t.refresh),side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } TeachingDemos/R/run.cor.examp.R0000644000175100001440000000737412657235445016055 0ustar hornikusers"run.old.cor.examp" <- function(n=100,seed) { if (!missing(seed)){ set.seed(seed) } if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')} x <- scale(matrix(rnorm(2*n,0,1), ncol=2)) x <- x %*% solve( chol( cor(x) ) ) xr <- range(x) cor.refresh <- function(...) { r <- slider(no=1) if ( r == 1 ) { cmat <- matrix( c(1,0,1,0),2 ) } else if (r == -1) { cmat <- matrix( c(1,0,-1,0),2 ) } else { cmat <- chol( matrix( c(1,r,r,1),2) ) } new.x <- x %*% cmat plot(new.x, xlab='x',ylab='y', xlim=xr, ylim=xr) title(paste("r = ",round(cor(new.x[,1],new.x[,2]),3))) } slider( cor.refresh, 'Correlation', -1, 1, 0.01, 0, title="Correlation Demo") cor.refresh() } run.cor.examp <- function(n=100,seed,vscale=1.5,hscale=1.5,wait=FALSE) { if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') if(!missing(seed) ) set.seed(seed) x <- scale(matrix(rnorm(2*n,0,1), ncol=2)) x <- x %*% solve( chol( cor(x) ) ) xr <- range(x,-x) hsc <- tcltk::tclVar() tcltk::tclvalue(hsc) <- hscale vsc <- tcltk::tclVar() tcltk::tclvalue(vsc) <- vscale r <- tcltk::tclVar() tcltk::tclvalue(r) <- 0 replot <- function(...) { tmp.r <- as.numeric(tcltk::tclvalue(r)) if( tmp.r == 1 ) { cmat <- matrix( c(1,0,1,0),2 ) } else if( tmp.r == -1 ) { cmat <- matrix( c(1,0,-1,0),2 ) } else { cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) ) } new.x <- x %*% cmat plot(new.x, xlab='x', ylab='y', xlim=xr, ylim=xr) title(paste("r =", round( tmp.r, 3))) } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Cor2 Example") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr,text='r: '), side='left',anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=r, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=-1, to=1, resolution=0.01), side='right') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)), side='right',anchor='s') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left') tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait){ tcltk::tkwait.window(tt) tmp.r <- as.numeric(tcltk::tclvalue(r)) if( tmp.r == 1 ) { cmat <- matrix( c(1,0,1,0),2 ) } else if( tmp.r == -1 ) { cmat <- matrix( c(1,0,-1,0),2 ) } else { cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) ) } new.x <- x %*% cmat return( list(x=new.x[,1], y=new.x[,2]) ) } else { return(invisible(NULL)) } } TeachingDemos/R/pairs2.R0000644000175100001440000000751412657235444014551 0ustar hornikuserspairs2 <- function (x, y, xlabels, ylabels, panel = points, ..., row1attop = TRUE, gap = 1) { localAxis <- function(side, x, y, xpd, bg, col = NULL, main, oma, xlab, ylab, ... ) { if (side%%2 == 1){ Axis(x, side = side, xpd = NA, ...) mtext(xlab,side=side, line=3) } else { Axis(y, side = side, xpd = NA, ...) mtext(ylab,side=side, line=3) } } localPlot <- function(..., main, oma, font.main, cex.main) plot(...) localPanel <- function(..., main, oma, font.main, cex.main) panel(...) dots <- list(...) nmdots <- names(dots) if (!is.matrix(x)) { x <- as.data.frame(x) for (i in seq_along(names(x))) { if (is.factor(x[[i]]) || is.logical(x[[i]])) x[[i]] <- as.numeric(x[[i]]) if (!is.numeric(unclass(x[[i]]))) stop("non-numeric argument to 'pairs'") } } else if (!is.numeric(x)) stop("non-numeric argument to 'pairs'") if (!is.matrix(y)) { y <- as.data.frame(y) for (i in seq_along(names(y))) { if (is.factor(y[[i]]) || is.logical(y[[i]])) y[[i]] <- as.numeric(y[[i]]) if (!is.numeric(unclass(y[[i]]))) stop("non-numeric argument to 'pairs'") } } else if (!is.numeric(y)) stop("non-numeric argument to 'pairs'") panel <- match.fun(panel) nc.x <- ncol(x) nc.y <- ncol(y) has.xlabs <- has.ylabs <- TRUE if (missing(xlabels)) { xlabels <- colnames(x) if (is.null(xlabels)) xlabels <- paste("xvar", 1:nc.x) } else if (is.null(xlabels)) has.xlabs <- FALSE if (missing(ylabels)) { ylabels <- colnames(y) if (is.null(ylabels)) ylabels <- paste("yvar", 1:nc.x) } else if (is.null(ylabels)) has.ylabs <- FALSE oma <- if ("oma" %in% nmdots) dots$oma else NULL main <- if ("main" %in% nmdots) dots$main else NULL if (is.null(oma)) { oma <- c(4, 4, 4, 4) if (!is.null(main)) oma[3] <- 6 } opar <- par(mfrow = c(nc.y, nc.x), mar = rep.int(gap/2, 4), oma = oma) on.exit(par(opar)) for (i in if (row1attop) 1:nc.y else nc.y:1) for (j in 1:nc.x) { localPlot(x[, j], y[, i], xlab = "", ylab = "", axes = FALSE, type = "n", ...) if (i == j || i < j || i > j ) { box() if (i == 1 && (!(j%%2))) localAxis(1 + 2 * row1attop, x[, j], y[, i], xlab=xlabels[j], ylab=ylabels[i], ...) if (i == nc.y && (j%%2)) localAxis(3 - 2 * row1attop, x[, j], y[, i], xlab=xlabels[j], ylab=ylabels[i], ...) if (j == 1 && (!(i%%2) )) localAxis(2, x[, j], y[, i], xlab=xlabels[j], ylab=ylabels[i], ...) if (j == nc.x && (i%%2)) localAxis(4, x[, j], y[, i], xlab=xlabels[j], ylab=ylabels[i], ...) mfg <- par("mfg") localPanel(as.vector(x[, j]), as.vector(y[,i]), ...) if (any(par("mfg") != mfg)) stop("the 'panel' function made a new plot") } else par(new = FALSE) } if (!is.null(main)) { font.main <- if ("font.main" %in% nmdots) dots$font.main else par("font.main") cex.main <- if ("cex.main" %in% nmdots) dots$cex.main else par("cex.main") mtext(main, 3, 3, TRUE, 0.5, cex = cex.main, font = font.main) } invisible(NULL) } TeachingDemos/R/loess.demo.R0000644000175100001440000000462112657235444015415 0ustar hornikusers"loess.demo" <- function(x, y, span = 2/3, degree = 1, nearest = FALSE, xlim = numeric(0), ylim = numeric(0), verbose = FALSE) { # function to demonstrate the locally weighted regression function loess # written by Dr. Greg Snow # Brigham Young University, Department of Statistics # gls@byu.edu now greg.snow@imail.org # Modified by Henrik Aa. Nielsen, IMM, DTU (han@imm.dtu.dk) miss.xy <- is.na(x) | is.na(y) x <- x[!miss.xy] y <- y[!miss.xy] y <- y[order(x)] x <- x[order(x)] fit.d <- loess(y ~ x, degree = degree, span = span, family = "gaussian", control = loess.control( surface = "direct")) fit.i <- loess(y ~ x, degree = degree, span = span, family = "gaussian") est <- list(x = seq(min(x), max(x), len = 500)) est$y <- predict(fit.i, newdata = data.frame(x = est$ x)) xl <- range(x, est$x, xlim) xl <- xl + c(-1, 1) * 0.03 * diff(xl) yl <- range(y, est$y, fitted(fit.d), ylim) yl <- yl + c(-1, 1) * 0.05 * diff(yl) fitPlot <- function(x, y, est, fit.d, xl, yl) { plot(x, y, pch = 3, xlim = xl, ylim = yl) lines(x, fitted(fit.d), col = 'red') mtext("Exact estimate with linear interpolation between x-values", col = 'red', adj = 0.5, line = 0.5) lines(est, col = 'blue') mtext("Estimate obtained using the default interpolation scheme", col = 'blue', adj = 0.5, line = 2) NULL } fitPlot(x, y, est, fit.d, xl, yl) repeat { x0 <- locator(1)$x if(length(x0) < 1) break if(nearest) x0 <- unique(x[abs(x - x0) == min( abs(x - x0))]) if(verbose){ cat("x0 =", x0, "\n") flush.console() } if(span < 1) { q <- as.integer(span * length(x)) d <- sort(abs(x - x0))[q] } else { d <- max(abs(x - x0)) * sqrt(span) } w <- rep(0, length(x)) s <- abs(x - x0) <= d w[s] <- (1 - (abs(x[s] - x0)/d)^3)^3 fitPlot(x, y, est, fit.d, xl, yl) symbols(x, y, circles = sqrt(w), inches = 0.3, add = T, col = 'lightgrey') if(degree > 0) lines(x, fitted(lm(y ~ poly(x, degree ), weights = w)), col = 'purple', err = -1) else { ##lines(x, fitted(lm(y ~ 1, weights = w)), col = 8, err = -1) abline(a = sum(w * y)/sum(w), b = 0, col = 'purple') } abline(v = x0, col = 'green') if(x0 - d > xl[1]) abline(v = x0 - d, col = 'green', lty = 2) if(x0 + d < xl[2]) abline(v = x0 + d, col = 'green', lty = 2) } } TeachingDemos/R/vis.binom.R0000644000175100001440000000763112657235445015256 0ustar hornikusers"vis.binom" <- function(){ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package') if(!exists('slider.env')) slider.env<<-new.env() n <- 10 ; assign('n',tcltk::tclVar(n),envir=slider.env) p <- 0.5; assign('p',tcltk::tclVar(p),envir=slider.env) sn <- 0 ; assign('sn',tcltk::tclVar(sn), envir=slider.env) sp <- 0 ; assign('sp',tcltk::tclVar(sp), envir=slider.env) binom.refresh <- function(...){ n <- as.numeric(evalq(tcltk::tclvalue(n), envir=slider.env)) p <- as.numeric(evalq(tcltk::tclvalue(p), envir=slider.env)) sn <- as.numeric(evalq(tcltk::tclvalue(sn), envir=slider.env)) sp <- as.numeric(evalq(tcltk::tclvalue(sp), envir=slider.env)) mu <- p*n sd <- sqrt(n*p*(1-p)) if(sn){ xx <- seq(-1,n+1, length=250) plot(xx,dnorm(xx,mu,sd), type='l', col='green', ylim=range(0,dnorm(mu,mu,sd),dbinom( seq(0,n), n, p)), xlab='x', ylab='Probability') if(sp){ points( seq(0,n), dpois( seq(0,n), mu ), type='h', col='blue') points( seq(0,n), dpois( seq(0,n), mu ), pch='-', col='blue',cex=2) } abline(h=0) lines(xx, dnorm(xx,mu,sd), col='green') points( seq(0,n), dbinom( seq(0,n), n, p), type='h' ) points( seq(0,n), dbinom( seq(0,n), n, p), type='p' ) } else { if(sp){ plot( seq(0,n), dpois( seq(0,n), mu ), type='h', col='blue', xlim=c(-1,n+1), xlab='x', ylab='Probability', ylim=range(0,dpois( seq(0,n), mu), dbinom(seq(0,n),n,p))) points( seq(0,n), dpois( seq(0,n), mu ), pch='-', col='blue',cex=2) points( seq(0,n), dbinom( seq(0,n), n, p), type='h') } else { plot( seq(0,n), dbinom( seq(0,n), n, p), type='h', xlim=c(-1,n+1), xlab='x', ylab='Probability') } abline(h=0) points( seq(0,n), dbinom( seq(0,n), n, p) ) } title( paste("Mean =",round(mu,3),"Std. Dev. =",round(sd,3)) ) } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'Visualizing the Binomial Distribution') tcltk::tkwm.geometry(m,'+0+0') # n tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='n', width='10'), side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=binom.refresh, from=1, to=100, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=n), envir=slider.env) # p tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='p', width='10'), side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=binom.refresh, from=0, to=1, orient='horiz', resolution=0.01, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=p), envir=slider.env) # show normal tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=binom.refresh), side='left') tcltk::tkpack(tcltk::tklabel(fr, text='Show Normal Approximation',width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sn), envir=slider.env) # show poisson tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=binom.refresh), side='left') tcltk::tkpack(tcltk::tklabel(fr, text='Show Poisson Approximation',width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=sp), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=binom.refresh), side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } TeachingDemos/R/ci.examp.R0000644000175100001440000000506012657235444015047 0ustar hornikusers"ci.examp" <- function(mean.sim=100, sd=10, n=25, reps=50, conf.level=0.95, method="z", lower.conf=(1-conf.level)/2, upper.conf=1-(1-conf.level)/2 ) { # This function demonstrates confidence intervals. It will simulate # data from a normal distribution and create multiple confidence # intervals and plot all intervals of the mean along with a reference # line indicating the mean. lower.conf and upper.conf allow you to # create unbalanced intervals. data <- matrix( rnorm( n*reps, mean.sim, sd), ncol=n) rmeans <- rowMeans(data) switch(method, Z=,z={ lower <- qnorm( lower.conf, rmeans, sd/sqrt(n)) upper <- qnorm( upper.conf, rmeans, sd/sqrt(n)) }, T=,t= { cv.l <- qt(lower.conf, n-1) cv.u <- qt(upper.conf, n-1) rsds <- sqrt( apply(data,1,var) )/sqrt(n) lower <- rmeans+cv.l*rsds upper <- rmeans+cv.u*rsds }, BOTH=, Both=, both={ lz <- qnorm( lower.conf, rmeans, sd/sqrt(n)) uz <- qnorm( upper.conf, rmeans, sd/sqrt(n)) cv.l <- qt(lower.conf, n-1) cv.u <- qt(upper.conf, n-1) rsds <- sqrt( apply(data,1,var) )/sqrt(n) lt <- rmeans+cv.l*rsds ut <- rmeans+cv.u*rsds lower <- c(rbind(lt,lz,mean.sim)) upper <- c(rbind(ut,uz,mean.sim)) reps <- reps*3 rmeans <- rep(rmeans, each=3) rmeans[c(F,F,T)] <- NA }, stop("method must be z, t, or both") ) if( any( upper==Inf ) ) upper <- rep( 2*mean.sim-min(lower), reps ) if( any( lower==-Inf ) ) lower <- rep( 2*mean.sim-max(upper), reps ) xr <- range( upper, lower ) plot(lower,seq(1,reps), type="n", xlim=xr, xlab="Confidence Interval", ylab="Index") abline( v= qnorm(c(1-upper.conf,1-lower.conf), mean.sim, sd/sqrt(n)), col=10) if( method=="both" || method=="Both" || method=="BOTH"){ title( main="Confidence intervals based on both distributions", sub="Upper interval is Z in each pair") } else { title( main=paste("Confidence intervals based on",method,"distribution")) } colr <- ifelse( lower > mean.sim, 5, ifelse( upper < mean.sim, 6, 1) ) abline(v=mean.sim) for( i in seq(1,reps) ){ segments(lower[i], i, upper[i], i, col=colr[i]) } points( rmeans, seq(along=rmeans), pch="|" ) invisible(NULL) } TeachingDemos/R/rotate.wireframe.R0000644000175100001440000000633012657235445016623 0ustar hornikusers"rotate.wireframe" <- function(x, ...){ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')} if(!exists('slider.env')) slider.env <<-new.env() if(!requireNamespace('lattice', quietly = TRUE)){stop('The lattice package is needed')} lab1 <- 'z'; assign('lab1', tcltk::tclVar(lab1), envir=slider.env) lab2 <- 'y'; assign('lab2', tcltk::tclVar(lab2), envir=slider.env) lab3 <- 'x'; assign('lab3', tcltk::tclVar(lab3), envir=slider.env) val1 <- 40; assign('val1', tcltk::tclVar(val1), envir=slider.env) val2 <- 0; assign('val2', tcltk::tclVar(val2), envir=slider.env) val3 <- -60; assign('val3', tcltk::tclVar(val3), envir=slider.env) wire.options <- list(...) wire.refresh <- function(...){ lab1 <- evalq(tcltk::tclvalue(lab1), envir=slider.env) lab2 <- evalq(tcltk::tclvalue(lab2), envir=slider.env) lab3 <- evalq(tcltk::tclvalue(lab3), envir=slider.env) val1 <- as.numeric(evalq(tcltk::tclvalue(val1), envir=slider.env)) val2 <- as.numeric(evalq(tcltk::tclvalue(val2), envir=slider.env)) val3 <- as.numeric(evalq(tcltk::tclvalue(val3), envir=slider.env)) sl <- list(val1,val2,val3) names(sl) <- c(lab1,lab2,lab3) wire.options$x <- x wire.options$screen <- sl print( do.call(lattice::wireframe,wire.options) ) } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'Rotate Wireframe plot') tcltk::tkwm.geometry(m,'+0+0') # one tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=wire.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=val1), envir=slider.env) assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e,textvariable=lab1), envir=slider.env) # two tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=wire.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=val2), envir=slider.env) assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e,textvariable=lab2), envir=slider.env) # three tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=wire.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=val3), envir=slider.env) assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e,textvariable=lab3), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=wire.refresh),side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } TeachingDemos/R/cnvrt.coords.R0000644000175100001440000000656512657235444016002 0ustar hornikusers"cnvrt.coords" <- function(x,y=NULL,input=c('usr','plt','fig','dev','tdev')) { warning('this function is now depricated, use grconvertX instead') input <- match.arg(input) xy <- xy.coords(x,y, recycle=TRUE) cusr <- par('usr') cplt <- par('plt') cfig <- par('fig') cdin <- par('din') comi <- par('omi') cdev <- c(comi[2]/cdin[1],(cdin[1]-comi[4])/cdin[1], comi[1]/cdin[2],(cdin[2]-comi[3])/cdin[2]) if(input=='usr'){ usr <- xy plt <- list() plt$x <- (xy$x-cusr[1])/(cusr[2]-cusr[1]) plt$y <- (xy$y-cusr[3])/(cusr[4]-cusr[3]) fig <- list() fig$x <- plt$x*(cplt[2]-cplt[1])+cplt[1] fig$y <- plt$y*(cplt[4]-cplt[3])+cplt[3] dev <- list() dev$x <- fig$x*(cfig[2]-cfig[1])+cfig[1] dev$y <- fig$y*(cfig[4]-cfig[3])+cfig[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='plt') { plt <- xy usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] fig <- list() fig$x <- plt$x*(cplt[2]-cplt[1])+cplt[1] fig$y <- plt$y*(cplt[4]-cplt[3])+cplt[3] dev <- list() dev$x <- fig$x*(cfig[2]-cfig[1])+cfig[1] dev$y <- fig$y*(cfig[4]-cfig[3])+cfig[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='fig') { fig <- xy plt <- list() plt$x <- (fig$x-cplt[1])/(cplt[2]-cplt[1]) plt$y <- (fig$y-cplt[3])/(cplt[4]-cplt[3]) usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] dev <- list() dev$x <- fig$x*(cfig[2]-cfig[1])+cfig[1] dev$y <- fig$y*(cfig[4]-cfig[3])+cfig[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='dev'){ dev <- xy fig <- list() fig$x <- (dev$x-cfig[1])/(cfig[2]-cfig[1]) fig$y <- (dev$y-cfig[3])/(cfig[4]-cfig[3]) plt <- list() plt$x <- (fig$x-cplt[1])/(cplt[2]-cplt[1]) plt$y <- (fig$y-cplt[3])/(cplt[4]-cplt[3]) usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='tdev'){ tdev <- xy dev <- list() dev$x <- (tdev$x-cdev[1])/(cdev[2]-cdev[1]) dev$y <- (tdev$y-cdev[3])/(cdev[4]-cdev[3]) fig <- list() fig$x <- (dev$x-cfig[1])/(cfig[2]-cfig[1]) fig$y <- (dev$y-cfig[3])/(cfig[4]-cfig[3]) plt <- list() plt$x <- (fig$x-cplt[1])/(cplt[2]-cplt[1]) plt$y <- (fig$y-cplt[3])/(cplt[4]-cplt[3]) usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } } TeachingDemos/R/faces.R0000644000175100001440000001277012657235444014432 0ustar hornikusers#16: #1: faces<-function(xy=rbind(1:3,5:3,3:5,5:7),which.row,fill=FALSE,nrow,ncol, scale=TRUE,byrow=FALSE,main,labels){ #21: spline<-function(a,y,m=200,plot=FALSE){ n<-length(a) h<-diff(a) dy<-diff(y) sigma<-dy/h lambda<-h[-1]/(hh<-h[-1]+h[-length(h)]) mu<-1-lambda d<-6*diff(sigma)/hh tri.mat<-2*diag(n-2) tri.mat[2+ (0:(n-4))*(n-1)] <-mu[-1] tri.mat[ (1:(n-3))*(n-1)] <-lambda[-(n-2)] M<-c(0,solve(tri.mat)%*%d,0) x<-seq(from=a[1],to=a[n],length=m) anz.kl <- hist(x,breaks=a,plot=FALSE)$counts adj<-function(i) i-1 i<-rep(1:(n-1),anz.kl)+1 S.x<- M[i-1]*(a[i]-x )^3 / (6*h[adj(i)]) + M[i] *(x -a[i-1])^3 / (6*h[adj(i)]) + (y[i-1] - M[i-1]*h[adj(i)]^2 /6) * (a[i]-x)/ h[adj(i)] + (y[i] - M[i] *h[adj(i)]^2 /6) * (x-a[i-1]) / h[adj(i)] if(plot){ plot(x,S.x,type="l"); points(a,y) } return(cbind(x,S.x)) } #:21 #4: n.char<-15 xy<-rbind(xy) if(byrow) xy<-t(xy) if(!missing(which.row)&& all( !is.na(match(which.row,1:dim(xy)[2])) )) xy<-xy[,which.row,drop=FALSE] mm<-dim(xy)[2]; n<-dim(xy)[1] xnames<-dimnames(xy)[[1]] if(is.null(xnames)) xnames<-as.character(1:n) if(!missing(labels)) xnames<-labels if(scale){ xy<-apply(xy,2,function(x){ x<-x-min(x); x<-if(max(x)>0) 2*x/max(x)-1 else x }) } else xy[]<-pmin(pmax(-1,xy),1) xy<-rbind(xy);n.c<-dim(xy)[2] xy<-xy[,(h<-rep(1:mm,ceiling(n.char/mm))),drop=FALSE] if(fill) xy[,-(1:n.c)]<-0 #:4 #5: face.orig<-list( eye =rbind(c(12,0),c(19,8),c(30,8),c(37,0),c(30,-8),c(19,-8),c(12,0)) ,iris =rbind(c(20,0),c(24,4),c(29,0),c(24,-5),c(20,0)) ,lipso=rbind(c(0,-47),c( 7,-49),lipsiend=c( 16,-53),c( 7,-60),c(0,-62)) ,lipsi=rbind(c(7,-54),c(0,-54)) # add lipsiend ,nose =rbind(c(0,-6),c(3,-16),c(6,-30),c(0,-31)) ,shape =rbind(c(0,44),c(29,40),c(51,22),hairend=c(54,11),earsta=c(52,-4), earend=c(46,-36),c(38,-61),c(25,-83),c(0,-89)) ,ear =rbind(c(60,-11),c(57,-30)) # add earsta,earend ,hair =rbind(hair1=c(72,12),hair2=c(64,50),c(36,74),c(0,79)) # add hairend ) lipso.refl.ind<-4:1 lipsi.refl.ind<-1 nose.refl.ind<-3:1 hair.refl.ind<-3:1 shape.refl.ind<-8:1 shape.xnotnull<-2:8 nose.xnotnull<-2:3 #:5 #2: nr<-n^0.5; nc<-n^0.5 if(!missing(nrow)) nr<-nrow if(!missing(ncol)) nc<-ncol opar<-par(mfrow=c(ceiling(c(nr,nc))),oma=rep(6,4), mar=rep(.7,4)) on.exit(par(opar)) #:2 #6: for(ind in 1:n){ #7: factors<-xy[ind,] face <- face.orig #:7 #9: m<-mean(face$lipso[,2]) face$lipso[,2]<-m+(face$lipso[,2]-m)*(1+0.7*factors[4]) face$lipsi[,2]<-m+(face$lipsi[,2]-m)*(1+0.7*factors[4]) face$lipso[,1]<-face$lipso[,1]*(1+0.7*factors[5]) face$lipsi[,1]<-face$lipsi[,1]*(1+0.7*factors[5]) face$lipso["lipsiend",2]<-face$lipso["lipsiend",2]+20*factors[6] #:9 #10: m<-mean(face$eye[,2]) face$eye[,2] <-m+(face$eye[,2] -m)*(1+0.7*factors[7]) face$iris[,2]<-m+(face$iris[,2]-m)*(1+0.7*factors[7]) m<-mean(face$eye[,1]) face$eye[,1] <-m+(face$eye[,1] -m)*(1+0.7*factors[8]) face$iris[,1]<-m+(face$iris[,1]-m)*(1+0.7*factors[8]) #:10 #11: m<-min(face$hair[,2]) face$hair[,2]<-m+(face$hair[,2]-m)*(1+0.2*factors[9]) m<-0 face$hair[,1]<-m+(face$hair[,1]-m)*(1+0.2*factors[10]) m<-0 face$hair[c("hair1","hair2"),2]<-face$hair[c("hair1","hair2"),2]+50*factors[11] #:11 #12: m<-mean(face$nose[,2]) face$nose[,2]<-m+(face$nose[,2]-m)*(1+0.7*factors[12]) face$nose[nose.xnotnull,1]<-face$nose[nose.xnotnull,1]*(1+factors[13]) #:12 #13: m<-mean(face$shape[c("earsta","earend"),1]) face$ear[,1]<-m+(face$ear[,1]-m)* (1+0.7*factors[14]) m<-min(face$ear[,2]) face$ear[,2]<-m+(face$ear[,2]-m)* (1+0.7*factors[15]) #:13 #8: face<-lapply(face,function(x){ x[,2]<-x[,2]*(1+0.2*factors[1]);x}) face<-lapply(face,function(x){ x[,1]<-x[,1]*(1+0.2*factors[2]);x}) face<-lapply(face,function(x){ x[,1]<-ifelse(x[,1]>0, ifelse(x[,2] > -30, x[,1], pmax(0,x[,1]+(x[,2]+50)*0.2*sin(1.5*(-factors[3])))),0);x}) #face$shape[,2]<-face$shape[,2]*(1+0.2*factors[1]) #face$shape[,1]<-face$shape[,1]*(1+0.2*factors[2]) #face$shape[,1]<-face$shape[,1]<-ifelse(face$shape[,1]>0, # ifelse(face$shape[,2] > -30, face$shape[,1], # pmax(0,face$shape[,1]+(face$shape[,2]+50)*0.2*sin(1.5*(-factors[3])))),0) #:8 #14: invert<-function(x) cbind(-x[,1],x[,2]) face.obj<-list( eyer=face$eye ,eyel=invert(face$eye) ,irisr=face$iris ,irisl=invert(face$iris) ,lipso=rbind(face$lipso,invert(face$lipso[lipso.refl.ind,])) ,lipsi=rbind(face$lipso["lipsiend",],face$lipsi, invert(face$lipsi[lipsi.refl.ind,,drop=FALSE]), invert(face$lipso["lipsiend",,drop=FALSE])) ,earr=rbind(face$shape["earsta",],face$ear,face$shape["earend",]) ,earl=invert(rbind(face$shape["earsta",],face$ear,face$shape["earend",])) ,nose=rbind(face$nose,invert(face$nose[nose.refl.ind,])) ,hair=rbind(face$shape["hairend",],face$hair,invert(face$hair[hair.refl.ind,]), invert(face$shape["hairend",,drop=FALSE])) ,shape=rbind(face$shape,invert(face$shape[shape.refl.ind,])) ) #:14 #15: plot(1,type="n",xlim=c(-105,105)*1.1, axes=FALSE, ylab="",ylim=c(-105,105)*1.3) title(xnames[ind]) for(ind in seq(face.obj)) { x <-face.obj[[ind]][,1]; y<-face.obj[[ind]][,2] xx<-spline(1:length(x),x,40,FALSE)[,2] yy<-spline(1:length(y),y,40,FALSE)[,2] lines(xx,yy) } #:15 } #:6 #3: if(!missing(main)){ par(opar);par(mfrow=c(1,1)) mtext(main, 3, 3, TRUE, 0.5) title(main) } #:3 } #:1 #:16 TeachingDemos/R/limits.g.R0000644000175100001440000000134412657235444015072 0ustar hornikusers"limits.g" <- function (center, std.dev, sizes, conf) { if (conf >= 1) { p <- 1/center lcl <- center - conf * sqrt(1-p)/p lcl[lcl < 0] <- 0 ucl <- center + conf * sqrt(1-p)/p warning("The Geometric distribution is quite skewed, it is better to set conf at the required confidence level (0 < conf < 1) instead of as a multiplier of sigma.") } else { if (conf > 0 & conf < 1) { p <- 1/center ucl <- qgeom(1 - (1 - conf)/2, p) lcl <- qgeom((1 - conf)/2, p) } else stop("invalid conf argument. See help.") } limits <- matrix(c(lcl, ucl), ncol = 2) rownames(limits) <- rep("", length = nrow(limits)) colnames(limits) <- c("LCL", "UCL") return(limits) } TeachingDemos/R/TkPredict.R0000644000175100001440000000566612657235445015251 0ustar hornikusersPredict.Plot <- function(model, pred.var, ..., type='response', add=FALSE, plot.args=list(), n.points=100, ref.val, ref.col='green', ref.lty=1, data ) { x2 <- list(...) if(missing(pred.var)) pred.var <- names(x2)[1] if(is.character(plot.args)) plot.args <- eval(parse(text=plot.args)) getdata <- function(model) { if ('data' %in% names(model)) return(model$data) tmpcall <- model$call tmpcall[[1]] <- as.name('glm') model <- eval(tmpcall) model$data } if( pred.var %in% names(x2) ) { if (length(x2[[pred.var]]) > 1) { tmp.x <- seq( min(x2[[pred.var]]), max(x2[[pred.var]]), length.out=n.points) } else { if( missing(data) ) data <- getdata(model) ref.val <- x2[[pred.var]] tmp.x <- seq( min(data[[pred.var]]), max(data[[pred.var]]), length.out=n.points) } } else { if( missing(data) ) data <- getdata(model) tmp.x <- seq( min(data[[pred.var]]), max(data[[pred.var]]), length.out=n.points) } x2[[pred.var]] <- tmp.x x <- as.data.frame(x2) yhat <- predict(model, x, type=type) if(add){ plot.args$x <- x[[pred.var]] plot.args$y <- yhat do.call(lines, plot.args) } else { nms <- names(plot.args) plot.args$x=x[[pred.var]] plot.args$y=yhat if( !( 'ylab' %in% nms ) ) plot.args$ylab='Predicted Value' if( !( 'xlab' %in% nms ) ) plot.args$xlab=pred.var if( !( 'type' %in% nms ) ) plot.args$type='l' do.call(plot, plot.args) } if(!missing(ref.val)){ tmp.x <- list(...) tmp.x[[pred.var]] <- ref.val yhat <- predict(model, as.data.frame(tmp.x), type=type) usr <- par('usr') lines( c(ref.val,ref.val,usr[1]), c(usr[3],yhat,yhat), col=ref.col, lty=ref.lty) } } TkPredict <- function(model, data, pred.var, ...){ if( missing(data) ){ if( class(model)[1] == 'lm' ){ tmpcall <- model$call tmpcall[[1]] <- as.name('glm') model2 <- eval(tmpcall) } else { model2 <- model } data <- model2$data } tr <- delete.response( terms(model) ) x <- get_all_vars(tr, data) if(missing(pred.var)) pred.var <- names(x)[1] lst <- list() lst$pred.var <- list('radiobuttons',values=names(x), init=pred.var) lst[[2]] <- list() for ( v in names(x) ) { tmp.x <- x[[v]] if( is.factor(tmp.x) ) { lvls <- levels(tmp.x) if(length(lvls) < 11 ) { lst[[2]][[v]] <- list('radiobuttons', values=lvls, init=lvls[1] ) } else { lst[[2]][[v]] <- list('Entry', init=lvls[1]) } } else { tmp.min <- min(tmp.x) tmp.max <- max(tmp.x) tmp.med <- median(tmp.x) lst[[2]][[v]] <- list('slider',from=tmp.min, to=tmp.max, init=tmp.med, resolution=signif( (tmp.max-tmp.min)/100, 2 ) ) } } lst[[3]] <- list() lst[[3]]$plot.args <- list( 'entry', init='list()' ) lst[[3]]$type <- list('entry', init='response') cl <- as.call( substitute( Predict.Plot(model) ) ) eval(substitute(tkexamp( cl, lst, plotloc='left' ))) } TeachingDemos/R/sigma.test.R0000644000175100001440000000243612657235445015426 0ustar hornikuserssigma.test <- function (x, sigma = 1, sigmasq = sigma^2, alternative = c("two.sided", "less", "greater"), conf.level = 0.95, ...) { alternative <- match.arg(alternative) sigma <- sqrt(sigmasq) n <- length(x) xs <- var(x)*(n-1)/sigma^2 out <- list(statistic = c("X-squared" = xs)) class(out) <- "htest" out$parameter <- c(df = n-1) minxs <- min(c(xs, 1/xs)) maxxs <- max(c(xs, 1/xs)) PVAL <- pchisq(xs, df = n - 1) out$p.value <- switch(alternative, two.sided = 2*min(PVAL, 1 - PVAL), less = PVAL, greater = 1 - PVAL) out$conf.int <- switch(alternative, two.sided = xs * sigma^2 * 1/c(qchisq(1-(1-conf.level)/2, df = n-1), qchisq((1-conf.level)/2, df = n-1)), less = c(0, xs * sigma^2 / qchisq(1-conf.level, df = n-1)), greater = c(xs * sigma^2 / qchisq(conf.level, df = n-1), Inf)) attr(out$conf.int, "conf.level") <- conf.level out$estimate <- c("var of x" = var(x)) out$null.value <- c(variance = sigma^2) out$alternative <- alternative out$method <- "One sample Chi-squared test for variance" out$data.name <- deparse(substitute(x)) names(out$estimate) <- paste("var of", out$data.name) return(out)} TeachingDemos/R/bct.R0000644000175100001440000000026112657235444014111 0ustar hornikusers"bct" <- function(y,lambda){ gm <- exp( mean( log(y) ) ) if(lambda==0) return( log(y)*gm ) yt <- (y^lambda - 1)/( lambda * gm^(lambda-1) ) return(yt) } TeachingDemos/R/plot2script.R0000644000175100001440000000272112657235444015631 0ustar hornikusersplot2script <- function(file='clipboard'){ con <- file(file) open(con, open='a') tmp <- recordPlot()[[1]] for (i in seq(along.with=tmp)){ fn <- tmp[[i]][[1]] args <- tmp[[i]][[2]] fns <- deparse(fn) m <- sub('^.*"(.*)".*$', '\\1', fns, perl=TRUE) c2 <- as.list(c(m,args)) tmp2 <- do.call('call',c2) tmp3 <- match.call(get(m), call=tmp2) if(tmp3[[1]] == 'box'){ tmp3$which <- c("plot", "figure", "inner", "outer")[ tmp3$which ] } dput(tmp3, file=con) } close(con) } oldzoomplot <- function( xlim, ylim=NULL ){ xy <- xy.coords(xlim,ylim) xlim <- range(xy$x) ylim <- range(xy$y) tmp <- recordPlot()[[1]] for(i in seq(along=tmp)){ fn <- tmp[[i]][[1]] alst <- as.list(tmp[[i]][[2]]) tmp2 <- all.equal( '.Primitive("locator")', deparse(fn) ) if(is.logical(tmp2) && tmp2){ next } tmp2 <- all.equal( '.Primitive("plot.window")', deparse(fn) ) if(is.logical(tmp2) && tmp2) { alst[[1]] <- xlim alst[[2]] <- ylim } do.call(fn, alst) } } zoomplot <- function( xlim, ylim=NULL ){ xy <- xy.coords(xlim,ylim) xlim <- range(xy$x) ylim <- range(xy$y) tmp <- recordPlot() for(i in seq(along=tmp[[1]])){ fn <- tmp[[1]][[i]][[2]][[1]] if(fn$name == 'C_plot_window') { tmp[[1]][[i]][[2]][[2]] <- xlim tmp[[1]][[i]][[2]][[3]] <- ylim } } replayPlot(tmp) } TeachingDemos/R/vis.boxcox.R0000644000175100001440000001121112657235445015441 0ustar hornikusersvis.boxcox.old <- function(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1) ) { if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package') x <- runif(100, 1, 10) y <- 3+2*x + rnorm(100) if ( min(y) <= 0 ) y <- y - min(y) + 0.05 if (lambda==0) { y <- exp(y) } else { y <- y^(1/lambda) } if(!exists('slider.env')) slider.env <<-new.env() lam <- 1 ; assign('lam',tcltk::tclVar(lam), envir=slider.env) bc.refresh <- function(...){ lam <- as.numeric(evalq(tcltk::tclvalue(lam), envir=slider.env)) old.par <- par(mfcol=c(2,2)) on.exit(par(old.par)) tmp1 <- lm(y~x) tmp2 <- lm(bct(y,lam)~x) plot(x,y,main="Raw Data") abline(tmp1) scatter.smooth(x,resid(tmp1),main="Raw Residuals",ylab='Residuals') abline(h=0, lty=2 ) plot(x,bct(y,lam), main=bquote( lambda == .(lam) ),ylab="Transformed y" ) abline(tmp2) scatter.smooth(x,resid(tmp2), main=bquote( lambda == .(lam) ), ylab="Residuals") abline(h=0, lty=2) } m <- tcltk::tktoplevel() tcltk::tkwm.title(m, 'Box Cox Transform') tcltk::tkwm.geometry(m,'+0+0') tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='lambda', width='10'), side='right') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=bc.refresh, from=-2, to=3, orient='horiz', resolution=0.1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=lam), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=bc.refresh), side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } vis.boxcox <- function(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1), hscale=1.5, vscale=1.5, wait=FALSE) { if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available') x <- runif(100, 1, 10) y <- 3+2*x + rnorm(100) if( min(y) <= 0 ) y <- y - min(y) + 0.05 if(lambda==0) { y <- exp(y) } else { y <- y^(1/lambda) } lam <- tcltk::tclVar() tcltk::tclvalue(lam) <- 1 hsc <- tcltk::tclVar() tcltk::tclvalue(hsc) <- hscale vsc <- tcltk::tclVar() tcltk::tclvalue(vsc) <- hscale replot <- function(...) { tmp.l <- as.numeric(tcltk::tclvalue(lam)) par(mfcol=c(2,2)) tmp1 <- lm(y~x) tmp2 <- lm( bct(y,tmp.l)~x) plot(x,y,main="Raw Data") abline(tmp1) scatter.smooth(x,resid(tmp1), main="Raw Residuals", ylab='Residuals') abline(h=0, lty=2) plot(x,bct(y,tmp.l), main=bquote( lambda == .(tmp.l) ), ylab="Transformed y") abline(tmp2) scatter.smooth(x,resid(tmp2), main=bquote( lambda == .(tmp.l) ), ylab='Residuals') abline(h=0, lty=2) } tt <- tcltk::tktoplevel() tcltk::tkwm.title(tt, "Box Cox Demo") img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale) tcltk::tkpack(img, side='top') tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top') tcltk::tkpack(tcltk::tklabel(fr, text='lambda: '), side='left', anchor='s') tcltk::tkpack(tcltk::tkscale(fr, variable=lam, orient='horizontal', command=function(...) tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ), from=-2, to=4, resolution=.05), side='right') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)), vscale=as.numeric(tcltk::tclvalue(vsc)) ) ), side='left',anchor='s') tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)), side='right',anchor='s') tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x') tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left') tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left') tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tcltk::tkwait.window(tt) return( list(lambda = as.numeric(tcltk::tclvalue(lam)), x=x, y=y, ty = bct(y, as.numeric(tcltk::tclvalue(lam))) )) } else { return(invisible(NULL)) } } TeachingDemos/R/faces2.R0000644000175100001440000000345212657235444014511 0ustar hornikusers"faces2" <- function(mat, which=1:ncol(mat), labels=rownames(mat), nrows=ceiling(nrow(mat)/ncols), ncols=ceiling(sqrt(nrow(mat))), byrow=TRUE, scale=c("columns","all","center","none"), fill=c(.5,.5,1,.5,.5,.3,.5,.5,.5,.5,.5,.5,.5,.5, .5,.5,1,.5), ...) { old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) if(byrow){ par(mfrow=c(nrows,ncols)) } else { par(mfcol=c(nrows,ncols)) } par(mar=rep(0,4)) mat <- as.matrix(mat) scale <- match.arg(scale) if(scale=="columns") { mat <- sweep(mat,2, apply(mat,2,min,na.rm=TRUE), '-') mat <- sweep(mat,2, apply(mat,2,max,na.rm=TRUE), '/') } else if(scale=="all") { mat <- mat - min(mat,na.rm=TRUE) mat <- mat / max(mat,na.rm=TRUE) } else if(scale=="center"){ mat <- sweep(mat, 2, apply(mat,2,mean,na.rm=TRUE), '-') mat <- sweep(mat, 2, apply(abs(mat),2,max,na.rm=TRUE), '/') mat <- (mat+1)/2 } if(ncol(mat) > 18){ warning("using only first 18 columns of input") mat <- mat[,1:18] } mat2 <- matrix(fill, ncol=18, nrow=nrow(mat), byrow=TRUE) mat2[,which] <- mat lo <- c(rep(0.2, 5), 0.1, 0.2, 0, 0.2, 0.1, 0.1, 0.3, 0.1, 0.3, rep(0.1, 4)) hi <- c(0.8, 0.8, 1, 0.8, 0.8, 0.4, 0.8, 1, 0.8, 0.7, 0.9, 0.7, rep(0.9, 4), 1, 0.9) df <- hi-lo mat2 <- sweep(mat2, 2, df, '*') mat2 <- sweep(mat2, 2, lo, '+') ## special handeling for column 8 mat2[,8] <- (2*mat2[,8]-1)*mat2[,9] if(length(labels != nrow(mat2))){ labels=rep(labels,nrow(mat2))[1:nrow(mat2)] } for (i in 1:nrow(mat2)){ face2.plot(mat2[i,]) text(0,-500,labels[i],...) } invisible() } TeachingDemos/R/rotate.cloud.R0000644000175100001440000000616112657235445015752 0ustar hornikusers"rotate.cloud" <- function(x, ...){ if(!requireNamespace('tcltk', quietly=TRUE)){stop('The tcltk package is needed')} if(!exists('slider.env')) slider.env <<-new.env() lab1 <- 'z'; assign('lab1', tcltk::tclVar(lab1), envir=slider.env) lab2 <- 'y'; assign('lab2', tcltk::tclVar(lab2), envir=slider.env) lab3 <- 'x'; assign('lab3', tcltk::tclVar(lab3), envir=slider.env) val1 <- 40; assign('val1', tcltk::tclVar(val1), envir=slider.env) val2 <- 0; assign('val2', tcltk::tclVar(val2), envir=slider.env) val3 <- -60; assign('val3', tcltk::tclVar(val3), envir=slider.env) cloud.options <- list(...) cloud.refresh <- function(...){ lab1 <- evalq(tcltk::tclvalue(lab1), envir=slider.env) lab2 <- evalq(tcltk::tclvalue(lab2), envir=slider.env) lab3 <- evalq(tcltk::tclvalue(lab3), envir=slider.env) val1 <- as.numeric(evalq(tcltk::tclvalue(val1), envir=slider.env)) val2 <- as.numeric(evalq(tcltk::tclvalue(val2), envir=slider.env)) val3 <- as.numeric(evalq(tcltk::tclvalue(val3), envir=slider.env)) sl <- list(val1,val2,val3) names(sl) <- c(lab1,lab2,lab3) cloud.options$x <- x cloud.options$screen <- sl print( do.call('cloud',cloud.options) ) } m <- tcltk::tktoplevel() tcltk::tkwm.title(m,'Rotate Cloud plot') tcltk::tkwm.geometry(m,'+0+0') # one tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=cloud.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=val1), envir=slider.env) assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e,textvariable=lab1), envir=slider.env) # two tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=cloud.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=val2), envir=slider.env) assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e,textvariable=lab2), envir=slider.env) # three tcltk::tkpack(fr <- tcltk::tkframe(m), side='top') tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left') tcltk::tkpack(sc <- tcltk::tkscale(fr, command=cloud.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tcltk::tkconfigure(sc, variable=val3), envir=slider.env) assign('e',e,envir=slider.env) evalq(tcltk::tkconfigure(e,textvariable=lab3), envir=slider.env) tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=cloud.refresh),side='left') tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)), side='right') } TeachingDemos/R/panel.mysymbols.R0000644000175100001440000000560312657235444016502 0ustar hornikuserspanel.my.symbols <- function(x, y, symb, inches=1, polygon = FALSE, ..., symb.plots=FALSE, subscripts, MoreArgs ) { if(symb.plots) { stop('self plotting symbols (symb.plots=TRUE) is not implemented yet') } dots <- list(...) tmp <- sapply(dots, is.null) dots[tmp] <- NULL if ( 'type' %in% names(dots) ) dots$type <- 'l' tmp.xlen <- length(x) if( (length(inches) != 1) && (length(inches) != tmp.xlen) ) { inches <- rep(inches[subscripts], length.out=tmp.xlen) } dots <- lapply(dots, function(x) { if( (length(x) != 1) && (length(x) != tmp.xlen) ) { x <- rep(x[subscripts], length.out=tmp.xlen) } x } ) plotfun <- if( is.function(symb) ) { function(x,y,inches,polygon,symb, ...) { dots1 <- list(...) sargs <- setdiff(names(formals(symb)),'...') dots2 <- dots1[sargs] dots1[sargs] <- NULL symb2 <- xy.coords(do.call(symb,dots2)) xx <- grid::convertWidth( grid::unit(symb2$x*inches/2, 'inches'), 'native', TRUE ) yy <- grid::convertHeight( grid::unit(symb2$y*inches/2, 'inches'), 'native', TRUE ) dots1$x <- x+xx dots1$y <- y+yy if(polygon) { do.call(lattice::lpolygon, dots1) } else { do.call(lattice::llines, dots1) } } } else { function(x,y,inches,polygon,symb, ...) { dots <- list(...) symb2 <- xy.coords(symb) xx <- grid::convertWidth( grid::unit(symb2$x*inches/2, 'inches'), 'native', TRUE ) yy <- grid::convertHeight( grid::unit(symb2$y*inches/2, 'inches'), 'native', TRUE ) dots$x <- x+xx dots$y <- y+yy if(polygon) { do.call(lattice::lpolygon, dots) } else { do.call(lattice::llines, dots) } } } funargs <- c(list(x=x, y=y, inches=inches, polygon=polygon), dots) funargs$FUN <- plotfun if(missing(MoreArgs)) { funargs$MoreArgs <- list(symb=symb) } else { funargs$MoreArgs <- c(MoreArgs, list(symb=symb)) } do.call(mapply, funargs) invisible(NULL) } ### original code if(FALSE) { my.df <- data.frame( x=runif(10), y=runif(10) ) xyplot(y~x, my.df, panel=function(x,y,...) { xx <- grid::convertX( grid::unit(ms.male[,1]/5, 'inches'), 'native', TRUE ) yy <- grid::convertY( grid::unit(ms.male[,2]/5, 'inches'), 'native', TRUE ) xx <- c(xx,NA); yy <- c(yy, NA) llines( outer(xx, x, '+'), outer(yy, y, '+') ) } ) } # convert and unit from grid package TeachingDemos/R/col2grey.R0000644000175100001440000000031112657235444015063 0ustar hornikuserscol2grey <- function(cols){ rgb <- col2rgb(cols) gry <- rbind( c(0.3, 0.59, 0.11) ) %*% rgb rgb(gry,gry,gry, maxColorValue=255) } col2gray <- function(cols){ col2grey(cols) } TeachingDemos/R/triplot.R0000644000175100001440000000605212657235445015043 0ustar hornikusers"triplot" <- function(x, y=NULL, z=NULL, labels=dimnames(x)[[2]], txt=dimnames(x)[[1]], legend=NULL, legend.split=NULL, inner=TRUE, inner.col=c('lightblue','pink'), inner.lty=c(2,3), add=FALSE, main="", ...){ old.par <- par(xpd=TRUE) on.exit(par(old.par)) if( is.data.frame(x) ) x <- as.matrix(x) x <- cbind(x,y,z) if( ncol(x) < 2 || ncol(x) > 3 ){ stop("need 2 or 3 columns") } if( ncol(x)==3 ){ x <- sweep(x,1,FUN="/",apply(x,1,sum)) } if( ncol(x)==2 ){ x <- cbind(x, 1-x[,1]-x[,2]) } if(dev.cur()==1){ dev.new() add <- FALSE } if( !add ){ pin <- par("pin") xstar <- (pin[1]/pin[2]*sqrt(3)-2)/2 plot( c(0,1,2,0), c(0,sqrt(3),0,0), type="l", lwd=3, xlim=c(-xstar,2+xstar), xlab="",ylab="",axes=FALSE, main=main) if(inner){ lines( c(1,1.5,0.5,1), c(0,sqrt(3)/2,sqrt(3)/2,0), lwd=.5, col=inner.col[1], lty=inner.lty[1]) lines( c(1.25, 1, .75, 1.25), c(sqrt(3)/4, sqrt(3)/2, sqrt(3)/4, sqrt(3)/4), lwd=0.25, col=inner.col[2],lty=inner.lty[2]) } if(length(labels)==0){ labels <- c("X","Y","Z") } ystar <- par("cxy")[2] * 1.1 text( c(0,2,1), c(-ystar,-ystar,sqrt(3)+ystar), labels, cex=1.5 ) } newy <- x[,3] * sqrt(3) newx <- 2-2*x[,1]-x[,3] if(length(txt)==length(newx)){ text(newx,newy,txt,...) } else { points(newx,newy,...) } if(length(legend)==length(newx)){ labpos <- function(y){ strh <- par("cxy")[2]*1.15 y2 <- sort(y) df <- y2[-1] - y2[-length(y2)] i <- 1 while(any (df < strh)){ y2[c(df < strh, FALSE)] <- y2[ c(df < strh,FALSE)] - strh/10 y2[c(FALSE, df < strh)] <- y2[ c(FALSE,df < strh)] + strh/10 if(min(y2)<0){y2 <- y2 - min(y2)} y2 <- sort(y2) df <- y2[-1] - y2[ -length(y2)] i <- i+1 if(i>100){break} } y2 } if(length(legend.split)==1){ tmp.x <- quantile(newx, legend.split) y1 <- newy[newx <= tmp.x] y1 <- labpos(y1)[order(order(y1))] text(rep(-0.01,length(y1)), y1, legend[newx<=tmp.x], adj=1) segments(rep(0,length(y1)), y1, newx[newx<=tmp.x], newy[newx<=tmp.x]) y2 <- newy[newx>tmp.x] y2 <- labpos(y2)[order(order(y2))] text(rep(2.01,length(y2)), y2, legend[newx>tmp.x], adj=0) segments(rep(2,length(y2)), y2, newx[newx>tmp.x], newy[newx>tmp.x]) } else { if(any(newx <= 1)){ y1 <- newy[newx<=1] y1 <- labpos(y1)[order(order(y1))] text(rep(-0.01,length(y1)), y1, legend[newx<=1],adj=1) segments(rep(0,length(y1)), y1, newx[newx<=1], newy[newx<=1]) } if(any(newx > 1)){ y2 <- newy[newx>1] y2 <- labpos(y2)[order(order(y2))] text(rep(2.01,length(y2)), y2, legend[newx>1],adj=0) segments(rep(2,length(y2)), y2, newx[newx>1], newy[newx>1]) } } } invisible(cbind(x=newx,y=newy)) } TeachingDemos/R/lattice.demo.R0000644000175100001440000000737612657235444015727 0ustar hornikusers"lattice.demo" <- function(x,y,z, show3d=TRUE){ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')} if(!requireNamespace('lattice', quietly=TRUE)){stop('the lattice package is needed')} if(!exists('slider.env')) slider.env <<- new.env() center <- mean(z); assign('center',tcltk::tclVar(center), envir=slider.env) width <- diff(range(z))/20*3; assign('width',tcltk::tclVar(width), envir=slider.env) s3d <- 1; assign('s3d', tcltk::tclVar(s3d), envir=slider.env) lattice.refresh <- function(...){ center <- as.numeric(evalq(tcltk::tclvalue(center), envir=slider.env)) width <- as.numeric(evalq(tcltk::tclvalue(width), envir=slider.env)) s3d <- as.numeric(evalq(tcltk::tclvalue(s3d), envir=slider.env)) shingle.min <- max(min(z), center-width/2) shingle.max <- min(max(z), center+width/2) shingle.scaled.range <- c( (shingle.min-min(z))/diff(range(z)), (shingle.max-min(z))/diff(range(z))) - 0.5 if(s3d){ print(lattice::xyplot(y~x|shingle(z,rbind(range(z),c(shingle.min,shingle.max))), index.cond=list(2), strip=lattice::strip.custom(strip.names=TRUE,strip.levels=TRUE), par.strip.text=list(cex=0.75)), split=c(1,1,1,2), more=T) print(lattice::cloud(y~z+x, panel=function(x,y,z,...){ lattice::panel.cloud(x,y,z,panel.3d.cloud=function(x,y,z,groups,...){ lattice::panel.3dscatter(x,y,z, groups= factor(x>shingle.scaled.range[1] & x ', mouse.move) tcltk::tkbind(img, '', mouse.down) tcltk::tkbind(img, '', mouse.up) if(wait) { tcltk::tkwait.window(tt) out <- list( x=ccx, y=yy ) } else { out <- NULL } invisible(out) } TeachingDemos/MD50000644000175100001440000002106012657277161013327 0ustar hornikusers897fb4c8d60dcae56807599ab32193dc *DESCRIPTION 76e7aa439672adf69fd8da2ba0c84df7 *NAMESPACE 904252f50c7633e5be44bf05a91805ef *NEWS af63983980ef4756e1654375eab35a56 *R/00vars.R 58fd3ea73ca7a7c3486668e43b19563c *R/HWidentify.R 83ca905a7ae454a8a35245beb2ec5d16 *R/Pvalue.sim.R b64f269e29a814182cd25210b7f54075 *R/R2txt.R 7ecfb3aa2895a43029ea4888fb432a35 *R/SensSpec.demo.R da2a1db1065a61ef8bc02e4a3e36b9bc *R/TkApprox.R f4d7768737addab71a699ca254b94e4d *R/TkBuildDist.R ea8920c7c069178ad87f9fa9af5d4ac5 *R/TkListView.R fa736158ba3b4465d70d9105c26dd972 *R/TkPredict.R aa1c6ad9e146171976268f56da32b250 *R/TkSpline.R b3da80c8325f04b7141b8ea4a5040f5f *R/bct.R 5d8f83b5b0d203d17c2bab5e76814beb *R/cal.R 3bf191e3cd5bee2f9cf34a0a52cae178 *R/char2seed.R ded1da2b4851c1cd43e895b92c5c35e0 *R/chisq.detail.R ad00af800f75ed5bebf3268804de9359 *R/ci.examp.R d07ebfa8a3e8a6f170e4f7019ed91b7d *R/clipplot.R d2f8b6e9ef63ce007d9865dc1b3b3616 *R/clt.examp.R 6b42497aba4b3d5d9976c019eae86d9f *R/cnvrt.coords.R d077092b97db985c273e60ca7f7e3aec *R/col2grey.R 27beddffee77d82783b1bdb52848ac13 *R/correct.R 521784d55179c115f4f710f7f826bdd1 *R/dice.R 8a72f33197f97c16bfeef20b86e65f88 *R/digits.R cfb05736198fa3001b3cd2404f1c0863 *R/dots.R 75c43e07e0ba4d2168a5b89753ae60c9 *R/dots2.R 4cfbb70e2f2644d8edc6671947055485 *R/dynIdentify.R f46e5b70e090c67c76c66a8dd617030f *R/face2.plot.R 23bd6d628aa18b7aff73a6a454a61f97 *R/faces.R 60a3c70e663c040ee28c2914e730d187 *R/faces2.R aa2ae4b7f9114fc851d21ed8c800980f *R/fagan.R 1375c2a419b5f7af16791bcd2f35408a *R/flip.rgl.coin.R 16973a33ec9bc005787bf9c04f9f0b53 *R/gnuplot.R e15423f4e966dfd9a1f2cc6f7a8cb1fc *R/gp.splot.R 18616d8ebd4e9df7de968d762d8d86e3 *R/hpd.R 4ab586b3ac5e572617665aa96e83994f *R/ineq.R 0ee8908da5fee534ab3e9f71571888b1 *R/lattice.demo.R 3fced4b2f6f50518b502001c205d8e84 *R/limits.g.R a9b444dc84c8d8d9f9cefe675c0ff729 *R/loess.demo.R 1b57c7b1278eee080d9dc9448e3e34c1 *R/manipulate.cor.examp.R fd3a9345dc6847100d79c5e4c051ff41 *R/mle.demo.R 9a1cc2a1fb484564769868e675218c60 *R/ms.face.R fd89f48b106c0f5963f46e94498f8c5e *R/mysymbols.R 328876dd059347545fba20628ff66a92 *R/pairs2.R 66cb855dc651716e748e728ab3457f18 *R/panel.dice.R 51a96cd6123764909485f51bcb608d11 *R/panel.mysymbols.R f9de73949f5e9682758562fd25e89378 *R/petals.R 61fc27009a114aa40306245ec6bc42de *R/plot.dice.R fe9b50be472a74f950adc25b34f1aaa4 *R/plot.rgl.coin.R 261909b3574bc6babd34398085646bb4 *R/plot.rgl.die.R 66ecfb67374c2e5931c35ec2af0d1ae3 *R/plot2script.R 66d727e6a19bcad4aaca00d6e5edd8e9 *R/power.examp.R e4149e1707642de82e7371d1893e4666 *R/power.refresh.R 94e4fea63f54415ceb14ee4e0b2de636 *R/prepanel.dice.R b70c65b54e5477b6ce8353b9f22371a4 *R/prob.axis.R b990be3cd99f047779b3d3c94d12bdad *R/put.points.demo.R 3f05484a77cdd8965c89610f91944787 *R/range.R 298d939b4107f2eca43e2bc3fc9a0c3c *R/rgl.Map.R 783f81158c7604f6704ee598a5f6eeca *R/roc.demo.R 65687e4db1d1b21fd623cfca72dcbbbb *R/roll.rgl.die.R 309f330913e0924d41f66fbad83a4c3a *R/rotate.cloud.R 560f882be4e4c4c551eeb606c0b44ea7 *R/rotate.persp.R 98e7e44e566a8e8aea76eb15ce6b7538 *R/rotate.wireframe.R b43e6bdd9bccebe28a60fb4a8ee976a3 *R/run.ci.examp.R 9d343d9739881c6c41d035bf51ecaac0 *R/run.cor.examp.R bd9cf51e1d3fa2d3c8d568ca43ea53ed *R/run.cor2.examp.R 466c41a7e55779a3d1e436305d01cb16 *R/run.hist.demo.R 27b3349075beafc9e2146ad55994c818 *R/run.old.cor.examp.R be7764047a007d578b54cbd8521fdaf8 *R/run.old.cor2.examp.R 40ed2c2be2eeb61304d3bb23b0e9199c *R/run.power.examp.R 32cc8235b557c88bc1822498cd14de25 *R/shadowtext.R 4a6219248da317cb6468c6bd1ecd8b9e *R/sigma.test.R dd1193805d3e6d1ef0f67a58013dd73a *R/simfun.R 3aa38aa3dc9f7be125ea33ed8dce8361 *R/slideRule.R 6f9694d01a32cc57f655b3f936fa63c4 *R/slider.R f1e776f9d7f22892de2a3c703cd40efb *R/sliderv.R c279ead2d78b0935f7f48baef12328aa *R/spread.labs.R a790112260956733a2cd64248dae7482 *R/squishplot.R 31888877ea06f40d7043eed3f8e05472 *R/subplot.R 74deea904dd26a06835bc33e960e96bf *R/tdspinner.R 9a381b4e07d68970477905a3b89515d1 *R/tests.R 8dcb11459e1a32582cb2876222a8b814 *R/tkBrush.R f5566e1117e42151d99112291d370fd4 *R/tkexamp.R 9b5c7069c94891cb5eaf6a33bade4776 *R/tree.demo.R 43bb666e82429e68a64edd21936bf965 *R/triplot.R c013c03f9282e177b78ec3f31d1e4b06 *R/updateusr.R e1e613de99adcc9666ab3b739cbd1817 *R/vis.binom.R a3310256ff9d8f4feb69a7d5b24a157e *R/vis.boxcox.R cae45074402fdf654a0587683bfd571e *R/vis.boxcoxu.R c083f2708a48d4de7dede001a72eeed7 *R/vis.gamma.R dd8376f2c70caf5327aba7008bf7ac0f *R/vis.normal.R 143535152aa5ce70dc38a034d91d9af1 *R/vis.t.R bb9b7dbe8e5cd644987625fc15169537 *R/vis.test.R 16cdaf4ccf9e19061d3421c9767cc748 *R/z.test.R de2db1801d9946cae7ef584b15e57460 *data/USCrimes.rda 409c99a3ec4d294667f2793cf3599e09 *data/coin.faces.rda 26639abf4a55f99cd06ebdf9ff2d66b9 *data/evap.rda 578018c8e779a12d0dc6a6bc2c221856 *data/gps.rda 71f326dddd0da705a6713a04f266a624 *data/ldsgrowth.rda 832fd98ba287b6f910493fdd082990c4 *data/outliers.rda d14d598615dfb3a21a6b09f9643aac83 *data/steps.rda a7827043a84362dca95610c2b7c82b92 *data/stork.rda bf0350619f5b1c35007854fb709c0878 *man/HWidentify.Rd d2101e3256d7046e7173a48028220001 *man/Pvalue.sim.Rd 76475b1797094a5cc8b05a1f2553200f *man/R2txt.Rd 9665a0a0f562021b137b7b7888a26a64 *man/SensSpec.demo.Rd 2909f310ddf48911e75f60f221d6bf55 *man/TeachingDemos-package.Rd b8999431ef804a11be37925559935b8f *man/TkApprox.Rd 2dd60e5129058668181186714c0540d5 *man/TkBuildDist.Rd 61281ae4682c84945788a79240547c97 *man/TkListView.Rd d652b08eaef94ea3676c0e44e96aa4dd *man/TkPredict.Rd 11fcb9cd2d53698e6538a4c7888a866d *man/TkSpline.Rd f5ec21d2bad43aa79c83f50bfb56521d *man/USCrimes.Rd 5eeec237c1c216684a04bb2a795f0511 *man/bct.Rd 197be677a8d19f38fcb9014e55d8631c *man/cal.Rd 9e251af8547372c52f9f087aa9aa5998 *man/ccc.Rd 3fdf7f16d0b34c0b1b7adaab354452a7 *man/char2seed.Rd cd550ee11ffb26b5262755b1f737da2f *man/chisq.detail.Rd 4ccec473e61229ec7e6b07a4711c739f *man/ci.examp.Rd 5aa4c2a8245494b0cb986d0c7cfa253a *man/clipplot.Rd 95d9c3e171f7b9b486e08a253c2ee7b3 *man/clt.examp.Rd 684811e24e463e1bd8068f17434faf95 *man/cnvrt.coords.Rd df72d98529a4ce786e9562812618341d *man/coin.faces.Rd 95ab530538c9f1eda87d981b3eb5de8a *man/col2grey.Rd 9e40a9b87438c4dd2cd83db0441487cb *man/correct.Rd 57349eaaaf61f0bd5492dcc11ce412b0 *man/cortest.Rd 98a0303cbf75b7bb4966e1e33fd2c9b8 *man/dice.Rd abfadb70a2ffc9c9958972b525705f80 *man/digits.Rd 39e92d82ff1bbd4b3853489f3aa2b12f *man/dots.Rd 2eedae3e076ebd7a0b93dc1fb7002cc1 *man/dynIdentify.Rd 5c38ef7c17f19b90e608b66ef3885197 *man/evap.Rd 57210d622965fa97cb029ce8c4d9927e *man/faces.Rd c29f8b7dbb02e9d82f4a81023ff41526 *man/faces2.Rd 0be6959275894d5390b113de9426bcdf *man/fagan.Rd 54e5b86f884518916f846d6c44e3c5d1 *man/gp.open.Rd 8bb57d2f34ab917727ee742d71e01112 *man/hpd.Rd 6a6581ff9412ae6d48a319d6fcdcffdd *man/ineq.Rd 4db985a54544231e90e2bd322db848f7 *man/lattice.demo.Rd 93342564a8107e5efcd2f4abd4f7492e *man/ldsgrowth.Rd c57775c407aad1049016bdae0f1ac7d3 *man/loess.demo.Rd 5c1c0fae52246c842c89f622d9dcbe3b *man/mle.demo.Rd 239ac8d633ed64b9c7febbad3057c69a *man/ms.polygram.Rd fd995437a8b589cc4d6dd580a8d3470c *man/mysymbols.Rd 07488c70ff6003a98a6c6fa279bc9d1e *man/normtest.Rd 56de9a1a4dc69c5ed1a0fbf2441f1459 *man/outliers.Rd 4e920e179b5556f2ffc6bdf6fe2c52b6 *man/pairs2.Rd d85cd64b5890228b09068f982ccf6d9e *man/panel.mysymbols.Rd 7e3182717d8b1e5a2562a43cdf707cde *man/petals.Rd c2e16ef8481dc28a4321e052afdf4e22 *man/plot.rgl.coin.Rd da0f417b8f49753c1ffaee8e1cee2951 *man/plot2script.Rd 597aaddc7c24dffabd8b547892eb16ae *man/power.examp.Rd 351cbefc6c4d6b4f45c5b19247bac709 *man/put.points.demo.Rd 7cb2453b961a967c7f82ef32a0f4ca2e *man/rgl.Map.Rd 899582bf2feb1c16c6f86f74261bc76b *man/roc.demo.Rd 9fbc32b81cf7e1a4431d4a87be39b6b3 *man/rotate.cloud.Rd 96c57bab8a79e3e7bb4a6971a2219650 *man/run.cor.examp.Rd 61b081ee568fc38aea4f2a402c493ff0 *man/run.hist.demo.Rd ba8dcd3f9a14f1d706f5b927c63c3649 *man/shadowtext.Rd 5435bae8bddb23dc81677cf0fec4c7d8 *man/sigma.test.Rd 42e0eca92792d8bdce21be8fecece772 *man/simfun.Rd ea8ff131017333137f3fefebd969173c *man/slider.Rd b9cdb4d73d75f6d8db56b8a456866a06 *man/sliderv.Rd 082f9656600a1ec4b291b961094737e1 *man/spread.labs.Rd 5b1ac4a906bff3dd390b626b64042280 *man/squishplot.Rd a0f02b9530a79681925970402fd61d52 *man/steps.Rd 939e0eda45e163643a0011bf565e66ff *man/stork.Rd 85e77faaf5cf24a276fbf850d3b7969c *man/subplot.Rd 7adf8ab5c65775a51b7c84b133e12301 *man/tkBrush.Rd bc4df3320f86f835966550efb2873e1c *man/tkexamp.Rd 133b0eb9442c1f391f1e03e292b5d01c *man/tree.demo.Rd e4a6314717717c3f185f8b40e7a7af69 *man/triplot.Rd 217013a384af5f18052a0e2e6711760f *man/updateusr.Rd 4f0979515e942b48c031573fb99df73a *man/vis.binom.Rd dcf864aed54b2a7f79b2a253e90d07fb *man/vis.boxcox.Rd 36ca5f5af58b296c32b7c1badf2fb10c *man/vis.test.Rd f48dd2affc24842c20e062214fdfef64 *man/z.test.Rd e6da88e86d010a603b64dabf1d8309de *man/zoomplot.Rd TeachingDemos/DESCRIPTION0000644000175100001440000000115612657277161014531 0ustar hornikusersPackage: TeachingDemos Title: Demonstrations for Teaching and Learning Version: 2.10 Author: Greg Snow Description: Demonstration functions that can be used in a classroom to demonstrate statistical concepts, or on your own to better understand the concepts or the programming. Maintainer: Greg Snow <538280@gmail.com> License: Artistic-2.0 Date: 2016-02-08 Suggests: tkrplot, lattice, MASS, rgl, tcltk, tcltk2, png, ggplot2, logspline, maptools, R2wd, manipulate LazyData: true KeepSource: true NeedsCompilation: no Packaged: 2016-02-12 01:53:42 UTC; Family Repository: CRAN Date/Publication: 2016-02-12 07:40:49 TeachingDemos/man/0000755000175100001440000000000012657235444013571 5ustar hornikusersTeachingDemos/man/put.points.demo.Rd0000644000175100001440000000411412657235444017126 0ustar hornikusers\name{put.points.demo} \alias{put.points.demo} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Demonstrate Correlation and Regression by placing and moving data points } \description{ Place data points on a graph to demonstrate concepts related to correlation and regression. } \usage{ put.points.demo(x = NULL, y = NULL, lsline = TRUE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ x-coordinates for initial points. } \item{y}{ y-coordinates for initial points. } \item{lsline}{ Logical, should the ls regresion line be included. } } \details{ The plot area is divided into 2 sections, the left section shows a scatterplot of your points, the right panel controls what happens when you click in the left panel. The top of the right panel has an "end" button that you click on to end the demonstration. The middle right panel toggles the least squares line and information. The bottom right panel has radio buttons that determine what clicking in the left panel will do, the options are to add a point, delete a point, or move a point. To move a point click on the point you want to move, it will become solid, then click in the place you want it to move to. When deleting or moving points, the closest point to where you click will be deleted or moved, even if you click in an empty area. Whenever you add, delete, or move a point the correlation, r\^2, and regression line will be updated. You can start with a set of points then demonstrate what happens to the correlation and regression line when outliers are added or important points are moved or deleted. } \value{ This function does not return anything. } \author{ Greg Snow \email{538280@gmail.com} } \seealso{ \code{\link{plot}}, \code{\link{cor}} } \examples{ if(interactive()){ put.points.demo() x <- rnorm(25, 5, 1) y <- x + rnorm(25) put.points.demo(x,y) } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ iplot }% __ONLY ONE__ keyword per line \keyword{regression}TeachingDemos/man/char2seed.Rd0000644000175100001440000000401412657235444015717 0ustar hornikusers\name{char2seed} \alias{char2seed} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Convert a character string into a random seed } \description{ This function creates a seed for the random number generator from a character string. Character strings can be based on student names so that every student has a different random sample, but the teacher can generate the same datasets. } \usage{ char2seed(x, set = TRUE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ A character string } \item{set}{ Logical, should the seed be set or just returned } \item{\dots}{ Additional parameters passed on to \code{set.seed} } } \details{ Simulations or other situations call for the need to have repeatable random numbers, it is easier to remember a word or string than a number, so this function converts words or character strings to an integer and optionally sets the seed based on this. Teachers can assign students to generate a random dataset using their name to seed the rng, this way each student will have a different dataset, but the teacher can generate the same set of data to check values. Any characters other than letters (a-zA-Z) or digits (0-9) will be silently removed. This function is not case sensitive, so "ABC" and "abc" will generate the same seed. This is a many to one function, so it is possible to find different words that generate the same seed, but this is unlikely by chance alone. } \value{ This returns an integer (but mode numeric) to use as a seed for the RNG. If \code{set} is true then it is returned invisibly. } \author{ Greg Snow \email{538280@gmail.com} } \seealso{ \code{\link{set.seed}} } \examples{ char2seed('Snow') x <- rnorm(100) rnorm(10) tmp <- char2seed('Snow',set=FALSE) set.seed(tmp) y <- rnorm(100) all.equal(x,y) # should be true } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ datagen } TeachingDemos/man/faces.Rd0000644000175100001440000000520212657235444015140 0ustar hornikusers\name{faces} \alias{faces} \title{ Chernoff Faces } \description{ faces represent the rows of a data matrix by faces } \usage{ faces(xy, which.row, fill = FALSE, nrow, ncol, scale = TRUE, byrow = FALSE, main, labels) } \arguments{ \item{xy}{ \code{xy} data matrix, rows represent individuals and columns attributes } \item{which.row}{ defines a permutation of the rows of the input matrix } \item{fill}{ \code{if(fill==TRUE)}, only the first \code{nc} attributes of the faces are transformed, \code{nc} is the number of columns of \code{xy} } \item{nrow}{ number of columns of faces on graphics device } \item{ncol}{ number of rows of faces } \item{scale}{ \code{if(scale==TRUE)}, attributes will be normalized } \item{byrow}{ \code{if(byrow==TRUE)}, \code{xy} will be transposed } \item{main}{ title } \item{labels}{ character strings to use as names for the faces } } \details{ The features paramters of this implementation are: 1-height of face, 2-width of face, 3-shape of face, 4-height of mouth, 5-width of mouth, 6-curve of smile, 7-height of eyes, 8-width of eyes, 9-height of hair, 10-width of hair, 11-styling of hair, 12-height of nose, 13-width of nose, 14-width of ears, 15-height of ears. For details look at the literate program of \code{faces} } \value{ a plot of faces is created on the graphics device, no numerical results } \references{ Chernoff, H. (1973): The use of faces to represent statistiscal assoziation, JASA, 68, pp 361--368. The smooth curves are computed by an algorithm found in Ralston, A. and Rabinowitz, P. (1985): A first course in numerical analysis, McGraw-Hill, pp 76ff. \url{http://www.wiwi.uni-bielefeld.de/~wolf/} : S/R - functions : faces } \author{ H. P. Wolf } \note{ version 12/2003 } \seealso{ --- } \examples{ faces(rbind(1:3,5:3,3:5,5:7)) data(longley) faces(longley[1:9,]) set.seed(17) faces(matrix(sample(1:1000,128,),16,8),main="random faces") if(interactive()){ tke1 <- rep( list(list('slider',from=0,to=1,init=0.5,resolution=0.1)), 15) names(tke1) <- c('FaceHeight','FaceWidth','FaceShape','MouthHeight', 'MouthWidth','SmileCurve','EyesHeight','EyesWidth','HairHeight', 'HairWidth','HairStyle','NoseHeight','NoseWidth','EarWidth','EarHeight') tkfun1 <- function(...){ tmpmat <- rbind(Min=0,Adjust=unlist(list(...)),Max=1) faces(tmpmat, scale=FALSE) } tkexamp( tkfun1, list(tke1), plotloc='left', hscale=2, vscale=2 ) } } %\keyword{ Chernoff faces}% at least one, from doc/KEYWORDS %\keyword{ Flury faces }% __ONLY ONE__ keyword per line %\keyword{ faces }% __ONLY ONE__ keyword per line \keyword{ hplot }TeachingDemos/man/gp.open.Rd0000644000175100001440000000547412657235444015440 0ustar hornikusers\name{gp.open} \alias{gp.open} \alias{gp.close} \alias{gp.send} \alias{gp.plot} \alias{gp.splot} \title{Alpha version functions to send plotting commands to GnuPlot} \description{These functions allow you to open a connection to a gnuplot process, send data and possibly other information to gnuplot for it to plot, then close gnuplot and clean up temporary files and variables. These functions are alpha level at best, use at your own risk.} \usage{ gp.open(where='c:/progra~1/GnuPlot/bin/pgnuplot.exe') gp.close(pipe=gpenv$gp) gp.send(cmd='replot',pipe=gpenv$gp) gp.plot(x,y,type='p',add=FALSE, title=deparse(substitute(y)),pipe=gpenv$gp) gp.splot(x,y,z, add=FALSE, title=deparse(substitute(z)), pipe=gpenv$gp, datafile=tempfile()) } \arguments{ \item{where}{Path to GnuPlot Executable} \item{pipe}{The pipe object connected to GnuPlot (returned from \code{gp.open}), warning: changing this from the default will probably break things} \item{cmd}{Text string, the command to be sent verbatim to the GnuPlot process} \item{x}{The \code{x} coordinates to plot} \item{y}{the \code{y} coordinates to plot} \item{z}{the \code{z} coordinates to splot} \item{type}{Either 'p' or 'l' for plotting points or lines} \item{add}{Logical, should the data be added to the existing plot or start a new plot} \item{title}{The title or legend entry} \item{datafile}{The file to store the data in for transfer to gnuplot} } \details{ These functions provide a basic interface to the GnuPlot program (you must have GnuPlot installed (separate install)), \code{gp.open} runs GnuPlot and establishes a pipe connection, \code{gp.close} sends a quite command to gnuplot and cleans up temporary variables and files, \code{gp.send} sends a command to the GnuPlot process verbatim, and \code{gp.plot} sends data and commands to the process to create a standard scatterplot or line plot. } \value{ \code{gp.open} returns and invisible copy of the pipe connection object (to pass to other functions, but don't do this because it doesn't work right yet). The other 3 functions don't return anything meaningful. All functions are run for their side effects. } \references{ \url{http://www.gnuplot.info/} } \author{ Greg Snow \email{538280@gmail.com}} \note{ These functions create some temporary files and 2 temporary global variables (.gp and .gp.tempfiles), running \code{gp.close} will clean these up (so use it). These functions are still alpha level. } \seealso{\code{\link{plot}} } \examples{ \dontrun{ x <- 1:10 y <- 3-2*x+x*x+rnorm(10) gp.open() gp.plot(x,y) gp.send('replot 3-2*x+x**2') tmp <- expand.grid(x=1:10, y=1:10) tmp <- transform(tmp, z=(x-5)*(y-3)) gp.splot(tmp$x, tmp$y, tmp$z) gp.close() } } \keyword{hplot} TeachingDemos/man/vis.test.Rd0000644000175100001440000002004512657235444015640 0ustar hornikusers\name{vis.test} \Rdversion{1.1} \alias{vis.test} \alias{vt.qqnorm} \alias{vt.normhist} \alias{vt.scatterpermute} \alias{vt.tspermute} \alias{vt.residpermute} \alias{vt.residsim} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Do a Visual test of a null hypothesis by choosing the graph that does not belong. } \description{ These functions help in creating a set of plots based on the real data and some modification that makes the null hypothesis true. The user then tries to choose which graph represents the real data. } \usage{ vis.test(..., FUN, nrow=3, ncol=3, npage=3, data.name = "", alternative) vt.qqnorm(x, orig=TRUE) vt.normhist(x, ..., orig=TRUE) vt.scatterpermute(x, y, ..., orig=TRUE) vt.tspermute(x, type='l', ..., orig=TRUE) vt.residpermute(model, ..., orig=TRUE) vt.residsim(model, ..., orig=TRUE) } \arguments{ \item{\dots}{ data and arguments to be passed on to \code{FUN} or to plotting functions, see details below} \item{FUN}{ The function to create the plots on the original or null hypothesis data} \item{nrow}{ The number of rows of graphs per page } \item{ncol}{ The number of columns of graphs per page } \item{npage}{ The number of pages to use in the testing } \item{data.name}{Optional character string for the name of the data in the output} \item{alternative}{Optional character string for the alternative hypothesis in the output} \item{orig}{ Logical, should the original data be plotted, or data based on the null hypothesis } \item{x}{data or x-coordinates of the data} \item{y}{y-coordinates of the data} \item{type}{type of plot, passed on to plot function (use 'p' for points)} \item{model}{An \code{lm} object, or any model object for which \code{fitted} and \code{resid} return vectors} } \details{ The \code{vis.test} function will create a \code{nrow} by \code{ncol} grid of plots, one of which is based on the real (original) data and the others which are based on a null hypothesis simulation (a statistical "lineup"). The real plot is placed at random within the set. The user then clicks on their best guess of which plot is the real one (the most different from the others). If the null hypothesis is true for the real data, then this will be a guess with a 1/(\code{nrow}*\code{ncol}) probability of success. This process is then repeated for a total of \code{npage} times. A p-value is then constructed based on the number of correct guesses and the null hypothesis that there is a 1/(\code{nrow}*\code{ncol}) chance of guessing correct each time (this will work best if the person doing the choosing has not already seen plots/summaries of the data). If the plotting function (\code{FUN}) is not passed as a named argument, then the first argument (in the \dots) that is a function will be used. If no functions are passed then the function will stop with an error. The plotting function (\code{FUN}) can be an existing function or a user supplied function. The function must have an argument named "orig" which indicates whether to plot the original data or the null hypothesis data. A new seed will be set before each call to \code{FUN} except when \code{orig} is \code{TRUE}. Inside the function if \code{orig} is \code{TRUE} then the function should plot the original data. When \code{orig} is \code{FALSE} then the function should do some form of simulation based on the data with the null hypothesis true and plot the simulated data (making sure to give no signs that it is different from the original plot). The return object includes a list with the seeds set before each of the plots (\code{NA} for the original data plot) and a vector of the plots selected by the user. This information can be used to recreate the simulated plots by setting the seed then calling \code{FUN}. The \code{vt.qqnorm} function tests the null hypothesis that a vector of data comes from a normal distribution (or at least pretty close) by creating a \code{qqnorm} plot of the original data, or the same plot of random data from a normal distribution with the same mean and standard deviation as the original data. The \code{vt.normhist} function tests the null hypothesis that a vector of data comes from a normal distribution (or at least pretty close) by plotting a histogram with a reference line representing a normal distribution of either the original data or a set of random data from a normal distribution with the same mean and standard deviation as the original. The \code{vt.scatterpermute} function tests the null hypothesis of "no relationship" between 2 vectors of data. When \code{orig} is \code{TRUE} the function creates a scatterplot of the 2 variables, when \code{orig} is \code{FALSE} the function first permutes the y variable randomly (making no relationship) then creates a scatter plot with the original x and permuted y variables. The \code{vt.tspermute} function creates a time series type plot of a single vector against its index. When \code{orig} is false, the vector is permuted before plotting. The \code{vt.residpermute} function takes a regression object (class lm, or any model type object for which \code{fitted} and \code{resid} return vectors) and does a residual plot of the fitted values on the x axis and residuals on the y axis. The loess smooth curve (\code{scatter.smooth} is the plotting function) and a reference line at 0 are included. When \code{orig} is \code{FALSE} the residuals are randomly permuted before being plotted. The \code{vt.residsim} function takes a regression object (class lm, or any model type object for which \code{fitted} and \code{resid} return vectors) and does a residual plot of the fitted values on the x axis and residuals on the y axis. The loess smooth curve (\code{scatter.smooth} is the plotting function) and a reference line at 0 are included. When \code{orig} is \code{FALSE} the residuals are simulate from a normal distribution with mean 0 and standard deviation the same as the residuals. } \value{ The \code{vis.test} function returns an object of class \code{htest} with the following components: \item{method}{The string "Visual Test"} \item{data.name}{The name of the data passed to the function} \item{statistic}{The number of correct "guesses"} \item{p.value}{The p-value based on the number of correct "guesses"} \item{nrow}{The number of rows per page} \item{ncol}{The number of columns per page} \item{npage}{The number of pages} \item{seeds}{A list with 3 vectors containing the seeds set before calling \code{FUN}, the correct plot has an \code{NA}} \item{selected}{A vector of length \code{npage} indicating the number of the figure picked in each of the \code{npage} tries} The other functions are run for their side effects and do not return anything meaningful. } \references{ Buja, A., Cook, D. Hofmann, H., Lawrence, M. Lee, E.-K., Swayne, D.F and Wickham, H. (2009) Statistical Inference for exploratory data analysis and model diagnostics Phil. Trans. R. Soc. A 2009 367, 4361-4383 doi: 10.1098/rsta.2009.0120 } \author{Greg Snow \email{538280@gmail.com}} %% ~Make other sections like Warning with \section{Warning }{....} ~ \section{Warning}{The p-value is based on the assumption that under the null hypothesis there is a 1/(\code{nrow}*\code{ncol}) chance of picking the correct plot and that the \code{npage} choices are independent of each other. This may not be true if the user is familiar with the data or remembers details of the plot between picks.} \seealso{\code{\link{set.seed}} } \examples{ if(interactive()) { x <- rexp(25, 1/3) vis.test(x, vt.qqnorm) x <- rnorm(100, 50, 3) vis.test(x, vt.normhist) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ hplot } \keyword{ datagen }% __ONLY ONE__ keyword per line \keyword{ htest }TeachingDemos/man/correct.Rd0000644000175100001440000000524312657235444015525 0ustar hornikusers\name{cor.rect.plot} \alias{cor.rect.plot} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plot a visualization of the correlation using colored rectangles } \description{ This function creates a scatterplot of the data, then adds colored rectangles between the points and the mean of x and y to represent the idea of the correlation coefficient. } \usage{ cor.rect.plot(x, y, corr = TRUE, xlab = deparse(substitute(x)), ylab = deparse(substitute(y)), col = c("#ff000055", "#0000ff55"), ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The \code{x} value or any object that can be interpreted by \code{xy.coords} } \item{y}{ The \code{y} value } \item{corr}{ Should the standardized axes (right and top) show the values divided by the standard deviation (TRUE, which shows correlation ideas) or not (FALSE, shows covariance idea) } \item{xlab}{ The label for the \code{x} axis } \item{ylab}{ The label for the \code{y} axis } \item{col}{ A vector of length 2 with the colors to use for the fill of the rectangles, the 1st value will be used for "positive" rectangles and the 2nd value will be used for the "negative" rectangles. } \item{\dots}{ Possible further arguments, currently ignored } } \details{ This will create a scatterplot of the data, draw refrence lines at the mean of \code{x} and the mean of \code{y}, then draw rectangles from the mean point to the data points. The right and top axes will show the centered (and possibly scaled if \code{corr=TRUE}) values. The idea is that the correlation/covariance is based on summing the area of the "positive" rectangles and subtracting the sum of the areas of the "negative" rectangles (then dividing by n-1). If the positive and negative areas are about the same then the correlation/covariance is near 0, if there is more area in the positive rectangles then the correlation/covariance will be positive. } \value{ This function returns an invisible NULL, it is run for its side effects. } \author{Greg Snow, \email{538280@gmail.com}} \seealso{ \code{\link{cor}} } \examples{ ## low correlation x <- rnorm(25) y <- rnorm(25) cor(x,y) cor.rect.plot(x,y) ## Positive correlation x <- rnorm(25) y <- x + rnorm(25,3, .5) cor(x,y) cor.rect.plot(x,y) ## negative correlation x <- rnorm(25) y <- rnorm(25,10,1.5) - x cor(x,y) cor.rect.plot(x,y) ## zero correlation but a definite relationship x <- -5:5 y <- x^2 cor(x,y) cor.rect.plot(x,y) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ hplot } TeachingDemos/man/updateusr.Rd0000644000175100001440000000535612657235444016105 0ustar hornikusers\name{updateusr} \alias{updateusr} %- Also NEED an '\alias' for EACH other topic documented here. \title{Updates the 'usr' coordinates in the current plot. } \description{ For a traditional graphics plot this function will update the 'usr' coordinates by transforming a pair of points from the current usr coordinates to those specified. } \usage{ updateusr(x1, y1 = NULL, x2, y2 = NULL) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x1}{ The x-coords of 2 points in the current 'usr' coordianates, or anything that can be passed to \code{xy.coords}.} \item{y1}{ The y-coords of 2 points in the current 'usr' coordinates, or an object representing the points in the new 'usr' coordinates. } \item{x2}{ The x-coords for the 2 points in the new coordinates. } \item{y2}{ The y-coords for the 2 points in the new coordinates. } } \details{ Sometimes graphs (in the traditional graphing scheme) end up with usr coordinates different from expected for adding to the plot (for example \code{barplot} does not center the bars at integers). This function will take 2 points in the current 'usr' coordinates and the desired 'usr' coordinates of the 2 points and transform the user coordinates to make this happen. The updating only shifts and scales the coordinates, it does not do any rotation or warping transforms. If \code{x1} and \code{y1} are lists or matricies and \code{x2} and \code{y2} are not specified, then \code{x1} is taken to be the coordinates in the current system and \code{y1} is the coordinates in the new system. Currently you need to give the function exactly 2 points in each system. The 2 points cannot have the same x values or y values in either system. } \value{ An invisible list with the previous 'usr' coordinates from \code{par}. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow, \email{538280@gmail.com} } \note{ Currently you need to give coordinates for exactly 2 points without missing values. Future versions of the function will allow missing values or multiple points. } \seealso{\code{\link{par}} } \examples{ tmp <- barplot(1:4) updateusr(tmp[1:2], 0:1, 1:2, 0:1) lines(1:4, c(1,3,2,2), lwd=3, type='b',col='red') # update the y-axis to put a reference distribution line in the bottom # quarter tmp <- rnorm(100) hist(tmp) tmp2 <- par('usr') xx <- seq(min(tmp), max(tmp), length.out=250) yy <- dnorm(xx, mean(tmp), sd(tmp)) updateusr( tmp2[1:2], tmp2[3:4], tmp2[1:2], c(0, max(yy)*4) ) lines(xx,yy) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ dplot } \keyword{ aplot }% __ONLY ONE__ keyword per line TeachingDemos/man/stork.Rd0000644000175100001440000000265512657235444015232 0ustar hornikusers\name{stork} \Rdversion{1.1} \alias{stork} \docType{data} \title{ Neyman's Stork data } \description{ Data invented by Neyman to look at spurious correlations and adjusting for lurking variables by looking at the relationship between storks and biths. } \usage{data(stork)} \format{ A data frame with 54 observations on the following 6 variables. \describe{ \item{\code{County}}{ID of county} \item{\code{Women}}{Number of Women (*10,000)} \item{\code{No.storks}}{Number of Storks sighted} \item{\code{No.babies}}{Number of Babies Born} \item{\code{Stork.rate}}{Storks per 10,000 women (=No.storks/Women)} \item{\code{Birth.rate}}{Babies per 10,000 women (=No.babies/Women)} } } \details{ This is an entertaining example to show a relationship that is due to a third possibly lurking variable. The source paper shows how completely different relationships can be found by mis-analyzing the data. } \source{ Kronmal, Richard A. (1993) Spurious Cerrolation and the Fallacy of the Ratio Standard Revisited. Journal of the Royal Statistical Society. Series A, Vol. 156, No. 3, 379-392. } \references{ Neyman, J. (1952) Lectures and Conferences on Mathematical Statistics and Probability, 2nd edn, pp. 143-154. Washington DC: US Department of Agriculture. } \examples{ data(stork) pairs(stork[,-1], panel=panel.smooth) ## maybe str(stork) ; plot(stork) ... } \keyword{datasets} TeachingDemos/man/sigma.test.Rd0000644000175100001440000000340612657235444016141 0ustar hornikusers\name{sigma.test} \alias{sigma.test} %- Also NEED an '\alias' for EACH other topic documented here. \title{ One sample Chi-square test for a population variance } \description{ Compute the test of hypothesis and compute a confidence interval on the variance of a population. } \usage{ sigma.test(x, sigma = 1, sigmasq = sigma^2, alternative = c("two.sided", "less", "greater"), conf.level = 0.95, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Vector of data values. } \item{sigma}{ Hypothesized standard deviation of the population. } \item{sigmasq}{ Hypothesized variance of the population. } \item{alternative}{ Direction of the alternative hypothesis. } \item{conf.level}{ Confidence level for the interval computation. } \item{\dots}{ Additional arguments are silently ignored. } } \details{ Many introductory statistical texts discuss inference on a single population variance and introduce the chi-square test for a population variance as another example of a hypothesis test that can be easily derived. Most statistical packages do not include the chi-square test, perhaps because it is not used in practice very often, or because the test is known to be highly sensitive to nonnormal data. For the two-sample problem, see \code{var.test}. } \value{ An object of class \code{htest} containing the results } \author{ G. Jay Kerns \email{gkerns@ysu.edu} } \note{ This test is highly sensitive to nonnormality. } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{var.test}}, \code{\link{print.htest}} } \examples{ x <- rnorm(20, mean = 15, sd = 7) sigma.test(x, sigma = 6) } \keyword{ htest }% at least one, from doc/KEYWORDS TeachingDemos/man/col2grey.Rd0000644000175100001440000000213312657235444015605 0ustar hornikusers\name{col2grey} \alias{col2grey} \alias{col2gray} \title{Convert colors to grey/grayscale} \description{ Convert colors to grey/grayscale so that you can see how your plot will look after photocopying or printing to a non-color printer. } \usage{ col2grey(cols) col2gray(cols) } \arguments{ \item{cols}{ Colors to convert.} } \details{ converts colors to greyscale using the formula grey=0.3*red + 0.59*green + 0.11*blue. This allows you to see how your color plot will approximately look when printed on a non-color printer or photocopied. } \value{ A vector of colors (greys) corresponding to the input colors. } \author{ Greg Snow \email{538280@gmail.com} } \seealso{ \code{\link{grey}}, \code{\link{col2rgb}}, dichromat package } \examples{ par(mfcol=c(2,2)) tmp <- 1:3 names(tmp) <- c('red','green','blue') barplot( tmp, col=c('red','green','blue') ) barplot( tmp, col=col2gray( c('red','green','blue') ) ) barplot( tmp, col=c('red','#008100','#3636ff') ) barplot( tmp, col=col2grey( c('red','#008100','#3636ff') ) ) } \keyword{dplot} \keyword{color} TeachingDemos/man/cnvrt.coords.Rd0000644000175100001440000001213512657235444016506 0ustar hornikusers\name{cnvrt.coords} \alias{cnvrt.coords} %- Also NEED an '\alias' for EACH other topic documented here. \title{Convert between the 5 different coordinate sytems on a graphical device} \description{ Takes a set of coordinates in any of the 5 coordinate systems (usr, plt, fig, dev, or tdev) and returns the same points in all 5 coordinate systems. } \usage{ cnvrt.coords(x, y = NULL, input = c("usr", "plt", "fig", "dev","tdev")) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{Vector, Matrix, or list of x coordinates (or x and y coordinates), NA's allowed. } \item{y}{y coordinates (if \code{x} is a vector), NA's allowed. } \item{input}{Character scalar indicating the coordinate system of the input points. } } \details{ Every plot has 5 coordinate systems: usr (User): the coordinate system of the data, this is shown by the tick marks and axis labels. plt (Plot): Plot area, coordinates range from 0 to 1 with 0 corresponding to the x and y axes and 1 corresponding to the top and right of the plot area. Margins of the plot correspond to plot coordinates less than 0 or greater than 1. fig (Figure): Figure area, coordinates range from 0 to 1 with 0 corresponding to the bottom and left edges of the figure (including margins, label areas) and 1 corresponds to the top and right edges. fig and dev coordinates will be identical if there is only 1 figure area on the device (layout, mfrow, or mfcol has not been used). dev (Device): Device area, coordinates range from 0 to 1 with 0 corresponding to the bottom and left of the device region within the outer margins and 1 is the top and right of the region withing the outer margins. If the outer margins are all set to 0 then tdev and dev should be identical. tdev (Total Device): Total Device area, coordinates range from 0 to 1 with 0 corresponding to the bottom and left edges of the device (piece of paper, window on screen) and 1 corresponds to the top and right edges. } \value{ A list with 5 components, each component is a list with vectors named x and y. The 5 sublists are: \item{usr}{The coordinates of the input points in usr (User) coordinates.} \item{plt}{The coordinates of the input points in plt (Plot) coordinates.} \item{fig}{The coordinates of the input points in fig (Figure) coordinates.} \item{dev}{The coordinates of the input points in dev (Device) coordinates.} \item{tdev}{The coordinates of the input points in tdev (Total Device) coordinates. } } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com}} \note{ You must provide both x and y, but one of them may be \code{NA}. This function is now depricated with the new functions \code{grconvertX} and \code{grconvertY} in R version 2.7.0 and beyond. These new functions use the correct coordinate system names and have more coordinate systems available, you should start using them instead. } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{par}} specifically 'usr','plt', and 'fig'. Also 'xpd' for plotting outside of the plotting region and 'mfrow' and 'mfcol' for multi figure plotting. \code{\link{subplot}}, \code{grconvertX} and \code{grconvertY} in R2.7.0 and later} \examples{ old.par <- par(no.readonly=TRUE) par(mfrow=c(2,2),xpd=NA) # generate some sample data tmp.x <- rnorm(25, 10, 2) tmp.y <- rnorm(25, 50, 10) tmp.z <- rnorm(25, 0, 1) plot( tmp.x, tmp.y) # draw a diagonal line across the plot area tmp1 <- cnvrt.coords( c(0,1), c(0,1), input='plt' ) lines(tmp1$usr, col='blue') # draw a diagonal line accross figure region tmp2 <- cnvrt.coords( c(0,1), c(1,0), input='fig') lines(tmp2$usr, col='red') # save coordinate of point 1 and y value near top of plot for future plots tmp.point1 <- cnvrt.coords(tmp.x[1], tmp.y[1]) tmp.range1 <- cnvrt.coords(NA, 0.98, input='plt') # make a second plot and draw a line linking point 1 in each plot plot(tmp.y, tmp.z) tmp.point2 <- cnvrt.coords( tmp.point1$dev, input='dev' ) arrows( tmp.y[1], tmp.z[1], tmp.point2$usr$x, tmp.point2$usr$y, col='green') # draw another plot and add rectangle showing same range in 2 plots plot(tmp.x, tmp.z) tmp.range2 <- cnvrt.coords(NA, 0.02, input='plt') tmp.range3 <- cnvrt.coords(NA, tmp.range1$dev$y, input='dev') rect( 9, tmp.range2$usr$y, 11, tmp.range3$usr$y, border='yellow') # put a label just to the right of the plot and # near the top of the figure region. text( cnvrt.coords(1.05, NA, input='plt')$usr$x, cnvrt.coords(NA, 0.75, input='fig')$usr$y, "Label", adj=0) par(mfrow=c(1,1)) ## create a subplot within another plot (see also subplot) plot(1:10, 1:10) tmp <- cnvrt.coords( c( 1, 4, 6, 9), c(6, 9, 1, 4) ) par(plt = c(tmp$dev$x[1:2], tmp$dev$y[1:2]), new=TRUE) hist(rnorm(100)) par(fig = c(tmp$dev$x[3:4], tmp$dev$y[3:4]), new=TRUE) hist(rnorm(100)) par(old.par) } \keyword{ dplot }% at least one, from doc/KEYWORDS \keyword{ aplot }% __ONLY ONE__ keyword per line TeachingDemos/man/vis.binom.Rd0000644000175100001440000000327312657235444015771 0ustar hornikusers\name{vis.binom} \alias{vis.binom} \alias{vis.gamma} \alias{vis.normal} \alias{vis.t} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plot various distributions then interactivly adjust the parameters. } \description{ Plot a curve of a distribution, then using a Tk slider window adjust the parameters and see how the distribution changes. Optionally also plots reference distributions. } \usage{ vis.binom() vis.gamma() vis.normal() vis.t() } %- maybe also 'usage' for other objects documented here. \details{ These functions plot a distribution, then create a Tk slider box that allows you to adjust the parameters of the distribution to see how the curve changes. Check boxes are available in some cases to also show reference distributions (normal and poisson for the binomial, exponential and chi-squared for gamma, and normal for t). The exponential and chi-squared distributions are those with the same mean as the plotted gamma. If you change the plotting ranges then you need to click on the 'refresh' button to update the plot. } \value{ These functions are run for their side effects and do not return anything meaningful. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com} } %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{dnorm}}, \code{\link{dgamma}}, etc. } \examples{ if(interactive()){ vis.binom() vis.normal() vis.gamma() vis.t() } } \keyword{ distribution }% at least one, from doc/KEYWORDS \keyword{ hplot }% __ONLY ONE__ keyword per line \keyword{ dynamic }TeachingDemos/man/ms.polygram.Rd0000644000175100001440000001074512657235444016337 0ustar hornikusers\name{ms.polygram} \alias{ms.polygram} \alias{ms.polygon} \alias{ms.filled.polygon} \alias{ms.male} \alias{ms.female} \alias{ms.arrows} \alias{ms.sunflowers} \alias{ms.image} \alias{ms.face} \title{Symbol functions/data to be passed as symb argument to my.symbols} \description{ These functions/data matricies are examples of what can be passed as the \code{symb} argument in the \code{my.symbols} function. They are provided both to be used for some common symbols and as examples of what can be passed as the \code{symb} argument. } \usage{ ms.polygram(n, r=1, adj=pi/2, ...) ms.polygon(n, r=1, adj=pi/2, ...) ms.filled.polygon(n, r=1, adj=pi/2, fg=par('fg'), bg=par('fg'), ... ) ms.male ms.female ms.arrows(angle, r=1, adj=0.5, length=0.1, ...) ms.sunflowers(n,r=0.3,adj=pi/2, ...) ms.image(img, transpose=TRUE, ...) ms.face(features, ...) } \arguments{ \item{n}{The number of sides for polygons and polygrams, the number of petals(lines) for sunflowers.} \item{r}{The radius of the enclosing circle for polygons and polygrams (1 means that it will pretty much fill the bounding square). For sunflowers this is the radius (relative to the inches square) of the inner circle. For arrows this controls the length of the arrow, a value of 2 means the length of the arrow will be the same as inches (but it may then stick out of the box if adj != 1).} \item{adj}{For polygons, polygrams, and sunflowers this is the angle in radians that the first corner/point will be. The default puts a corner/point straight up, this can be used to rotate the symbols. For arrows, this determines the positioning of the arrow, a value of 0 means the arrow will start at the x,y point and point away from it, 0.5 means the arrow will be centered at x,y and 1 means that the arrow will end (point at) x,y.} \item{fg, bg}{Colors for the filled polygons. \code{fg} is the color of the line around the polygon and \code{bg} is the fill color, see \code{\link{polygon}}.} \item{angle}{The angle in radians that the arrow will point.} \item{length}{The length of the arrow head (see \code{\link{arrows}}).} \item{img}{ A 3 dimensional array representing an image such as produced by the png or EBImage packages.} \item{transpose}{Should the image be tranposed, use TRUE for images imported using package png and FALSE for images imported using EBImage.} \item{features}{A list of data representing the features of the faces, each element represents 1 face and the values need to be scaled between 0 and 1, see \code{\link{faces}} for details on which elements match which features.} \item{...}{additional parameters that will be passed to plotting functions or be ignored.} } \details{ These functions/matricies can be passed as the \code{symb} argument to the \code{my.symbols} function. The represent examples that can be used to create your own symbols or may be used directly. } \value{ These functions either return a 2 column matrix of points to be passed to \code{lines} or \code{NULL}. } \author{Greg Snow \email{538280@gmail.com}} \seealso{\code{\link{my.symbols}}, \code{\link{polygon}}, \code{\link{arrows}}, \code{\link{lines}}, \code{\link{faces}}, also see \code{\link{rasterImage}} for an alternative to ms.image } \examples{ plot(1:10,1:10) my.symbols(1:10,1:10, ms.polygram, n=1:10, r=seq(0.5,1,length.out=10), inches=0.3) my.symbols(1:10,1:10, ms.polygon, n=1:10, add=FALSE, inches=0.3) my.symbols(1:5, 5:1, ms.filled.polygon, add=FALSE, n=3:7, fg='green', bg=c('red','blue','yellow','black','white'), inches=0.3 ) my.symbols( 1:10, 1:10, ms.female, inches=0.3, add=FALSE) my.symbols( 1:10, 10:1, ms.male, inches=0.3, add=TRUE) plot(1:10, 1:10) my.symbols(1:10, 1:10, ms.arrows, angle=runif(10)*2*pi, inches=0.5, adj=seq(0,1,length.out=10), symb.plots=TRUE) my.symbols(1:10, 1:10, ms.sunflowers, n=1:10, inches=0.3, add=FALSE) if( require(png) ) { img <- readPNG(system.file("img", "Rlogo.png", package="png")) my.symbols( runif(10), runif(10), ms.image, MoreArgs=list(img=img), inches=0.5, symb.plots=TRUE, add=FALSE) } tmp.mtcars <- scale(mtcars, center=sapply(mtcars,min), scale=sapply(mtcars,function(x) diff(range(x))) ) tmp2.mtcars <- lapply( seq_len(nrow(tmp.mtcars)), function(i) tmp.mtcars[i,] ) my.symbols(mtcars$wt, mtcars$mpg, ms.face, inches=0.3, features=tmp2.mtcars, add=FALSE) } \keyword{dplot} \keyword{aplot}TeachingDemos/man/cal.Rd0000644000175100001440000000576412657235444014633 0ustar hornikusers\name{cal} \alias{cal} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plot a month or year calendar } \description{ Plot a calendar of the specified year or month. Monthly calendars can have additional information (text/plots) added to the individual cells. } \usage{ cal(month, year) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{month}{ The month for the calendar, if ommitted will do a yearly calendar, can either be a number from 1 to 12 or a character string that will be matched (using \code{pmatch}) against \code{month.name}. } \item{year}{ The year for the calendar. If ommitted and \code{month} is an integer less than or equal to 12 then \code{month} will be used as the year. } } \details{ This function plots on the current (or default) graphics device a yearly or monthly calendar. It tries to guess what you want, if both \code{year} and \code{month} are ommitted then it will plot the current month. If \code{month} is an integer greater than 12 and no \code{year} is specified then that value will be used as the year for a yearly calendar. The \code{month} can be either an integer from 1 to 12 or a character string that will be matched against \code{month.name} using \code{pmatch}. Each day of the monthly calendar is a plotting frame that can be added to using stardard low level functions, the coordinates of the plotting region (the entire box) are from 0 to 1 in both dimensions. The \code{\link{updateusr}} function can be used to change the coordinates. The return from the function (when creating a monthly calendar) can be used to select the day. } \value{ Nothing is returned when a whole year calendar is created. When the month calendar is created a function is returned invisibly that if passed an integer corresponding to a day of the month will set the graphics parameters so the corresponding day in the calendar becomes the current plotting figure. See the examples below. } \author{Greg Snow, \email{538280@gmail.com}} \seealso{ \code{\link{Sys.time}}, \code{\link{as.POSIXlt}}, \code{\link{par}}, \code{\link{updateusr}} } \examples{ cal(2011) cal('May') setday <- cal(11, 2011) setday(3) text(0.5,0.5, 'Some\nCentered\nText') setday(8) text(1,1,'Top Right',adj=c(1,1)) setday(18) text(0,0,'Bottom Left', adj=c(0,0) ) setday(21) tmp.x <- runif(25) tmp.y <- rnorm(25, tmp.x, .1) mrgn.x <- 0.04*diff(range(tmp.x)) mrgn.y <- 0.04*diff(range(tmp.y)) updateusr( 0:1, 0:1, range(tmp.x)+c(-1,1)*mrgn.x, range(tmp.y)+c(-1,1)*mrgn.y) points(tmp.x, tmp.y) setday(30) tmp <- hist(rnorm(100), plot=FALSE) updateusr( 0:1, 0:1, range(tmp$breaks), range(tmp$counts*1.1,0) ) lines(tmp) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{hplot} \keyword{chron}% __ONLY ONE__ keyword per line \keyword{ts} TeachingDemos/man/dice.Rd0000644000175100001440000000534512657235444014773 0ustar hornikusers\name{dice} \alias{dice} \alias{plot.dice} \alias{panel.dice} \alias{prepanel.dice} %- Also NEED an '\alias' for EACH other topic documented here. \title{Simulate rolling dice } \description{ Simulate and optionally plot rolls of dice. } \usage{ dice(rolls = 1, ndice = 2, sides = 6, plot.it = FALSE, load = rep(1, sides)) \method{plot}{dice}(x, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{rolls}{ Scalar, the number of times to roll the dice. } \item{ndice}{ Scalar, the number of dice to roll each time. } \item{sides}{ Scalar, the number of sides per die. } \item{plot.it}{ Logical, Should the results be plotted. } \item{load}{ Vector of length \code{sides}, how the dice should be loaded.} \item{x}{ Data frame, return value from \code{dice}. } \item{\dots}{ Additional arguments passed to lattice plotting function. } } \details{ Simulates the rolling of dice. By default it will roll 2 dice 1 time and the dice will be fair. Internally the \code{sample} function is used and the load option is passed to sample. \code{load} is not required to sum to 1, but the elements will be divided by the sum of all the values. } \value{ A data frame with \code{rolls} rows and \code{ndice} columns representing the results from rolling the dice. If only 1 die is rolled, then the return value will be a vector. If \code{plot.it} is TRUE, then the return value will be invisible. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com}} \note{ If the plot function is used or if \code{plot.it} is TRUE, then a plot will be created on the current graphics device.} \seealso{ \code{\link{sample}} } \examples{ # 10 rolls of 4 fair dice dice(10,4, plot.it=TRUE) # or plot(dice(10,4)) # or tmp <- dice(10,4) plot(tmp) # a loaded die table(tmp <- dice(100,1,plot.it=TRUE, load=6:1 ) ) colMeans(tmp) # Efron's dice ed <- list( rep( c(4,0), c(4,2) ), rep(3,6), rep( c(6,2), c(2,4) ), rep( c(5,1), c(3,3) ) ) tmp <- dice( 10000, ndice=4 ) ed.out <- sapply(1:4, function(i) ed[[i]][ tmp[[i]] ] ) mean(ed.out[,1] > ed.out[,2]) mean(ed.out[,2] > ed.out[,3]) mean(ed.out[,3] > ed.out[,4]) mean(ed.out[,4] > ed.out[,1]) ## redo De Mere's question demere1 <- dice(10000,4) demere2 <- dice(10000,24,sides=36) mean(apply( demere1, 1, function(x) 6 \%in\% x )) mean(apply( demere2, 1, function(x) 36 \%in\% x)) plot(demere1[1:10,]) ## plot all possible combinations of 2 dice plot.dice( expand.grid(1:6,1:6), layout=c(6,6) ) } \keyword{ distribution }% at least one, from doc/KEYWORDS \keyword{ hplot }% __ONLY ONE__ keyword per line \keyword{ datagen }TeachingDemos/man/TeachingDemos-package.Rd0000644000175100001440000001156012657235444020166 0ustar hornikusers\name{TeachingDemos-package} \alias{TeachingDemos-package} \alias{TeachingDemos} \docType{package} \title{ Various functions for demonstration and learning. } \description{ This package provides various demonstrations that can be used in classes or by individuals to better learn statistical concepts and usage of R. Various utility functions are also included} \details{ \tabular{ll}{ Package: \tab TeachingDemos\cr Type: \tab Package\cr Version \tab 2.4\cr Date: \tab 2011-04-10\cr License: \tab Artistic-2.0\cr } Demonstration functions in this package include: \tabular{ll}{ ci.examp, run.ci.examp \tab Confidence Interval Examples \cr clt.examp \tab Central Limit Theorem Example\cr dice, plot.dice \tab Roll and Plot dice (possibly loaded)\cr faces, faces2 \tab Chernoff face plots\cr fagan.plot \tab Fagan plot for screening designs\cr lattice.demo \tab The 3d slicing idea behind lattice/trellis graphics\cr loess.demo \tab Interactive demo to show ideas of loess smooths\cr mle.demo \tab Interactive demo of Maximum Likelihood Estimation\cr plot.rgl.coin, plot.rgl.die \tab Animate flipping a coin or rolling a die\cr power.examp \tab Demonstrate concepts of Power.\cr put.points.demo \tab Add/move points on a plot and see the effect on correlation and regression.\cr roc.demo \tab Interactive demo of ROC curves.\cr rotate.cloud \tab Interactively rotate 3d plots.\cr run.cor.examp \tab Show plots representing different correlations.\cr run.hist.demo \tab Interactively change parameters for histograms.\cr SensSpec.demo \tab Show relationship between Sensitivity, Specificity, Prevalence and PPV and NPV.\cr TkApprox \tab Interactive linear interpolations of data.\cr tkBrush \tab Brush points in a scatterplot matrix.\cr TkSpline \tab Interactive spline interpolations of data.\cr tree.demo \tab Interactively Recursive partition data (create trees).\cr vis.binom \tab Plot various probability distributions and interactively change parameters.\cr vis.boxcox \tab Interactively change lambda for Box Cox Transforms.\cr z.test \tab Z-test similar to t.test for students who have not learned t tests yet.\cr Pvalue.norm.sim \tab \cr Pvalue.binom.sim \tab Simulate P-values to see how they are distributed.\cr run.Pvalue.norm.sim \tab GUI for above. \cr run.Pvalue.binom.sim \tab \cr HWidentify \tab \cr HTKidentify \tab Identify the point Hovered over with the mouse. \cr vis.test \tab test a null hypothesis by comparing graphs. \cr } Utility functions include: \tabular{ll}{ bct \tab Box-Cox Transforms.\cr char2seed \tab set or create the random number seed using a character string\cr clipplot \tab clip a plot to a rectangular region within the plot\cr col2grey \tab convert colors to greyscale\cr cnvrt.coords \tab Convert between the different coordinate systems\cr dynIdentify \tab Scatterplot with point labels that can be dragged to a new position \cr TkIdentify \tab Scatterplot with lables that can be dragged to new positions \cr gp.plot gp.splot \tab send commonds to gnuplot\cr hpd \tab Highest Posterior Density intervals\cr my.symbols \tab Create plots using user defined symbols.\cr panel.my.symbols \tab Create lattice plots using user defined symbols.\cr plot2script \tab Create a script file that recreates the current plot.\cr shadowtext \tab plot text with contrasting shadow for better readability. \cr squishplot \tab Set the margins so that a plot has a specific aspect ratio without large whitespace inside.\cr spread.labs \tab Spread out coordinates so that labels do not overlap.\cr subplot \tab create a plot inside of an existing plot.\cr tkexamp \tab create plots that can have parameters adjusted interactively.\cr triplot \tab Trilinear plot for 3 proportions.\cr txtStart/etxtStart/wdtxtStart \tab Save commands and output to a text file (possibly for post processing with enscript).\cr zoomplot \tab recreate the current plot with different x/y limits (zoom in out).\cr %<% %<=% \tab Transtitive inequalities.\cr } } \author{ Greg Snow \email{538280@gmail.com} } \keyword{package} \keyword{aplot} \keyword{iplot} \keyword{dynamic} \seealso{ The tkrplot package } \examples{ ci.examp() clt.examp() clt.examp(5) plot.dice( expand.grid(1:6,1:6), layout=c(6,6) ) faces(rbind(1:3,5:3,3:5,5:7)) plot(1:10, 1:10) my.symbols( 1:10, 1:10, ms.polygram, n=1:10, inches=0.3 ) x <- seq(1,100) y <- rnorm(100) plot(x,y, type='b', col='blue') clipplot( lines(x,y, type='b', col='red'), ylim=c(par('usr')[3],0)) power.examp() power.examp(n=25) power.examp(alpha=0.1) } TeachingDemos/man/TkApprox.Rd0000644000175100001440000000560112657235444015632 0ustar hornikusers\name{TkApprox} \alias{TkApprox} \title{Plot a set of data in a Tk window and interactively move lines to see predicted y-values corresponding to selected x-values.} \description{ This function plots a dataset in a Tk window then places 3 lines on the plot which show a predicted y value for the given x value. The lines can be clicked on and dragged to new x-values with the predicted y-values automatically updating. A table at the bottom of the graph shows the differences between the pairs of x-values and y-values. } \usage{ TkApprox(x, y, type = "b", snap.to.x = FALSE, digits = 4, cols = c("red", "#009900", "blue"), xlab = deparse(substitute(x)), ylab = deparse(substitute(y)), hscale = 1.5, vscale = 1.5, wait = TRUE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The x-values of the data, should be sorted } \item{y}{ The corresponding y-values of the data } \item{type}{ Type of plot (lines, points, both) passed to \code{plot} } \item{snap.to.x}{If True then the lines will snap to x-values (can be changed with a checkbox in the Tk window) } \item{digits}{Number of significant digits to display (passed to \code{format}) } \item{cols}{Vector of 3 colors, used for the reference lines } \item{xlab}{ Label for x-axis } \item{ylab}{ Label for y-axis } \item{hscale}{ Horizontal Scale of the plot, passed to \code{tkrplot} } \item{vscale}{ Vertical Scale of the plot, passed to \code{tkrplot} } \item{wait}{ Should R wait for the window to be closed } \item{\dots}{ Additional parameters passed to \code{plot}} } \details{ This provides an interactive way to explore predictions from a set of x and y values. Internally the function \code{approxfun} is used to make the predictions. The x-value of the 3 reference lines can be changed by clicking and dragging the line to a new position. The x and y values are shown in the margins of the graph. Below the graph is a table with the differences (absolute value) between the pairs of points. This can be used to find peaks/valleys in trends and to see how they differ from starting points, other peaks/valleys, etc.. } \value{ If \code{wait} is FALSE then an invisible NULL is returned, if \code{wait} is TRUE then an invisible list with the x and y values of the 3 reference lines is returned. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ % % ~Make other sections like Warning with \section{Warning }{....} ~ %} \seealso{\code{\link{approxfun}}, \code{\link{TkSpline}} } \examples{ if(interactive()) { with(ccc, TkApprox(Time2,Elevation)) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{dplot } \keyword{dynamic }% __ONLY ONE__ keyword per line TeachingDemos/man/mysymbols.Rd0000644000175100001440000001747612657235444016135 0ustar hornikusers\name{my.symbols} \alias{my.symbols} \title{Draw Symbols (User Defined) on a Plot} \description{This function draws symbols on a plot. It is similar to the builtin \code{symbols} function with the difference that it plots symbols defined by the user rather than a prespecified set of symbols.} \usage{ my.symbols(x, y=NULL, symb, inches=1, xsize, ysize, add=TRUE, vadj=0.5, hadj=0.5, symb.plots=FALSE, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), main=NULL, xlim=NULL, ylim=NULL, linesfun=lines, ..., MoreArgs) } \arguments{ \item{x, y}{The \code{x} and \code{y} coordinates for the position of the symbols to be plotted. These can be specified in any way which is accepted by \code{xy.coords}.} \item{symb}{Either a matrix, list, or function defining the symbol to be plotted. If it is a matrix or list it needs to be formatted that it can be passed directly to the \code{lines} function. It then defines the shape of the symbol on on a range/domain of -1 to 1. If this is a function it can either return a matrix or list as above (points on the range/domain of -1 to 1), or it can do the plotting itself.} \item{inches}{The size of the square containing the symbol in inches (note: unlike \code{symbols} this cannot be \code{FALSE}). This is ignored if \code{xsize} or \code{ysize} is specified.} \item{xsize}{The width of the bounding box(s) of the symbols in the same units as the \code{x} variable. Computed from \code{ysize} or \code{inches} if not specified. Can be a single value or a vector.} \item{ysize}{The height of the bounding box(s) of the symbols in the same units as the \code{y} variable. Computed from \code{xsize} or \code{inches} if not specified. Can be a single value or a vector.} \item{add}{if 'add' is 'TRUE' then the symbols are added to the existing plot, otherwise a new plot is created.} \item{vadj,hadj}{Numbers between 0 and 1 indicating how 'x' and 'y' specify the location of the symbol. The defaults center the symbol at x,y; 0 means put the bottom/left at x,y; and 1 means put the top/right of the symbol at x,y.} \item{symb.plots}{If \code{symb} is a function that does its own plotting, set this to TRUE, otherwise it should be FALSE.} \item{xlab, ylab, main, xlim, ylim}{If 'add' is 'FALSE' these are passed to the \code{plot} function when setting up the plot.} \item{linesfun}{The function to draw the lines if the function does not do its own drawing. The default is \code{lines} but could be replaced with \code{polygon} to draw filled polygons} \item{...}{Additional arguments will be replicated to the same length as \code{x} then passed to \code{symb} (if \code{symb} is a function) and/or the \code{lines} function (one value per symbol drawn).} \item{MoreArgs}{A list with any additional arguments to be passed to the \code{symb} function (as is, without being replicated/split).} } \details{ The \code{symb} argument can be a 2 column matrix or a list with components 'x' and 'y' that defines points on the interval [-1,1] that will be connected with lines to draw the symbol. If you want a closed polygon then be sure to replicate the 1st point as the last point. If any point contains an NA then the line will not be drawn to or from that point. This can be used to create a symbol with disjoint parts that should not be connected. If \code{symb} is a function then it should include a '...' argument along with any arguments to define the symbol. Any unmatched arguments that end up in the '...' argument will be replicated to the same length as 'x' (using the \code{rep} function) then the values will be passed one at a time to the \code{symb} function. If \code{MoreArgs} is specified, the elements of it will also be passed to \code{symb} without modification. The \code{symb} function can either return a matrix or list with the points that will then be passed to the \code{lines} function (see above). Or the function can call the plotting functions itself (set \code{symb.plots} to TRUE). High level plotting can be done (\code{plot}, \code{hist}, and other functions), or low level plotting functions (\code{lines}, \code{points}, etc) can be used; in this case they should add things to a plot with 'x' and 'y' limits of -1 to 1. The size of the symbols can be specified by using \code{inches} in which case the symbol will be set inside of squares whose sizes are \code{inches} size based on the plotting device. The size can also be set using \code{xsize} and/or \code{ysize} which use the same units as the \code{x} and/or \code{y} variables. If only one is specified then the box will be square. If both are specified and they do not match the aspect ratio of the plot then the bounding box will not be square and the symbol will be distorted. } \value{ This function is run for its side effect of plotting, it returns an invisible NULL. } \author{Greg Snow \email{538280@gmail.com}} \note{Since the '...' argument is passed to both \code{lines} and \code{symb}, the \code{symb} function should have a '...' argument so that it will ignore any additional arguments. Arguments such as 'type' can be passed through the '...' argument if you want the symbol made of something other than lines. Plotting coordinates and sizes are based on the size of the device at the time the function is called. If you resize the device after plotting, all bets are off. Currently missing values in \code{x} or \code{y} are not handled well. It is best if remove all missing values first. } \seealso{\code{\link{symbols}}, \code{\link{subplot}}, \code{\link{mapply}}, \code{\link{ms.polygram}}, \code{\link{lines}}} \examples{ # symb is matrix my.symbols( 1:10, runif(10), ms.male, add=FALSE, xlab='x', ylab='y', inches=0.3, col=c('blue','green'), xlim=c(0,11), ylim=c(-0.1,1.1)) my.symbols( (1:10)+0.5, runif(10), ms.female, add=TRUE, inches=0.3, col=c('red','green') ) # symb is function returning matrix plot(1:10, 1:10) my.symbols( 1:10, 1:10, ms.polygram, n=1:10, inches=0.3 ) # symb is plotting function # create a variation on monthplot fit <- lm( log(co2) ~ time(co2) ) fit.r <- resid(fit) x <- 1:12 y <- tapply(fit.r, cycle(co2), mean) tmp.r <- split( fit.r, cycle(co2) ) tmp.r <- lapply( tmp.r, function(x) x-mean(x) ) yl <- do.call('range',tmp.r) tmpfun <- function(w,data,ylim,...){ tmp <- data[[w]] plot(seq(along=tmp),tmp, type='l', xlab='',ylab='', axes=FALSE, ylim=ylim) lines(par('usr')[1:2], c(0,0), col='grey') } my.symbols(x,y, symb=tmpfun, inches=0.4, add=FALSE, symb.plots=TRUE, xlab='Month',ylab='Adjusted CO2', xlim=c(0.5,12.5), ylim=c(-0.012,0.012), w=1:12, MoreArgs=list(data=tmp.r,ylim=yl) ) # using xsize and ysize plot( 1:10, (1:10)*100, type='n', xlab='', ylab='' ) my.symbols( 5, 500, ms.polygon, n=250, inches=1.5 ) my.symbols( 5, 500, ms.polygon, n=250, xsize=2, col='blue' ) my.symbols( 5, 500, ms.polygon, n=250, ysize=200, col='green' ) my.symbols( 5, 500, ms.polygon, n=250, xsize=2, ysize=200, col='red' ) abline( v=c(4,6), col='grey' ) abline( h=c(400, 600), col='grey' ) # hand crafted hexagonal grid x1 <- seq(0, by=2*sqrt(3), length.out=10) y1 <- seq(0, by=3, length.out=10) mypoints <- expand.grid(x=x1, y=y1) mypoints[,1] <- mypoints[,1] + rep( c(0,sqrt(3)), each=10, length.out=100 ) plot(mypoints, asp=1, xlim=c(-2,35)) my.symbols(mypoints, symb=ms.filled.polygon, n=6, inches=par('pin')[1]/(diff(par('usr')[1:2]))*4, bg=paste('gray',1:100,sep=''), fg='green' ) } \keyword{aplot} \keyword{dplot} \keyword{hplot} TeachingDemos/man/zoomplot.Rd0000644000175100001440000000475012657235444015751 0ustar hornikusers\name{zoomplot} \alias{oldzoomplot} \alias{zoomplot} \title{Zoom or unzoom an existing plot in the plot window} \description{This function allows you to change the x and y ranges of the plot that is currently in the plot window. This has the effect of zooming into a section of the plot, or zooming out (unzooming) to show a larger region than is currently shown.} \usage{ zoomplot(xlim, ylim=NULL ) oldzoomplot(xlim, ylim=NULL ) } \arguments{ \item{xlim, ylim}{The new x and y limits of the plot. These can be passed in in any form understood by \code{xy.coords}. The range of xlim and ylim are actually used so you can pass in more than 2 points.} } \details{ This function recreates the current plot in the graphics window but with different xlim, ylim arguments. This gives the effect of zooming or unzooming the plot. This only works with traditional graphics (not lattice/trellis). This function is a quick hack that should only be used for quick exploring of data. For any serious work you should create a script with the plotting commands and adjust the xlim and ylim parameters to give the plot that you want. Only the x and y ranges are changed, the size of the plotting characters and text will stay the same. The \code{oldzoomplot} function is the version that worked for 2.15 and earlier, \code{zoomplot} should be used for R 3.0. } \value{ This function is run for its side effects and does not return anything meaningful. } \author{Greg Snow \email{538280@gmail.com}} \note{ For any serious projects it is best to put your code into a script to begin with and edit the original script rather than using this function. This function works with the standard \code{plot} function and some others, but may not work for more complicated plots. This function depends on the \code{recordPlot} function which can change in any version. Therefore this function should not be considered stable. } \seealso{\code{\link{plot.default}}, \code{\link{par}}, \code{\link{matplot}}, \code{\link{plot2script}}, \code{\link{source}}} \examples{ if(interactive()){ with(iris, plot(Sepal.Length, Petal.Width, col=c('red','green','blue')[Species])) text( 6.5, 1.5, 'test' ) zoomplot( locator(2) ) # now click on 2 points in the plot to zoom in plot( 1:10, rnorm(10) ) tmp <- rnorm(10,1,3) lines( (1:10) + 0.5, tmp, col='red' ) zoomplot( c(0,11), range(tmp) ) } } \keyword{dplot} \keyword{iplot} TeachingDemos/man/TkBuildDist.Rd0000644000175100001440000000610612657235444016245 0ustar hornikusers\name{TkBuildDist} \alias{TkBuildDist} \alias{TkBuildDist2} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interactively create a probability distribution. } \description{ Build a probability distribution (one option for creating a prior distribution) by clicking or dragging a plot. } \usage{ TkBuildDist(x = seq(min + (max - min)/nbin/2, max - (max - min)/nbin/2, length.out = nbin), min = 0, max = 10, nbin = 10, logspline = TRUE, intervals = FALSE) TkBuildDist2( min=0, max=1, nbin=10, logspline=TRUE) } \arguments{ \item{x}{ A starting set of data points, will default to a sequence of uniform values. } \item{min}{ The minimum value for the histogram } \item{max}{ The maximum value for the histogram } \item{nbin}{ The number of bins for the histogram } \item{logspline}{ Logical, whether to include a logspline curve on the plot and in the output. } \item{intervals}{ Logical, should the logspline fit be based on the interval counts rather than the clicked data points, also should the interval summary be returned. } } \details{ Bothe of these functions will open a Tk window to interact with. The window will show a histogram (the defaults will show a uniform distribution), optionally a logspline fit line will be included as well. Including the logspline will slow things down a bit, so you may want to skip it on slow computers. If you use the \code{TkBuildDist} function then a left click on the histogram will add an additional point to the histogram bar clicked on (the actual x-value where clicked will be saved, returned, and used in the optional logspline unless \code{intervals} is TRUE). Right clicking on the histogram will remove the point closest to where clicked (based only on x), which will usually have the effect of decreasing the clicked bar by 1, but could affect the neigboring bar if you click near the edge or click on a bar that is 0. If you use the \code{TkBuildDist2} function then the individual bars can be adjusted by clicking at the top of a bar and dragging up or down, or clicking at what you want the new height of the bar to be. As the current bar is adjusted the other bars will adjust in the oposite direction proportional to their current heights. The logspline fit assumes the basis for the distribution is the real line, the \code{min} and \code{max} arguments only control the histogram and where values can be changed. } \value{ Both functions return a list with the breaks that were used the logspline fit (if \code{logspline} is TRUE), the x-values clicked on (for \code{TkBuildDist}), and the proportion of the distribution within each interval (for \code{TkBuildDist2} or if \code{intervals} is TRUE). } \author{Greg Snow \email{538280@gmail.com}} \seealso{ The logspline package } \examples{ if(interactive()){ tmp1 <- TkBuildDist() tmp2 <- TkBuildDist2() } } % R documentation directory. \keyword{ iplot } \keyword{ dynamic }% __ONLY ONE__ keyword per line TeachingDemos/man/plot.rgl.coin.Rd0000644000175100001440000000705312657235444016555 0ustar hornikusers\name{rgl.coin} \alias{rgl.coin} \alias{rgl.die} \alias{flip.rgl.coin} \alias{roll.rgl.die} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Animated die roll or coin flip } \description{ Open an rgl window, plot either a representation of a coin or a die then animate the flipping/rolling. } \usage{ rgl.coin(x, col = "black", heads = x[[1]], tails = x[[2]], ...) rgl.die(x=1:6, col.cube = "white", col.pip = "black", sides = x, ...) flip.rgl.coin(side = sample(2, 1), steps = 150) roll.rgl.die(side = sample(6, 1), steps = 250) } \arguments{ \item{x}{ for \code{rgl.coin} a list with information for drawing the faces of the coin, defaults to \code{coin.faces}. For \code{rgl.die} a vector with the number of pips to put on the sides of the die (alternative way of specifying \code{sides}). } \item{col}{ Color of lines on the coin faces. } \item{heads}{ Design to use as "heads" side of coin. } \item{tails}{ Design to use as "tails" side of coin. } \item{col.cube}{ Color of the cube for the die. } \item{col.pip}{ Color of the pips (spots) on the die } \item{sides}{ Vector of length 6 indicating which numbers to show on the die. } \item{side}{ Which side of the coin (1 or 2) or die (1 through 6) should end up face up. } \item{steps}{ The number of steps in each part of the animation, higher values will be smoother and slower, lower values will be faster but more jumpy. } \item{...}{ Currently any additional options are silently ignored. } } \details{ You must use the plot function first to create the coin or die, then use the flip or roll function to start the animation. You can animate multiple times for a single use of the plotting function. You can manually rotate the image as well, see the \code{rgl} package for details. The defaults plot a regular coin and die, but arguments are available to create special casses (2 headed coin, die with 2 6's and no 1, ...). The data list \code{coin.faces} contains information on designs for the faces of the coins in case you want to choose a different design. The default rolling and flipping options ranomly choose which side will be face up following a uniform distribution. You can specify the side yourself, or use the \code{sample} function to do a biased random flip/roll. } \value{ Which side ended up face up (1 or 2 for coin, 1 through 6 for die). This is the internal numbering and does not match a change in the \code{sides} argument. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com}} \note{ The current algorithm for animating the die roll shows all the sides, but I am not satisfied with it. Please suggest improvements. } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{dice}}, \code{\link{plot.dice}}, \code{\link{coin.faces}}, \code{\link{sample}} } \examples{ if(interactive()){ rgl.coin() flip.rgl.coin() flip.rgl.coin(1) flip.rgl.coin(2) rgl.clear() # two-headed coin rgl.coin(tails=coin.faces$qh) rgl.clear() # letters instead of pictures rgl.coin(heads=coin.faces$H, tails=coin.faces$T) # biased flip flip.rgl.coin( sample(2,1, prob=c(0.65, 0.35) ) ) rgl.clear() rgl.die() roll.rgl.die() roll.rgl.die(6) # biased roll roll.rgl.die( sample(6,1, prob=c(1,2,3,3,2,1) ) ) } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ datagen }% __ONLY ONE__ keyword per line \keyword{distribution}TeachingDemos/man/TkPredict.Rd0000644000175100001440000001145112657235444015753 0ustar hornikusers\name{TkPredict} \alias{TkPredict} \alias{Predict.Plot} %- Also NEED an '\alias' for EACH other topic documented here. %- cp slider2.Rd /home/wiwi/pwolf/work/work.rtrevive/install.dir/rwined/man/slider.Rd \title{Plot predicted values from a model against one of the predictors for a given value of the othe predictors} \description{ These functions create a plot of predicted values vs. one of the predictors for given values of the other predictors. TkPredict further creates a Tk gui to allow you to change the values of the other predictors. } \usage{ Predict.Plot(model, pred.var, ..., type='response', add=FALSE, plot.args=list(), n.points=100, ref.val, ref.col='green', ref.lty=1, data) TkPredict(model, data, pred.var, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{model}{A model of class 'lm' or 'glm' (or possibly others) from which to plot predictions.} \item{pred.var}{A character string indicating which predictor variable to put on the x-axis of the plot.} \item{...}{for \code{Predict.Plot} The predictor variables and their values for the predictions. See below for detail.} \item{type}{The type value passed on to the predict function.} \item{add}{Whether to add a line to the existing plot or start a new plot.} \item{plot.args}{A list of additional options passed on to the plotting function.} \item{n.points}{The number of points to use in the approximation of the curve.} \item{ref.val}{A reference value for the \code{pred.var}, a reference line will be drawn at this value to the corresponding predicted value.} \item{ref.col, ref.lty}{The color and line type of the reference line if plotted.} \item{data}{The data frame or environment where the variables that the model was fit to are found. If missing, the model will be examined for an attempt find the needed data.} } \details{ These functions plot the predicted values from a regression model (\code{lm} or \code{glm}) against one of the predictor variables for given values of the other predictors. The values of the other predictors are passed as the \code{...} argument to \code{Predict.Plot} or are set using gui controls in \code{TkPredict} (initial values are the medians). If the variable for the x axis (name put in \code{pred.var}) is not included with the \code{...} variables, then the range will be computed from the \code{data} argument or the data component of the \code{model} argument. If the variable passed as \code{pred.var} is also included in the \code{...} arguments and contains a single value, then this value will be used as the \code{ref.val} argument. If it contains 2 or more values, then the range of these values will be used as the x-limits for the predictions. When running \code{TkPredict} you can click on the "Print Call" button to print out the call of \code{Predict.Plot} that will recreate the same plot. Doing this for different combinations of predictor values and editing the \code{plot.args} and \code{add} arguments will give you a script that will create a static version of the predictions. } \value{ These functions are run for their side effects of creating plots and do not return anything. } \author{Greg Snow, \email{538280@gmail.com}} \seealso{ \code{tkrplot}, \code{\link{tkexamp}}, \code{\link{predict}} } \note{ The GUI currently allows you to select a factor as the x-variable. If you do this it will generate some errors and you will not see the plot, just choose a different variable as the x-variable and the plot will return. } \examples{ library(splines) fit.lm1 <- lm( Sepal.Width ~ ns(Petal.Width,3)*ns(Petal.Length,3)+Species, data=iris) Predict.Plot(fit.lm1, pred.var = "Petal.Width", Petal.Width = 1.22, Petal.Length = 4.3, Species = "versicolor", plot.args = list(ylim=range(iris$Sepal.Width), col='blue'), type = "response") Predict.Plot(fit.lm1, pred.var = "Petal.Width", Petal.Width = 1.22, Petal.Length = 4.3, Species = "virginica", plot.args = list(col='red'), type = "response", add=TRUE) Predict.Plot(fit.lm1, pred.var = "Petal.Width", Petal.Width = 1.22, Petal.Length = 4.4, Species = "virginica", plot.args = list(col='purple'), type = "response", add=TRUE) fit.glm1 <- glm( Species=='virginica' ~ Sepal.Width+Sepal.Length, data=iris, family=binomial) Predict.Plot(fit.glm1, pred.var = "Sepal.Length", Sepal.Width = 1.99, Sepal.Length = 6.34, plot.args = list(ylim=c(0,1), col='blue'), type = "response") Predict.Plot(fit.glm1, pred.var = "Sepal.Length", Sepal.Width = 4.39, Sepal.Length = 6.34, plot.args = list(col='red'), type = "response", add=TRUE) if(interactive()){ TkPredict(fit.lm1) TkPredict(fit.glm1) } } \keyword{dynamic}% at least one, from doc/KEYWORDS \keyword{iplot}% __ONLY ONE__ keyword per line \keyword{regression} TeachingDemos/man/tree.demo.Rd0000644000175100001440000000346012657235444015745 0ustar hornikusers\name{tree.demo} \alias{tree.demo} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interactively demonstrate regression trees } \description{ Interactively recursively partition a dataset to demonstrate regression trees. } \usage{ tree.demo(x, y) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The predictor variable. } \item{y}{ The response variable. } } \details{ This function first creates a scatterplot of \code{x} and \code{y} and shows the residual sum of squares from fitting a horizontal line to the y-values. Clicking anywhere on the graph will show an updated graph where the data is partitioned into 2 groups based on the x-value where you clicked with a horizontal line fit to each group (including showing the updated residual sum of squares). Clicking again will move the partitioning value based on the new click. When you have found a good partitioning (reduces the RSS), right click and choose 'stop' and that partition will become fixed. Now you can click to do a second set of partions (breaking the data into 3 groups). To finish the demo, right click and choose 'stop', then right click again and choose 'stop' again. } \value{ A vector with the x-values of the cut points that you selected (sorted). } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com} } %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ The rpart and tree packages } \examples{ if(interactive()){ data('ethanol', package='lattice') print(with(ethanol, tree.demo(E,NOx))) } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ models }% __ONLY ONE__ keyword per line TeachingDemos/man/bct.Rd0000644000175100001440000000250712657235444014634 0ustar hornikusers\name{bct} \alias{bct} %- Also NEED an '\alias' for EACH other topic documented here. \title{Box-Cox Transforms} \description{ Computes the Box-Cox transform of the data for a given value of lambda. Includes the scaling factor. } \usage{ bct(y, lambda) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{y}{Vector of data to be transformed.} \item{lambda}{Scalar exponent for transform (1 is linear, 0 is log).} } \details{ \code{bct} computes the Box-Cox family of transforms: y = (y\^lambda - 1)/(lambda*gm\^(lambda-1)), where gm is the geometric mean of the y's. returns log(y)*gm when lambda equals 0. } \value{ A vector of the same length as y with the corresponding transformed values. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{vis.boxcox}}, \code{\link{vis.boxcoxu}}, \code{\link[MASS]{boxcox}} in package MASS, other implementations in various packages} \examples{ y <- rlnorm(500, 3, 2) par(mfrow=c(2,2)) qqnorm(y) qqnorm(bct(y,1/2)) qqnorm(bct(y,0)) hist(bct(y,0)) } \keyword{manip}% at least one, from doc/KEYWORDS \keyword{datagen} \keyword{regression} TeachingDemos/man/lattice.demo.Rd0000644000175100001440000000414612657235444016435 0ustar hornikusers\name{lattice.demo} \alias{lattice.demo} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interactively explore the conditioned panels in lattice plots. } \description{ Plot 1 panel from an xyplot, and optionally a 3d graph highligting the shown points, then allow you to interactively set the conditioning set of data to see the effects and help you better understand how xyplot works. } \usage{ lattice.demo(x, y, z, show3d = TRUE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The x variable to plot (numeric). } \item{y}{ The y variable to plot (numeric). } \item{z}{ The variable to condition on (numeric). } \item{show3d}{ Logical, should a 3D cloud be shown as well.} } \details{ This function is intended to for demonstration purposes to help understand what is happening in an \code{xyplot} (lattice). When you run the demo it will create a single panel from a conditioned \code{xyplot} and optionally a 3D cloud with the points included in the panel highlighted. The function then opens a tcl/tk dialog box that allows you to choose which points are included in the panel (based on the conditioning variable). You can choose the center and width of the shingle displayed and the graph will update to show the new selection. The intent for this function is for a teacher to show a class how lattice graphics take slices of a 3d plot and show each slice seperately. Students could then work through some examples on their own to better understand what functions like \code{xyplot} are doing automatically. } \value{ No meaningful return value, this function is run for the side effects. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ } \seealso{\code{xyplot} in lattice package} \examples{ if(interactive()){ require(stats) lattice.demo(quakes$long, quakes$lat, quakes$depth) } } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ dynamic }% __ONLY ONE__ keyword per line TeachingDemos/man/ineq.Rd0000644000175100001440000000423612657235444015021 0ustar hornikusers\name{\%<\%} \Rdversion{1.1} \alias{\%<\%} \alias{\%<=\%} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Less than or Less than and equal operators that can be chained together. } \description{Comparison operators that can be chained together into something like 0 \%<\% x \%<\% 1 instead of 0 < x \&\& x < 1. } \usage{ x \%<\% y x \%<=\% y } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x,y}{Values to compare } } \details{ These functions/operators allow chained inequalities. To specify that you want the values between two values (say 0 and 1) you can use \code{0 \%<\% x \%<\% 1 } rather than \code{ 0 < x \&\& x < 1 }. } \value{ %% ~Describe the value returned %% If it is a LIST, use %% \item{comp1 }{Description of 'comp1'} %% \item{comp2 }{Description of 'comp2'} %% ... A logical vector is returned that can be used for subsetting like \code{<}, but the original values are included as attributes to be used in additional comparisons. } %\references{ %% ~put references to the literature/web site here ~ %} \author{ Greg Snow, \email{538280@gmail.com} } \note{ %% ~~further notes~~ This operator is not fully associative and has different precedence than \code{<} and \code{<=}, so be careful with parentheses. See the examples. } %% ~Make other sections like Warning with \section{Warning }{....} ~ %\seealso{ %% ~~objects to See Also as \code{\link{help}}, ~~~ %} \examples{ x <- -3:3 -2 \%<\% x \%<\% 2 c( -2 \%<\% x \%<\% 2 ) x[ -2 \%<\% x \%<\% 2 ] x[ -2 \%<=\% x \%<=\% 2 ] x <- rnorm(100) y <- rnorm(100) x[ -1 \%<\% x \%<\% 1 ] range( x[ -1 \%<\% x \%<\% 1 ] ) cbind(x,y)[ -1 \%<\% x \%<\% y \%<\% 1, ] cbind(x,y)[ (-1 \%<\% x) \%<\% (y \%<\% 1), ] cbind(x,y)[ ((-1 \%<\% x) \%<\% y) \%<\% 1, ] cbind(x,y)[ -1 \%<\% (x \%<\% (y \%<\% 1)), ] cbind(x,y)[ -1 \%<\% (x \%<\% y) \%<\% 1, ] # oops 3 %<% 1:10 %<% 2*3 # oops 3 %<% 1:10 %<% (2*3) # meant this } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ manip } \keyword{ logic }% __ONLY ONE__ keyword per line TeachingDemos/man/clipplot.Rd0000644000175100001440000000503512657235444015711 0ustar hornikusers\name{clipplot} \alias{clipplot} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Clip plotting to a rectangular region } \description{ Clip plotting to a rectangular region that is a subset of the plotting area } \usage{ clipplot(fun, xlim = par("usr")[1:2], ylim = par("usr")[3:4]) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{fun}{ The function or expression to do the plotting. } \item{xlim}{ A vector of length 2 representing the x-limits to clip plotting to, defaults to the entire width of the plotting region. } \item{ylim}{ A vector of length 2 representing the y-limits to clip the plot to, defaults to the entire height of the plotting region. } } \details{ This function resets the active region for plotting to a rectangle within the plotting area and turns on clipping so that any points, lines, etc. that are outside the rectange are not plotted. A side effect of this function is a call to the \code{box()} command, it is called with a fully transparent color so if your graphics device honors transparency then you will probably see no effect. } \value{ Nothing meaningful is returned } \author{ Greg Snow \email{538280@gmail.com} } \note{ This function abuses some of the intent of what par(plt=...) is supposed to mean. In R2.7.0 and beyond there is a new funcntion \code{clip} with the intended purpose of doing this in a more proper manner (however as of my last test it is not working perfectly either, so \code{clipplot} will remain undepricated for now). It uses some hacks to make sure that the clipping region is set, but it does this by plotting some tranparent boxes, therefore you should not use this on devices where tranparency is not supported (or you may see extra boxes). } \seealso{ \code{\link{par}}, \code{\link{lines}}, \code{clip} in R2.7.0 and later } \examples{ x <- seq(1,100) y <- rnorm(100) plot(x,y, type='b', col='blue') clipplot( lines(x,y, type='b', col='red'), ylim=c(par('usr')[3],0)) attach(iris) tmp <- c('red','green','blue') names(tmp) <- levels(Species) plot(Petal.Width,Petal.Length, col=tmp[Species]) for(s in levels(Species)){ clipplot( abline( lm(Petal.Length~Petal.Width, data=iris, subset=Species==s), col=tmp[s]), xlim=range(Petal.Width[Species==s])) } detach(iris) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ aplot } \keyword{ dplot }% __ONLY ONE__ keyword per line TeachingDemos/man/chisq.detail.Rd0000644000175100001440000000345112657235444016433 0ustar hornikusers\name{chisq.detail} \alias{chisq.detail} %- Also NEED an '\alias' for EACH other topic documented here. \title{Print details of a chi-squared test} \description{ Prints out the details of the computations involved in a chi-squared test on a table. Includes the expected values and the chi-squared contribution of each cell. } \usage{ chisq.detail(tab) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{tab}{Matrix or table to be analyzed} } \details{ This function prints out the input table along with the expected value for each cell under the null hypothesis. It also prints out the chi-squared contribution of each cell in the same pattern as the table. This shows the computations involved and one rule of thumb is to look for these values that are greater than 4 as a post-hoc analysis. } \value{ This function is used primarily for its side effect of printing the results, but does return invisibly a list with the following components: \item{obs}{A matrix of the observed values, same as tab.} \item{expected}{A matrix of the expected values under the null hypothesis.} \item{chi.table}{A matrix of the chi-squared contributions of each cell.} \item{chi2}{The chi-squared test statistic.} } \references{ ~put references to the literature/web site here ~ Moore, bps } \author{Greg Snow, \email{538280@gmail.com}} %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{chisq.test}},\code{\link{loglin}}, \code{\link{xtabs}}, \code{\link{table}}, \code{\link{prop.table}}, \code{CrossTable} from the gmodels package.} \examples{ chisq.detail(HairEyeColor[,,1]) chisq.detail(HairEyeColor[,,2]) } \keyword{htest}% at least one, from doc/KEYWORDS TeachingDemos/man/faces2.Rd0000644000175100001440000000706512657235444015233 0ustar hornikusers\name{faces2} \alias{faces2} \alias{face2.plot} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Chernoff Faces } \description{ Plot Chernoff Faces of the dataset, rows represent subjects/observations, columns represent variables. } \usage{ faces2(mat, which = 1:ncol(mat), labels = rownames(mat), nrows = ceiling(nrow(mat)/ncols), ncols = ceiling(sqrt(nrow(mat))), byrow = TRUE, scale = c("columns", "all", "center", "none"), fill = c(0.5, 0.5, 1, 0.5, 0.5, 0.3, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 1, 0.5), ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{mat}{ Matrix containing the data to plot. } \item{which}{ Which columns correspond to which features (see details). } \item{labels}{ Labels for the individual faces } \item{nrows}{ Number of rows in the graphical layout } \item{ncols}{ Number of columns in the graphical layout } \item{byrow}{ Logical, should the faces be drawn rowwise or columnwise. } \item{scale}{ Character, how should the data be scaled. } \item{fill}{ What value to use for features not assocaiated with a column of data. } \item{\dots}{ Additional arguments passed on to plotting functions. } } \details{ The features are: 1 Width of center 2 Top vs. Bottom width (height of split) 3 Height of Face 4 Width of top half of face 5 Width of bottom half of face 6 Length of Nose 7 Height of Mouth 8 Curvature of Mouth (abs < 9) 9 Width of Mouth 10 Height of Eyes 11 Distance between Eyes (.5-.9) 12 Angle of Eyes/Eyebrows 13 Circle/Ellipse of Eyes 14 Size of Eyes 15 Position Left/Right of Eyeballs/Eyebrows 16 Height of Eyebrows 17 Angle of Eyebrows 18 Width of Eyebrows The face plotting routine needs the data values to be between 0 and 1 (inclusive). The \code{scale} option controls how scaling will be done on \code{mat}: "columns" scales each column to range from 0 to 1, "all" scales the entire dataset to vary from 0 to 1, "center" scales each column so that the mean of the column becomes 0.5 and all other values are between 0 and 1, and "none" does no scaling assuming that the data has already been scaled. } \value{ This function is run for its side effect of plotting and does not return anything. } \references{ Chernoff, H. (1973): The use of faces to represent statistiscal assoziation, JASA, 68, pp 361--368. } \author{ Original code by ; current implementation by Greg Snow \email{538280@gmail.com} } \note{ If you choose to not scale the data and any data values are outside of the 0 to 1 range, then strange things may happen. This function is based on code found on the internet, the good things come from there, any problems are likely due to my (Greg's) tweaking. } \seealso{\code{\link{faces}}} \examples{ faces2(matrix( runif(18*10), nrow=10), main='Random Faces') if(interactive()){ tke2 <- rep( list(list('slider',from=0,to=1,init=0.5,resolution=0.1)), 18) names(tke2) <- c('CenterWidth','TopBottomWidth','FaceHeight','TopWidth', 'BottomWidth','NoseLength','MouthHeight','MouthCurve','MouthWidth', 'EyesHeight','EyesBetween','EyeAngle','EyeShape','EyeSize','EyeballPos', 'EyebrowHeight','EyebrowAngle','EyebrowWidth') tkfun2 <- function(...){ tmpmat <- rbind(Min=0,Adjust=unlist(list(...)),Max=1) faces2(tmpmat, scale='none') } tkexamp( tkfun2, list(tke2), plotloc='left', hscale=2, vscale=2 ) } } \keyword{ hplot }% at least one, from doc/KEYWORDS TeachingDemos/man/slider.Rd0000644000175100001440000002033012657235444015340 0ustar hornikusers\name{slider} \alias{slider} %- Also NEED an '\alias' for EACH other topic documented here. %- cp slider2.Rd /home/wiwi/pwolf/work/work.rtrevive/install.dir/rwined/man/slider.Rd \title{slider / button control widgets} \description{ \code{slider} constructs a Tcl/Tk-widget with sliders and buttons automated calculation and plotting. For example slider allows complete all axes rotation of objects in a plot. } \usage{ slider(sl.functions, sl.names, sl.mins, sl.maxs, sl.deltas, sl.defaults, but.functions, but.names, no, set.no.value, obj.name, obj.value, reset.function, title) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{sl.functions}{set of functions or function connected to the slider(s)} \item{sl.names}{labels of the sliders} \item{sl.mins}{minimum values of the sliders' ranges} \item{sl.maxs}{maximum values of the sliders' ranges} \item{sl.deltas}{change of step per click} \item{sl.defaults}{default values for the sliders} \item{but.functions}{function or list of functions that are assigned to the button(s)} \item{but.names}{labels of the buttons} \item{no}{\code{slider(no=i)} requests slider \code{i}} \item{set.no.value}{\code{slider(set.no.value=c(i,val))} sets slider \code{i} to value \code{val}} \item{obj.name}{\code{slider(obj.name=name)} requests the value of variable \code{name} from environment \code{slider.env}} \item{obj.value}{\code{slider(obj.name=name,obj.value=value)} assigns \code{value} to variable \code{name} in environment \code{slider.env}} \item{reset.function}{function that comprises the commands of the \code{reset.button}} \item{title}{title of the control window} } \details{ With slider you can: a. define (multiple) sliders and buttons, b. request or set slider values, and c. request or set variables in the environment \code{slider.env}. Slider function management takes place in the environment \code{slider.env}. If \code{slider.env} is not found it is generated. Definition: ... of sliders: First of all you have to define sliders, buttons and the attributes of them. Sliders are established by six arguments: \code{sl.functions, sl.names, sl.minima, sl.maxima,sl.deltas}, and \code{sl.defaults}. The first argument, \code{sl.functions}, is either a list of functions or a single function that entails the commands for the sliders. If there are three sliders and slider 2 is moved with the mouse the function stored in \code{sl.functions[[2]]} (or in case of one function for all sliders the function \code{sl.functions}) is called. Definition: ... of buttons: Buttons are defined by a vector of labels \code{but.names} and a list of functions: \code{but.functions}. If button \code{i} is pressed the function stored in \code{but.functions[[i]]} is called. Requesting: ... a slider: \code{slider(no=1)} returns the actual value of slider 1, \code{slider(no=2)} returns the value of slider 2, etc. You are allowed to include expressions of the type \code{slider(no=i)} in functions describing the effect of sliders or buttons. Setting: ... a slider: \code{slider(set.no.value=c(2,333))} sets slider \code{2} to value 333. \code{slider(set.no.value=c(i,value))} can be included in the functions defining the effects of moving sliders or pushing buttons. Variables: ... of the environment \code{slider.env}: Sometimes information has to be trransferred back and forth between functions defining the effects of sliders and buttons. Imagine for example two sliders: one to control \code{p} and another one to control \code{q}, but they should satisfy: \code{p+q=1}. Consequently, you have to correct the value of the first slider after the second one was moved. To prevent the creation of global variables store them in the environment \code{slider.env}. Use \code{slider(obj.name="p.save",obj.value=1-slider(no=2))} to assign value \code{1-slider(no=2)} to the variable \code{p.save} . \code{slider(obj.name=p.save)} returns the value of variable \code{p.save}. } \value{ Using \code{slider} in definition mode \code{slider} returns the value of new created the top level widget. \code{slider(no=i)} returns the actual value of slider \code{i}. \code{slider(obj.name=name)} returns the value of variable \code{name} in environment \code{slider.env}. } \author{Hans Peter Wolf} \note{You can move the slider in 3 different ways: You can left click and drag the slider itself, you can left click in the trough to either side of the slider and the slider will move 1 unit in the direction you clicked, or you can right click in the trough and the slider will jump to the location you clicked at. This function may not stay in this package (consider it semi-depricated), the original of the slider function is in the relax package and can be used from there. In TeachingDemos the \code{\link{tkexamp}} function is taking the place of \code{slider} and gives a possibly more general approach. } \seealso{\code{\link{tkexamp}}, \code{\link{sliderv}}} \examples{ # example 1, sliders only \dontrun{ ## This example cannot be run by examples() but should work in an interactive R session plot.sample.norm<-function(){ refresh.code<-function(...){ mu<-slider(no=1); sd<-slider(no=1); n<-slider(no=3) x<-rnorm(n,mu,sd) plot(x) } slider(refresh.code,sl.names=c("value of mu","value of sd","n number of observations"), sl.mins=c(-10,.01,5),sl.maxs=c(+10,50,100),sl.deltas=c(.01,.01,1),sl.defaults=c(0,1,20)) } plot.sample.norm() } # example 2, sliders and buttons \dontrun{ ## This example cannot be run by examples() but should work in an interactive R session plot.sample.norm.2<-function(){ refresh.code<-function(...){ mu<-slider(no=1); sd<-slider(no=2); n<-slider(no=3) type= slider(obj.name="type") x<-rnorm(n,mu,sd) plot(seq(x),x,ylim=c(-20,20),type=type) } slider(refresh.code,sl.names=c("value of mu","value of sd","n number of observations"), sl.mins=c(-10,.01,5),sl.maxs=c(10,10,100),sl.deltas=c(.01,.01,1),sl.defaults=c(0,1,20), but.functions=list( function(...){slider(obj.name="type",obj.value="l");refresh.code()}, function(...){slider(obj.name="type",obj.value="p");refresh.code()}, function(...){slider(obj.name="type",obj.value="b");refresh.code()} ), but.names=c("lines","points","both")) slider(obj.name="type",obj.value="l") } plot.sample.norm.2() } # example 3, dependent sliders \dontrun{ ## This example cannot be run by examples() but should work in an interactive R session print.of.p.and.q<-function(){ refresh.code<-function(...){ p.old<-slider(obj.name="p.old") p<-slider(no=1); if(abs(p-p.old)>0.001) {slider(set.no.value=c(2,1-p))} q<-slider(no=2); if(abs(q-(1-p))>0.001) {slider(set.no.value=c(1,1-q))} slider(obj.name="p.old",obj.value=p) cat("p=",p,"q=",1-p,"\n") } slider(refresh.code,sl.names=c("value of p","value of q"), sl.mins=c(0,0),sl.maxs=c(1,1),sl.deltas=c(.01,.01),sl.defaults=c(.2,.8)) slider(obj.name="p.old",obj.value=slider(no=1)) } print.of.p.and.q() } # example 4, rotating a surface \dontrun{ ## This example cannot be run by examples() but should work in an interactive R session R.veil.in.the.wind<-function(){ # Mark Hempelmann / Peter Wolf par(bg="blue4", col="white", col.main="white", col.sub="white", font.sub=2, fg="white") # set colors and fonts samp <- function(N,D) N*(1/4+D)/(1/4+D*N) z<-outer(seq(1, 800, by=10), seq(.0025, 0.2, .0025)^2/1.96^2, samp) # create 3d matrix h<-100 z[10:70,20:25]<-z[10:70,20:25]+h; z[65:70,26:45]<-z[65:70,26:45]+h z[64:45,43:48]<-z[64:45,43:48]+h; z[44:39,26:45]<-z[44:39,26:45]+h x<-26:59; y<-11:38; zz<-outer(x,y,"+"); zz<-zz*(650];rz<-25+row(zz)[zz>0]; z[cbind(cz,rz)]<-z[cbind(cz,rz)]+h refresh.code<-function(...){ theta<-slider(no=1); phi<-slider(no=2) persp(x=seq(1,800,by=10),y=seq(.0025,0.2,.0025),z=z,theta=theta,phi=phi, scale=T, shade=.9, box=F, ltheta = 45, lphi = 45, col="aquamarine", border="NA",ticktype="detailed") } slider(refresh.code, c("theta", "phi"), c(0, 0),c(360, 360),c(.2, .2),c(85, 270) ) } R.veil.in.the.wind() } } \keyword{dynamic}% at least one, from doc/KEYWORDS \keyword{iplot}% __ONLY ONE__ keyword per line TeachingDemos/man/plot2script.Rd0000644000175100001440000000506412657235444016352 0ustar hornikusers\name{plot2script} \alias{plot2script} \title{Create a script from the current plot} \description{This function attempts to create a script that will recreate the current plot (in the graphics window). You can then edit any parts of the script that you want changed and rerun to get the modified plot.} \usage{ plot2script(file='clipboard') } \arguments{ \item{file}{The filename (the clipboard by default) for the script to create or append to.} } \details{ This function works with the graphics window and mainly traditional graphics (it may work with lattice or other graphics, but has not really been tested with those). This function creates a script file (or puts it on the clipboard so that you can past into a script window or text editor) that will recreate the current graph in the current graph window. The script consists of very low level functions (calls to \code{plot.window} and \code{axis} rather than letting \code{plot} handle all this). If you want the higher level functions that were actually used, then use the \code{history} or \code{savehistory} commands (this will probably be the better method for most cases). Some of the low level plotting functions use different arguments to the internal version than the user callable version (\code{box} for example), the arguments to these functions may need to be editted before the full script will run correctly. The lengths of command lines between the creation of the script and what can be run in R do not always match, you may need to manually wrap long lines in the script before it will run properly. } \value{ This function is run for its side effects and does not return anything meaningful. } \author{Greg Snow \email{538280@gmail.com}} \note{ For any serious projects it is best to put your code into a script to begin with and edit the original script rather than using this function. This function depends on the \code{recordPlot} function which can change in any version. Therefore this function should not be considered stable. } \seealso{\code{\link{history}}, \code{\link{savehistory}}, \code{\link{recordPlot}}, \code{\link{source}} } \examples{ if(interactive()){ # create a plot plot(runif(10),rnorm(10)) lines( seq(0,1,length=10), rnorm(10,1,3) ) # create the script plot2script() # now paste the script into a script window or text processor. # edit the ranges in plot.window() and change some colors or # other options. Then run the script. } } \keyword{iplot} \keyword{dplot}TeachingDemos/man/Pvalue.sim.Rd0000644000175100001440000000665312657235444016115 0ustar hornikusers\name{Pvalue.norm.sim} \alias{Pvalue.norm.sim} \alias{Pvalue.binom.sim} \alias{run.Pvalue.norm.sim} \alias{run.Pvalue.binom.sim} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Simulate P-values } \description{ Simulate and plot p-values from a normal or binomial based test under various conditions. When all the assumptions are true, the p-values should follow an approximate uniform distribution. These functions show that along with how violating the assumptions changes the distribution of the p-values. } \usage{ Pvalue.norm.sim(n = 50, mu = 0, mu0 = 0, sigma = 1, sigma0 = sigma, test= c("z", "t"), alternative = c("two.sided", "less", "greater", "<>", "!=", "<", ">"), alpha = 0.05, B = 10000) Pvalue.binom.sim(n=100, p=0.5, p0=0.5, test=c('exact','approx'), alternative=c('two.sided', 'less', 'greater', '<>','!=','<','>'), alpha=0.05, B=1000) run.Pvalue.norm.sim() run.Pvalue.binom.sim() } %- maybe also 'usage' for other objects documented here. \arguments{ \item{n}{Sample Size for each simulated dataset} \item{mu}{Simulation mean for samples} \item{mu0}{Hypothesized mean for tests} \item{sigma}{Simulation SD for samples} \item{sigma0}{Hypothesized SD for tests, if blank or missing, use the sample SD in the tests} \item{p}{Simulation proportion for samples} \item{p0}{Hypothesized proportion for tests} \item{test}{Which test to use, "z" or "t" tests for normal, "exact" (binomial) or "approx" (normal approximation) for binomial } \item{alternative}{Direction for alternative hypothesis } \item{alpha}{alpha level for test (optional) } \item{B}{Number of simulated datasets } } \details{ These functions generate \code{B} samples from either a normal or binomial distribution, then compute the P-values for the test of significance on each sample and plot the P-values. The \code{run.Pvalue.norm.sim} and \code{run.Pvalue.binom.sim} functions are GUI wrappers for the other 2 functions allowing you to change the parameters and click on "refresh" to run a new set of simulations. Using \code{NA} for \code{sigma0} will result in the sample standard deviations being used (leave blank in the GUI). When the simulation conditions and the hypothesized values match, the distributions of the p-values will be approximately uniform. Changing the parameter of interest will show the idea of power. Changing the other parameters can show the effects of assumptions not being met. } \value{ The P-values are invisibly returned. } \references{ Murdock, D, Tsai, Y, and Adcock, J (2008) _P-Values are Random Variables_. The American Statistician. (62) 242-245.} \author{Greg Snow, \email{538280@gmail.com}} \note{ Note: the 2-sided p-values for the binomial may not match the results from binom.test and prop.test. The method used here is an approximation for speed. } \seealso{ \code{\link{t.test}}, \code{\link{z.test}}, \code{\link{binom.test}}, \code{\link{prop.test}}, \code{\link{tkexamp}} } \examples{ if(interactive()) { run.Pvalue.norm.sim() run.Pvalue.binom.sim() } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{hplot} \keyword{dynamic}% __ONLY ONE__ keyword per line \keyword{datagen} \keyword{distribution} \keyword{htest}TeachingDemos/man/shadowtext.Rd0000644000175100001440000000415512657235444016257 0ustar hornikusers\name{shadowtext} \Rdversion{1.1} \alias{shadowtext} %- Also NEED an '\alias' for EACH other topic documented here. \title{Add text to a plot with a contrasting background.} \description{ This is similar to the text function, but it also puts a background shadow (outline) behind the text to make it stand out from the background better. } \usage{ shadowtext(x, y = NULL, labels, col = "white", bg = "black", theta = seq(pi/4, 2 * pi, length.out = 8), r = 0.1, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{x-coordinates for the text} \item{y}{y-coordinates for the text} \item{labels}{The text labels to plot} \item{col}{Color of the text} \item{bg}{Color of the background shadow} \item{theta}{Angles for plotting the background} \item{r}{Thickness of the shadow relative to plotting size} \item{\dots}{Additional arguments passed on to \code{text}} } \details{ When adding text to a plot it is possible that the color of the text may make it difficult to see relative to its background. If the text spans different backgrounds then it may not be possible to find a single color to give proper contrast. This function creates a contrasting shadow for the text by first plotting several copies of the text at angles \code{theta} and distance \code{r} in the background color, then plotting the text on top. This gives a shadowing or outlining effect to the text making it easier to read on any background. } \value{ This function is run for its side effects, returns NULL. } %\references{ %% ~put references to the literature/web site here ~ %} \author{Greg Snow, \email{538280@gmail.com}} %\note{ %% ~~further notes~~ %} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{text}} } \examples{ plot(1:10, 1:10, bg='aliceblue') rect(3,3,5,8, col='navy') text(5,6, 'Test 1', col='lightsteelblue') shadowtext(5,4, 'Test 2', col='lightsteelblue') } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ aplot } TeachingDemos/man/coin.faces.Rd0000644000175100001440000000233512657235444016073 0ustar hornikusers\name{coin.faces} \alias{coin.faces} \docType{data} \title{ Designs for coin faces for use with plot.rgl.coin} \description{ This is a list of matricies where each matrix represents a design for drawing lines on the face of a coin. } \usage{data(coin.faces)} \format{ The format is: List of 4 $ qh: num [1:57, 1:2] 0.387 0.443 0.515 0.606 0.666 ... $ qt: num [1:62, 1:2] 0.862 0.873 0.875 0.857 0.797 ... $ H : num [1:28, 1:2] 0.503 0.506 0.548 0.548 0.500 ... $ T : num [1:18, 1:2] 0.506 0.520 0.569 0.626 0.626 ... } \details{ The current options are a capitol "H", a capitol "T", a design representing George Washingtons head traced from the heads of a US quarter, and a design representing an eagle traced from the tails of a US quarter. The tracings here have pretty much exhausted my artistic ability, if you can do better, please do, I will be happy to include it in future versions. It would also be nice to include some designs representing faces of non-US coins, please submit your contributions (the design should fit within a circle inscribed within the unit square). } \examples{ \dontrun{ plot.rgl.coin(heads=coin.faces$H, tails=coin.faces$T) } } \keyword{datasets} TeachingDemos/man/tkexamp.Rd0000644000175100001440000002515012657235444015534 0ustar hornikusers\name{tkexamp} \alias{tkexamp} %- Also NEED an '\alias' for EACH other topic documented here. %- cp slider2.Rd /home/wiwi/pwolf/work/work.rtrevive/install.dir/rwined/man/slider.Rd \title{Create Tk dialog boxes with controls to show examples of changing parameters on a graph.} \description{ This utility will create a Tk window with a graph and controls to change the parameters of the plotting function interactively. } \usage{ tkexamp(FUN, param.list, vscale=1.5, hscale=1.5, wait=FALSE, plotloc='top', an.play=TRUE, print=FALSE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{FUN}{A function call to create the example plot} \item{param.list}{A list of lists with information on the parameters to control and the controls to use. See Details Below} \item{vscale}{Vertical size of plot, passed to \code{tkrplot}} \item{hscale}{Horizontal size of plot, passed to \code{tkrplot}} \item{wait}{Should R wait for the demo to end} \item{plotloc}{Character with "top", "left", or "right" indicating where the plot should be placed relative to the controls} \item{an.play}{Should the scheduling in tcltk2 package be used for animations} \item{print}{Automatically print the result (useful for ggplot2/lattice)} \item{...}{Extra arguments, currently ignored} } \details{ This is a helper function to create interactive demonstrations of the effect of various function arguments on the resulting graph. The \code{FUN} argument should be a function call to create the basic plot (if run stand alone this should create the starting plot). The arguments to be changed should not be included. The \code{param.list} is a nested list of lists that defines which controls to use for which function arguments. Additional levels of nested lists creates groups of controls (see examples below) and if the list is named in the enclosing list, that name will be used to label the group. The lowest level of lists control a single function argument with the control to be used. The name of the list in the enclosing list is the name of the function argument to be used, e.g. \code{"pch=list(...)"} will create a control for the \code{pch} parameter. The first element of the innermost list is a character string specifying which control to use (from the list below), the rest of the elements must be named and specify parameters of the controls. For details on all possible parameters see the tcltk documentation. Any parameter can be set using this list, for example most controls have a \code{width} parameter that can be set with code like \code{width=5}. Most controls also have an \code{init} argument that specifies the initial value that the control will be set to (most have a default in case you don't specify the value). The following are the possible controls you can specify as the first element of the list along with the most common parameters to specify: "numentry", an entry box where a number can be typed in, this will be passed to \code{FUN} wrapped in \code{as.numeric()}. "entry", an entry box where a character string can be typed in (this will be passed to \code{FUN} as a character string, not converted). "slider", a slider (or scale) that can be dragged left and right to choose the different values. The common parameters to specify are "from" (the lowest value), "to" (the largest value), and "resolution" (the increment size when sliding). "vslider", just like slider except that the slider is dragged up and down rather than left and right. "spinbox", an entry widget for a number with small arrows on the right side that can be used to increment/decrement the value, or you can type in a value. The common parameters to set are "from" (smallest value), "to" (largest value), and "increment" (how much to change the value by when clicking on the arrows). You can also set "values" which is a vector of values that can be used. This will be passed to \code{FUN} as a number. "checkbox", a box that can be checked, passed to \code{FUN} as a logical (TRUE if checked, FALSE if not checked). To set the intial value as TRUE (the default is FALSE) use \code{init='T'}. "combobox", an entry widget with an arrow on the right side that will bring up a list of values to choose from. This value is passed to \code{FUN} as a character string. The important parameter to set is "values" which is a vector of character strings to choose between. This option will only work with tcl version 8.5 or later and will probably produce an error in earlier versions. "radiobuttons", a set of choices with check boxes next to each, when one is selected the previous selection is cleared. The important parameter to set is "values" wich is a vector of character strings to choose between. "animate", is a combination of a slider and a button. If the tcltk2 package is avaliable and \code{an.play=TRUE} then the button will say "Play" and pressing the button will automatically increment the slider (and update the graph) until it reaches the maximum value. Otherwise the button will say "Inc" and you must click and hold on the button to run the animation (this might be prefered in that you can stop the animation). Either way you can set the delay option (all other options match with the slider option) and move the slider when the interaction is not happening. The animation starts at the current value on the slider and goes to the maximum value. You should only have at most one animation control (multiple will confuse each other), this includes not having multiple windows operating at the same time with animation controls. Each nesting of lists will also change how the controls are placed (top to bottom vs. left to right). The Tk window will also have a default set of controls at the bottom. These include entry widgets for \code{vscale} and \code{hscale} for changing the size of the graph (initially set by arguments to \code{tkexamp}). A "Refresh" button that will refresh the graph with the new parameter values (some controls like sliders will automatically refresh, but others like entries will not refresh on their own and you will need to click on this button to see the updates). A "Print Call" button that when clicked will print a text string to the R terminal that represents the function call with the current argument settings (copying and pasting this to the command line should recreate the current plot on the current plotting device). And an "Exit" button that will end the demo and close the window. } \value{ If \code{wait} is FALSE then it returns an invisible NULL, if \code{wait} is TRUE then it returns a list with the argument values when the window was closed. } \author{Greg Snow, \email{538280@gmail.com}} \note{You can move the sliders in 3 different ways: You can left click and drag the slider itself, you can left click in the trough to either side of the slider and the slider will move 1 unit in the direction you clicked, or you can right click in the trough and the slider will jump to the location you clicked at. } \seealso{ \code{tkrplot}, the fgui package, the playwith package, and the rpanel package } \examples{ if(interactive()) { x <- sort( runif(25,1,10) ) y <- rnorm(25, x) # some common plotting parameters tke.test1 <- list(Parameters=list( pch=list('spinbox',init=1,from=0,to=255,width=5), cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1), type=list('combobox',init='b', values=c('p','l','b','o','c','h','s','S','n'), width=5), lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5), lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5) )) tkexamp( plot(x,y), tke.test1, plotloc='top' ) # different controls for the parameters tke.test2 <- list(Parameters=list( pch=list('spinbox',init=1,values=c(0:25,32:255),width=5), cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1), type=list('radiobuttons',init='b', values=c('p','l','b','o','c','h','s','S','n'), width=5), lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5), lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5), xpd=list('checkbox') )) tkexamp( plot(x,y), tke.test2, plotloc='left') tmp <- tkexamp( plot(x,y), list(tke.test2), plotloc='right', wait=TRUE ) # now recreate the plot tmp$x <- x tmp$xlab <- 'x' tmp$y <- y tmp$ylab <- 'y' do.call('plot', tmp) # a non plotting example tke.test3 <- list( sens=list('slider', init=0.95, from=0.9, to=1, resolution=0.005), spec=list('slider', init=0.9, from=0.8, to=1, resolution=0.005), prev=list('slider', init=0.01, from=0.0001, to=0.1, resolution=0.0001), step=list('spinbox', init=1, from=1, to=11, width=5), n=list('numentry',init=100000, width=7) ) options(scipen=1) tkexamp( SensSpec.demo(), tke.test3 ) # now increment step and watch the console # Above example but converting it to plot tempfun <- function(sens,spec,prev,step,n) { if(missing(sens) || missing(n)) return(invisible(NULL)) tmp <- capture.output( SensSpec.demo(sens=sens,spec=spec, prev=prev, n=n, step=step) ) par(cex=2.25) plot.new() tmp2 <- strheight(tmp) text(0, 1-cumsum(tmp2*1.5), tmp, family='mono', adj=0) title('Sensitivity and Specificity Example') } tkexamp( tempfun(), tke.test3, hscale=4, vscale=2 ) # an example using trellis graphics tke.test4 <- list( alpha=list('slider', from=0,to=1,init=1, resolution=0.05), cex=list('spinbox',init=.8,from=.1,to=3,increment=.1,width=5), col=list('entry',init='#0080ff'), pch=list('spinbox',init=1, from=0,to=255, increment=1,width=5), fill=list('entry',init='transparent') ) tempfun <- function(x,y,alpha,cex,col,pch,fill) { if(missing(alpha) || missing(cex)) {return()} trellis.par.set(plot.symbol=list(alpha=alpha, cex=cex, col=col, font=1,pch=pch,fill=fill)) print(xyplot( y~x )) } require(lattice) tkexamp( tempfun(x,y), list(tke.test4), plotloc='left') # Two example using ggplot2 if( require(ggplot2) ) { ## 1 tkexamp( qplot(cty,data=mpg, geom='histogram'), list(binwidth=list('slider',from=1,to=25)), print=TRUE) ## 2 tmpfun <- function(bw=2){ print(ggplot(mpg, aes(cty)) + geom_histogram(binwidth = bw)) } tkexamp( tmpfun, list(bw=list('slider',from=1, to=5))) } } } \keyword{dynamic}% at least one, from doc/KEYWORDS \keyword{iplot}% __ONLY ONE__ keyword per line TeachingDemos/man/USCrimes.Rd0000644000175100001440000000746312657235444015564 0ustar hornikusers\name{USCrimes} \alias{USCrimes} \docType{data} \title{ US Crime Statistics } \description{ This is a 3 dimensional Array of the US crime statistics downloaded from the "Uniform Crime Reporting Statistics" of the US government. It comprises the years 1960 through 2010 for all 50 states, Washington DC, and a total for the country. } \usage{data(USCrimes)} \format{ The format is: num [1:52, 1:51, 1:19] 3266740 226167 1302161 1786272 15717204 ... - attr(*, "dimnames")=List of 3 ..$ State: chr [1:52] "Alabama" "Alaska" "Arizona" "Arkansas" ... ..$ : chr [1:51] "1960" "1961" "1962" "1963" ... ..$ : chr [1:19] "Population" "ViolentCrimeRate" "MurderRate" "RapeRate" ... } \details{ The first dimension is the state, the dimnames match the variable \code{state.name} with the exception of including "District of Columbia" in the 9th position (alphabetically) and "United States-Total" in position 45 (alphabetical). The second dimension is the year, ranging from 1960 to 2010. If indexing by year, remember to put the year in quotes. The third dimension is the variable: \describe{ \item{Population:}{Total number of residents} \item{ViolentCrimeRate:}{The total of the violent crimes (Murder, Rape, Robbery, Assault) per 100,000 population} \item{MurderRate:}{The number of Murders and Nonnegligent Manslaughters per 100,000 population} \item{RapeRate:}{Forcible Rapes per 100,000 population} \item{RobberyRate:}{Robberies per 100,000 population} \item{AssaultRate:}{Aggravated Assults per 100,000} \item{PropertyCrimeRate:}{The total of the property crimes (Burglary, Theft, Vehicle Theft) per 100,000 population} \item{BurglaryRate:}{Burglaries per 100,000 population} \item{TheftRate:}{Larceny-Thefts per 100,000 population} \item{VehicleTheftRate:}{Motor Vehicle Thefts per 100,000 population} \item{ViolentCrimeTotal:}{The total of the violent crimes (Murder, Rape, Robbery, Assault} \item{Murder:}{The number of Murders and Nonnegligent Manslaughters} \item{Rape:}{Forcible Rapes} \item{Robbery:}{Robberies} \item{Assault:}{Aggravated Assults} \item{PropertyCrimeTotal:}{The total of the property crimes (Burglary, Theft, Vehicle Theft)} \item{Burglary:}{Burglaries} \item{Theft:}{Larceny-Thefts} \item{VehicleTheft:}{Motor Vehicle Thefts} } } \source{ \url{http://www.ucrdatatool.gov/} } %\references{ %% ~~ possibly secondary sources and usages ~~ %} \examples{ data(USCrimes) ## maybe str(USCrimes) # plot time series/sparkline for each state if(require(maptools)) { data(state.vbm) plot(state.vbm) tmp.x <- state.vbm$center_x tmp.x <- c( tmp.x[1:8], 147, tmp.x[9:43], 83, tmp.x[44:50] ) tmp.y <- state.vbm$center_y tmp.y <- c( tmp.y[1:8], 45, tmp.y[9:43], -18, tmp.y[44:50] ) tmp.r <- range( USCrimes[,,'ViolentCrimeRate'], na.rm=TRUE) for(i in 1:52) { subplot( plot(1960:2010, USCrimes[i,,'ViolentCrimeRate'], ann=FALSE, bty='n', type='l', axes=FALSE), tmp.x[i], tmp.y[i], size=c(0.2,0.2) ) } } ## Gapminder style animation over time if( interactive() ) { x.r <- range( USCrimes[-c(9,45),,'Population'], na.rm=TRUE ) y.r <- range( USCrimes[-c(9,45),,'PropertyCrimeRate'], na.rm=TRUE ) tmpfun <- function(Year=1960, ... ) { y <- as.character(Year) plot( USCrimes[-c(9,45),y,'Population'], USCrimes[-c(9,45),y,'PropertyCrimeRate'], type='n', xlab='log Population', ylab='Property Crime Rate', main=y, xlim=x.r, ylim=y.r, log='x' ) text( USCrimes[-c(9,45),y,'Population'], USCrimes[-c(9,45),y,'PropertyCrimeRate'], state.abb, ... ) } tmp.list <- list( Year=list('animate', from=1960, to=2010, delay=250) ) tmpcol <- c('blue','darkgreen','red','purple')[state.region] tkexamp( tmpfun(col=tmpcol), tmp.list ) } } \keyword{datasets} TeachingDemos/man/dynIdentify.Rd0000644000175100001440000000575612657235444016363 0ustar hornikusers\name{dynIdentify} \alias{dynIdentify} \alias{TkIdentify} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interacively place labels for points in a plot } \description{ These functions create a scatterplot of your points and place labels for the points on them. You can then use the mouse to click and drag the labels to new positions with a line stretching between the point and label. } \usage{ dynIdentify(x, y, labels = seq_along(x), corners = cbind(c(-1, 0, 1, -1, 1, -1, 0, 1), c(1, 1, 1, 0, 0, -1, -1, -1)), ...) TkIdentify(x, y, labels=seq_along(x), hscale=1.75, vscale=1.75, corners = cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) ),...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{x-values to plot } \item{y}{y-values to plot } \item{labels}{Labels for the points, defaults to a sequence of integers } \item{corners}{ 2 column matrix of locations where the line can attach to the label, see below} \item{hscale,vscale}{Scaling passed to tkrplot} \item{\dots}{Additional parameters passed to \code{plot}} } \details{ These functions create a scatterplot of the x and y points with the labels (from the argument above) plotted on top. You can then use the mouse to click and drag the labels to new locations. The Tk version shows the labels being dragged, \code{dynIdentify} does not show the labels being dragged, but the label will jump to the new location as soon as you release the mouse button. The \code{corners} argument is a 2 column matrix that gives the allowable points at which the line from the point can attach to the label (so the line does not cover thelabel). The first column represents the x-coordinates and the 2nd column the y-coordinates. A 1 represents the right/top of the label, A -1 is the left/bottom and a 0 is the center. The default values allow attachments at the 4 corners and the centers of the 4 sides of the rectangle bounding the label. } \value{ A list of lists with the coordinates of the final positions of the labels and the line ends. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow, \email{538280@gmail.com} } \seealso{\code{\link{identify}} } \note{ The \code{dynIdentify} function only works on windows, \code{TkIdentify} should work on any platform with tcltk. } \examples{ if(interactive()) { tmp <- TkIdentify(state.x77[,'Frost'], state.x77[,'Murder'], state.abb) ### now move the labels ### recreate the graph on the current device plot( state.x77[,'Frost'], state.x77[,'Murder'], xlab='Frost', ylab='Frost') text( tmp$labels$x, tmp$labels$y, state.abb ) segments( state.x77[,'Frost'], state.x77[,'Murder'], tmp$lineends$x, tmp$lineends$y ) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ dynamic } \keyword{ aplot }% __ONLY ONE__ keyword per line TeachingDemos/man/cortest.Rd0000644000175100001440000000603612657235444015550 0ustar hornikusers\name{SnowsCorrectlySizedButOtherwiseUselessTestOfAnything} \alias{SnowsCorrectlySizedButOtherwiseUselessTestOfAnything} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Snow's Correctly Sized But Otherwise Useless Test of Anything } \description{ This is a hypothesis test designed to be correctly sized in that the probability of rejecting the null when it is true will be equal to your alpha level. Other than that it is a pretty useless test mainly intended for when people say something like "I just need a p-value". } \usage{ SnowsCorrectlySizedButOtherwiseUselessTestOfAnything(x, data.name = deparse(substitute(x)), alternative = "You Are Lucky", ..., seed) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The data, or nothing, or something equally irrelevant} \item{data.name}{ The name of the data for the output} \item{alternative}{The phrase for the alternate hypothesis in the output} \item{\dots}{ Additional arguments that will be silently ignored (like \code{x}), future versions may mockingly ignore these instead} \item{seed}{ A seed (numeric or character) used to seed the random number generator. Use this or manually set the seed if you want reproducible (but still meaningless) results} } \details{ Some of the advantages/disadvantages of this test include: \itemize{ \item{The probability of a Type I error is alpha} \item{Power can be easily computed (it is alpha)} \item{Power is independent of the sample size} \item{Power is independent of the hypotheses} \item{This test is not affected by missing data (present data either)} \item{This test does not depend on any distributional or independence assumptions} } } \value{ An object of class htest with the following elements: \item{p.value}{The p-value} \item{statistic}{The test statistic (identical to the p-value)} \item{data.name}{The name of the data (if any)} \item{method}{The name of the test} \item{alternative}{a phrase representing the alternative hypothesis} \item{seed}{optionally the seed that was used} } \references{ The author is unlikely to be willing to publish in any "journal" that would be willing to publish this test. fortune(264) } \author{ Greg Snow \email{538280@gmail.com} } \note{ If someone has suggested that you consider this test, they most likely do not intend for you to actually use the test, rather to reconsider your question or the assumptions that you are making or trying to avoid. This test should only be used to illustrate a point and decisions (other than maybe who should pay for lunch) should never be made based on the results of this test. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{runif}} } \examples{ SnowsCorrectlySizedButOtherwiseUselessTestOfAnything(log(rnorm(100))) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ htest } TeachingDemos/man/dots.Rd0000644000175100001440000000275312657235444015040 0ustar hornikusers\name{dots} \alias{dots} \alias{dots2} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Create a quick dotchart (histogram)} \description{ Create a quick dotchart of 1 or 2 datasets. These dotcharts are a poor man's histogram, not the trellis dotplot. } \usage{ dots(x,...) dots2(x, y, colx = "green", coly = "blue", lab1 = deparse(substitute(x)), lab2 = deparse(substitute(y)),...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Vector, data to be plotted (should be rounded). } \item{y}{ Vector, second dataset to be plotted. } \item{colx}{ Color of points for \code{x}. } \item{coly}{ Color of points for \code{y}. } \item{lab1}{ Label for \code{x}.} \item{lab2}{ Label for \code{y}.} \item{\ldots}{ Additional arguments passed to plotting functions. } } \details{ These functions create basic dotcharts that are quick "back of the envelope" approximations to histograms. Mainly intended for demonstration. } \value{ No meaninful value. These functions are run for the side effect of creating a plot. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com } } %\note{ ~~further notes~~ } \seealso{ \code{\link{dotplot}} in the lattice package, \code{\link{hist}} } \examples{ dots( round( rnorm(50, 10,3) ) ) dots2( round( rnorm(20, 10,3) ), round(rnorm(20,12,2)) ) } \keyword{ hplot }% at least one, from doc/KEYWORDS TeachingDemos/man/steps.Rd0000644000175100001440000001452512657235444015225 0ustar hornikusers\name{steps} \alias{steps} \docType{data} \title{ Steps data } \description{ This is the export from a pedometer worn for nearly about 11 months by the package author. } \usage{data(steps)} \format{ A data frame with 331 observations on the following 79 variables. \describe{ \item{\code{Date}}{The Date for the given data} \item{\code{Total.Steps}}{Total Steps recorded for the day} \item{\code{Aerobic.Steps}}{Total Aerobic Steps recorded for the day (see below)} \item{\code{Aerobic.Walking.Time}}{Time spent in aerobic walking for the day} \item{\code{Calories}}{Estimated calories burned for the day} \item{\code{Distance}}{Estimated distance walked for the day in miles} \item{\code{Fat.Burned}}{Estimated grams of fat burned by walking} \item{\code{Steps.12AM}}{Steps recorded between Midnight and 1 am} \item{\code{Steps.1AM}}{Steps recorded between 1 am and 2 am} \item{\code{Steps.2AM}}{Steps recorded between 2 am and 3 am} \item{\code{Steps.3AM}}{Steps recorded between 3 am and 4 am} \item{\code{Steps.4AM}}{Steps recorded between 4 am and 5 am} \item{\code{Steps.5AM}}{Steps recorded between 5 am and 6 am} \item{\code{Steps.6AM}}{Steps recorded between 6 am and 7 am} \item{\code{Steps.7AM}}{Steps recorded between 7 am and 8 am} \item{\code{Steps.8AM}}{Steps recorded between 8 am and 9 am} \item{\code{Steps.9AM}}{Steps recorded between 9 am and 10 am} \item{\code{Steps.10AM}}{Steps recorded between 10 am and 11 am} \item{\code{Steps.11AM}}{Steps recorded between 11 am and Noon} \item{\code{Steps.12PM}}{Steps recorded between Noon and 1 pm} \item{\code{Steps.1PM}}{Steps recorded between 1 pm and 2 pm} \item{\code{Steps.2PM}}{Steps recorded between 2 pm and 3 pm} \item{\code{Steps.3PM}}{Steps recorded between 3 pm and 4 pm} \item{\code{Steps.4PM}}{Steps recorded between 4 pm and 5 pm} \item{\code{Steps.5PM}}{Steps recorded between 5 pm and 6 pm} \item{\code{Steps.6PM}}{Steps recorded between 6 pm and 7 pm} \item{\code{Steps.7PM}}{Steps recorded between 7 pm and 8 pm} \item{\code{Steps.8PM}}{Steps recorded between 8 pm and 9 pm} \item{\code{Steps.9PM}}{Steps recorded between 9 pm and 10 pm} \item{\code{Steps.10PM}}{Steps recorded between 10 pm and 11 pm} \item{\code{Steps.11PM}}{Steps recorded between 11 pm and Midnight} \item{\code{Aerobic.Steps.12AM}}{Aerobic steps recorded between Midnight and 1 am} \item{\code{Aerobic.Steps.1AM}}{Aerobic steps recorded between 1 am and 2 am} \item{\code{Aerobic.Steps.2AM}}{Aerobic steps recorded between 2 am and 3 am} \item{\code{Aerobic.Steps.3AM}}{Aerobic steps recorded between 3 am and 4 am} \item{\code{Aerobic.Steps.4AM}}{Aerobic steps recorded between 4 am and 5 am} \item{\code{Aerobic.Steps.5AM}}{Aerobic steps recorded between 5 am and 6 am} \item{\code{Aerobic.Steps.6AM}}{Aerobic steps recorded between 6 am and 7 am} \item{\code{Aerobic.Steps.7AM}}{Aerobic steps recorded between 7 am and 8 am} \item{\code{Aerobic.Steps.8AM}}{Aerobic steps recorded between 8 am and 9 am} \item{\code{Aerobic.Steps.9AM}}{Aerobic steps recorded between 9 am and 10 am} \item{\code{Aerobic.Steps.10AM}}{Aerobic steps recorded between 10 am and 11 am} \item{\code{Aerobic.Steps.11AM}}{Aerobic steps recorded between 11 am and Noon} \item{\code{Aerobic.Steps.12PM}}{Aerobic steps recorded between Noon and 1 pm} \item{\code{Aerobic.Steps.1PM}}{Aerobic steps recorded between 1 pm and 2 pm} \item{\code{Aerobic.Steps.2PM}}{Aerobic steps recorded between 2 pm and 3 pm} \item{\code{Aerobic.Steps.3PM}}{Aerobic steps recorded between 3 pm and 4 pm} \item{\code{Aerobic.Steps.4PM}}{Aerobic steps recorded between 4 pm and 5 pm} \item{\code{Aerobic.Steps.5PM}}{Aerobic steps recorded between 5 pm and 6 pm} \item{\code{Aerobic.Steps.6PM}}{Aerobic steps recorded between 6 pm and 7 pm} \item{\code{Aerobic.Steps.7PM}}{Aerobic steps recorded between 7 pm and 8 pm} \item{\code{Aerobic.Steps.8PM}}{Aerobic steps recorded between 8 pm and 9 pm} \item{\code{Aerobic.Steps.9PM}}{Aerobic steps recorded between 9 pm and 10 pm} \item{\code{Aerobic.Steps.10PM}}{Aerobic steps recorded between 10 pm and 11 pm} \item{\code{Aerobic.Steps.11PM}}{Aerobic steps recorded between 11 pm and Midnight} \item{\code{Used.12AM}}{Any movement detected between Midnight and 1 am} \item{\code{Used.1AM}}{Any movement detected between 1 am and 2 am} \item{\code{Used.2AM}}{Any movement detected between 2 am and 3 am} \item{\code{Used.3AM}}{Any movement detected between 3 am and 4 am} \item{\code{Used.4AM}}{Any movement detected between 4 am and 5 am} \item{\code{Used.5AM}}{Any movement detected between 5 am and 6 am} \item{\code{Used.6AM}}{Any movement detected between 6 am and 7 am} \item{\code{Used.7AM}}{Any movement detected between 7 am and 8 am} \item{\code{Used.8AM}}{Any movement detected between 8 am and 9 am} \item{\code{Used.9AM}}{Any movement detected between 9 am and 10 am} \item{\code{Used.10AM}}{Any movement detected between 10 am and 11 am} \item{\code{Used.11AM}}{Any movement detected between 11 am and Noon} \item{\code{Used.12PM}}{Any movement detected between Noon and 1 pm} \item{\code{Used.1PM}}{Any movement detected between 1 pm and 2 pm} \item{\code{Used.2PM}}{Any movement detected between 2 pm and 3 pm} \item{\code{Used.3PM}}{Any movement detected between 3 pm and 4 pm} \item{\code{Used.4PM}}{Any movement detected between 4 pm and 5 pm} \item{\code{Used.5PM}}{Any movement detected between 5 pm and 6 pm} \item{\code{Used.6PM}}{Any movement detected between 6 pm and 7 pm} \item{\code{Used.7PM}}{Any movement detected between 7 pm and 8 pm} \item{\code{Used.8PM}}{Any movement detected between 8 pm and 9 pm} \item{\code{Used.9PM}}{Any movement detected between 9 pm and 10 pm} \item{\code{Used.10PM}}{Any movement detected between 10 pm and 11 pm} \item{\code{Used.11PM}}{Any movement detected between 11 pm and Midnight} } } \examples{ data(steps) ## maybe str(steps) ; plot(steps) ... } \keyword{datasets} TeachingDemos/man/clt.examp.Rd0000644000175100001440000000504612657235444015760 0ustar hornikusers\name{clt.examp} \alias{clt.examp} %- Also NEED an '\alias' for EACH other topic documented here. \title{Plot Examples of the Central Limit Theorem} \description{ Takes samples of size \code{n} from 4 different distributions and plots histograms of the means along with a normal curve with matching mean and standard deviation. Creating the plots for different values of \code{n} demonstrates the Central Limit Theorem. } \usage{ clt.examp(n = 1, reps = 10000, nclass = 16, norm.param=list(mean=0,sd=1), gamma.param=list(shape=1, rate=1/3), unif.param=list(min=0,max=1), beta.param=list(shape1=0.35, shape2=0.25)) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{n}{size of the individual samples} \item{reps}{number of samples to take from each distribution} \item{nclass}{number of bars in the histograms} \item{norm.param}{List with parameters passed to \code{rnorm}} \item{gamma.param}{List with parameters passed to \code{rgamma}} \item{unif.param}{List with parameters passed to \code{runif}} \item{beta.param}{List with parameters passed to \code{rbeta}} } \details{ The 4 distributions sampled from are a Normal with defaults mean 0 and standard deviation 1, a gamma with defaults shape 1 (exponential) and lambda 1/3 (mean = 3), a uniform distribution from 0 to 1 (default), and a beta distribution with default alpha 0.35 and beta 0.25 (U shaped left skewed). The \code{norm.param}, \code{gamma.param}, \code{unif.param}, and \code{beta.param} arguments can be used to change the parameters of the generating distributions. Running the function with \code{n}=1 will show the populations. Run the function again with \code{n} at higher values to show that the sampling distribution of the uniform quickly becomes normal and the exponential and beta distributions eventually become normal (but much slower than the uniform). } \value{ This function is run for its side effect of creating plots. It returns NULL invisibly. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{rnorm}}, \code{\link{rexp}}, \code{\link{runif}}, \code{\link{rbeta}} } \examples{ clt.examp() clt.examp(5) clt.examp(30) clt.examp(50) } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ distribution }% __ONLY ONE__ keyword per line \keyword{ univar }TeachingDemos/man/tkBrush.Rd0000644000175100001440000000762112657235444015510 0ustar hornikusers\name{tkBrush} \alias{tkBrush} \title{Change the Color and Styles of points interactively} \description{Creates a Tk window with a scatterplot matrix, then allows you to "brush" the points to change their color and/or style.} \usage{ tkBrush(mat,hscale=1.75,vscale=1.75,wait=TRUE,...) } \arguments{ \item{mat}{A matrix of the data to plot, columns are variables, rows are observations, same as \code{pairs}} \item{hscale}{Passed to \code{tkrplot}} \item{vscale}{Passed to \code{tkrplot}} \item{wait}{Should the function wait for you to finish, see below} \item{...}{Additional arguments passed to the panel functions} } \details{ This function creates a Tk window with a pairs plot of \code{mat}, then allows you to interactively move a rectangle (the brush) over the points to change their color and plotting character. The arrow keys can be used to change the size and shape of the brush. The left arrow makes the rectangle wider, the right makes it narrower. The up arrow key makes it taller, the right makes it shorter. When the mouse button is not pressed the points inside the brush will change while in the brush, but return to their previous state when the brush moves off them. If the mouse button is pressed then the points inside the brush will be changed and the change will remain until a different set of conditions is brushed on them. The style of the brushed points is determined by the values of the 2 entry boxes on the right side of the plot. You can specify the plotting character in the \code{pch} box, this can be anything that you would regularly pass to the \code{pch} argument of \code{points}, e.g. an integer or single character. You can specify the color of the brushed points using the \code{color} entry box, specify the name of any color recognized by R (see \code{colors}), if this box does not contain a legal color name then black will be used. If \code{wait} is FALSE then the Tk window will exist independently of R and you can continue to do other things in the R window, in this case the function returns NULL. If \code{wait} is TRUE then R waits for you to close the Tk window (using the quit button) then returns a list with the colors and plotting characters resulting from your brushing, this information can be used to recreate the plot using \code{pairs} on a new graphics device (for printing or saving). } \value{ Either NULL (if Wait=FALSE) or a list with components \code{col} and \code{pch} corresponding to the state of the points. } \author{ Greg Snow \email{538280@gmail.com}} \seealso{\code{\link{pairs}},\code{colors},\code{\link{points}}, the \code{iplots} package} \examples{ if(interactive()){ # Iris dataset out1 <- tkBrush(iris) # Now brush the points pairs(iris, col=out1$col, pch=out1$pch) # or colhist <- function(x,...){ tmp <- hist(x,plot=F) br <- tmp$breaks w <- as.numeric(cut(x,br,include.lowest=TRUE)) sy <- unlist(lapply(tmp$counts,function(x)seq(length=x))) my <- max(sy) sy <- sy/my my <- 1/my sy <- sy[order(order(x))] tmp.usr <- par('usr'); on.exit(par(usr=tmp.usr)) par(usr=c(tmp.usr[1:2],0,1.5)) rect(br[w], sy-my, br[w+1], sy, col=out1$col, # note out1$col is hardcoded here. border=NA) rect(br[-length(br)], 0, br[-1], tmp$counts*my) } pairs(iris, col=out1$col, pch=out1$pch, diag.panel=colhist) # some spheres s1 <- matrix(nrow=0,ncol=3) while( nrow(s1) < 1000 ){ tmp <- rnorm(3) if( sum(tmp^2) <= 1 ){ s1 <- rbind(s1,tmp) } } s2 <- matrix(rnorm(3000), ncol=3) s2 <- s2/apply(s2,1,function(x) sqrt(sum(x^2))) tkBrush(s1, wait=FALSE) tkBrush(s2, wait=FALSE) # now paint values where var 2 is close to 0 in both plots # and compare the var 1 and var 3 relationship } } \keyword{ hplot } \keyword{ iplot } \keyword{ dynamic }TeachingDemos/man/loess.demo.Rd0000644000175100001440000000622312657235444016133 0ustar hornikusers\name{loess.demo} \alias{loess.demo} \title{ Demonstrate the internals of loess curve fits } \description{ Creates a scatterplot with a loess fit, then interactively shows the window and case weights used to create the curve at the selected value of \code{x}. } \usage{ loess.demo(x, y, span = 2/3, degree = 1, nearest = FALSE, xlim = numeric(0), ylim = numeric(0), verbose = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The \code{x} coordinates to be plotted. } \item{y}{ The \code{y} coordinates to be plotted. } \item{span}{ The relative width of the window, passed on to \code{loess}. } \item{degree}{ Degree of polynomial to use (0, 1, or 2), passed on to \code{loess}. } \item{nearest}{ Logical, should predictions be made at the point where you clicked (FALSE), or at the nearest x value of the data to where you clicked (TRUE).} \item{xlim}{ Limits of the Horizonal axis. } \item{ylim}{ Limits of the Vertical axis. } \item{verbose}{ If true then print the x coordinate being predicted. } } \details{ This function demonstrates the underlying calculations of loess curves. Given \code{x} and \code{y} vectors it will create a scatterplot and add 2 loess fit lines (one using straight loess smooth with linear interpolation and one that does a spline interpolation of the loess fit). The function then waits for the user to click on the plot. The function then shows the window of points (centered at the \code{x} value clicked on) used in the weighting for predicting that point and shows a circle around each point in the window where the area of the circle is proportional to the weight of that point in the linear fit. The function also shows the linear (or quadratic) fit used to predict at the selected point. The basic steps of the loess algorithm (as demonstrated by the function) is that to predict the y-value for a given x-value the computer: 1. Find all the points within a window around the x-value (the width of the window is based on the parameter \code{span}). 2. Weight the points in the window with points nearest the x-value having the highest weight. 3. Fit a weighted linear (quadratic) line to the points in the window. 4. Use the y-value of the fitted line (curve) at the x-value to give loess prediction at that x-value. Clicking on another point in the graph will replot with the new situation. Right click and select 'stop' to end the demonstration. } \value{ This function does not return anything, it is run purely for its side effects. } \author{ Greg Snow \email{538280@gmail.com}} \seealso{ \code{\link{loess}}, \code{\link{locator}} } \examples{ if(interactive()){ data(ethanol, package='lattice') attach(ethanol) loess.demo(E, NOx) # now click a few places, right click to end loess.demo(E, NOx, span=1.5) loess.demo(E, NOx, span=0.25) loess.demo(E, NOx, degree=0) loess.demo(E, NOx, degree=2) detach() } } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ dynamic }% __ONLY ONE__ keyword per line \keyword{ iplot }TeachingDemos/man/run.hist.demo.Rd0000644000175100001440000000212112657235444016551 0ustar hornikusers\name{run.hist.demo} \alias{run.hist.demo} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Create a histogram and interactively change the number of bars. } \description{ Create a histogram then use a Tk slider window to change the number of bars, the minimum, and the maximum. } \usage{ run.hist.demo(x) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Data to plot. } } \details{ Draws a histogram and creates a Tk slider window that allows you to explore how changing the parameters affects the appearance of the plot. } \value{ No meaninful value is returned. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com} } %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{hist}}, \code{\link{slider}} } \examples{ if(interactive()){ run.hist.demo( rnorm(250, 100, 5) ) } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ hplot }% __ONLY ONE__ keyword per line TeachingDemos/man/rgl.Map.Rd0000644000175100001440000000323412657235444015362 0ustar hornikusers\name{rgl.Map} \alias{rgl.Map} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plot a map in an rgl window } \description{ Plots a map (from a Map object from package maptools) on a unit sphere in an rgl window that can then be interactively rotated. } \usage{ rgl.Map(Map, which, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{Map}{ A \code{Map} object } \item{which}{ Vector indicating the subset of polygons to plot. } \item{\dots}{ Additional arguments passed on to \code{rgl.lines}. } } \details{ This assumes that the map is cordinates in degrees and plots the map on a unit sphere in an rgl window making a globe. You can then rotate the globe by clicking and dragging in the window. } \value{ There is no return value, this function is run for its side effect. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com}} \note{ This function is still beta level software (some extra lines show up). This needs to be updated to use the new spatial objects, you can use it as an idea, but probably won't work directly.} % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{rgl} in package rgl, \code{plot.Map} in package maptools } \examples{ if(interactive()){ # assumes that the time zone shape files have been downloaded # from: http://openmap.bbn.com/data/shape/timezone/ tz <- maptools:::read.shape('WRLDTZA') rgl.Map(tz) rgl.spheres(0,0,0,.999, col='darkblue') } } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ dynamic }% __ONLY ONE__ keyword per line TeachingDemos/man/ci.examp.Rd0000644000175100001440000000622112657235444015565 0ustar hornikusers\name{ci.examp} \alias{ci.examp} \alias{run.ci.examp} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plot examples of Confidence Intervals } \description{ Generate \code{reps} samples from a normal distribution then compute and plot confidence intervals for each sample along with information about the population to demonstrate confidence intervals. Optionally change the confidence level using a Tk slider. } \usage{ ci.examp(mean.sim = 100, sd = 10, n = 25, reps = 50, conf.level = 0.95, method = "z", lower.conf = (1 - conf.level)/2, upper.conf = 1 - (1 - conf.level)/2) run.ci.examp(reps = 100, seed, method="z", n=25) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{mean.sim}{ The mean of the population. } \item{sd}{ The standard deviation of the population. } \item{n}{ The sample size for each sample. } \item{reps}{ The number of samples/intervals to create. } \item{conf.level}{ The confidence level of the intervals. } \item{method}{ 'z', 't', or 'both', should the intervals be based on the normal, the t, or both distributions. } \item{lower.conf}{ Quantile for lower confidence bound. } \item{upper.conf}{ Quantile for upper confidence bound. } \item{seed}{ The seed to use for the random number generation. } } \details{ These functions demonstrate the concept of confidence intervals by taking multiple samples from a known normal distribution and calculating a confidence interval for each sample and plotting the interval relative to the true mean. Intervals that contain the true mean will be plotted in black and those that do not include the true mean will be plotted in different colors. The \code{method} argument determines the type of interval: 'z' will use the normal distribution and the known population standard deviation, 't' will use the t distribution and the sample standard deviations, 'both' will compute both for each sample for easy comparison (it is best to reduce \code{reps} to about 25 when using 'both'). The optional arguments \code{lower.conf} and \code{upper.conf} can be used to plot non-symmetric or 1 sided confidence intervals. The function \code{run.ci.examp} also creates a Tk slider that will allow you to interactively change the confidence level and replot the intervals to show how the interval widths change with the confidence level. } \value{ These functions are run solely for the side effect of plotting the intervals, there is no meaningfull return value. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com} } %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{z.test}}, \code{\link{t.test}} } \examples{ ci.examp() if(interactive()) { run.ci.examp() } # 1 sided confidence intervals ci.examp(lower.conf=0, upper.conf=0.95) # non-symmetric intervals ci.examp(lower.conf=0.02, upper.conf=0.97) } \keyword{hplot}% at least one, from doc/KEYWORDS \keyword{dynamic}% __ONLY ONE__ keyword per line \keyword{univar} TeachingDemos/man/evap.Rd0000644000175100001440000000354412657235444015021 0ustar hornikusers\name{evap} \Rdversion{1.1} \alias{evap} \docType{data} \title{ Data on soil evaporation. } \description{ Data from 46 consecutive days on weather variables used to estimate amount of evaporation from the soil. } \usage{data(evap)} \format{ A data frame with 46 observations on the following 14 variables. \describe{ \item{\code{Obs}}{Observation number} \item{\code{Month}}{Month (6-June, 7-July)} \item{\code{day}}{Day of the month} \item{\code{MaxST}}{Maximum Soil Temperature} \item{\code{MinST}}{Minimum Soil Temperature} \item{\code{AvST}}{Average (integrated) Soil Temperature} \item{\code{MaxAT}}{Maximum Air Temperature} \item{\code{MinAT}}{Minimum Air Temperature} \item{\code{AvAT}}{Average (integrated) Air Temperature} \item{\code{MaxH}}{Maximum Relative Humidity} \item{\code{MinH}}{Minimum Relative Humidity} \item{\code{AvH}}{Average (integrated) Relative Humidity} \item{\code{Wind}}{Total Wind} \item{\code{Evap}}{Total evoporation from the soil} } } \details{ The idea of the data is to predict the amount of evaporation given the other variables. Note that the "average" values are scaled differently from the others, this is more an area under the curve measure representing the total/average value. This dataset was entered by hand from a low quality copy of the paper. If you find any typos, please e-mail them to the package maintainer. } \source{ Freund, R.J. (1979) Multicollinearity etc., Some "New" Examples. Proceedings of the Statistical Computing Section, *4*, 111-112. %% ~~ reference to a publication or URL from which the data were obtained ~~ } %\references{ %% ~~ possibly secondary sources and usages ~~ %} \examples{ data(evap) pairs(evap[,-c(1,2,3)], panel=panel.smooth) ## maybe str(evap) ; plot(evap) ... } \keyword{datasets} TeachingDemos/man/digits.Rd0000644000175100001440000000370612657235444015351 0ustar hornikusers\name{digits} \alias{digits} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Return the digits that make up an integer } \description{ Takes an integer or vector of integers and returns a vector, list, or matrix of the individual digits (decimal) that make up that number. } \usage{ digits(x, n = NULL, simplify = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ An integer or vector of integers (if not integer, the fractional part will be ignored) } \item{n}{ The number of digits to be returned, this can be used to place 0's in front of smaller numbers. If this is less than the number of digits then the last \code{n} digits are returned. } \item{simplify}{ Should \code{sapply} simplify the list into a matrix } } \details{ This function transforms an integer (or real ignoring the fractional part) into the decimal digits that make of the decimal representation of the number using modular mathematics rather than converting to character, splitting the string, and converting back to numeric. } \value{ If \code{x} is of length 1 then a vector of the digits is returned. If \code{x} is a vector and \code{simplify} is \code{FALSE} then a list of vectors is returned, one element for each element of \code{x}. If \code{x} is a vector and \code{simplify} is \code{TRUE} then a matrix with 1 column for each element of \code{x}. } \author{ Greg Snow \email{538280@gmail.com} } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{\%\%}}, \code{\link{\%/\%}}, \code{\link{strsplit}} } \examples{ digits( 12345 ) digits( 567, n=5 ) x <- c(1, 23, 456, 7890) digits(x) digits(x, simplify=TRUE) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ manip } \keyword{ arith }% __ONLY ONE__ keyword per line TeachingDemos/man/squishplot.Rd0000644000175100001440000000467612657235444016310 0ustar hornikusers\name{squishplot} \alias{squishplot} %- Also NEED an '\alias' for EACH other topic documented here. \title{Squish the plotting area to a specified aspect ratio } \description{ Adjusts the plotting area to a specific aspect ratio. This is different from using the \code{asp} argument in that it puts the extra space in the margins rather than inside the plotting region. } \usage{ squishplot(xlim, ylim, asp = 1, newplot=TRUE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{xlim}{ The x limits of the plot, or the entire x vector.} \item{ylim}{ The y limits of the plot, or the entire y vector.} \item{asp}{ The y/x aspect ratio.} \item{newplot}{ Should plot.new() be called before making the calculations.} } \details{ This function sets the plot area of the current graph device so that the following plot command will plot with the specified aspect ratio. This is different from using the \code{asp} argument to \code{plot.default} in where the created white space goes (see the example). Using \code{plot.default} will place the whitespace within the plotting region and can result in the axes and annotations being quite far from the actual data. This command sets up the plotting region so that the extra whitespace is in the margin areas and moves the axes and annotations close to the data. Any other desired parameter settings or resizing of the graphics device should be set before calling \code{squishplot}, especially settings dealing with multiple figures or margin areas. After plotting, the parameters need to be reset or later plots may come out wrong. } \value{ Invisible list containing the '\code{plt}' values from \code{par} that were in place before the call to \code{squishplot} that can be used to reset the graphical parameters after plotting is finished. } \author{ Greg Snow \email{538280@gmail.com} } \note{ Remember to set other graphical parameters, then call \code{squishplot}, then call the plotting function(s), then reset the parameters. } \seealso{ \code{\link{plot.default}}, \code{\link{plot.window}}, \code{\link{par}} } \examples{ x <- rnorm(25, 10, 2 ) y <- 5 + 1.5*x + rnorm(25,0,2) par(mfrow=c(1,3)) plot(x,y) op <- squishplot(x,y,1) plot(x,y) par(op) plot(x,y, asp=1) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ dplot } TeachingDemos/man/ldsgrowth.Rd0000644000175100001440000000234112657235444016075 0ustar hornikusers\name{ldsgrowth} \alias{ldsgrowth} \docType{data} \title{ Growth of The Church of Jesus Christ of Latter-day Saints. } \description{ Data on the Growth of The Church of Jesus Christ of Latter-day Saints (commonly known as the Mormon church (\url{http://www.mormon.org})). } \usage{data(ldsgrowth)} \format{ A data frame with 179 observations on the following 6 variables. \describe{ \item{\code{Year}}{Year from 1830 to 2008} \item{\code{Members}}{Total number of Members} \item{\code{Wards}}{Number of Wards and Branches (individual congregations)} \item{\code{Stakes}}{Number of Stakes (a group of wards/branches)} \item{\code{Missions}}{Number of Missions} \item{\code{Missionaries}}{Number of Missionaries called} } } \details{ The data comes from the church records and are as of December 31st of each year. The church was officially organized on 6 April 1830 (hence the starting year of 1830). The \code{Missionaries} column represents the number of missionaries called each year. Missionaries generally serve for about 2 years. } \source{ Deseret News 2010 Church News Almanac } \examples{ data(ldsgrowth) with(ldsgrowth, plot(Year, log(Members))) } \keyword{datasets} TeachingDemos/man/ccc.Rd0000644000175100001440000000461712657235444014620 0ustar hornikusers\name{towork} \alias{towork} \alias{h2h} \alias{ccc} \docType{data} \title{ Sample data downloaded and converted from a GPS unit} \description{ These are GPS information from 3 trips. } \format{ Data frames with the following variables. \describe{ \item{\code{Index}}{Measurement number} \item{\code{Time}}{a POSIXt, Time of measurement} \item{\code{Elevation}}{a numeric vector, Elevation in Feet} \item{\code{Leg.Dist}}{a character/numeric vector, The distance traveled in that leg (in feet for \code{ccc})} \item{\code{Leg.Time}}{a difftime, the time of that leg} \item{\code{Speed}}{a numeric vector, Speed in mph} \item{\code{Direction}}{a numeric vector, Direction in Degrees, 0 is North, 90 is East, 180 is South, 270 is West} \item{\code{LatLon}}{a character vector, Latitude and Longitude as characters} \item{\code{Leg.Dist.f}}{a numeric vector, Length of that leg in feet} \item{\code{Leg.Dist.m}}{a numeric vector, Length of that leg in miles} \item{\code{Lat}}{a numeric vector, Numeric latitude} \item{\code{Lon}}{a numeric vector, Numeric longitude (negative for west)} \item{\code{Distance}}{a numeric vector, Distance from start in feet} \item{\code{Distance.f}}{a numeric vector, Distance from start in feet} \item{\code{Distance.m}}{a numeric vector, Distance from start in miles} \item{\code{Time2}}{a difftime, Time from start} \item{\code{Time3}}{a difftime, cumsum of \code{Leg.Time}} } } \details{ The data frame \code{ccc} came from when I was walking back to my office from a meeting and decided to take the scenic route and started the GPS. The data frame \code{h2h} is a trip from my office to another for a meeting. The first part is traveling by car, the last part by foot from the parking lot to the building. Speed is a mixture of distributions. The data frame \code{towork} came from driving to work one morning (the first point is where the GPS got it's first lock, not my house). The overall trip was mostly NorthWest but with enough North and NorthEast that a simple average of direction shows SouthEast, good example for circular stats. } \source{ My GPS device } %\references{ % ~~ possibly secondary sources and usages ~~ %} \examples{ if( interactive() ){ with(ccc, TkApprox(Distance, Elevation)) } } \keyword{datasets} TeachingDemos/man/SensSpec.demo.Rd0000644000175100001440000000450212657235444016527 0ustar hornikusers\name{SensSpec.demo} \alias{SensSpec.demo} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Demonstrate Sensitivity, Specificity, PPV, and NPV } \description{ This function demonstrates how to get PPV and NPV from Sensitivity, Specificity, and Prevalence by using a virtual population rather than a direct application of Bayes Rule. This approach is more intuitive to mathphobes. } \usage{ SensSpec.demo(sens, spec, prev, n = 100000, step = 11) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{sens}{ Sensitivity (between 0 and 1) } \item{spec}{ Specificity (between 0 and 1) } \item{prev}{ Prevalence (between 0 and 1) } \item{n}{ Size of the virtual population (large round number) } \item{step}{ which step of the process to display } } \details{ The common way to compute Positive Predictive Value (probability of disease given a positive test (PPV)) and Negative Predictive Value (probability of no disease given negative test (NPV)) is to use Bayes' rule with the Sensitivity, Specificity, and Prevalence. This approach can be overwhelming to non-math types, so this demonstration goes through the steps of assuming a virtual population, then filling in a 2x2 table based on the population and given values of Sensitivity, Specificity, and Prevalence. PPV and NPV are then computed from this table. This approach is more intuitive to many people. The function can be run multiple times with different values of \code{step} to show the steps in building the table, then rerun with different values to show how changes in the inputs affect the results. } \value{ An invisible matrix with the 2x2 table } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow, \email{538280@gmail.com} } %\note{ ~~further notes~~ % % ~Make other sections like Warning with \section{Warning }{....} ~ %} \seealso{ \code{\link{roc.demo}}, \code{\link{fagan.plot}}, the various Epi packages, \code{\link{tkexamp}}} \examples{ for(i in seq(1,11,2)) { SensSpec.demo(sens=0.95, spec=0.99, prev=0.01, step=i) if( interactive() ) { readline("Press Enter to continue") } } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ univar } TeachingDemos/man/simfun.Rd0000644000175100001440000002234512657235444015367 0ustar hornikusers\name{simfun} \alias{simfun} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Create a function to simulate data } \description{ This function is used to create a new function that will simulate data. This could be used by a teacher to create homework or test conditions that the students would then simulate data from (each student could have their own unique data set) or this function could be used in simulations for power or other values of interest. } \usage{ simfun(expr, drop, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{expr}{ This is an expression, usually just one or more statements, that will generate the simulated data. } \item{drop}{ A character vector of names of objects/columns that will be dropped from the return value. These are usually intermediate objects or parameter values that you don't want carried into the final returned object. } \item{\dots}{ Additional named items that will be in the environment when \code{expr} is evaluated. } } \details{ This function creates another function to simulate data. You supply the general ideas of the simulation to this function and the resulting function can then be used to create simulated datasets. The resulting function can then be given to students for them to simulate datasets, or used localy as part of larger simulations. The environment where the expression is evaluated will have all the columns or elements of the \code{data} argument available as well as the \code{data} argument itself. Any variables/parameters passed through \code{...} in the original function will also be available. You then supply the code based on those variables to create the simulated data. The names of any columns or parameters submitted as part of \code{data} will need to match the code exactly (provide specific directions to the users on what columns need to be named). Rember that indexing using factors indexes based on the underlying integers not the character representation. See the examples for details. The resulting function can be saved and loaded/attached in different R sessions (it is important to use \code{save} rather than something like \code{dput} so that the environment of the function is preserved). The function includes an optional seed that will be used with the \code{\link{char2seed}} function (if the seed is a character) so that each student could use a unique but identifiable seed (such as their name or something based on their name) so that each student will use a different dataset, but the instructor will be able to generate the exact same dataset to check answers. The "True" parameters are hidden in the environment of the function so the student will not see the "true" values by simply printing the function. However an intermediate level R programmer/user would be able to extract the simulation parameters (but the correct homework or test answer will not be the simulation parameters). } \value{ The return value is a function that will generate simulated datasets. The function will have 2 arguments, \code{data} and \code{seed}. The \code{data} argument can be either a data frame of the predictor variables (study design) or a list of simulation parameters. The \code{seed} argument will be passed on to \code{\link{set.seed}} if it is numeric and \code{\link{char2seed}} if it is a character. The return value of this function is a dataframe with the simulated data and any explanitory variables passed to the function. See the examples for how to use the result function. } \author{Greg Snow, \email{538280@gmail.com}} \note{ This function was not designed for speed, if you are doing long simulations then hand crafting the simulation function will probably run quicker than one created using this function. Like the prediction functions the data frame passed in as the data argument will need to have exact names of the columns to match with the code (including capitolization). This function is different from the \code{\link{simulate}} functions in that it allows for different sample sizes, user specified parameters, and different predictor variables. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{set.seed}}, \code{\link{char2seed}}, \code{\link{within}}, \code{\link{simulate}}, \code{\link{save}}, \code{\link{load}}, \code{\link{attach}} } \examples{ # Create a function to simulate heights for a given dataset simheight <- simfun( {h <- c(64,69); height<-h[sex]+ rnorm(10,0,3)}, drop='h' ) my.df <- data.frame(sex=rep(c('Male','Female'),each=5)) simdat <- simheight(my.df) t.test(height~sex, data=simdat) # a more general version, and have the expression predefined # (note that this assumes that the levels are Female, Male in that order) myexpr <- quote({ n <- length(sex) h <- c(64,69) height <- h[sex] + rnorm(n,0,3) }) simheight <- simfun(eval(myexpr), drop=c('n','h')) my.df <- data.frame(sex=sample(rep(c('Male','Female'),c(5,10)))) (simdat <- simheight(my.df)) # similar to above, but use named parameter vector and index by names myexpr <- quote({ n <- length(sex) height <- h[ as.character(sex)] + rnorm(n,0,sig) }) simheight <- simfun(eval(myexpr), drop=c('n','h','sig'), h=c(Male=69,Female=64), sig=3) my.df <- data.frame( sex=sample(c('Male','Female'),100, replace=TRUE)) (simdat <- simheight(my.df, seed='example')) # Create a function to simulate Sex and Height for a given sample size # (actually it will generate n males and n females for a total of 2*n samples) # then use it in a set of simulations simheight <- simfun( {sex <- factor(rep(c('Male','Female'),each=n)) height <- h[sex] + rnorm(2*n,0,s) }, drop=c('h','n'), h=c(64,69), s=3) (simdat <- simheight(list(n=10))) out5 <- replicate(1000, t.test(height~sex, data=simheight(list(n= 5)))$p.value) out15 <- replicate(1000, t.test(height~sex, data=simheight(list(n=15)))$p.value) mean(out5 <= 0.05) mean(out15 <= 0.05) # use a fixed population simstate <- simfun({ tmp <- state.df[as.character(State),] Population <- tmp[['Population']] Income <- tmp[['Income']] Illiteracy <- tmp[['Illiteracy']] }, state.df=as.data.frame(state.x77), drop=c('tmp','state.df')) simstate(data.frame(State=sample(state.name,10))) # Use simulation, but override setting the seed simheight <- simfun({ set.seed(1234) h <- c(64,69) sex <- factor(rep(c('Female','Male'),each=50)) height <- round(rnorm(100, rep(h,each=50),3),1) sex <- sex[ID] height <- height[ID] }, drop='h') (newdat <- simheight(list(ID=c(1:5,51:55)))) (newdat2<- simheight(list(ID=1:10))) # Using a fitted object fit <- lm(Fertility ~ . , data=swiss) simfert <- simfun({ Fertility <- predict(fit, newdata=data) Fertility <- Fertility + rnorm(length(Fertility),0,summary(fit)$sigma) }, drop=c('fit'), fit=fit) tmpdat <- as.data.frame(lapply(swiss[,-1], function(x) round(runif(100, min(x), max(x))))) names(tmpdat) <- names(swiss)[-1] fertdat <- simfert(tmpdat) head(fertdat) rbind(coef(fit), coef(lm(Fertility~., data=fertdat))) # simulate a nested mixed effects model simheight <- simfun({ n.city <- length(unique(city)) n.state <- length(unique(state)) n <- length(city) height <- h[sex] + rnorm(n.state,0,sig.state)[state] + rnorm(n.city,0,sig.city)[city] + rnorm(n,0,sig.e) }, sig.state=1, sig.city=0.5, sig.e=3, h=c(64,69), drop=c('sig.state','sig.city','sig.e','h','n.city','n.state','n')) tmpdat <- data.frame(state=gl(5,20), city=gl(10,10), sex=gl(2,5,length=100, labels=c('F','M'))) heightdat <- simheight(tmpdat) # similar to above, but include cost information, this assumes that # each new state costs $100, each new city is $10, and each subject is $1 # this shows 2 possible methods simheight <- simfun({ n.city <- length(unique(city)) n.state <- length(unique(state)) n <- length(city) height <- h[sex] + rnorm(n.state,0,sig.state)[state] + rnorm(n.city,0,sig.city)[city] + rnorm(n,0,sig.e) cost <- 100 * (!duplicated(state)) + 10*(!duplicated(city)) + 1 cat('The total cost for this design is $', 100*n.state+10*n.city+1*n, '\n', sep='') }, sig.state=1, sig.city=0.5, sig.e=3, h=c(64,69), drop=c('sig.state','sig.city','sig.e','h','n.city','n.state','n')) tmpdat <- data.frame(state=gl(5,20), city=gl(10,10), sex=gl(2,5,length=100, labels=c('F','M'))) heightdat <- simheight(tmpdat) sum(heightdat$cost) # another mixed model method simheight <- simfun({ state <- gl(n.state, n/n.state) city <- gl(n.city*n.state, n/n.city/n.state) sex <- gl(2, n.city, length=n, labels=c('F','M') ) height <- h[sex] + rnorm(n.state,0,sig.state)[state] + rnorm(n.city*n.state,0,sig.city)[city] + rnorm(n,0,sig.e) }, drop=c('n.state','n.city','n','sig.city','sig.state','sig.e','h')) heightdat <- simheight( list( n.state=5, n.city=2, n=100, sig.state=10, sig.city=3, sig.e=1, h=c(64,69) )) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ datagen } \keyword{ design } TeachingDemos/man/HWidentify.Rd0000644000175100001440000000471412657235444016140 0ustar hornikusers\name{HWidentify} \Rdversion{1.1} \alias{HWidentify} \alias{HTKidentify} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Show label for point being Hovered over. } \description{ These functions create a scatterplot then you Hover the mouse pointer over a point in the plot and it will show an id label for that point. } \usage{ HWidentify(x, y, label = seq_along(x), lab.col="darkgreen", pt.col="red", adj=c(0,0), clean=TRUE, xlab = deparse(substitute(x)), ylab = deparse(substitute(y)), ...) HTKidentify(x, y, label = seq_along(x), lab.col="darkgreen", pt.col="red", adj=c(0,0), xlab = deparse(substitute(x)), ylab = deparse(substitute(y)), ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ x-coordinates to plot } \item{y}{ y-coordinates to plot} \item{label}{ Labels to show for each point } \item{lab.col}{The color to plot the labels} \item{pt.col}{The color of the highlighting point} \item{adj}{The adjustment of the labels relative to the cursor point. The default places the label so that its bottom left corner is at the curser, values below 0 or greater than 1 will move the label to not touch the cursor.} \item{clean}{Logical value, should any labels on the plot be removed at the end of the plotting.} \item{xlab}{ Label for x-axis } \item{ylab}{ Label for y-axis} \item{\dots}{additional arguments passed through to plot} } \details{ This is an alternative to the \code{identify} function. The label only shows up for the point currently closest to the mouse pointer. When the mouse pointer moves closer to a different point, the label changes to the one for the new point. The currently labeled point is also highlighted. HWidentify only works on windows, HTKidentify requires the tkrplot package. } \value{ These functions are run for their side effects, nothing meaningful is returned. } %\references{ %% ~put references to the literature/web site here ~ %} \author{ Greg Snow, \email{538280@gmail.com} } %\note{ %% ~~further notes~~ %} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{identify}} } \examples{ if( interactive() ){ tmpx <- runif(25) tmpy <- rnorm(25) HTKidentify(tmpx,tmpy, LETTERS[1:25], pch=letters) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ dynamic } \keyword{ iplot } TeachingDemos/man/triplot.Rd0000644000175100001440000000626312657235444015564 0ustar hornikusers\name{triplot} \alias{triplot} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Create or add to a Trilinear Plot } \description{ Create (or add to) a trilinear plot of 3 proportions that sum to 1. } \usage{ triplot(x, y = NULL, z = NULL, labels = dimnames(x)[[2]], txt = dimnames(x)[[1]], legend = NULL, legend.split = NULL, inner = TRUE, inner.col = c("lightblue", "pink"), inner.lty = c(2, 3), add = FALSE, main = "", ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Vector or matrix of up to 3 columns. } \item{y}{ Vector (if \code{x} is a vector). } \item{z}{ Vector (if \code{x} is a vector). } \item{labels}{ Labels for the 3 components (printed at corners). } \item{txt}{ Vector of text strings to be plotted instead of points. } \item{legend}{ Labels for the data points } \item{legend.split}{ What proportion of the labels will go on the left. } \item{inner}{ Logical, should the inner reference lines be plotted. } \item{inner.col}{ Colors for the 2 inner triangles. } \item{inner.lty}{ Line types for the 2 inner triangles. } \item{add}{ Add points to existing plot (TRUE), or create a new plot (FALSE). } \item{main}{ Main title for the plot. } \item{\dots}{ Additional arguments passed on to \code{points} or \code{text}. } } \details{ Trilinear plots are useful for visualizing membership in 3 groups by plotting sets of 3 proportions that sum to 1 within each set. The data can be passed to the function as a matrix with either 2 or 3 columns, or as seperate vectors to \code{x}, \code{y}, and optionaly \code{z}. If 2 columns are passed in, then they must be between 0 and 1 and the 3rd column will be created by subtracting both from 1. If 3 columns of data are given to the function then each will be divided by the sum of the 3 columns (they don't need to sum to 1 before being passed in). } \value{ An invisible matrix with 2 columns and the same number of rows as \code{x} corresponding to the points plotted (after transforming to 2 dimensions). The return matrix can be passed to \code{identify} for labeling of individual points. Using \code{type='n'} and \code{add=FALSE} will return the transformed points without doing any plotting. } \references{ Allen, Terry. Using and Interpreting the Trilinear Plot. Chance. 15 (Summer 2002). } \author{ Greg Snow \email{538280@gmail.com} } %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{triangle.plot} in package ade4, \code{ternaryplot} in package vcd, \code{tri} in package cwhtool, \code{soil.texture} and \code{triax.plot} in package plotrix. } \examples{ triplot(USArrests[c(1,4,2)]) tmp <- triplot(USArrests[c(1,4,2)],txt=NULL) if(interactive()){ identify(tmp, lab=rownames(USArrests) ) } tmp <- rbind( HairEyeColor[,,'Male'], HairEyeColor[,,'Female']) tmp[,3] <- tmp[,3] + tmp[,4] tmp <- tmp[,1:3] triplot(tmp, legend=rep(c('Male','Femal'),each=4), col=rep(c('black','brown','red','yellow'),2)) } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ aplot }% __ONLY ONE__ keyword per line TeachingDemos/man/fagan.Rd0000644000175100001440000000545712657235444015147 0ustar hornikusers\name{fagan.plot} \alias{fagan.plot} \alias{plotFagan} \alias{plotFagan2} \alias{plotFagan.old} \alias{plotFagan2.old} \title{Create a Fagan plot to demonstrate Bayes Theorem and screening tests} \description{ These functions create a plot showing the relationship between the prior probability, the LR (combination of sensitivity and specificity), and the posterior probability. } \usage{ fagan.plot(probs.pre.test, LR, test.result="+") plotFagan(hscale=1.5, vscale=1.5, wait=FALSE) plotFagan2(hscale=1.5, vscale=1.5, wait=FALSE) plotFagan.old() plotFagan2.old() } \arguments{ \item{probs.pre.test}{ The prior probability } \item{LR}{ the likelihood ratio (sensitivity/(1-specificity))} \item{test.result}{either '+' or '-' indicating whether you want the probability of the event or of not seeing the event} \item{hscale}{Horizontal scale, passed to \code{tkrplot}} \item{vscale}{Vertical scale, passed to \code{tkrplot}} \item{wait}{Should the R session wait for the window to close} } \details{ When Bayes theorem is expressed in terms of log-odds it turns out that the posterior log-odds are a linear function of the prior log-odds and the log likelihood ratio. These functions plot an axis on the left with the prior log-odds, an axis in the middle representing the log likelihood ratio and an axis on the right representing the posterior log-odds. A line is then drawn from the prior probability on the left through the LR in the center and extended to the posterior probability on the right. The \code{fagan.plot} creates the plot based on input to the function. The \code{plotFagan} and \code{plotFagan2} functions set up Tk windows with sliders representing the possible inputs and show how the plot and the posterior probability changes when you adjust the inputs. The \code{plotFagan} function creates sliders for the prior probability and the LR, while the \code{plotFagan2} function replaces the LR slider with 2 sliders for the sensitivity and specificity. More detail on the plots and the math behind them can be found at the websites below. } \value{ The old functions are run for their side effects and do not return a meaningful value. If \code{wait} is FALSE then NULL is returned, if \code{wait} is TRUE, then a list with the current values is returned.} \references{ Fagan TJ. Nomogram for Bayes theorem. N Engl J Med 1975;293(5):257-61. \url{http://www.cmh.edu/stats/definitions/fagan.htm} \url{http://ebm.bmjjournals.com/cgi/content/full/6/6/164} } \author{ Guazzetti Stefano and Greg Snow \email{538280@gmail.com}} \seealso{ \code{slider}} \examples{ fagan.plot(0.8, 2) fagan.plot(0.8, 0.95/(1-0.90) ) if(interactive()) { plotFagan() plotFagan2() } } \keyword{hplot} \keyword{dynamic} TeachingDemos/man/z.test.Rd0000644000175100001440000000443012657235444015310 0ustar hornikusers\name{z.test} \alias{z.test} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Z test for known population standard deviation } \description{ Compute the test of hypothesis and compute confidence interval on the mean of a population when the standard deviation of the population is known. } \usage{ z.test(x, mu = 0, stdev, alternative = c("two.sided", "less", "greater"), sd = stdev, n=length(x), conf.level = 0.95, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Vector of data values or the mean of the data. } \item{mu}{ Hypothesized mean of the population. } \item{stdev}{ Known standard deviation of the population. } \item{alternative}{ Direction of the alternative hypothesis. } \item{sd}{ Alternative to \code{stdev} } \item{n}{ The sample size if \code{x} is the sample mean. } \item{conf.level}{ Confidence level for the interval computation. } \item{\dots}{ Additional arguments are silently ignored. } } \details{ Many introductory statistical texts introduce inference by using the Z test and Z based confidence intervals based on knowing the population standard deviation. Most statistical packages do not include functions to do Z tests since the T test is usually more appropriate for real world situations. This function is meant to be used during that short period of learning when the student is learning about inference using Z procedures, but has not learned the T based procedures yet. Once the student has learned about the T distribution the \code{t.test} function should be used instead of this one (but the syntax is very similar, so this function should be an appropriate introductory step to learning \code{t.test}). } \value{ An object of class \code{htest} containing the results } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com} } \note{ This function should be used for learning only, real data should generally use \code{t.test}. } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{t.test}}, \code{\link{print.htest}} } \examples{ x <- rnorm(25, 100, 5) z.test(x, 99, 5) } \keyword{ htest }% at least one, from doc/KEYWORDS TeachingDemos/man/vis.boxcox.Rd0000644000175100001440000000516412657235444016170 0ustar hornikusers\name{vis.boxcox} \alias{vis.boxcox} \alias{vis.boxcox.old} \alias{vis.boxcoxu} \alias{vis.boxcoxu.old} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interactively visualize Box-Cox transformations } \description{ Explore the Box-Cox family of distributions by plotting data transformed and untransformed and interactively choose values for lambda. } \usage{ vis.boxcox(lambda = sample(c(-1,-0.5,0,1/3,1/2,1,2), 1), hscale=1.5, vscale=1.5, wait=FALSE) vis.boxcoxu(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1), y, xlab=deparse(substitute(y)), hscale=1.5, vscale=1.5, wait=FALSE) vis.boxcox.old(lambda = sample(c(-1, -0.5, 0, 1/3, 1/2, 1, 2), 1)) vis.boxcoxu.old(lambda = sample(c(-1, -0.5, 0, 1/3, 1/2, 1, 2), 1)) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{lambda}{ The true value of lambda to use. } \item{y}{ Optional data to use in the transform. } \item{xlab}{ Label for x-axis.} \item{hscale}{ The horizontal scale, passed to \code{tkrplot}. } \item{vscale}{ The vertical scale, passed to \code{tkrplot}. } \item{wait}{ Should R wait for the demo window to close. } } \details{ These functions will generate a sample of data and plot the untrasformed data (left panels) and the transformed data (right panels). Initially the value of \code{lambda} is 1 and the 2 sets of plots will be identical. You then adjust the transformation parameter \code{lambda} to see how the right panels change. The function \code{vis.boxcox} shows the effect of transforming the y-variable in a simple linear regression. The function \code{vis.boxcoxu} shows a single variable compared to the normal distribution. } \value{ The old versions have no useful return value. If \code{wait} is FALSE then they will return an invisible NULL, if \code{wait} is TRUE then the return value will be a list with the final value of \code{lamda}, the original data, and the transformed y (at the final \code{lamda} value). } \references{ GEP Box; DR Cox. An Analysis of Transformations. Journal of the Royal Statitical Society. Series B, Vol. 26, No. 2 (1964) 211-252 } \author{ Greg Snow \email{538280@gmail.com} } %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{bct}}, \code{boxcox} in package MASS } \examples{ if(interactive()) { vis.boxcoxu() vis.boxcox() } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ univar }% __ONLY ONE__ keyword per line \keyword{ regression }TeachingDemos/man/spread.labs.Rd0000644000175100001440000000621612657235444016263 0ustar hornikusers\name{spread.labs} \alias{spread.labs} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Spread out close points for labeling in plots } \description{ This function takes as set of coordinates and spreads out the close values so that they can be used in labeling plots without overlapping. } \usage{ spread.labs(x, mindiff, maxiter = 1000, stepsize = 1/10, min = -Inf, max = Inf) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The coordinate values (x or y, not both) to spread out. } \item{mindiff}{ The minimum distance between return values } \item{maxiter}{ The maximum number of iterations } \item{stepsize}{ How far to move values in each iteration } \item{min}{ Minimum bound for returned values } \item{max}{ Maximum bound for returned values } } \details{ Sometimes the desired locations for labels in plots results in the labels overlapping. This function takes the coordinate values (x or y, not both) and finds those points that are less than \code{mindiff} (usually a function of \code{strheight} or \code{strwidth}) apart and increases the space between them (by \code{stepsize} * \code{mindiff}). This may or may not be enough and moving some points away from their nearest neighbor may move them too close to another neighbor, so the process is iterated until either \code{maxiter} steps have been tried, or all the values are at least \code{mindiff} apart. The \code{min} and \code{max} arguments prevent the values from going outside that range (they should be specified such that the original values are all inside the range). The values do not need to be presorted. } \value{ A vector of coordinates (order corresponding to the original \code{x}) that can be used as a replacement for \code{x} in placing labels. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow, \email{538280@gmail.com} } %\note{ ~~further notes~~ % % ~Make other sections like Warning with \section{Warning }{....} ~ %} \seealso{ \code{\link{text}}, the \code{spread.labels} function in the \code{plotrix} package. } \examples{ # overlapping labels plot(as.integer(state.region), state.x77[,1], ylab='Population', xlab='Region',xlim=c(1,4.75), xaxt='n') axis(1, at=1:4, lab=levels(state.region) ) text( as.integer(state.region)+.5, state.x77[,1], state.abb ) segments( as.integer(state.region)+0.025, state.x77[,1], as.integer(state.region)+.375, state.x77[,1] ) # now lets redo the plot without overlap tmp.y <- state.x77[,1] for(i in levels(state.region) ) { tmp <- state.region == i tmp.y[ tmp ] <- spread.labs( tmp.y[ tmp ], 1.2*strheight('A'), maxiter=1000, min=0 ) } plot(as.integer(state.region), state.x77[,1], ylab='Population', xlab='Region', xlim=c(1,4.75), xaxt='n') axis(1, at=1:4, lab=levels(state.region) ) text( as.integer(state.region)+0.5, tmp.y, state.abb ) segments( as.integer(state.region)+0.025, state.x77[,1], as.integer(state.region)+0.375, tmp.y ) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ dplot } TeachingDemos/man/petals.Rd0000644000175100001440000000670712657235444015362 0ustar hornikusers\name{petals} \alias{petals} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Play the Petals Around the Rose game } \description{ This plays the lateral thinking game Petals Around the Rose. This is a game where 5 regular dice are rolled and the players then try to figure out how many petals are around the rose. } \usage{ petals(plot = TRUE, txt = TRUE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{plot}{ Should the dice be plotted to the current/default graphics device. } \item{txt}{ Should the dice be shown in the console window using text. %% ~~Describe \code{txt} here~~ } } \details{ At least one of the arguments \code{plot} and \code{txt} needs to be true, otherwise you will be guessing blind (or testing your psychic abilities). The game is usually played with 5 physical dice, one person who knows the rules (the potentate of the rose, here the computer), and one or more players trying to learn the puzzle. The potentate can only give the players the following 3 rules: \enumerate{ \item The name of the game is "Petals Around the Rose" and the name is significant. \item The answer is always 0 or an even number. \item The potentate can tell the answer for any roll after any guesses are made. } The potentate (or other player) then rolls the 5 dice and any players are then allowed to guess. The potentate either confirms a correct guess or tells the correct answer, then the game continues with another roll. Players are not to discuss their reasoning so that each can solve it themselves. When a player thinks they have worked out the reasoning they demonstrate it by getting correct guesses, but not by discussing it with anyone. Generally 6 correct guesses in a row is considered evidence that they have figured out the rules and they are then considered a potentate of the rose. For this implementation the computer will simulate the role of 5 dice and display the results and ask for a guess of how many petals are around the rose. The player then enters their guess and the computer then either confirms that it is correct or gives the correct answer. Pressing enter without making a guess ends the game. } \value{ This function only returns NULL, it is run for its side effects. %% ~Describe the value returned %% If it is a LIST, use %% \item{comp1 }{Description of 'comp1'} %% \item{comp2 }{Description of 'comp2'} %% ... } \references{ \url{http://www.borrett.id.au/computing/petals-bg.htm} %% ~put references to the literature/web site here ~ } \author{Greg Snow, \email{538280@gmail.com} %% ~~who you are~~ } \note{ Casual viewing of the function source code is unlikely to reveal the secret (and therefore this could be used as an example of one way to disguise portions of code from casual examination). More on disguising source code is at \url{https://stat.ethz.ch/pipermail/r-devel/2011-October/062236.html}. Some basic debugging can reveal the secret, but that would be cheating and an admission that such a simple game has defeated you, so don't do it, just keep playing until you figure it out. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{dice} } \examples{ if(interactive()){ petals() } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ misc } TeachingDemos/man/rotate.cloud.Rd0000644000175100001440000000440612657235444016467 0ustar hornikusers\name{rotate.cloud} \alias{rotate.cloud} \alias{rotate.persp} \alias{rotate.wireframe} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interactively rotate 3D plots } \description{ Interactively rotate common 3d plots: cloud, persp, and wireframe. } \usage{ rotate.cloud(x, ...) rotate.persp(x, y, z) rotate.wireframe(x, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ \code{x}, see \code{persp}, or formula/matrix to pass to cloud or wireframe } \item{y}{ \code{y}, see \code{persp} } \item{z}{ \code{z}, see \code{persp} } \item{\dots}{ additional arguments passed on to \code{cloud} or \code{persp}} } \details{ Use these functions just like \code{cloud}, \code{persp}, and \code{wireframe}. In addition to the default plot a Tk slider window will be created that will allow you to rotate the plot. The rotations parameters are passed the \code{screen} argument of \code{cloud} and \code{wireframe} and the \code{theta}, \code{phi}, \code{r}, \code{d}, \code{ltheta}, \code{lphi}, and \code{shade} arguments of \code{persp}. For \code{cloud} and \code{wireframe} plots the order of the \code{x}, \code{y}, and \code{z} argumets can be rearanged, just type the appropriate letters in the boxes on the left, then press the "refresh" button (changing the order changes the plot for these 2 plots). } \value{ These functions are run for the side effects of the plots and Tk windows, nothing meaninful is returned. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{cloud} it the lattice package, \code{\link{persp}}, \code{wireframe} in the lattice package } \examples{ if(interactive()){ rotate.cloud(Sepal.Length ~ Petal.Length*Petal.Width, data=iris) rotate.wireframe(volcano) z <- 2 * volcano # Exaggerate the relief x <- 10 * (1:nrow(z)) # 10 meter spacing (S to N) y <- 10 * (1:ncol(z)) # 10 meter spacing (E to W) rotate.persp(x,y,z) } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ hplot }% __ONLY ONE__ keyword per line TeachingDemos/man/power.examp.Rd0000644000175100001440000000622512657235444016332 0ustar hornikusers\name{power.examp} \alias{power.examp} \alias{run.power.examp} \alias{run.power.examp.old} \alias{power.refresh} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Graphically illustrate the concept of power. } \description{ Create graphs of a normal test statistic under the null and alternative hypotheses to graphically show the idea of power. } \usage{ power.examp(n = 1, stdev = 1, diff = 1, alpha = 0.05, xmin = -2, xmax = 4) run.power.examp(hscale=1.5, vscale=1.5, wait=FALSE) run.power.examp.old() } %- maybe also 'usage' for other objects documented here. \arguments{ \item{n}{ The sample size for the test statistic. } \item{stdev}{ The standard deviation of the population. } \item{diff}{ The true difference in means (alternate hypothesis). } \item{alpha}{ The type I error rate to use for the test. } \item{xmin}{ The minimum x value to show on the graph. } \item{xmax}{ The maximum x value to show on the graph. } \item{hscale}{Controls width of plot, passed to \code{tkrplot}.} \item{vscale}{Controls height of plot, passed to \code{tkrplot}.} \item{wait}{Should R wait for the window to close.} } \details{ This function will draw 2 graphs representing an upper-tailed test of hypothesis. The upper panel represents the test statistic under the null hypothesis that the true mean (or mean difference) is 0. It then also shows the upper tail area equal to \code{alpha} and the rejection region for the test statistic. The lower panel shows the normal distribution for the test statistic under the alternative hypothesis where the true mean (or mean difference) is \code{diff}. Using the rejection region from the upper panel it shades the upper tail area that corresponds to the power of the test. Both curves are affected by the specified \code{stdev} and sample size \code{n}. The function \code{run.power.examp} will in addition create a Tk slider box that will allow you to interactively change the values of \code{stdev}, \code{diff}, \code{alpha}, and \code{n} to dynamically see the effects of the change on the graphs and on the power of the test. This can be used to demonstrate the concept of power, show the effect of sample size on power, show the inverse relationship between the type I and type II error rates, and show how power is dependent on the true mean (or difference) and the population standard deviation. } \value{ \code{power.examp} invisibly returns the power computed. \code{run.power.examp} returns a list with the parameter settings and the power if \code{wait} is TRUE. \code{run.power.examp.old} does not return anything meaningful. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com} } %\note{ ~~further notes~~ } %~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{power.t.test}} } \examples{ power.examp() power.examp(n=25) power.examp(alpha=0.1) } \keyword{ hplot }% at least one, from doc/KEYWORDS \keyword{ dynamic }% __ONLY ONE__ keyword per line \keyword{ univar } \keyword{ htest } TeachingDemos/man/panel.mysymbols.Rd0000644000175100001440000001025212657235444017214 0ustar hornikusers\name{panel.my.symbols} \alias{panel.my.symbols} \title{Draw Symbols (User Defined) on a Lattice Plot} \description{This function draws symbols on a lattice plot. It is similar to the builtin \code{symbols} function with the difference that it plots symbols defined by the user rather than a prespecified set of symbols.} \usage{ panel.my.symbols(x, y, symb, inches=1, polygon=FALSE, ..., symb.plots=FALSE, subscripts, MoreArgs) } \arguments{ \item{x, y}{The \code{x} and \code{y} coordinates for the position of the symbols to be plotted. These can be specified in any way which is accepted by \code{xy.coords}.} \item{symb}{Either a matrix, list, or function defining the symbol to be plotted. If it is a matrix or list it needs to be formatted that it can be passed directly to the \code{llines} function. It then defines the shape of the symbol on on a range/domain of -1 to 1. If this is a function it can either return a matrix or list as above (points on the range/domain of -1 to 1).} \item{inches}{The size of the square containing the symbol in inches (note: unlike \code{symbols} this cannot be \code{FALSE}).} \item{polygon}{If TRUE, use \code{lpolygon} function to plot rather than the \code{llines} function.} \item{symb.plots}{Currently not implemented.} \item{...}{Additional arguments will be replicated to the same length as \code{x} then passed to \code{symb} (if \code{symb} is a function) and/or the \code{lines} function (one value per symbol drawn).} \item{subscripts}{subscripts for the current panel} \item{MoreArgs}{A list with any additional arguments to be passed to the \code{symb} function (as is, without being replicated/split).} } \details{ The \code{symb} argument can be a 2 column matrix or a list with components 'x' and 'y' that defines points on the interval [-1,1] that will be connected with lines to draw the symbol. If you want a closed polygon then be sure to replicate the 1st point as the last point or use the \code{polygon} option. If any point contains an NA then the line will not be drawn to or from that point. This can be used to create a symbol with disjoint parts that should not be connected. If \code{symb} is a function then any unmatched arguments that end up in the '...' argument will be replicated to the same length as 'x' (using the \code{rep} function) then the values will be passed one at a time to the \code{symb} function. If \code{MoreArgs} is specified, the elements of it will also be passed to \code{symb} without modification. The \code{symb} function can either return a matrix or list with the points that will then be passed to the \code{llines} function (see above). } \value{ This function is run for its side effect of plotting, it returns an invisible NULL. } \author{Greg Snow \email{538280@gmail.com}} \note{ Plotting coordinates and sizes are based on the size of the device at the time the function is called. If you resize the device after plotting, all bets are off. } \seealso{\code{\link{symbols}}, \code{\link{my.symbols}}, \code{\link{subplot}}, \code{\link{mapply}}, \code{\link{ms.polygram}}, \code{\link{lines}}} \examples{ if(require(lattice)) { tmpdf <- data.frame( x=1:10, y=1:10, g=rep( c("A","B"), each=5 ), z=c(1:5,5:1) ) xyplot( y ~ x, tmpdf, panel=panel.my.symbols, symb=ms.female, inches=0.3 ) xyplot( y ~ x | g, tmpdf, panel=panel.my.symbols, symb=ms.male, inches=0.3) xyplot( y ~ x, tmpdf, panel=panel.superpose, groups=g, panel.groups= function(group.number, ...) { if(group.number==1) { panel.my.symbols(..., symb=ms.male) } else { panel.my.symbols(..., symb=ms.female) } }, inches=0.3 ) xyplot( y ~ x, tmpdf, panel=panel.my.symbols, symb=ms.polygram, n=tmpdf$z, inches=0.3) xyplot( y ~ x | g, tmpdf, panel=panel.my.symbols, symb=ms.polygram, n=tmpdf$z, inches=0.3) xyplot( y ~ x, tmpdf, panel=panel.superpose, groups=g, panel.groups = panel.my.symbols, inches=0.3, symb=ms.polygon, n=tmpdf$z, polygon=TRUE, adj=rep(c(0,pi/4),5) ) } } \keyword{aplot} \keyword{dplot} \keyword{hplot} TeachingDemos/man/TkSpline.Rd0000644000175100001440000000541412657235444015615 0ustar hornikusers\name{TkSpline} \alias{TkSpline} \title{Plot a set of data in a Tk window and interactively move a line to see predicted y-values from a spline fit corresponding to selected x-values.} \description{ This function plots a dataset in a Tk window then draws the spline fit through the points. It places a line to show the predicted y from the given x value. The line can be clicked on and dragged to new x-values with the predicted y-values automatically updating. A table at the bottem of the graph shows the values and the 3 derivatives. } \usage{ TkSpline(x, y, method='natural', snap.to.x=FALSE, digits=4, col=c('blue','#009900','red','black'), xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), hscale=1.5, vscale=1.5, wait=TRUE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The x-values of the data, should be sorted } \item{y}{ The corresponding y-values of the data } \item{method}{Spline Method, passed to \code{splinefun}} \item{snap.to.x}{Logical, if TRUE then the line will only take on the values of \code{x}} \item{digits}{Number of digits to print, passed to \code{format}} \item{col}{Colors of the prediction and other lines} \item{xlab}{Label for the x-axis, passed to \code{plot}} \item{ylab}{Label for the y-axis, passed to \code{plot}} \item{hscale}{Horizontal scaling, passed to \code{tkrplot}} \item{vscale}{Vertical scaling, passed to \code{tkrplot}} \item{wait}{Should R wait for the window to close} \item{\dots}{ Additional parameters passed to \code{plot}} } \details{ This provides an interactive way to explore predictions from a set of x and y values. Internally the function \code{splinefun} is used to make the predictions. The x-value of the reference line can be changed by clicking and dragging the line to a new position. The x and y values are shown in the margins of the graph. Below the graph is a table with the y-value and derivatives. } \value{ If \code{wait} is FALSE then an invisible NULL is returned, if \code{wait} is TRUE then an invisible list with the x and y values and derivatives is returned. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ % % ~Make other sections like Warning with \section{Warning }{....} ~ %} \seealso{\code{\link{splinefun}}, \code{\link{TkApprox}} } \examples{ if(interactive()) { x <- 1:10 y <- sin(x) TkSpline(x,y, xlim=c(0,11)) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{dplot } \keyword{dynamic }% __ONLY ONE__ keyword per line TeachingDemos/man/TkListView.Rd0000644000175100001440000000651212657235444016131 0ustar hornikusers\name{TkListView} \alias{TkListView} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interactivly view structures of list and list like objects. } \description{ This is somewhat like the \code{str} function, except that it creates a new Tk window and a tree object representing the list or object. You can then click on the '+' signs to expand branches of the list to see what they contain. } \usage{ TkListView(list) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{list}{ The list or object to be viewed. } } \details{ This function opens a Tk window with a tree view of the list in the leftmost pane. Next to the tree is the result from the \code{str} function for each element of the list. Clicking on the '+' symbol next to list elements will expand the tree branch to show what that list/sublist contains. On the right is an output pane with 3 buttons below it. These can be used by first selecting (clicking on) a list element in the left pane (this can be a whole list or single element), then clicking on one of the buttons. The output from the button appears in the right pane (replacing anything that may have been there before). The 'print' button just prints the element/sublist selected. The 'str' button calls the \code{str} function on the selected element/list/sublist. The 'Eval:' button will evaluate the code in the entry box next to it with the selected element of the list being the 'x' variable. For example you could click on an element in the list that is a numeric vector, type 'hist(x)' in the entry box, and click on the 'Eval:' button to produce a histogram (current/default R graphics device) of the data in that element. any lists/objects with attributes will show the attributes as an additional branch in the tree with a label of "<>". This function works on S3 objects that are stored as lists. Since currently S4 objects are saved as attributes, wrapping them in a list will work with this function to view their structure, see the example below. } \value{ This function is ran for its side effects, it does not return anything of use. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow, \email{538280@gmail.com} } %\note{ ~~further notes~~ % % ~Make other sections like Warning with \section{Warning }{....} ~ %} \seealso{ \code{\link{str}} } \examples{ if(interactive()) { tmp <- list( a=letters, b=list(1:10, 10:1), c=list( x=rnorm(100), z=data.frame(x=rnorm(10),y=rnorm(10)))) TkListView(tmp) if(require(maptools)){ data(state.vbm) TkListView(list(state.vbm)) # change the eval box to: plot(x, type='l') and eval the main branches } fit <- lm(Petal.Width ~ ., data=iris) TkListView(fit) if(require(stats4)){ # this example is copied almost verbatim from ?mle x <- 0:10 y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8) ll <- function(ymax=15, xhalf=6) -sum(stats::dpois(y, lambda=ymax/(1+x/xhalf), log=TRUE)) (fit <- mle(ll)) TkListView(list(fit)) } } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ manip } \keyword{ attribute }% __ONLY ONE__ keyword per line \keyword{ list } TeachingDemos/man/pairs2.Rd0000644000175100001440000000533412657235444015265 0ustar hornikusers\name{pairs2} \alias{pairs2} %- Also NEED an '\alias' for EACH other topic documented here. \title{Create part of a scatterplot matrix} \description{ This function is similar to the \code{pairs} function, but instead of doing all pairwise plots, it takes 2 matricies or data frames and does all combinations of the first on the x-axis with the 2nd on the y-axis. Used with pairs and subsets can spread a scatterplot matrix accross several pages. } \usage{ pairs2(x, y, xlabels, ylabels, panel = points, ..., row1attop = TRUE, gap = 1) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Matrix or data frame of variables to be used as the x-axes. } \item{y}{ Matrix or data frame of variables to be used as the y-axes. } \item{xlabels}{ Labels for x variables (defaults to colnames of \code{x}). } \item{ylabels}{ Labels for y variables (defaults to colnames of \code{y}). } \item{panel}{ Function to do the plotting (see \code{pairs}). } \item{\dots}{ additional arguments passed to graphics functions} \item{row1attop}{ Logical, should the 1st row be the top.} \item{gap}{ Distance between plots. } } \details{ This functios is similar to the \code{pairs} function, but by giving it 2 sets of data it only does the combinations between them. Think of it as giving the upper right or lower left set of plots from \code{pairs}. If a regular scatterplot matrix is too small on the page/device then use \code{pairs} on subsets of the data to get the diagonal blocks of a scatterplot matrix and this function to get the off diagonal blocks. } \value{ This function is run for the side effect of the plot. It does not return anything useful. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow, \email{538280@gmail.com}} \note{ Large amounts of the code for this function were blatently borrowed/stolen from the \code{pairs} function, the credit for the useful parts should go to the original authors, blame for any problems should go to me. This function is also released under GPL since much of it comes from GPL code. } \seealso{\code{\link{pairs}}, \code{splom} in the lattice package} \examples{ pairs2(iris[,1:2], iris[,3:4], col=c('red','green','blue')[iris$Species]) # compare the following plot: pairs(state.x77, panel=panel.smooth) # to the following 4 plots pairs(state.x77[,1:4], panel=panel.smooth) pairs(state.x77[,5:8], panel=panel.smooth) pairs2( state.x77[,1:4], state.x77[,5:8], panel=panel.smooth) pairs2( state.x77[,5:8], state.x77[,1:4], panel=panel.smooth) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{hplot} TeachingDemos/man/run.cor.examp.Rd0000644000175100001440000000457612657235444016573 0ustar hornikusers\name{run.cor.examp} \alias{run.cor.examp} \alias{run.cor2.examp} \alias{run.old.cor.examp} \alias{run.old.cor2.examp} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Interactively demonstrate correlations } \description{ Make a scatterplot and a Tk slider window that allows you to interactively set the correlation and/or R\^2. } \usage{ run.cor.examp(n=100, seed, vscale=1.5, hscale=1.5, wait=FALSE) run.cor2.examp(n=100, seed, vscale=1.5, hscale=1.5, wait=FALSE) run.old.cor.examp(n = 100, seed) run.old.cor2.examp(n = 100, seed) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{n}{ Number of points to plot. } \item{seed}{ What seed to use. } \item{vscale}{ Vertical scale passed to tkrplot. } \item{hscale}{ Horizontal scale passed to tkrplot. } \item{wait}{ Should R wait for the tk window to close. } } \details{ The function \code{run.cor.examp} draws a scatterplot and allows you to set the correlation using a Tk slider window. The function \code{run.cor2.examp} does the same, but has a slider for R\^2 as well as the correlation, when either slider is moved the other one will update to match. The 2 "old" versions use the default graphics device with a seperate window with the sliders, the versions without "old" in the name include the plot and sliders together in a single tk window. The size of the plot can be changed by changing the values in the hscale and vscale boxes and clicking on the "Refresh" button. } \value{ If \code{wait} is TRUE, then the return value is a list with the x and y values of the final plot. If \code{wait} is FALSE (and in the "old" versions) an invisible NULL is returned. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com} } \note{ If \code{wait} is TRUE then R will wait until you click on the "Exit" button before you can use your R session again. If \code{wait} is FALSE then the tk window will appear, but R will regain control so that you can continue to use R as well as interact with the demonstration window.} % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{cor}}, \code{\link{tkexamp}} } \examples{ if(interactive()) { run.cor2.examp() } } \keyword{ dynamic }% at least one, from doc/KEYWORDS TeachingDemos/man/mle.demo.Rd0000644000175100001440000000455612657235444015572 0ustar hornikusers\name{mle.demo} \alias{mle.demo} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Demonstrate the basic concept of Maximum Likelihood Estimation } \description{ This function graphically shows log likelihoods for a set of data and the normal distribution and allows you to interactively change the parameter estimates to see the effect on the log likelihood. } \usage{ mle.demo(x = rnorm(10, 10, 2), start.mean = mean(x) - start.sd, start.sd = 1.2 * sqrt(var(x))) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ A vector of data (presumably from a normal distribution). } \item{start.mean}{ The initial value for estimating the mean. } \item{start.sd}{ The initial value for estimating the standard deviation. } } \details{ The function creates a plot with 3 panels: the top panel shows a normal curve based on the current values of the mean and standard deviation along with a vertical line for each point in \code{x} (the product of the heights of these lines is the likelihood, the sum of the logs of their heights is the log likelihood). The lower 2 plots show the profiles of the mean and standard deviation. The y-axis is the likelihoods of the parameters tried so far, and the x-axes are the mean and standard deviation tried. The point corresponding to the current parameter estimates will be solid red. A Tk slider box is also created that allows you to change the current estimates of the mean and standard deviation to show the effect on the log likelihood and find the maximum likelihood estimate. } \value{ This function is run for its side effects and returns NULL. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{fitdistr} in package MASS, \code{mle} in package stats4, \code{\link{slider}} } \examples{ if(interactive()){ mle.demo() m <- runif(1, 50,100) s <- runif(1, 1, 10) x <- rnorm(15, m, s) mm <- mean(x) ss <- sqrt(var(x)) ss2 <- sqrt(var(x)*11/12) mle.demo(x) # now find the mle from the graph and compare it to mm, ss, ss2, m, and s } } \keyword{ iplot }% at least one, from doc/KEYWORDS \keyword{ dynamic }% __ONLY ONE__ keyword per line TeachingDemos/man/roc.demo.Rd0000644000175100001440000000422612657235444015572 0ustar hornikusers\name{roc.demo} \alias{roc.demo} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Demonstrate ROC curves by interactively building one } \description{ This demonstration allows you to interactively build a Receiver Operator Curve to better understand what goes into creating them. } \usage{ roc.demo(x = rnorm(25, 10, 1), y = rnorm(25, 11, 1.5)) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Data values for group 1 (controls). } \item{y}{ Data values for group 2 (cases). } } \details{ Density plots for the 2 groups will be created in the lower panel of the plot (colored red (group 1) and blue (group 2)) along with rug plots of the actual datapoints. There is also a green vertical line that represents a decision rule cutoff, any points higher than the cutoff are predicted to be in group 2 and points less than the cuttoff are predicted to be in group 1. The sensitivity and specificity for the current cuttoff value are printed below the plot. A Tk slider box is also created that allows you to move the cuttoff value and update the plots. As the cutoff value changes, the different combinations of sensitivity and specificity are added to the ROC curve in the top panel (the point corresponding to the current cuttoff value is highlighted in red). A line is also drawn from the point representing sensitivity and specificity both equal to 1 to the point closest to it. } \value{ No meaninful value is returned, this function is run solely for the side effects. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{slider}}, \code{ROC} function in package Epi, \code{auROC} in package limma, package ROC } \examples{ if(interactive()){ roc.demo() with(CO2, roc.demo(uptake[Type=='Mississippi'], uptake[Type=='Quebec'] ) ) } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ classif }% __ONLY ONE__ keyword per line TeachingDemos/man/normtest.Rd0000644000175100001440000000525712657235444015744 0ustar hornikusers\name{SnowsPenultimateNormalityTest} \alias{SnowsPenultimateNormalityTest} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Test the uninteresting question of whether the data represents an exact normal distribution. } \description{ This function tests the null hypothesis that the data comes from an exact normal population. This is a much less interesting/useful null than what people usually want, which is to know if the data come from a distribution that is similar enough to the normal to use normal theory inference. } \usage{ SnowsPenultimateNormalityTest(x) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ The data } } \details{ The theory for this test is based on the probability of getting a rational number from a truly continuous distribution defined on the reals. The main goal of this test is to quickly give a p-value for those that feel it necessary to test the uninteresting and uninformative null hypothesis that the data represents an exact normal, and allows the user to then move on to much more important questions, like "is the data close enough to the normal to use normal theory inference?". After running this test (or better instead of running this and any other test of normality) you should ask yourself what it means to test for normality and why you would want to do so. Then plot the data and explore the interesting/useful questions. } \value{ %% ~Describe the value returned %% If it is a LIST, use %% \item{comp1 }{Description of 'comp1'} %% \item{comp2 }{Description of 'comp2'} %% ... An object of class "htest" with components: \item{p.value}{The p-value} \item{alternative}{a string representing the alternative hypothesis} \item{method}{a string describing the method} \item{data.name}{a string describing the name of the data} } \references{ \code{fortune(234)} } \author{ Greg Snow \email{538280@gmail.com} } \note{ Note: if you just use this function and report the p-value then the function has failed in its purpose. If this function helps you to think about your analysis and what question(s) you are really interested in, create meaningful plots, and focus on the more meaningful parts of research, then it has succeeded. See also Cochrane's Aphorism. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{qqnorm}}, \code{\link{vis.test}} } \examples{ SnowsPenultimateNormalityTest(rt(100,25)) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ distribution } \keyword{ htest }% __ONLY ONE__ keyword per line TeachingDemos/man/sliderv.Rd0000644000175100001440000000475212657235444015540 0ustar hornikusers\name{sliderv} \alias{sliderv} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Create a Tk slider window } \description{ Create a Tk slider window with the sliders positioned vertically instead of horizontally. } \usage{ sliderv(refresh.code, names, minima, maxima, resolutions, starts, title = "control", no = 0, set.no.value = 0) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{refresh.code}{ Function to be called when sliders are moved. } \item{names}{ Labels for the sliders. } \item{minima}{ Vector of minimum values for the sliders. } \item{maxima}{ Vector of maximum values for the sliders. } \item{resolutions}{ Vector of resolutions for the sliders. } \item{starts}{ Vector of starting values for the sliders. } \item{title}{ Title to put at the top of the Tk box. } \item{no}{ The number of the slider whose value you want. } \item{set.no.value}{ Vector of length 2 with the number of slider to set and the new value. } } \details{ This is a variation on the \code{slider} function with vertical sliders arranged in a row rather than horizontal sliders arranged in a column. This is based on an early version of \code{slider} and therefore does not have as many bells and whistles (but sometimes fits the screen better). } \value{ Returns the value of a given slider when used as: \code{slider(no=i)}. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{538280@gmail.com} } \note{ You can move the slider in 3 different ways: You can left click and drag the slider itself, you can left click in the trough to either side of the slider and the slider will move 1 unit in the direction you clicked, or you can right click in the trough and the slider will jump to the location you clicked at. This function may not stay in this package (consider it semi-depricated). See the \code{\link{tkexamp}} function for another approach to do the same thing. } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{tkexamp}}, \code{\link{slider}} } \examples{ if(interactive()){ face.refresh <- function(...){ vals <- sapply(1:15, function(x) slider(no=x)) faces( rbind(0, vals, 1), scale=F) } sliderv( face.refresh, as.character(1:15), rep(0,15), rep(1,15), rep(0.05, 15), rep(0.5,15), title='Face Demo') } } \keyword{ dynamic }% at least one, from doc/KEYWORDS \keyword{ iplot} TeachingDemos/man/subplot.Rd0000644000175100001440000001426712657235444015562 0ustar hornikusers\name{subplot} \alias{subplot} %- Also NEED an '\alias' for EACH other topic documented here. \title{Embed a new plot within an existing plot} \description{ Subplot will embed a new plot within an existing plot at the coordinates specified (in user units of the existing plot). } \usage{ subplot(fun, x, y, size=c(1,1), vadj=0.5, hadj=0.5, inset=c(0,0), type=c('plt','fig'), pars=NULL) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{fun}{an expression defining the new plot to be embedded.} \item{x}{\code{x}-coordinate(s) of the new plot (in user coordinates of the existing plot), or a character string.} \item{y}{\code{y}-coordinate(s) of the new plot, \code{x} and \code{y} can be specified in any of the ways understood by \code{xy.coords}.} \item{size}{The size of the embedded plot in inches if \code{x} and \code{y} have length 1.} \item{vadj}{vertical adjustment of the plot when \code{y} is a scalar, the default is to center vertically, 0 means place the bottom of the plot at \code{y}, 1 places the top of the plot at \code{y}.} \item{hadj}{horizontal adjustment of the plot when \code{x} is a scalar, the default is to center horizontally, 0 means place the left edge of the plot at \code{x}, and 1 means place the right edge of the plot at \code{x}.} \item{inset}{1 or 2 numbers representing the proportion of the plot to inset the subplot from edges when x is a character string. The first element is the horizontal inset, the second is the vertical inset.} \item{type}{Character string, if 'plt' then the plotting region is defined by \code{x}, \code{y}, and \code{size} with axes, etc. outside that box; if 'fig' then all annotations are also inside the box.} \item{pars}{a list of parameters to be passed to \code{par} before running \code{fun}.} } \details{ The coordinates \code{x} and \code{y} can be scalars or vectors of length 2. If vectors of length 2 then they determine the opposite corners of the rectangle for the embedded plot (and the parameters \code{size}, \code{vadj}, and \code{hadj} are all ignored). If \code{x} and \code{y} are given as scalars then the plot position relative to the point and the size of the plot will be determined by the arguments \code{size}, \code{vadj}, and \code{hadj}. The default is to center a 1 inch by 1 inch plot at \code{x,y}. Setting \code{vadj} and \code{hadj} to \code{(0,0)} will position the lower left corner of the plot at \code{(x,y)}. If \code{x} is a character string, then it will be parsed for the strings "left", "right", "top", and "bottom" and x and y will be set appropriately (anything not specified will be set at the center in that dimension) using also the \code{inset} argument. This allows the position of the subplot to be specified as 'topleft' or 'bottom', etc. The \code{inset} argument is in proportion of the plot units, so 0.1 means inset 10\% of the width/height of the plotting distance. If \code{hadj}/\code{vadj} are not specified, they will be set appropriately. The rectangle defined by \code{x}, \code{y}, \code{size}, \code{vadj}, and \code{hadj} will be used as the plotting area of the new plot. Any tick marks, axis labels, main and sub titles will be outside of this rectangle if \code{type} is 'plt'. If type is 'fig' then the annotations will be inside the box. Any graphical parameter settings that you would like to be in place before \code{fun} is evaluated can be specified in the \code{pars} argument (warning: specifying layout parameters here (\code{plt}, \code{mfrow}, etc.) may cause unexpected results). After the function completes the graphical parameters will have been reset to what they were before calling the function (so you can continue to augment the original plot). } \value{ An invisible list with the graphical parameters that were in effect when the subplot was created. Passing this list to \code{par} will enable you to augment the embedded plot. } %\references{ ~put references to the literature/web site here ~ } \author{Greg Snow \email{538280@gmail.com}} %\note{ ~~further notes~~ } % ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{\code{\link{grconvertX}}, \code{\link{par}}, \code{\link{symbols}}, \code{\link{my.symbols}}, \code{\link{ms.image}}} \examples{ # make an original plot plot( 11:20, sample(51:60) ) # add some histograms subplot( hist(rnorm(100)), 15, 55) subplot( hist(runif(100),main='',xlab='',ylab=''), 11, 51, hadj=0, vadj=0) subplot( hist(rexp(100, 1/3)), 20, 60, hadj=1, vadj=1, size=c(0.5,2) ) subplot( hist(rt(100,3)), c(12,16), c(57,59), pars=list(lwd=3,ask=FALSE) ) ### some of the following examples work fine in an interactive session, ### but loading the packages required does not work well in testing. # augment a map if( interactive() && require(maptools) ){ plot(state.vbm,fg=NULL) tmp <- cbind( state.vbm$center_x, state.vbm$center_y ) for( i in 1:50 ){ tmp2 <- as.matrix(USArrests[i,c(1,4)]) tmp3 <- max(USArrests[,c(1,4)]) subplot( barplot(tmp2, ylim=c(0,tmp3),names=c('',''),yaxt='n'), x=tmp[i,1], y=tmp[i,2], size=c(.1,.1)) } } tmp <- rnorm(25) qqnorm(tmp) qqline(tmp) tmp2 <- subplot( hist(tmp,xlab='',ylab='',main=''), grconvertX(0.1,from='npc'), grconvertY(0.9,from='npc'), vadj=1, hadj=0 ) abline(v=0, col='red') # wrong way to add a reference line to histogram # right way to add a reference line to histogram op <- par(no.readonly=TRUE) par(tmp2) abline(v=0, col='green') par(op) # scatter-plot using images if(interactive() && require(png)) { image.png <- function(x,...) { cols <- rgb( x[,,1], x[,,2], x[,,3], x[,,4] ) z <- 1:length(cols) dim(z) <- dim(x[,,1]) z <- t(z) z <- z[ ,rev(seq_len(ncol(z))) ] image(z, col=cols, axes=FALSE, ...) } logo <- readPNG(system.file("img", "Rlogo.png", package="png")) x <- runif(10) y <- runif(10) plot(x,y, type='n') for(i in 1:10) { subplot(image.png(logo), x[i], y[i], size=c(0.3,0.3)) } } } \keyword{aplot}% at least one, from doc/KEYWORDS \keyword{dplot} TeachingDemos/man/hpd.Rd0000644000175100001440000000324412657235444014636 0ustar hornikusers\name{hpd} \alias{hpd} \alias{emp.hpd} \title{Compute Highest Posterior Density Intervals} \description{ Compute the Highest Posterior Density Interval (HPD) from an inverse density function (hpd) or a vector of realizations of the distribution (emp.hpd). } \usage{ hpd(posterior.icdf, conf=0.95, tol=0.00000001,...) emp.hpd(x, conf=0.95) } \arguments{ \item{posterior.icdf}{ Function, the inverse cdf of the posterior distribution (usually a function whose name starts with 'q').} \item{x}{ A vector of realizations from the posterior distribution.} \item{conf}{ Scalar, the confidence level desired. } \item{tol}{ Scalar, the tolerance for \code{optimize}.} \item{\dots}{Additional arguments to \code{posterior.icdf}.} } \details{ These functions compute the highest posterior density intervals (sometimes called minimum length confidence intervals) for a Bayesian posterior distribution. The \code{hpd} function is used when you have a function representing the inverse cdf (the common case with conjugate families). The \code{emp.hpd} function is used when you have realizations of the posterior (when you have results from an MCMC run). } \value{ A vector of length 2 with the lower and upper limits of the interval. } \author{ Greg Snow \email{538280@gmail.com}} \note{These functions assume that the posterior distribution is unimodal, they compute only 1 interval, not the set of intervals that are appropriate for multimodal distributions.} \seealso{\code{hdr} in the hdrcde package.} \examples{ hpd(qbeta, shape1=50, shape2=250) tmp <- rbeta(10000, 50, 250) emp.hpd(tmp) } \keyword{univar} TeachingDemos/man/outliers.Rd0000644000175100001440000000343712657235444015735 0ustar hornikusers\name{outliers} \alias{outliers} \docType{data} \title{ Outliers data } \description{ This dataset is approximately bell shaped, but with some outliers. It is meant to be used for demonstration purposes. If students are tempted to throw out all outliers, then have them work with this data (or use a scaled/centered/shuffled version as errors in a regression problem) and see how many throw away 3/4 of the data before rethinking their strategy. } \usage{data(outliers)} \format{ The format is: num [1:100] -1.548 0.172 -0.638 0.233 -0.228 ... } \details{ This is simulated data meant to demonstrate "outliers". } \source{ Simulated, see the examples section. } %\references{ %% ~~ possibly secondary sources and usages ~~ %} \examples{ data(outliers) qqnorm(outliers) qqline(outliers) hist(outliers) o.chuck <- function(x) { # function to throw away outliers qq <- quantile(x, c(1,3)/4, names=FALSE) r <- diff(qq) * 1.5 tst <- x < qq[1] - r | x > qq[2] + r if(any(tst)) { cat('Removing ', paste(x[tst], collapse=', '), '\n') x <- x[!tst] out <- Recall(x) } else { out <- x } out } x <- o.chuck( outliers ) length(x) if(require(MASS)) { char2seed('robust') x <- 1:100 y <- 3 + 2*x + sample(scale(outliers))*10 plot(x,y) fit <- lm(y~x) abline(fit, col='red') fit.r <- rlm(y~x) abline(fit.r, col='blue', lty='dashed') rbind(coef(fit), coef(fit.r)) length(o.chuck(resid(fit))) } ### The data was generated using code similar to: char2seed('outlier') outliers <- rnorm(25) dir <- 1 while( length(outliers) < 100 ){ qq <- quantile(c(outliers, dir*Inf), c(1,3)/4) outliers <- c(outliers, qq[ 1.5 + dir/2 ] + dir*1.55*diff(qq) + dir*abs(rnorm(1)) ) dir <- -dir } } \keyword{datasets} TeachingDemos/man/R2txt.Rd0000644000175100001440000002251112657235444015104 0ustar hornikusers\name{txtStart} \alias{txtStart} \alias{txtStop} \alias{txtComment} \alias{txtSkip} \alias{etxtStart} \alias{etxtStop} \alias{etxtComment} \alias{etxtSkip} \alias{etxtPlot} \alias{wdtxtStart} \alias{wdtxtStop} \alias{wdtxtComment} \alias{wdtxtSkip} \alias{wdtxtPlot} \alias{mdtxtStart} \alias{mdtxtStop} \alias{mdtxtComment} \alias{mdtxtSkip} \alias{mdtxtPlot} \title{Save a transcript of commands and/or output to a text file. } \description{ These functions save a transcript of your commands and their output to a script file, possibly for later processing with the "enscript" or "pandoc" program. They work as a combinations of \code{sink} and \code{history} with a couple extra bells and whistles. } \usage{ txtStart(file, commands=TRUE, results=TRUE, append=FALSE, cmdfile, visible.only=TRUE) txtStop() txtComment(txt,cmdtxt) txtSkip(expr) etxtStart(dir = tempfile("etxt"), file = "transcript.txt", commands = TRUE, results = TRUE, append = FALSE, cmdbg = "white", cmdcol = "red", resbg = "white", rescol = "navy", combg = "cyan", comcol = "black", cmdfile, visible.only = TRUE) etxtStop() etxtComment(txt, cmdtxt) etxtSkip(expr) etxtPlot(file=paste(tempfile('plot',R2txt.vars$dir),'.eps',sep=''), width=4, height=4) wdtxtStart(commands=TRUE, results=TRUE, fontsize=9, cmdfile, visible.only=TRUE) wdtxtStop() wdtxtComment(txt,cmdtxt) wdtxtSkip(expr) wdtxtPlot(height=5, width=5, pointsize=10) mdtxtStart(dir=tempfile('mdtxt'), file='transcript.md', commands=TRUE, results=TRUE, append=FALSE, cmdfile, visible.only=TRUE) mdtxtStop() mdtxtComment(txt,cmdtxt) mdtxtSkip(expr) mdtxtPlot(file=tempfile('plot',R2txt.vars$dir,'.png'), width=4, height=4) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{dir}{ Directory to store transcript file and any graphics file in } \item{file}{ Text file to save transcript in } \item{commands}{ Logical, should the commands be echoed to the transcript file } \item{results}{ Logical, should the results be saved in the transcript file } \item{append}{ Logical, should we append to \code{file} or replace it } \item{cmdbg}{ Background color for command lines in \code{file} } \item{cmdcol}{ Color of text for command lines in \code{file} } \item{resbg}{ Background color for results sections in \code{file} } \item{rescol}{ Text color of results sections in \code{file} } \item{combg}{ Background color for comments in \code{file} } \item{comcol}{ Text color of comments in \code{file} } \item{cmdfile}{ A filename to store commands such that it can be \code{source}d or copied and pasted from } \item{visible.only}{ Should non-printed output be included, not currently implemented.} \item{txt}{Text of a comment to be inserted into \code{file} } \item{cmdtxt}{Text of a comment to be inserted into \code{cmdfile} } \item{expr}{An expression to be executed without being included in \code{file} or \code{cmdfile} } \item{width}{Width of plot, passed to \code{dev.copy2eps}, \code{wdPlot}, or \code{dev.copy}} \item{height}{Height of plot, passed to \code{dev.copy2eps}, \code{wdPlot}, or \code{dev.copy}} \item{fontsize}{Size of font to use in MSWord} \item{pointsize}{ passed to \code{wdPlot} } } \details{ These functions are used to create transcript/command files of your R session. There are 4 sets of functions, those starting with "txt",those starting with "etxt", and those starting with "wdtxt" and those starting with "mdtxt". The "txt" functions create a plain text transcript while the "etxt" functions create a text file with extra escapes and commands so that it can be post processed with enscript (an external program) to create a postscript file and can include graphics as well. The postscript file can be converted to pdf or other format file. The "wdtxt" functions will insert the commands and results into a Microsoft Word document. The "mdtxt" functions create a text file but with MarkDown escapes so that it can be post processed with "pandoc" (an external program) to create other formats such as html, pdf, MS Word documents, etc. If the command starts with the string "pander" or "pandoc" (after optional whitespace) then the results will be inserted directly, without escapes, into the transcript file. This assumes that you are using code from the "pander" package which generates markdown formatted output. This will create nicer looking tables and other output. If \code{results} is TRUE and \code{commands} is FALSE then the result is similar to the results of \code{sink}. If \code{commands} is true as well then the transcript file will show both the commands and results similar to the output on the screen. If both \code{commands} and \code{results} are FALSE then pretty much the only thing these functions will accomplish is to waste some computing time. If \code{cmdfile} is specified then an additional file is created with the commands used (similar to the \code{history} command), this file can be used with \code{source} or copied and pasted to the terminal. The Start functions specify the file/directory to create and start the transcript, \code{wdtxtStart} will open Word if it is not already open or create a connection to an open word window. The prompts are changed to remind you that the commands/results are being copied to the transcript. The Stop functions stop the recording and reset the prompts. The R parser strips comments and does some reformatting so the transcript file may not match exactly with the terminal output. Use the \code{txtComment}, \code{etxtComment}, \code{wdtxtComment}, or \code{mdtxtComment} functions to add a comment. This will show up as a line offset by whitespace in the transcript file, highlighted in the etxt version, and the default font in Word. If \code{cmdtxt} is specified then that line will be inserted into \code{cmdfile} preceded by a \# so it will be skipped if sourced or copied. The \code{txtSkip}, \code{etxtSkip}, \code{wdtxtSkip}, and \code{mdtxtSkip} functions will run the code in \code{expr} but will not include the commands or results in the transcript file (this can be used for side computations, or requests for help, etc.). The \code{etxtPlot} function calls \code{dev.copy2eps} to create a copy of the current plot and inserts the proper command into the transcript file so that the eps file will be included in the final postscript file after processing. The \code{wdtxtPlot} function calls \code{wdPlot} to send a copy of the current graph to MS Word. The \code{mdtxtPlot} function calls \code{dev.copy} to create a copy of the current plot as a .png file and inserts the proper command into the transcript file so that the .png file will be included when processing with pandoc. } \value{ Most of these commands do not return anything of use. The exceptions are: \code{etxtStop} returns the name of the transcript file (including the directory path). \code{txtSkip}, \code{etxtSkip}, \code{wdtxtSkip}, and \code{mdtxtSkip} return the value of \code{expr}. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow, \email{538280@gmail.com} } \note{ These commands do not do any fancy formatting of output, just what you see in the regular terminal window. If you want more formatted output then you should look into \code{Sweave}, \code{knitr}, or the R2HTML package. The MS word functions will insert into the current word document at the location of the cursor. This means that if you look at the document and move the current location to somewhere in the middle (or have another word document open with the location in the middle), when you go back to R, the new transcript will be inserted into the middle of the document. So be careful to position the cursor at the end of the correct document before going back to R. Note that the "wdtxt" functions depend on the "R2wd" package which in turn depends on tools that are not free. Do not use these functions in combination with R2HTML or \code{sink}. Only one of these sets of functions will work at a time. } \seealso{\code{\link{sink}}, \code{\link{history}}, \code{\link{Sweave}}, the odfWeave package, the R2HTML package, the R2wd package, the pander package } \examples{ \dontrun{ etxtStart() etxtComment('This is todays transcript') date() x <- rnorm(25) summary(x) stem(x) etxtSkip(?hist) hist(x) etxtPlot() Sys.Date() Sys.time() my.file <- etxtStop() # assumes enscript and ps2pdf are on your path system(paste('enscript -e -B -p transcript.ps ', my.file) ) system('ps2pdf transcript.ps') # if the above commands used mdtxt instead of etxt and the pandoc # program is installed and on your path (and dependent programs) then use: system(paste('pandoc -o transcript.docx ', my.file)) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ character } \keyword{ IO }% __ONLY ONE__ keyword per line \keyword{ utilities }