TeachingDemos/0000755000176000001440000000000012077260443013021 5ustar ripleyusersTeachingDemos/MD50000644000176000001440000002041112077260443013327 0ustar ripleyusers65cfa4d9e52eb662794300cc13ce90e4 *DESCRIPTION 28f345b76de3298c46c8cde0d989452a *NAMESPACE 517ebbd0821fa81f0d13592e6137a945 *NEWS 0201f22d0b9a3b0192f9f9cd825cba45 *R/00vars.R 8902674892ccc4f3cd92d2829e078f11 *R/HWidentify.R 83ca905a7ae454a8a35245beb2ec5d16 *R/Pvalue.sim.R 593e228f1e2a53748ba5580f1bdc902c *R/R2txt.R 7ecfb3aa2895a43029ea4888fb432a35 *R/SensSpec.demo.R 06321e3597d94a064d65f4f41fec3ff8 *R/TkApprox.R 00bd4273b92b7bc9179f47f71f23dd6d *R/TkBuildDist.R ab99deefd8c8b3b916be24c1bd56c6c1 *R/TkListView.R fa736158ba3b4465d70d9105c26dd972 *R/TkPredict.R 1cb88921a6a8720b20262a5680947569 *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 f33d4e761db262fa6d5962728ba20b23 *R/dice.R cfb05736198fa3001b3cd2404f1c0863 *R/dots.R 75c43e07e0ba4d2168a5b89753ae60c9 *R/dots2.R 3512f842efbe109487d3f984ec3dc8e5 *R/dynIdentify.R f46e5b70e090c67c76c66a8dd617030f *R/face2.plot.R 23bd6d628aa18b7aff73a6a454a61f97 *R/faces.R 60a3c70e663c040ee28c2914e730d187 *R/faces2.R 6ab826228e3c7a923df2fb14c68cae31 *R/fagan.R 19ae4f4806c2ddd16c131620c6d9935d *R/flip.rgl.coin.R 16973a33ec9bc005787bf9c04f9f0b53 *R/gnuplot.R e15423f4e966dfd9a1f2cc6f7a8cb1fc *R/gp.splot.R 18616d8ebd4e9df7de968d762d8d86e3 *R/hpd.R 4ab586b3ac5e572617665aa96e83994f *R/ineq.R 232ad0c64a21f23c9fd94aa285fa5ca5 *R/lattice.demo.R a9b444dc84c8d8d9f9cefe675c0ff729 *R/loess.demo.R e65860386d73c9eaecf9c1033e8466b8 *R/mle.demo.R 9a1cc2a1fb484564769868e675218c60 *R/ms.face.R cd41a12c871bcdb4a108e7c9f7468b50 *R/mysymbols.R 328876dd059347545fba20628ff66a92 *R/pairs2.R 7cc9d028c3d1110eb80bd0fca82e9d87 *R/panel.dice.R d609da3db032961f341ed417dbd94804 *R/panel.mysymbols.R f9de73949f5e9682758562fd25e89378 *R/petals.R 5ac205f2c958d8395315ce3364454e1c *R/plot.dice.R f7037ba702afa4c3cf300af593a55901 *R/plot.rgl.coin.R b7561654b8b713a8848576ccda2f55c1 *R/plot.rgl.die.R 7ca8250a004e016a81e0a7b339f09ad5 *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 df8e8f60bc34cc1962be33cb4c02da6a *R/rgl.Map.R 8387f29cf1d9615e86b50823b6385a07 *R/roc.demo.R e123c0bff5e475d2be2afafb9065e906 *R/roll.rgl.die.R 8118f4ab359e8a1409444470f6e0a9f4 *R/rotate.cloud.R 93f220fba9c909199323720b6807b772 *R/rotate.persp.R 2cf913f6a7e2bc90aeb5d575a0837461 *R/rotate.wireframe.R 701daccf6dbac56e14cc79cf4f4318bf *R/run.ci.examp.R 55fe77be89976baa7d8bdd590d0a9e54 *R/run.cor.examp.R 9cf15dcfda2f09e9a08a5bf0abb60896 *R/run.cor2.examp.R e30f290304d3c45007899418f962f625 *R/run.hist.demo.R 6b7e99b54c6269cd3b331e93aa8b5d19 *R/run.old.cor.examp.R 3a1ab980a64da6c9a2cbcb822905b863 *R/run.old.cor2.examp.R 5a99c0fe5afe5ac0cb766415dab040bc *R/run.power.examp.R 32cc8235b557c88bc1822498cd14de25 *R/shadowtext.R 4a6219248da317cb6468c6bd1ecd8b9e *R/sigma.test.R dd1193805d3e6d1ef0f67a58013dd73a *R/simfun.R 3aa38aa3dc9f7be125ea33ed8dce8361 *R/slideRule.R b21fef36da47634c9b5a9b8062848a1c *R/slider.R cddf473111b372de1929cc8f28863709 *R/sliderv.R c279ead2d78b0935f7f48baef12328aa *R/spread.labs.R a790112260956733a2cd64248dae7482 *R/squishplot.R 20a3da9bf4e43dbac9c70ae419a8cd9f *R/subplot.R 205f932d660fd861ad3cf16337571895 *R/tdspinner.R 9a381b4e07d68970477905a3b89515d1 *R/tests.R ef52505b1e58775abad13e824040b8d1 *R/tkBrush.R 5037cf9e27735b4d52a4450d223d60cd *R/tkexamp.R 9b5c7069c94891cb5eaf6a33bade4776 *R/tree.demo.R b746c38e083349a75fa6380f184eb339 *R/triplot.R c013c03f9282e177b78ec3f31d1e4b06 *R/updateusr.R 1415191fdcdd0c9b9bce249e7345cad0 *R/vis.binom.R 6b644a07730f08d572478fc00a547376 *R/vis.boxcox.R 6ff8f528580c13186f830d17ddb30eae *R/vis.boxcoxu.R 59413d68d1ce42b7ec4ed0ff7f8336dd *R/vis.gamma.R d53bf86ebd1e7042ce35561e6089403e *R/vis.normal.R bb72d8e3b818e266747b7dbc0aff4028 *R/vis.t.R bb9b7dbe8e5cd644987625fc15169537 *R/vis.test.R e781bd345097e2e0d8f18815a80f6567 *R/z.test.R 74b2a543c1eec19c21e5293be106e77b *data/USCrimes.rda 56803ee928e023de329581717b807dc8 *data/coin.faces.rda 4728bd3317f687aea5de32efb6e56441 *data/evap.rda add77eb288b1c16a2b43e2fef2da627a *data/gps.rda 4414807b119113310b4bb1da95296b9b *data/ldsgrowth.rda 784924a35765f7b80d6055cf40e4204a *data/outliers.rda 5ce0925246f15845cd06ffb94af23552 *data/stork.rda bfdb260d000a9142cd49363b52c36c16 *man/HWidentify.Rd d105df0d833ddbd32cf33be2c03a6c32 *man/Pvalue.sim.Rd 35cbdc4e35c8e65320e2d0cc1d91c3d6 *man/R2txt.Rd e2f1b22a4834ec8dcbd3354bb9d44863 *man/SensSpec.demo.Rd 3b8ca23b1acb622a2b27d0c56063bdf3 *man/TeachingDemos-package.Rd f8bb80c065d1b6c0347e328f128a7e2d *man/TkApprox.Rd 32f8d2227e2144bc4113b5bc16ef2937 *man/TkBuildDist.Rd 82590c711653c567e9e78b96d414b708 *man/TkListView.Rd eaf70c0e28f10f8d3b2d2d96fd45900d *man/TkPredict.Rd cac6264f79e7dfd8412f274f64eb77fd *man/TkSpline.Rd f5ec21d2bad43aa79c83f50bfb56521d *man/USCrimes.Rd f7c45e1a57c4994c137425b67288fdaf *man/bct.Rd 901e84afb3d20d7f9c58861c24aee0a7 *man/cal.Rd 9e251af8547372c52f9f087aa9aa5998 *man/ccc.Rd e1243bcba0cb6b09e14be9ddbe4e99bf *man/char2seed.Rd 3509dffd96e7fb1de633f76a7ae9d1a0 *man/chisq.detail.Rd f629daab0505bc067371dcba7c3cedbd *man/ci.examp.Rd 00c775c99a330a26fadb8493244ce312 *man/clipplot.Rd 642c5d292e2b0bef388b7c6d4461ed27 *man/clt.examp.Rd d307753a5f44a8b1eb9d061dc7e09e89 *man/cnvrt.coords.Rd df72d98529a4ce786e9562812618341d *man/coin.faces.Rd ae9b9db0fb60794c59f8953bd244978f *man/col2grey.Rd b46d843bb39d817be93fb1e3a9b279ae *man/correct.Rd c34d8ee88d9fae14048a061e6f941fcf *man/cortest.Rd a42626f777bc47397b71cdb08689fee4 *man/dice.Rd 2aebfa0792d3b3abfba58af6822de836 *man/dots.Rd 6583f7fbd7f0a6b331005bbe9c273825 *man/dynIdentify.Rd 5c38ef7c17f19b90e608b66ef3885197 *man/evap.Rd 57210d622965fa97cb029ce8c4d9927e *man/faces.Rd c24be8cfdf870d6b3fc4bbd1d28e21a6 *man/faces2.Rd c49a5afb3843ec606e838682f8b28d1e *man/fagan.Rd a5c95f9cddf2297e8c7dc7c9e8d16691 *man/gp.open.Rd bad1b5ce5a56939b765d1ba7ebc876e7 *man/hpd.Rd 5698ef19e85e7f99b9dff05a8b889148 *man/ineq.Rd 54e18df4e93ed1febcc9edea9df28181 *man/lattice.demo.Rd 93342564a8107e5efcd2f4abd4f7492e *man/ldsgrowth.Rd 38261a08d11f04a7127631689c009785 *man/loess.demo.Rd 9f90886b3a25df89c212698ccdffb10a *man/mle.demo.Rd 4f1e6ea06cdddaf7dbcac3d286084182 *man/ms.polygram.Rd 876c07848c3043c14697bf2d445888d1 *man/mysymbols.Rd f83574c1e0d8d5a9b4b5e04f9c86e70c *man/normtest.Rd 56de9a1a4dc69c5ed1a0fbf2441f1459 *man/outliers.Rd ea1c81d3db9f9c476dae2dac75dcf715 *man/pairs2.Rd c807c06198e9e4eea1a6006355abcce1 *man/panel.mysymbols.Rd f8c71fe8c7d1c9891e69aa8a4d4ffab7 *man/petals.Rd 7a0c8b1523b7de13282b049edcb25e94 *man/plot.rgl.coin.Rd 7303fcaf0b1fea1003e4f83bda905cf6 *man/plot2script.Rd c823c83c1a176031a0d24a107d682bb2 *man/power.examp.Rd 028ac33a7fcaa5433aba9da6cde15e03 *man/put.points.demo.Rd 7b55ed33dc1c7abbb63bc0dd77622afb *man/rgl.Map.Rd ea1a714f52264d628bb0a29e6f5eb181 *man/roc.demo.Rd fafb7d5074318e6075d6497ac3fbb506 *man/rotate.cloud.Rd a88188c885617c38fdb18efc467cb45d *man/run.cor.examp.Rd ec6f1a89f76a4d919ddaaaee6b653e87 *man/run.hist.demo.Rd 09bd515f44fb1a2cfa253a0dfd4eb2e1 *man/shadowtext.Rd 7191be405ba55cab450201b814aa7740 *man/sigma.test.Rd e97c9055ecda8a1847977d715b166cdc *man/simfun.Rd 0fcfc6292b9b8e16b8113fca2036014a *man/slider.Rd c23f92608c56983008e88e0957acb8c9 *man/sliderv.Rd d9ec3befbf8c903b98a2ad81ff78b610 *man/spread.labs.Rd bd697186bc845d7b41be2641785fa2fb *man/squishplot.Rd 939e0eda45e163643a0011bf565e66ff *man/stork.Rd 1a7234183a67d016c36e1f89daeb22f1 *man/subplot.Rd a381f6eec48a093fac089a1eb114360d *man/tkBrush.Rd ca22d309f8f192187f982879ccf8b56b *man/tkexamp.Rd 83352bb20a756192e6b384cd0c53370c *man/tree.demo.Rd 611afcc78ec1c6d432c5480615fdc61f *man/triplot.Rd e548550b6527d65b4ed0a810da97a65f *man/updateusr.Rd 36dfe89e305c23688637fabd57561ead *man/vis.binom.Rd 17cf15b3e722f3edc513750f89dd6ca5 *man/vis.boxcox.Rd 64ef1f79242d00235ca9f6af373d1c9c *man/vis.test.Rd 0cb0ac89b31f006249b8a71066940ff6 *man/z.test.Rd 35e2c70e100d543a3c4a7a476a5e0f04 *man/zoomplot.Rd TeachingDemos/NEWS0000644000176000001440000001710412077032222013513 0ustar ripleyusersNew 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/man/0000755000176000001440000000000012077040012013560 5ustar ripleyusersTeachingDemos/man/run.cor.examp.Rd0000644000176000001440000000460111270200433016546 0ustar ripleyusers\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{greg.snow@imail.org} } \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/panel.mysymbols.Rd0000644000176000001440000001025511270200433017205 0ustar ripleyusers\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{greg.snow@imail.org}} \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/z.test.Rd0000644000176000001440000000426411270200433015303 0ustar ripleyusers\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, conf.level = 0.95, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Vector of data values. } \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{conf.level}{ Confidence level for the interval computation. } \item{\dots}{ Additional arguments are silently ignored. } } \details{ Most 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{greg.snow@imail.org} } \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/TkBuildDist.Rd0000644000176000001440000000610311710120471016232 0ustar ripleyusers\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{greg.snow@imail.org}} \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/col2grey.Rd0000644000176000001440000000213611270200433015576 0ustar ripleyusers\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{greg.snow@imail.org} } \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/tree.demo.Rd0000644000176000001440000000346311270200433015736 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/vis.test.Rd0000644000176000001440000002005111376605635015647 0ustar ripleyusers\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 indication 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{greg.snow@imail.org}} %% ~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/subplot.Rd0000644000176000001440000001423612074430242015552 0ustar ripleyusers\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{greg.snow@imail.org}} %\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}}} \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(EBImage)) { image.EBImage <- function(x,...) { tmp <- imageData(flip(x)) cols <- rgb( tmp[,,1], tmp[,,2], tmp[,,3] ) z <- 1:length(cols) dim(z) <- dim(tmp[,,1]) image(z, col=cols, axes=FALSE, ...) } logo <- readImage( paste( R.home('doc'), '/html/logo.jpg', sep='' ) ) x <- runif(10) y <- runif(10) plot(x,y, type='n') for(i in 1:10) { subplot(image.EBImage(logo), x[i], y[i], size=c(0.3,0.3)) } } } \keyword{aplot}% at least one, from doc/KEYWORDS \keyword{dplot} TeachingDemos/man/gp.open.Rd0000644000176000001440000000547511726220074015440 0ustar ripleyusers\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{greg.snow@imail.org} } \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/spread.labs.Rd0000644000176000001440000000622111270200433016245 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/outliers.Rd0000644000176000001440000000343711333063510015726 0ustar ripleyusers\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/fagan.Rd0000644000176000001440000000546211270200433015131 0ustar ripleyusers\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{greg.snow@imail.org}} \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/correct.Rd0000644000176000001440000000517112075624630015530 0ustar ripleyusers\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{greg.snow@imail.org}} \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/simfun.Rd0000644000176000001440000002214411760177141015367 0ustar ripleyusers\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{greg.snow@imail.org}} \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/power.examp.Rd0000644000176000001440000000623011270200433016314 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/sliderv.Rd0000644000176000001440000000475211270200433015526 0ustar ripleyusers\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{greg.snow@imail.org} } \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/Pvalue.sim.Rd0000644000176000001440000000665611270200433016106 0ustar ripleyusers\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{greg.snow@imail.org}} \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/put.points.demo.Rd0000644000176000001440000000426411270200433017122 0ustar ripleyusers\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. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{greg.snow@imail.org} } %\note{ ~~further notes~~ } \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/petals.Rd0000644000176000001440000000671212074430242015352 0ustar ripleyusers\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{greg.snow@imail.org} %% ~~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/R2txt.Rd0000644000176000001440000002251412076553755015124 0ustar ripleyusers\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{greg.snow@imail.org} } \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 }TeachingDemos/man/cal.Rd0000644000176000001440000000576711700374422014634 0ustar ripleyusers\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{greg.snow@imail.org}} \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/TkSpline.Rd0000644000176000001440000000541711270200433015606 0ustar ripleyusers\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{greg.snow@imail.org}} %\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/tkexamp.Rd0000644000176000001440000002515312075624630015542 0ustar ripleyusers\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{greg.snow@imail.org}} \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/TkApprox.Rd0000644000176000001440000000557311270200433015630 0ustar ripleyusers\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{greg.snow@imail.org}} %\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/TeachingDemos-package.Rd0000644000176000001440000001156311545706127020177 0ustar ripleyusers\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{greg.snow@imail.org} } \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/ineq.Rd0000644000176000001440000000424111667306170015022 0ustar ripleyusers\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{greg.snow@imail.org} } \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/mle.demo.Rd0000644000176000001440000000455711270200433015561 0ustar ripleyusers\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{greg.snow@imail.org} } %\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.Rd0000644000176000001440000000423211270200433015555 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/plot2script.Rd0000644000176000001440000000506711270200433016343 0ustar ripleyusers\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{greg.snow@imail.org}} \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/ms.polygram.Rd0000644000176000001440000001075011700374422016331 0ustar ripleyusers\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{greg.snow@imail.org}} \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/rgl.Map.Rd0000644000176000001440000000324011314430534015353 0ustar ripleyusers\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{greg.snow@imail.org} } \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/vis.binom.Rd0000644000176000001440000000327611270200433015762 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/ccc.Rd0000644000176000001440000000461711272142221014610 0ustar ripleyusers\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/ldsgrowth.Rd0000644000176000001440000000234111700374422016073 0ustar ripleyusers\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/run.hist.demo.Rd0000644000176000001440000000212411270200433016542 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/normtest.Rd0000644000176000001440000000526212074430242015734 0ustar ripleyusers\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{greg.snow@imail.org} } \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/HWidentify.Rd0000644000176000001440000000471611426112106016132 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/clipplot.Rd0000644000176000001440000000504011270200433015673 0ustar ripleyusers\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{greg.snow@imail.org} } \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/tkBrush.Rd0000644000176000001440000000762411270200433015501 0ustar ripleyusers\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{greg.snow@imail.org}} \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/rotate.cloud.Rd0000644000176000001440000000441211270200433016452 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/bct.Rd0000644000176000001440000000251211301407170014620 0ustar ripleyusers\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{greg.snow@imail.org}} %\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/shadowtext.Rd0000644000176000001440000000415511333063510016250 0ustar ripleyusers\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{greg.snow@imail.org}} %\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/loess.demo.Rd0000644000176000001440000000636012074430242016131 0ustar ripleyusers\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. } %\references{ ~put references to the literature/web site here ~ } \author{ Greg Snow \email{greg.snow@imail.org} } %\note{ ~~further notes~~ } \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/TkPredict.Rd0000644000176000001440000001145412074430242015752 0ustar ripleyusers\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{greg.snow@imail.org}} \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/updateusr.Rd0000644000176000001440000000536111270200433016067 0ustar ripleyusers\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{greg.snow@imail.org} } \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/faces2.Rd0000644000176000001440000000706611667306170015241 0ustar ripleyusers\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{greg.snow@imail.org} } \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 available at \url{}, 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/TkListView.Rd0000644000176000001440000000646011710120471016123 0ustar ripleyusers\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{greg.snow@imail.org} } %\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)){ TkListView(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/sigma.test.Rd0000644000176000001440000000336011270430321016127 0ustar ripleyusers\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/pairs2.Rd0000644000176000001440000000534011352763345015271 0ustar ripleyusers\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{greg.snow@imail.org} } \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/lattice.demo.Rd0000644000176000001440000000415211270200433016420 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/faces.Rd0000644000176000001440000000520211667306170015145 0ustar ripleyusers\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/hpd.Rd0000644000176000001440000000325011270200433014621 0ustar ripleyusers\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{greg.snow@imail.org }} \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/vis.boxcox.Rd0000644000176000001440000000516711270200433016161 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/triplot.Rd0000644000176000001440000000625611270200433015554 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/dots.Rd0000644000176000001440000000275611270200433015031 0ustar ripleyusers\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{greg.snow@imail.org } } %\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/dynIdentify.Rd0000644000176000001440000000574611270200433016350 0ustar ripleyusers\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{greg.snow@imail.org} } \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/chisq.detail.Rd0000644000176000001440000000345411270200433016424 0ustar ripleyusers\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{greg.snow@imail.org}} %\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/char2seed.Rd0000644000176000001440000000401711270200433015710 0ustar ripleyusers\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{greg.snow@imail.org} } \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/ci.examp.Rd0000644000176000001440000000621611270200433015557 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/USCrimes.Rd0000644000176000001440000000746312075624630015567 0ustar ripleyusers\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/clt.examp.Rd0000644000176000001440000000505111270200433015742 0ustar ripleyusers\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{greg.snow@imail.org}} %\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/evap.Rd0000644000176000001440000000354411270200433015007 0ustar ripleyusers\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/squishplot.Rd0000644000176000001440000000470111270200433016263 0ustar ripleyusers\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{greg.snow@imail.org} } \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/SensSpec.demo.Rd0000644000176000001440000000450511270200433016520 0ustar ripleyusers\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{greg.snow@imail.org} } %\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/cortest.Rd0000644000176000001440000000604112074430242015540 0ustar ripleyusers\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{greg.snow@imail.org} } \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/plot.rgl.coin.Rd0000644000176000001440000000707112011512111016534 0ustar ripleyusers\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{plot.rgl.coin} a list with information for drawing the faces of the coin, defaults to \code{coin.faces}. For \code{plot.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{greg.snow@imail.org} } \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/zoomplot.Rd0000644000176000001440000000426311270200433015736 0ustar ripleyusers\name{zoomplot} \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 ) } \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. } \value{ This function is run for its side effects and does not return anything meaningful. } \author{Greg Snow \email{greg.snow@imail.org}} \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{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/coin.faces.Rd0000644000176000001440000000233511270200433016061 0ustar ripleyusers\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/stork.Rd0000644000176000001440000000265511270200433015220 0ustar ripleyusers\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/cnvrt.coords.Rd0000644000176000001440000001214011435561331016502 0ustar ripleyusers\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{greg.snow@imail.org}} \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/dice.Rd0000644000176000001440000000535111700374422014766 0ustar ripleyusers\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{greg.snow@imail.org }} \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/slider.Rd0000644000176000001440000002032711270200433015334 0ustar ripleyusers\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/mysymbols.Rd0000644000176000001440000001750111760215171016121 0ustar ripleyusers\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{greg.snow@imail.org}} \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/DESCRIPTION0000644000176000001440000000143612077260443014533 0ustar ripleyusersPackage: TeachingDemos Title: Demonstrations for teaching and learning Version: 2.9 Author: Greg Snow Description: This package is a set of 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 License: Artistic-2.0 Date: 2013-01-21 Suggests: tkrplot, lattice, MASS, rgl, tcltk, tcltk2, R2wd, EBImage, png, ggplot2, logspline, maptools LazyData: true KeepSource: true Repository: CRAN Repository/R-Forge/Project: teachingdemos Repository/R-Forge/Revision: 56 Repository/R-Forge/DateTimeStamp: 2013-01-20 18:58:51 Date/Publication: 2013-01-21 16:39:15 Packaged: 2013-01-20 19:15:19 UTC; rforge Depends: R (>= 2.10) TeachingDemos/NAMESPACE0000644000176000001440000000351112077032222014230 0ustar ripleyusersexport(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, 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,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) S3method(plot, dice) TeachingDemos/R/0000755000176000001440000000000012077040011013205 5ustar ripleyusersTeachingDemos/R/panel.mysymbols.R0000644000176000001440000000553711270200463016501 0ustar ripleyuserspanel.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(lpolygon, dots1) } else { do.call(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(lpolygon, dots) } else { do.call(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/vis.normal.R0000644000176000001440000001045611726220074015437 0ustar ripleyusers"vis.normal" <- function(){ if( !require(tcltk) ) stop('This function depends on the tcltk package') if(!exists('slider.env')) slider.env<<-new.env() #library(tcltk) mu <- 0; assign('mu',tclVar(mu),envir=slider.env) sd <- 1; assign('sd',tclVar(sd),envir=slider.env) s2 <- 1; assign('s2',tclVar(s2),envir=slider.env) xmin <- -5; assign('xmin',tclVar(xmin),envir=slider.env) xmax <- 5; assign('xmax',tclVar(xmax),envir=slider.env) ymin <- 0; assign('ymin',tclVar(ymin),envir=slider.env) ymax <- round(dnorm(0,0,.5),2); assign('ymax',tclVar(ymax),envir=slider.env) sd.old <- sd s2.old <- s2 norm.refresh <- function(...){ mu <- as.numeric(evalq(tclvalue(mu), envir=slider.env)) sd <- as.numeric(evalq(tclvalue(sd), envir=slider.env)) s2 <- as.numeric(evalq(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("tclvalue(s2)<-", s2,sep="")),envir=slider.env)); sd.old <<- sd; s2.old <<- s2 } if(s2 != s2.old) { s2 <- as.numeric(evalq(tclvalue(s2), envir=slider.env)) sd <- round(sqrt(s2),5); # assign('sd',tclVar('sd'), envir=slider.env) try(eval(parse(text=paste("tclvalue(sd)<-", sd,sep="")),envir=slider.env)); sd.old <<- sd; s2.old <<- s2 } xmin <- as.numeric(evalq(tclvalue(xmin), envir=slider.env)) xmax <- as.numeric(evalq(tclvalue(xmax), envir=slider.env)) ymin <- as.numeric(evalq(tclvalue(ymin), envir=slider.env)) ymax <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m,'Visualizing the Normal Distribution') tkwm.geometry(m,'+0+0') # mean tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Mean', width='20'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=mu),envir=slider.env) # sd tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Standard Deviation', width='20'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=sd),envir=slider.env) # variance tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Variance', width='20'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=s2),envir=slider.env) # xmin tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Xmin:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=xmin), envir=slider.env) # xmax tkpack(tklabel(fr, text='Xmax:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=xmax), envir=slider.env) # ymin tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Ymin:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=ymin), envir=slider.env) # ymax tkpack(tklabel(fr, text='Ymax:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=ymax), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=norm.refresh),side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') } TeachingDemos/R/squishplot.R0000644000176000001440000000211211757052235015556 0ustar ripleyuserssquishplot <- 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/rotate.cloud.R0000644000176000001440000000544411726220074015753 0ustar ripleyusers"rotate.cloud" <- function(x, ...){ if(!require(tcltk)){stop('The tcltk package is needed')} if(!exists('slider.env')) slider.env <<-new.env() lab1 <- 'z'; assign('lab1', tclVar(lab1), envir=slider.env) lab2 <- 'y'; assign('lab2', tclVar(lab2), envir=slider.env) lab3 <- 'x'; assign('lab3', tclVar(lab3), envir=slider.env) val1 <- 40; assign('val1', tclVar(val1), envir=slider.env) val2 <- 0; assign('val2', tclVar(val2), envir=slider.env) val3 <- -60; assign('val3', tclVar(val3), envir=slider.env) cloud.options <- list(...) cloud.refresh <- function(...){ lab1 <- evalq(tclvalue(lab1), envir=slider.env) lab2 <- evalq(tclvalue(lab2), envir=slider.env) lab3 <- evalq(tclvalue(lab3), envir=slider.env) val1 <- as.numeric(evalq(tclvalue(val1), envir=slider.env)) val2 <- as.numeric(evalq(tclvalue(val2), envir=slider.env)) val3 <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m,'Rotate Cloud plot') tkwm.geometry(m,'+0+0') # one tkpack(fr <- tkframe(m), side='top') tkpack(e <- tkentry(fr, width=2), side='left') tkpack(sc <- tkscale(fr, command=cloud.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=val1), envir=slider.env) assign('e',e,envir=slider.env) evalq(tkconfigure(e,textvariable=lab1), envir=slider.env) # two tkpack(fr <- tkframe(m), side='top') tkpack(e <- tkentry(fr, width=2), side='left') tkpack(sc <- tkscale(fr, command=cloud.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=val2), envir=slider.env) assign('e',e,envir=slider.env) evalq(tkconfigure(e,textvariable=lab2), envir=slider.env) # three tkpack(fr <- tkframe(m), side='top') tkpack(e <- tkentry(fr, width=2), side='left') tkpack(sc <- tkscale(fr, command=cloud.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=val3), envir=slider.env) assign('e',e,envir=slider.env) evalq(tkconfigure(e,textvariable=lab3), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=cloud.refresh),side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') } TeachingDemos/R/Pvalue.sim.R0000644000176000001440000001112511270200463015356 0ustar ripleyusersPvalue.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/TkSpline.R0000644000176000001440000001040511435561331015073 0ustar ripleyusers### to do: add tangent line, parabola, cubic TkSpline <- function(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, ...) { if( !require(tkrplot) ) stop('This function depends on the tkrplot package being available') snap.x <- tclVar() tclvalue(snap.x) <- ifelse(snap.to.x,"T","F") d1 <- tclVar() d2 <- tclVar() d3 <- tclVar() tclvalue(d1) <- 'F' tclvalue(d2) <- 'F' tclvalue(d3) <- 'F' xxx <- as.numeric(x) ax <- (min(x)+max(x))/2 sf <- splinefun(x, y, method=method) ay <- sf(ax) ay1 <- sf(ax, 1) ay2 <- sf(ax, 2) ay3 <- sf(ax, 3) yy <- c(ay,ay1,ay2,ay3) txtvar <- tclVar() tclvalue(txtvar) <- " \n \n \n " first <- TRUE ul <- ur <- 0 replot <- function() { par(mar=c(5,4,2,2)+0.1) plot(x,y, xlab=xlab, ylab=ylab, ...) u <- par('usr') curve(sf(x), from=u[1], to=u[2],add=TRUE) lines( c(ax,ax,u[1]), c(u[3], ay, ay), col=col ) mtext( format( ax, digits=digits), side=3, at=ax, line=1, col=col[1]) mtext( format( ay, digits=digits), side=4, at=ay, line=1, col=col[1]) if(as.logical(tclvalue(d1))) { curve( ay+(x-ax)*yy[2], from=u[1], to=u[2], add=TRUE, col=col[2]) } if(as.logical(tclvalue(d2))) { curve( ay+(x-ax)*yy[2]+((x-ax)^2)*yy[3], from=u[1], to=u[2], add=TRUE, col=col[3]) } if(as.logical(tclvalue(d3))) { curve( ay+(x-ax)*yy[2]+((x-ax)^2)*yy[3]+((x-ax)^3)*yy[4], from=u[1], to=u[2], add=TRUE, col=col[4]) } tclvalue(txtvar) <<- paste( c('y: ','d1: ','d2: ','d3: '), format( yy, digits=digits ), collapse='\n') if(first) { first <<- FALSE # tmp <- cnvrt.coords(c(0,1),c(0,1), input='dev')$usr tmpx <- grconvertX(c(0,1), from='ndc') ul <<- tmpx[1] ur <<- tmpx[2] } } tt <- tktoplevel() tkwm.title(tt, "TkSpline") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(fr <- tkframe(tt), side='left') tkpack(tkcheckbutton(fr,variable=d1, onvalue="T", offvalue="F", text="Show d1", command=function()tkrreplot(img)), side='top') tkpack(tkcheckbutton(fr,variable=d2, onvalue="T", offvalue="F", text="Show d2", command=function()tkrreplot(img)), side='top') tkpack(tkcheckbutton(fr,variable=d3, onvalue="T", offvalue="F", text="Show d3", command=function()tkrreplot(img)), side='top') tkpack(tklabel(tt, textvariable=txtvar), side='top') tkpack(tkcheckbutton(fr,variable=snap.x, onvalue="T", offvalue="F", text="Snap to points"), side='top') tkpack(tkbutton(tt,text='Quit', command=function() tkdestroy(tt)), side='right') md <- FALSE iw <- as.numeric(tcl('image','width',tkcget(img,'-image'))) ih <- as.numeric(tcl('image','height',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(tclvalue(snap.x))) { ccx <<- xxx[ which.min( abs(ccx-xxx) ) ] } ax <<- ccx ccy <<- sf(ccx) yy <<- c( ccy, sf(ccx,1), sf(ccx,2), sf(ccx,3) ) ay <<- ccy tkrreplot(img) } } mouse.down <- function(x,y) { md <<- TRUE mouse.move(x,y) } mouse.up <- function(x,y) { md <<- FALSE } tkbind(img, '', mouse.move) tkbind(img, '', mouse.down) tkbind(img, '', mouse.up) if(wait) { tkwait.window(tt) out <- list( x=ccx, y=yy ) } else { out <- NULL } invisible(out) } TeachingDemos/R/panel.dice.R0000644000176000001440000000154011270200463015335 0ustar ripleyusers"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) 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 } lpoints( tmp.x+xo, tmp.y+yo, pch=16,col='black') } } TeachingDemos/R/vis.boxcox.R0000644000176000001440000001025111726220074015442 0ustar ripleyusersvis.boxcox.old <- function(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1) ) { if( !require(tcltk) ) 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',tclVar(lam), envir=slider.env) bc.refresh <- function(...){ lam <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m, 'Box Cox Transform') tkwm.geometry(m,'+0+0') tkpack(fr <- tkframe(m), side='top') tkpack(tklabel(fr, text='lambda', width='10'), side='right') tkpack(sc <- 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(tkconfigure(sc, variable=lam), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=bc.refresh), side='left') tkpack(tkbutton(m, text="Exit", command=function()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( !require(tkrplot) ) 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 <- tclVar() tclvalue(lam) <- 1 hsc <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() tclvalue(vsc) <- hscale replot <- function(...) { tmp.l <- as.numeric(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 <- tktoplevel() tkwm.title(tt, "Box Cox Demo") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr, text='lambda: '), side='left', anchor='s') tkpack(tkscale(fr, variable=lam, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=-2, to=4, resolution=.05), side='right') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function() tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left',anchor='s') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tkwait.window(tt) return( list(lambda = as.numeric(tclvalue(lam)), x=x, y=y, ty = bct(y, as.numeric(tclvalue(lam))) )) } else { return(invisible(NULL)) } } TeachingDemos/R/run.cor.examp.R0000644000176000001440000000663211355474556016065 0ustar ripleyusers"run.old.cor.examp" <- function(n=100,seed) { if (!missing(seed)){ set.seed(seed) } if(!require(tcltk)){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( !require(tkrplot) ) 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 <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() tclvalue(vsc) <- vscale r <- tclVar() tclvalue(r) <- 0 replot <- function(...) { tmp.r <- as.numeric(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 <- tktoplevel() tkwm.title(tt, "Cor2 Example") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr,text='r: '), side='left',anchor='s') tkpack(tkscale(fr, variable=r, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=-1, to=1, resolution=0.01), side='right') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function() tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left',anchor='s') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait){ tkwait.window(tt) tmp.r <- as.numeric(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/tests.R0000644000176000001440000000351311757052235014513 0ustar ripleyusersSnowsPenultimateNormalityTest <- function(x){ # the following function works for current implementations of R # to my knowledge, eventually it may need to be expanded is.rational <- function(x){ rep( TRUE, length(x) ) } tmp.p <- if( any(is.rational(x))) { 0 } else { # current implementation will not get here if length # of x is positive. This part is reserved for the # ultimate test 1 } out <- list( p.value = tmp.p, alternative = strwrap(paste('The data does not come from a', 'strict normal distribution (but may represent a distribution', 'that is close enough)'), prefix="\n\t"), method = "Snow's Penultimate Normality Test", data.name = deparse(substitute(x)) ) class(out) <- 'htest' out } SnowsCorrectlySizedButOtherwiseUselessTestOfAnything <- function(x, data.name=deparse(substitute(x)), alternative='You Are Lucky', ..., seed) { if( !missing(seed) ) { if( is.numeric(seed) ) { set.seed(seed) } else { char2seed(seed) } } tmp.p <- runif(1) out <- list( p.value = tmp.p, data.name=data.name, method = "Snow's Correctly Sized But Otherwise Useless Test of Anything", alternative=alternative) if( !missing(seed) ) out$seed <- seed names(tmp.p) <- 'Random Uniform Value' out$statistic <- tmp.p class(out) <- 'htest' return(out) } TeachingDemos/R/mle.demo.R0000644000176000001440000000557711726220074015057 0ustar ripleyusers"mle.demo" <- function(x=rnorm(10, 10, 2), start.mean = mean(x)-start.sd, start.sd = 1.2* sqrt(var(x)) ){ if( !require(tcltk) ) stop('This function depends on the tcltk package.') if(!exists('slider.env')) slider.env <<- new.env() #library(tcltk) mu <- start.mean; assign('mu',tclVar(mu),envir=slider.env) sig <- start.sd; assign('sig',tclVar(sig),envir=slider.env) .mu <- .sig <- .ll <- numeric(0) mle.refresh <- function(...){ mu <- as.numeric(evalq(tclvalue(mu), envir=slider.env)) sig <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m,'Maximum Likelihood Estimation') tkwm.geometry(m, '+0+0') # mu tkpack(fr <- tkframe(m), side='top') tkpack(tklabel(fr, text='mu', width='10'), side='right') tmp <- pretty( c( start.mean - 2*start.sd, start.mean + 3*start.sd), 100) tkpack(sc <- 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(tkconfigure(sc, variable=mu), envir=slider.env) # sigma tkpack(fr <- tkframe(m), side='top') tkpack(tklabel(fr, text='sigma', width='10'), side='right') tmp <- pretty( c( 0.5*start.sd, 2*start.sd), 100) tkpack(sc <- 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(tkconfigure(sc, variable=sig), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=mle.refresh), side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') return(invisible(x)) } TeachingDemos/R/vis.test.R0000644000176000001440000001004711376605635015135 0ustar ripleyusersvis.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/gnuplot.R0000644000176000001440000000176111726220074015036 0ustar ripleyusersgpenv <- 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/TkBuildDist.R0000644000176000001440000001363511705033122015524 0ustar ripleyusersTkBuildDist <- 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 <- require(logspline) require(tkrplot) 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 <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ) lines( nx, 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( xxx ) lines( nx, 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 <- tktoplevel() tkwm.title(tt, "Distribution Builder") img <- tkrplot(tt, replot, vscale=1.5, hscale=1.5) tkpack(img, side='top') tkpack( tkbutton(tt, text='Quit', command=function() tkdestroy(tt)), side='right') iw <- as.numeric(tcl('image','width',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) 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] tkrreplot(img) } } tkbind(img, '', mouse1.down) tkbind(img, '', mouse2.down) tkbind(img, '', mouse2.down) tkwait.window(tt) out <- list(x=xxx) if(logspline) { if( intervals ) { xx <- cut(xxx, brks, labels=FALSE) out$logspline <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ) } else { out$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 <- require(logspline) require(tkrplot) 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 <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )) lines( nx, 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 <- tktoplevel() tkwm.title(tt, "Distribution Builder") img <- tkrplot(tt, replot, vscale=1.5, hscale=1.5) tkpack(img, side='top') tkpack( tkbutton(tt, text='Quit', command=function() tkdestroy(tt)), side='right') iw <- as.numeric(tcl('image','width',tkcget(img,'-image'))) ih <- as.numeric(tcl('image','height',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]) tkrreplot(img) } } } mouse.down <- function(x,y) { md <<- TRUE mouse.move(x,y) } mouse.up <- function(x,y) { md <<- FALSE } tkbind(img, '', mouse.move) tkbind(img, '', mouse.down) tkbind(img, '', mouse.up) tkwait.window(tt) out <- list(breaks=brks, probs=xxx) if(logspline) { xx <- rep( 1:nbin, round(xxx*100) ) out$logspline <- oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ) } return(out) } TeachingDemos/R/TkListView.R0000644000176000001440000001075112074430242015407 0ustar ripleyusersTkListView <- function(list){ if( !require(tcltk) ) { stop('This function is dependent on the tcltk package') } if( !have.ttk() ) { stop('this function depends on having tcl 8.5 or higher') } tt <- tktoplevel() tkwm.title(tt, deparse(substitute(list))) fr1 <- tkframe(tt) tkpack(fr1, '-side', 'left', '-fill', 'both', '-expand', 0) tree <- tcltk::ttktreeview(fr1, '-selectmode','browse','-columns',1,height=21) scrtree1 <- tkscrollbar(fr1, command=function(...)tkyview(tree,...)) tkconfigure(tree, yscrollcommand=function(...)tkset(scrtree1,...)) tkpack(scrtree1, side='right', fill='y',expand=1) tkpack(tree, side='right',fill='both',expand=1) fr2 <- tkframe(tt) tkpack(fr2, '-side','top','-fill','both','-expand',1) txt <- tktext(fr2, bg="white", font="courier", wrap='none', width=40) scrtxt1 <- tkscrollbar(fr2, command=function(...)tkyview(txt,...)) scrtxt2 <- tkscrollbar(fr2, command=function(...)tkxview(txt,...), orient='horizontal') tkconfigure(txt, yscrollcommand=function(...)tkset(scrtxt1,...), xscrollcommand=function(...)tkset(scrtxt2,...)) tkgrid(txt,scrtxt1, sticky='nsew') tkgrid(scrtxt2,sticky='nsew') tkgrid.columnconfigure(fr2, 0, weight=1) 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(' ','\\\\ ',str.info) n <- length(list) nms <- names(list) if( is.null(nms) ) nms <- rep('', n) for( i in seq(length.out=n) ){ id <- paste(parent, '.', i, sep='') nm <- nms[i] if(nm == '') nm <- paste('[[',i,']]',sep='') 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]])) ) { 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) ) { tkinsert(tree, parent, 'end', '-id', paste(parent,'.aa',sep=''), '-text', '<>') Recall( tmp, tree, paste(parent,'.aa',sep='') ) } } buildtree(list, tree, '') getx <- function(list){ tmp <- tclvalue(tkselect(tree)) tmp2 <- strsplit(tmp, '\\.')[[1]][-1] 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 <- tkbutton(tt, text='print', command=function(...) { tmp <- capture.output(print(getx(list))) tkdelete(txt, '1.0','end') tkinsert(txt, 'end', paste(tmp, collapse='\n')) } ) st <- tkbutton(tt, text='str', command=function(...) { tmp <- capture.output(print(str(getx(list)))) tkdelete(txt, '1.0','end') tkinsert(txt, 'end', paste(tmp, collapse='\n')) } ) tkpack(pr, side='top', anchor='w') tkpack(st, side='top', anchor='w') fr3 <- tkframe(tt) tkpack(fr3, side='top', expand=1, fill='x') cmd <- tclVar('summary(x)') eve <- tkentry(fr3, textvariable=cmd) ev <- tkbutton(fr3, text='Eval:', command=function(...) { tmp <- capture.output( eval(parse(text=tclvalue(cmd)), list(x=getx(list)))) tkdelete(txt, '1.0', 'end') tkinsert(txt, 'end', paste(tmp, collapse='\n')) } ) tkpack(ev, side='left') tkpack(eve, side='left') tkpack(tkbutton(tt, text='Quit', command=function() tkdestroy(tt)), side='bottom', anchor='e') invisible(NULL) } TeachingDemos/R/prepanel.dice.R0000644000176000001440000000024611270200463016046 0ustar ripleyusers"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/chisq.detail.R0000644000176000001440000000301111270200463015676 0ustar ripleyusers"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/vis.t.R0000644000176000001440000000626011726220074014410 0ustar ripleyusers"vis.t" <- function(){ if( !require(tcltk) ) stop('This function depends on the tcltk package') if(!exists('slider.env')) slider.env<<-new.env() df <- 1; assign('df',tclVar(df),envir=slider.env) sn <- 0; assign('sn',tclVar(sn),envir=slider.env) xmin <- -5; assign('xmin',tclVar(xmin),envir=slider.env) xmax <- 5; assign('xmax',tclVar(xmax),envir=slider.env) ymin <- 0; assign('ymin',tclVar(ymin),envir=slider.env) ymax <- round(dnorm(0,0,1),2); assign('ymax',tclVar(ymax),envir=slider.env) t.refresh <- function(...){ df <- as.numeric(evalq(tclvalue(df), envir=slider.env)) sn <- as.numeric(evalq(tclvalue(sn), envir=slider.env)) xmin <- as.numeric(evalq(tclvalue(xmin), envir=slider.env)) xmax <- as.numeric(evalq(tclvalue(xmax), envir=slider.env)) ymin <- as.numeric(evalq(tclvalue(ymin), envir=slider.env)) ymax <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m,'Visualizing the t-Distribution') tkwm.geometry(m,'+0+0') # df tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='d.f.', width='5'),side='right') tkpack(sc <- tkscale(fr, command=t.refresh, from=1, to=50, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=df),envir=slider.env) # show normal tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Show Normal Distribution', width='25'),side='right') tkpack(sc <- tkcheckbutton(fr, command=t.refresh), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=sn),envir=slider.env) # xmin tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Xmin:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=xmin), envir=slider.env) # xmax tkpack(tklabel(fr, text='Xmax:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=xmax), envir=slider.env) # ymin tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Ymin:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=ymin), envir=slider.env) # ymax tkpack(tklabel(fr, text='Ymax:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=ymax), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=t.refresh),side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') } TeachingDemos/R/run.old.cor.examp.R0000644000176000001440000000137411355474556016640 0ustar ripleyusers"run.old.cor.examp" <- function(n=100,seed) { if (!missing(seed)){ set.seed(seed) } if(!require(tcltk)){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/plot.rgl.coin.R0000644000176000001440000000264312011512111016016 0ustar ripleyusersrgl.coin <- function(x, col='black', heads=x[[1]], tails=x[[2]], ... ) { if(!require(rgl)) stop("This function depends on the 'rgl' library which is not available") if(missing(x)) x <- coin.faces rgl.viewpoint(0,0) for(i in 0:39) { 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.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.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.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.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/rotate.wireframe.R0000644000176000001440000000544711726220074016631 0ustar ripleyusers"rotate.wireframe" <- function(x, ...){ if(!require(tcltk)){stop('The tcltk package is needed')} if(!exists('slider.env')) slider.env <<-new.env() lab1 <- 'z'; assign('lab1', tclVar(lab1), envir=slider.env) lab2 <- 'y'; assign('lab2', tclVar(lab2), envir=slider.env) lab3 <- 'x'; assign('lab3', tclVar(lab3), envir=slider.env) val1 <- 40; assign('val1', tclVar(val1), envir=slider.env) val2 <- 0; assign('val2', tclVar(val2), envir=slider.env) val3 <- -60; assign('val3', tclVar(val3), envir=slider.env) wire.options <- list(...) wire.refresh <- function(...){ lab1 <- evalq(tclvalue(lab1), envir=slider.env) lab2 <- evalq(tclvalue(lab2), envir=slider.env) lab3 <- evalq(tclvalue(lab3), envir=slider.env) val1 <- as.numeric(evalq(tclvalue(val1), envir=slider.env)) val2 <- as.numeric(evalq(tclvalue(val2), envir=slider.env)) val3 <- as.numeric(evalq(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('wireframe',wire.options) ) } m <- tktoplevel() tkwm.title(m,'Rotate Wireframe plot') tkwm.geometry(m,'+0+0') # one tkpack(fr <- tkframe(m), side='top') tkpack(e <- tkentry(fr, width=2), side='left') tkpack(sc <- tkscale(fr, command=wire.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=val1), envir=slider.env) assign('e',e,envir=slider.env) evalq(tkconfigure(e,textvariable=lab1), envir=slider.env) # two tkpack(fr <- tkframe(m), side='top') tkpack(e <- tkentry(fr, width=2), side='left') tkpack(sc <- tkscale(fr, command=wire.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=val2), envir=slider.env) assign('e',e,envir=slider.env) evalq(tkconfigure(e,textvariable=lab2), envir=slider.env) # three tkpack(fr <- tkframe(m), side='top') tkpack(e <- tkentry(fr, width=2), side='left') tkpack(sc <- tkscale(fr, command=wire.refresh, from=-180, to=180, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=val3), envir=slider.env) assign('e',e,envir=slider.env) evalq(tkconfigure(e,textvariable=lab3), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=wire.refresh),side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') } TeachingDemos/R/plot.rgl.die.R0000644000176000001440000000457712011512111015637 0ustar ripleyusersrgl.die <- function(x = 1:6, col.cube='white',col.pip='black',sides=x, ...) { if(!require(rgl)) stop("This function depends on the 'rgl' package wich is not available") 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.quads( c(0,0,1,1), c(0,1,1,0), c(0,0,0,0), col=col.cube) rgl.quads( c(0,0,1,1), c(0,1,1,0), c(1,1,1,1), col=col.cube) rgl.quads( c(0,0,0,0), c(0,1,1,0), c(0,0,1,1), col=col.cube) rgl.quads( c(1,1,1,1), c(0,1,1,0), c(0,0,1,1), col=col.cube) rgl.quads( c(0,0,1,1), c(0,0,0,0), c(0,1,1,0), col=col.cube) 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.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.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.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.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.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.triangles(xy[,1], rep(-0.001, nrow(xy)), xy[,2], col=col.pip,lit=FALSE) } } TeachingDemos/R/subplot.R0000644000176000001440000000374211452505130015032 0ustar ripleyuserssubplot <- 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'){ 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/sigma.test.R0000644000176000001440000000243611270430321015414 0ustar ripleyuserssigma.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/face2.plot.R0000644000176000001440000000657711270200463015307 0ustar ripleyusers"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/clipplot.R0000644000176000001440000000112411270200463015157 0ustar ripleyusersclipplot <- 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/power.examp.R0000644000176000001440000000343411270200463015604 0ustar ripleyuserspower.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/ci.examp.R0000644000176000001440000000506011270200463015040 0ustar ripleyusers"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/faces2.R0000644000176000001440000000345211270200463014502 0ustar ripleyusers"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/ineq.R0000644000176000001440000000303111270200463014264 0ustar ripleyusers#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/spread.labs.R0000644000176000001440000000172011270200463015531 0ustar ripleyusersspread.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/HWidentify.R0000644000176000001440000000513712074430242015416 0ustar ripleyusersHWidentify <- 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( !require(tkrplot) ) 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 <- tktoplevel() img <- tkrplot(tt, replot, hscale=1.5, vscale=1.5) tkpack(img, side='top') iw <- as.numeric(tcl("image","width", tkcget(img, "-image"))) ih <- as.numeric(tcl("image","height", 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] tkrreplot(img) } tkbind(img, "", mm) invisible() } # tmpx <- runif(25) # tmpy <- rnorm(25) # HTKidentify(tmpx,tmpy,LETTERS[1:25], pch=letters) # getGraphicsEvent( onMouseDown = function(buttons, xx, yy) cat(buttons,'\n'), # onMouseUp=function(buttons, xx, yy) cat('up: ',buttons,'\n'), # onMouseMove=function(buttons, xx, yy) cat('move: ',buttons,' x:',xx,' y:',yy,'\n') # ) TeachingDemos/R/tkexamp.R0000644000176000001440000005005311700374422015014 0ustar ripleyusers tkexamp <- function(FUN, param.list, vscale=1.5, hscale=1.5, wait=FALSE, plotloc='top', an.play=TRUE, print=FALSE,...) { if(!require("tkrplot")) { 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 <- tktoplevel() tkwm.title(tt,'Tk Example') img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side=plotloc) hsc <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() 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 <- tkframe(frame,relief='ridge',borderwidth=3) tkpack(fr, side=pkdir) if(length(eln) && nchar(eln)){ tkpack(tklabel(fr, text=eln), side='top',anchor='nw') } Recall(fr,el,ifelse(pkdir=='top','left','top'),vname) next } if( tolower(el[[1]]) == 'numentry' ){ tkpack(fr <- tkframe(frame),side=pkdir) tkpack(tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top')) tmp <- tclVar() 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) tkpack(do.call('tkentry',alist),side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(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' ){ tkpack(fr <- tkframe(frame),side=pkdir) tkpack(tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top')) tmp <- tclVar() 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) tkpack(do.call('tkentry',alist),side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(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' ){ tkpack(fr <- tkframe(frame), side=pkdir) tkpack(tklabel(fr,text=eln), side='left', anchor='s', pady=4) tmp <- tclVar() 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(...)tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tkpack( do.call('tkscale',alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(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' ){ tkpack(fr <- tkframe(frame), side=pkdir) tkpack(tklabel(fr,text=eln), side='left') tmp <- tclVar() 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(...)tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tkpack( do.call('tkscale',alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(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' ){ tkpack(fr <- tkframe(frame), side=pkdir) tkpack(tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top'),anchor='nw') tmp <- tclVar() tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else if( 'from' %in% names(el) ) { el$from } else { 1 } tmp2 <- tclvalue(tmp) # fix strange resetting on first alist <- list(fr, textvariable=tmp, command=function(...)tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL alist <- c(alist,el2) tkpack( do.call('tdspinner',alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs, tmpl) tclvalue(tmp) <- tmp2 # rest of fix for reset next } if( tolower(el[[1]])== 'checkbox' ){ tmp <- tclVar() tclvalue(tmp) <- if('init' %in% names(el)) { el$init } else { "F" } alist <- list(frame, variable=tmp,text=eln, onvalue="T", offvalue="F", command=function(...)tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) ) el2 <- el[-1] el2$init <- NULL tmpvars <- if('values' %in% names(el)){ el$values } else { "" } el2$values <- NULL alist <- c(alist,el2) tkpack( do.call('tkcheckbutton',alist), side=pkdir) tmpcl <- as.list(cl) tmpl <- list(substitute(as.logical(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') tkpack(fr <- tkframe(frame), side=pkdir) tkpack(tklabel(fr,text=eln), side=ifelse(pkdir=='top','left','top')) tmp <- tclVar() 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) tkpack( cb <-do.call('ttkcombobox',alist), side=pkdir) tkconfigure(cb, values=tmpvars) tkconfigure(cb, textvariable=tmp) tmpcl <- as.list(cl) tmpl <- list(substitute(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' ){ tkpack(fr <- tkframe(frame,relief='groove',borderwidth=3), side=pkdir) tkpack(tklabel(fr,text=eln), side='top', anchor='nw') tmp <- tclVar() 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()tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) ) pkdir2 <- ifelse( pkdir=='top', 'left', 'top' ) for( v in tmp.vals ){ tkpack( do.call('tkradiobutton', c(alist, value=v, text=v)), side=pkdir2 ) } tmpcl <- as.list(cl) tmpl <- list(substitute(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 && require('tcltk2')) { tkpack(fr <- tkframe(frame), side=pkdir) tkpack(tklabel(fr,text=eln),side='left',anchor='s',pady=4) tmp <- tclVar() 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(...)tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(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) tkpack( do.call('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(tclvalue(tmp)))/an.inc seq.val <- seq( as.numeric(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(){ tcl("set", .(tmpc), .(seq.val[i])) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) })) tclAfter(seq.wait[i], tmpfun) } } tkpack( tkbutton(fr, text="Play", command=tmp.tke.an), side='left') tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs,tmpl) } else { # using button hold tkpack(fr <- tkframe(frame), side=pkdir) tkpack(tklabel(fr,text=eln),side='left',anchor='s',pady=4) tmp <- tclVar() 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(...)tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(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) tkpack( do.call('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(tclvalue(tke.tmp)) < an.to ) { tclvalue(tke.tmp) <- as.numeric(tclvalue(tke.tmp)) + an.inc tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) } } tkpack( tkbutton(fr, text='Inc', command=tmp.tke.an, repeatdelay=1, repeatinterval=an.delay ), side='left') tmpcl <- as.list(cl) tmpl <- list(substitute(as.numeric(tclvalue(VNAME)), list(VNAME=as.character(tmp)))) names(tmpl) <- eln cl <<- as.call(c(tmpcl,tmpl)) exargs <<- c(exargs,tmpl) } next } } } tkpack(tfr <- tkframe(tt),side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function(){tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)))} ), side='left',anchor='s') tkpack(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') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') fillframe(tt, param.list, plotloc, 'tkv') PlotYet <- TRUE tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc))) if(wait){ 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/shadowtext.R0000644000176000001440000000076411270200463015534 0ustar ripleyusersshadowtext <- 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/roc.demo.R0000644000176000001440000000546211726220074015056 0ustar ripleyusers"roc.demo" <- function(x=rnorm(25,10,1), y=rnorm(25,11,1.5) ){ if(!require(tcltk)){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',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(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 <- tktoplevel() tkwm.title(m,'ROC curve demo') tkwm.geometry(m, '+0+0') # cutoff tkpack(fr <- tkframe(m), side='top') tkpack(tklabel(fr, text='cutoff', width='10'), side='right') tkpack(sc <- 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(tkconfigure(sc, variable=cutoff), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=roc.refresh), side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') } TeachingDemos/R/tkBrush.R0000644000176000001440000001130611435561331014765 0ustar ripleyuserstkBrush <- function(mat,hscale=1.75,vscale=1.75,wait=TRUE,...){ if( !require(tkrplot) ) 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<-tclVar(16) ecol<-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 <- tktoplevel() tkwm.title(tt,"Tk Brush") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img,side='left') tkpack( tklabel(tt,text='pch:'),side='top') tkpack(tkentry(tt,textvariable=epch),side='top') tkpack( tklabel(tt,text='Color:'),side='top') tkpack( tkentry(tt,textvariable=ecol),side='top') tkpack( tkbutton(tt, text='Quit', command=function()tkdestroy(tt)), side='bottom') iw <- as.numeric(tcl('image','width',tkcget(img,'-image'))) ih <- as.numeric(tcl('image','height',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(tclvalue(ecol)) if( !( tmpcol %in% colors() ) ) tmpcol <- 'black' tmpc[tmp] <- tmpcol tcols <<- tmpc tmpp <- rep(NA,nrow(mat)) tmppch <- as.numeric(tclvalue(epch)) if(is.na(tmppch)) tmppch <- as.character(tclvalue(epch)) tmpp[tmp] <- tmppch tpch <<- tmpp if(bp){ ppch <<- ifelse(is.na(tpch),ppch,tpch) pcols <<- ifelse(is.na(tcols),pcols,tcols) } tkrreplot(img) } mmm <- function(){ tmp <- di[ dx >= rx-rw & dx <= rx & dy >= ry & dy <= ry+rh ] tmpc <- rep(NA,nrow(mat)) tmpcol <- as.character(tclvalue(ecol)) if( !( tmpcol %in% colors() ) ) tmpcol <- 'black' tmpc[tmp] <- tmpcol tcols <<- tmpc tmpp <- rep(NA,nrow(mat)) tmppch <- as.numeric(tclvalue(epch)) if(is.na(tmppch)) tmppch <- as.character(tclvalue(epch)) tmpp[tmp] <- tmppch tpch <<- tmpp if(bp){ ppch <<- ifelse(is.na(tpch),ppch,tpch) pcols <<- ifelse(is.na(tcols),pcols,tcols) } tkrreplot(img) } tkbind(img, '', mm) tkbind(img, '', function() {bp<<-TRUE;mmm()}) tkbind(img, '', function() bp<<-FALSE) tkbind(tt, '',function(){rh <<- rh+0.01;mmm()}) tkbind(tt, '',function(){rh <<- rh-0.01;mmm()}) tkbind(tt, '',function(){rw <<- rw+0.01;mmm()}) tkbind(tt, '',function(){rw <<- rw-0.01;mmm()}) if(wait){ tkwait.window(tt) return(list(col=pcols, pch=ppch)) } else { return(invisible(NULL)) } } TeachingDemos/R/gp.splot.R0000644000176000001440000000106211726220074015106 0ustar ripleyusersgp.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/mysymbols.R0000644000176000001440000002726411760215171015412 0ustar ripleyusersmy.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='') } TeachingDemos/R/slider.R0000644000176000001440000000653711726220074014636 0ustar ripleyusersslider <- 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 if (!missing(no)) return(as.numeric(tclvalue(get(paste("slider", no, sep = ""), envir = slider.env)))) if (!missing(set.no.value)) { try(eval(parse(text = paste("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" #require(tcltk) nt <- tktoplevel() tkwm.title(nt, title) 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, "',tclVar(sl.defaults[i]),envir=slider.env)", sep = ""))) tkpack(fr <- tkframe(nt)) lab <- tklabel(fr, text = sl.names[i], width = "25") sc <- tkscale(fr, from = sl.mins[i], to = sl.maxs[i], showvalue = T, resolution = sl.deltas[i], orient = "horiz") tkpack(lab, sc, side = "right") assign("sc", sc, envir = slider.env) eval(parse(text = paste("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, "}"))) tkconfigure(sc, command = sl.fun) } assign("slider.values.old", sl.defaults, envir = slider.env) tkpack(f.but <- tkframe(nt), fill = "x") tkpack(tkbutton(f.but, text = "Exit", command = function() tkdestroy(nt)), side = "right") if (!missing(reset.function)){ if (!is.function(reset.function)) reset.function <- eval(parse(text = paste("function(...){", reset.function, "}"))) tkpack(tkbutton(f.but, text = "Reset", command = function() { for (i in seq(sl.names)) eval(parse(text = paste("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, "}"))) tkpack(tkbutton(f.but, text = but.names[i], command = but.fun), side = "left") cat("button", i, "eingerichtet") } invisible(nt) } TeachingDemos/R/slideRule.R0000644000176000001440000000357711426112106015276 0ustar ripleyusers 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/run.power.examp.R0000644000176000001440000001075311355474556016435 0ustar ripleyusersrun.power.examp.old <- function(){ if(!require(tcltk)){stop('The tcltk package is needed')} slider( power.refresh, c('Sample Size','Standard Deviation','True Difference', 'Alpha level'), c(1,0.25,-1,0.01), c(100,5,3,0.99), c(1,0.25,0.1,0.01), c(1,1,1,0.05), title="Power Demo") } run.power.examp <- function(hscale=1.5, vscale=1.5, wait=FALSE) { if( !require(tkrplot) ) stop('This function depends on the tkrplot package being available') n <- tclVar() stdev <- tclVar() diff <- tclVar() alpha <- tclVar() xmin <- tclVar() xmax <- tclVar() tclvalue(n) <- 1 tclvalue(stdev) <- 1 tclvalue(diff) <- 1 tclvalue(alpha) <- 0.05 tclvalue(xmin) <- -2 tclvalue(xmax) <- 4 hsc <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() tclvalue(vsc) <- vscale out <- numeric(1) replot <- function(...) { out <<- power.examp( as.numeric(tclvalue(n)), as.numeric(tclvalue(stdev)), as.numeric(tclvalue(diff)), as.numeric(tclvalue(alpha)), as.numeric(tclvalue(xmin)), as.numeric(tclvalue(xmax)) ) } tt <- tktoplevel() tkwm.title(tt, "Power Demo") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='left') tkpack(fr <- tkframe(tt), side='top', fill='x') tkpack(tklabel(fr, text="n: "), side='left') tkpack(tdspinner(fr, values=c(1,2,3,4,5,10,20,30,40,50), width=5, textvariable=n, command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left') tkpack(fr <- tkframe(tt), side='top',fill='x') tkpack(tklabel(fr, text="Standard Deviation: "), side='left') tkpack(tkscale(fr, variable=stdev, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0.1, to=4, resolution=.05), side='right') tkpack(fr <- tkframe(tt), side='top',fill='x') tkpack(tklabel(fr, text="True Difference: "), side='left') tkpack(tkscale(fr, variable=diff, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0, to=4, resolution=.05), side='right') tkpack(fr <- tkframe(tt), side='top',fill='x') tkpack(tklabel(fr, text="alpha: "), side='left') tkpack(tkscale(fr, variable=alpha, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0.001, to=0.2, resolution=0.001), side='right') tkpack(tfr <- tkframe(tt), side='top', fill='x') tkpack(tklabel(tfr,text="x min: "), side='left') tkpack(tkentry(tfr,textvariable=xmin,width=6), side='left') tkpack(tklabel(tfr,text=" x max: "), side='left') tkpack(tkentry(tfr,textvariable=xmax,width=6), side='left') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function() tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left',anchor='s') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') if(wait) { tkwait.window(tt) return(list( n=as.numeric(tclvalue(n)), stdev=as.numeric(tclvalue(stdev)), diff=as.numeric(tclvalue(diff)), alpha=as.numeric(tclvalue(alpha)), power=out )) } else { return(invisible(NULL)) } } TeachingDemos/R/triplot.R0000644000176000001440000000610111270200463015026 0ustar ripleyusers"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){ win.graph() 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/pairs2.R0000644000176000001440000000751411270200463014542 0ustar ripleyuserspairs2 <- 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/updateusr.R0000644000176000001440000000110311270200463015342 0ustar ripleyusersupdateusr <- 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/run.ci.examp.R0000644000176000001440000000441611355474556015673 0ustar ripleyusers"run.ci.examp" <- function(reps=100,seed, method='z',n=25) { if(!require(tcltk)){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/run.cor2.examp.R0000644000176000001440000001116011355474556016137 0ustar ripleyusers"run.old.cor2.examp" <- function(n=100,seed) { if (!missing(seed)){ set.seed(seed) } if(!require(tcltk)){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( !require(tkrplot) ) 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 <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() tclvalue(vsc) <- vscale r <- tclVar() tclvalue(r) <- 0 r2 <- tclVar() tclvalue(r2) <- 0 update.r <- function(...) { tmp <- as.numeric(tclvalue(r)) tmp2 <- as.numeric(tclvalue(r2)) tclvalue(r) <- ifelse( tmp < 0, -1,1) * sqrt(tmp2) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) } update.r2 <- function(...) { tmp <- as.numeric(tclvalue(r)) tclvalue(r2) <- tmp^2 tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) } replot <- function(...) { tmp.r <- as.numeric(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 <- tktoplevel() tkwm.title(tt, "Cor2 Example") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(tfr <- tkframe(tt), side='top') tkpack(fr <- tkframe(tfr), side='top',fill='x') tkpack(tklabel(fr,text='r: '), side='left',anchor='s') tkpack(tkscale(fr, variable=r, orient='horizontal', command=update.r2, from=-1, to=1, resolution=0.01), side='right') tkpack(fr <- tkframe(tfr), side='top',fill='x') tkpack(tklabel(fr,text='r^2: '),side='left',anchor='s') tkpack(tkscale(fr, variable=r2, orient='horizontal', command=update.r, from=0, to=1, resolution=0.01), side='right') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function() tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left',anchor='s') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait){ tkwait.window(tt) tmp.r <- as.numeric(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/R2txt.R0000644000176000001440000004503412077037153014376 0ustar ripleyusers### 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) { 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( !require(R2wd) ) 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) { 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) { 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/00vars.R0000644000176000001440000000003111270200463014440 0ustar ripleyusersslider.env <- new.env() TeachingDemos/R/cnvrt.coords.R0000644000176000001440000000656511435561331016002 0ustar ripleyusers"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/plot2script.R0000644000176000001440000000216011726220074015625 0ustar ripleyusersplot2script <- 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) } zoomplot <- 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) } } TeachingDemos/R/char2seed.R0000644000176000001440000000062011270200463015171 0ustar ripleyuserschar2seed <- 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/vis.boxcoxu.R0000644000176000001440000001037411726220074015635 0ustar ripleyusersvis.boxcoxu.old <- function(lambda = sample( c(-1, -0.5, 0, 1/3, 1/2, 1, 2), 1)) { if( !require(tkrplot) ) 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',tclVar(lam), envir=slider.env) bc.refresh <- function(...){ lam <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m, 'Box Cox Transform') tkwm.geometry(m,'+0+0') tkpack(fr <- tkframe(m), side='top') tkpack(tklabel(fr, text='lambda', width='10'), side='right') tkpack(sc <- 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(tkconfigure(sc, variable=lam), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=bc.refresh), side='left') tkpack(tkbutton(m, text="Exit", command=function()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 <- tclVar() tclvalue(lam) <- 1 hsc <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() tclvalue(vsc) <- hscale replot <- function(...) { tmp.l <- as.numeric(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 <- tktoplevel() tkwm.title(tt, "Box Cox Demo") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr, text='lambda: '), side='left', anchor='s') tkpack(tkscale(fr, variable=lam, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=-2, to=4, resolution=.05), side='right') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function() tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left',anchor='s') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tkwait.window(tt) return( list(lambda = as.numeric(tclvalue(lam)), y = y, ty = bct(y,as.numeric(tclvalue(lam))) ) ) } else { return(invisible(NULL)) } } TeachingDemos/R/bct.R0000644000176000001440000000026111270200463014102 0ustar ripleyusers"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/rotate.persp.R0000644000176000001440000000107311355474556016006 0ustar ripleyusers"rotate.persp" <- function(x,y,z){ if(!require(tcltk)){stop('The tcltk package is needed')} persp.refresh <- function(...){ persp(x,y,z, theta=slider(no=1), phi=slider(no=2), r=slider(no=3), d=slider(no=4), ltheta=slider(no=5), lphi=slider(no=6), shade=slider(no=7),col='lightblue' ) } slider( persp.refresh, c('theta','phi','r','d','ltheta','lphi','shade'), c(-360,-180,0,0,0,0,0), c(360,180, 10, 5, 360, 180, 1), c(5,5,.25,.1,5,5,.05), c(0,15,sqrt(3),1,120,15,.7), 'PerspControl') } TeachingDemos/R/vis.gamma.R0000644000176000001440000002263611726220074015234 0ustar ripleyusers"vis.gamma" <- function(){ if(!exists('slider.env')) slider.env<<-new.env() if(!require(tcltk)) { stop('This function needs the tcltk package') } shape <- 1; assign('shape',tclVar(shape),envir=slider.env) rate <- 1; assign('rate',tclVar(rate),envir=slider.env) scale <- 1; assign('scale',tclVar(scale),envir=slider.env) mean <- 1; assign('mean', tclVar(mean), envir=slider.env) sd <- 1; assign('sd',tclVar(sd), envir=slider.env) se <- 0; assign('se', tclVar(se), envir=slider.env) sc2 <- 0; assign('sc2', tclVar(sc2), envir=slider.env) sg <- 1; assign('sg', tclVar(sg), envir=slider.env) xmin <- 0; assign('xmin',tclVar(xmin),envir=slider.env) xmax <- 5; assign('xmax',tclVar(xmax),envir=slider.env) ymin <- 0; assign('ymin',tclVar(ymin),envir=slider.env) ymax <- 1; assign('ymax',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(tclvalue(shape), envir=slider.env)) rate <- as.numeric(evalq(tclvalue(rate), envir=slider.env)) scale <- as.numeric(evalq(tclvalue(scale), envir=slider.env)) mean <- as.numeric(evalq(tclvalue(mean), envir=slider.env)) sd <- as.numeric(evalq(tclvalue(sd), envir=slider.env)) if ( shape != old.shape ) { mean <- shape * scale sd <- round( sqrt(shape)*scale, 6 ); try(eval(parse(text=paste("tclvalue(mean)<-", mean,sep="")),envir=slider.env)); try(eval(parse(text=paste("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("tclvalue(scale)<-", scale,sep="")),envir=slider.env)); try(eval(parse(text=paste("tclvalue(mean)<-", mean,sep="")),envir=slider.env)); try(eval(parse(text=paste("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("tclvalue(rate)<-", rate,sep="")),envir=slider.env)); try(eval(parse(text=paste("tclvalue(mean)<-", mean,sep="")),envir=slider.env)); try(eval(parse(text=paste("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("tclvalue(rate)<-", rate,sep="")),envir=slider.env)); try(eval(parse(text=paste("tclvalue(shape)<-", shape,sep="")),envir=slider.env)); try(eval(parse(text=paste("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("tclvalue(rate)<-", rate,sep="")),envir=slider.env)); try(eval(parse(text=paste("tclvalue(shape)<-", shape,sep="")),envir=slider.env)); try(eval(parse(text=paste("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(tclvalue(se), envir=slider.env)) sc2 <- as.numeric(evalq(tclvalue(sc2), envir=slider.env)) sg <- as.numeric(evalq(tclvalue(sg), envir=slider.env)) xmin <- as.numeric(evalq(tclvalue(xmin), envir=slider.env)) xmax <- as.numeric(evalq(tclvalue(xmax), envir=slider.env)) ymin <- as.numeric(evalq(tclvalue(ymin), envir=slider.env)) ymax <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m,'Visualizing the Gamma Distribution') tkwm.geometry(m,'+0+0') # shape tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Shape', width='10'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=shape),envir=slider.env) # rate tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Rate', width='10'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=rate),envir=slider.env) # scale tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Scale', width='10'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=scale),envir=slider.env) # mean tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Mean', width='10'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=mean),envir=slider.env) # sd tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='S.D.', width='10'),side='right') tkpack(sc <- 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(tkconfigure(sc, variable=sd),envir=slider.env) # show exponential tkpack(fr <- tkframe(m),side='top') tkpack(sc <- tkcheckbutton(fr, command=gamma.refresh), side='left') tkpack(tklabel(fr, text='Show Exponential Distribution', width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=se),envir=slider.env) # show chisquared tkpack(fr <- tkframe(m),side='top') tkpack(sc <- tkcheckbutton(fr, command=gamma.refresh), side='left') tkpack(tklabel(fr, text='Show Chi-squared Distribution', width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=sc2),envir=slider.env) # show gamma tkpack(fr <- tkframe(m),side='top') tkpack(sc <- tkcheckbutton(fr, command=gamma.refresh), side='left') tkpack(tklabel(fr, text='Show Gamma Distribution', width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=sg),envir=slider.env) # xmin tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Xmin:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=xmin), envir=slider.env) # xmax tkpack(tklabel(fr, text='Xmax:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=xmax), envir=slider.env) # ymin tkpack(fr <- tkframe(m),side='top') tkpack(tklabel(fr, text='Ymin:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=ymin), envir=slider.env) # ymax tkpack(tklabel(fr, text='Ymax:', width=6), side='left') tkpack(e <- tkentry(fr,width=8), side='left') assign('e',e,envir=slider.env) evalq(tkconfigure(e, textvariable=ymax), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=gamma.refresh),side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') } TeachingDemos/R/z.test.R0000644000176000001440000000264011376605635014605 0ustar ripleyusers"z.test" <- function(x, mu=0, stdev, alternative = c("two.sided", "less", "greater"), sd=stdev, conf.level = 0.95, ... ){ if(missing(stdev) && missing(sd)) stop("You must specify a Standard Deviation of the population") alternative <- match.arg(alternative) n <- length(x) 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.R0000644000176000001440000000066111270200463015344 0ustar ripleyusers# 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 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(tcl("info","tclversion")) >= "8.5" } TeachingDemos/R/loess.demo.R0000644000176000001440000000462112074430242015411 0ustar ripleyusers"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/put.points.demo.R0000644000176000001440000000503411726220074016411 0ustar ripleyusers"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/plot.dice.R0000644000176000001440000000117111312055110015206 0ustar ripleyusers"plot.dice" <- function(x,...){ if(!require(lattice)) stop('The lattice package is needed') old.trellis.par <- trellis.par.get() on.exit(trellis.par.set(old.trellis.par)) trellis.par.set(theme=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(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/dots.R0000644000176000001440000000023311270200463014302 0ustar ripleyusers"dots" <- function(x,...){ sx <- sort(x) sy <- unlist(lapply(table(sx),seq)) plot(sx,sy, xlab=deparse(substitute(x)), ylab="Count",...) } TeachingDemos/R/TkApprox.R0000644000176000001440000000707711700374422015123 0ustar ripleyusersTkApprox <- 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( !require(tkrplot) ) stop('This function depends on the tkrplot package being available') snap.x <- tclVar() 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 <- tclVar() 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) 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 # tmp <- cnvrt.coords(c(0,1),c(0,1), input='dev')$usr tmpx <- grconvertX(c(0,1), from='ndc') ul <<- tmpx[1] ur <<- tmpx[2] } } tt <- tktoplevel() tkwm.title(tt, "TkApprox") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(tklabel(tt, textvariable=txtvar), side='top') tkpack(tkcheckbutton(tt,variable=snap.x, onvalue="T", offvalue="F", text="Snap to points"), side='left') tkpack(tkbutton(tt, text='Quit', command=function() tkdestroy(tt)), side='right') md <- FALSE iw <- as.numeric(tcl('image','width',tkcget(img,'-image'))) ih <- as.numeric(tcl('image','height',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(tclvalue(snap.x))) { ccx <<- xxx[ which.min( abs(ccx-xxx) ) ] } xx[ci] <<- ccx ccy <<- af(ccx) yy[ci] <<- ccy 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 } tkbind(img, '', mouse.move) tkbind(img, '', mouse.down) tkbind(img, '', mouse.up) if(wait) { tkwait.window(tt) out <- list( x=xx, y=yy ) } else { out <- NULL } invisible(out) } TeachingDemos/R/SensSpec.demo.R0000644000176000001440000000241011270200463015776 0ustar ripleyusersSensSpec.demo <- function(sens, spec, prev, n=100000, step=11) { mat <- matrix(NA, ncol=4, nrow=4) dimnames(mat) <- list( Test=c('Positive','Negative','','Total'), Disease=c(' Yes',' No',' ',' Total') ) pplines <- c(' ', 'PPV =', 'NPV =') mat[4,4] <- n if(step>1){ mat[4,1] <- round(n*prev) } if(step>2){ mat[4,2] <- n-mat[4,1] } if(step>3){ mat[1,1] <- round( sens*mat[4,1] ) } if(step>4){ mat[2,1] <- mat[4,1] - mat[1,1] } if(step>5){ mat[2,2] <- round( spec*mat[4,2] ) } if(step>6){ mat[1,2] <- mat[4,2]-mat[2,2] } if(step>7){ mat[1,4] <- mat[1,1]+mat[1,2] } if(step>8){ mat[2,4] <- mat[2,1]+mat[2,2] } if(step>9){ pplines[2] <- paste( 'PPV = ', mat[1,1], '/', mat[1,4], ' = ', round(mat[1,1]/mat[1,4], 4), sep='') } if(step>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/power.refresh.R0000644000176000001440000000022411270200463016122 0ustar ripleyusers"power.refresh" <- function(...) { power.examp(n=slider(no=1), stdev=slider(no=2), diff=slider(no=3), alpha=slider(no=4) ) } TeachingDemos/R/vis.binom.R0000644000176000001440000000711211726220074015246 0ustar ripleyusers"vis.binom" <- function(){ if( !require(tcltk) ) stop('This function depends on the tcltk package') if(!exists('slider.env')) slider.env<<-new.env() n <- 10 ; assign('n',tclVar(n),envir=slider.env) p <- 0.5; assign('p',tclVar(p),envir=slider.env) sn <- 0 ; assign('sn',tclVar(sn), envir=slider.env) sp <- 0 ; assign('sp',tclVar(sp), envir=slider.env) binom.refresh <- function(...){ n <- as.numeric(evalq(tclvalue(n), envir=slider.env)) p <- as.numeric(evalq(tclvalue(p), envir=slider.env)) sn <- as.numeric(evalq(tclvalue(sn), envir=slider.env)) sp <- as.numeric(evalq(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 <- tktoplevel() tkwm.title(m,'Visualizing the Binomial Distribution') tkwm.geometry(m,'+0+0') # n tkpack(fr <- tkframe(m), side='top') tkpack(tklabel(fr, text='n', width='10'), side='right') tkpack(sc <- tkscale(fr, command=binom.refresh, from=1, to=100, orient='horiz', resolution=1, showvalue=T), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=n), envir=slider.env) # p tkpack(fr <- tkframe(m), side='top') tkpack(tklabel(fr, text='p', width='10'), side='right') tkpack(sc <- 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(tkconfigure(sc, variable=p), envir=slider.env) # show normal tkpack(fr <- tkframe(m), side='top') tkpack(sc <- tkcheckbutton(fr, command=binom.refresh), side='left') tkpack(tklabel(fr, text='Show Normal Approximation',width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=sn), envir=slider.env) # show poisson tkpack(fr <- tkframe(m), side='top') tkpack(sc <- tkcheckbutton(fr, command=binom.refresh), side='left') tkpack(tklabel(fr, text='Show Poisson Approximation',width='25'), side='left') assign('sc',sc,envir=slider.env) evalq(tkconfigure(sc, variable=sp), envir=slider.env) tkpack(tkbutton(m, text="Refresh", command=binom.refresh), side='left') tkpack(tkbutton(m, text="Exit", command=function()tkdestroy(m)), side='right') } TeachingDemos/R/run.hist.demo.R0000644000176000001440000000114311355474556016053 0ustar ripleyusers"run.hist.demo" <- function(x) { if(!require(tcltk)){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") } TeachingDemos/R/faces.R0000644000176000001440000001277011270200463014423 0ustar ripleyusers#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/prob.axis.R0000644000176000001440000000012211270200463015233 0ustar ripleyusersprob.axis <- function(side, dist, dist.args, at=NULL, labels=TRUE, ...) { } TeachingDemos/R/roll.rgl.die.R0000644000176000001440000000161711270200463015633 0ustar ripleyusersroll.rgl.die <- function( side=sample(6,1), steps=250 ) { 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.viewpoint(tmp[j]+i, -tmp2[j]*45+tmp2[j]*i) } } if( side==1 ){ for(i in seq(0,45, length=steps/2)) { rgl.viewpoint(45+i, 45+i) } } else if( side==6 ) { for(i in seq(0,90, length=steps)) { rgl.viewpoint(45+i, 45-i) } for(i in seq(0,45, length=steps/2)) { 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.viewpoint(tmp[j]+i, -tmp2[j]*45+tmp2[j]*i) } } for(i in seq(0,45, length=steps/2)) { rgl.viewpoint(tmp[tmp3+1]+i, -tmp2[tmp3+1]*45+tmp2[tmp3+1]*i) } } return(side) } TeachingDemos/R/ms.face.R0000644000176000001440000001141311667306170014663 0ustar ripleyusers#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/tree.demo.R0000644000176000001440000000151211270200463015214 0ustar ripleyusers"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/dice.R0000644000176000001440000000133311270200463014237 0ustar ripleyusers"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/TkPredict.R0000644000176000001440000000566611270200463015241 0ustar ripleyusersPredict.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/run.old.cor2.examp.R0000644000176000001440000000223611355474556016720 0ustar ripleyusers"run.old.cor2.examp" <- function(n=100,seed) { if (!missing(seed)){ set.seed(seed) } if(!require(tcltk)){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) 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") cor.refresh() } TeachingDemos/R/rgl.Map.R0000644000176000001440000000116111270200463014632 0ustar ripleyusers"rgl.Map" <- function(Map,which,...) { if (missing(which)) which <- T if(!require(rgl)) 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 # x <- cos(lat)*sin(long) # y <- -sin(lat)*sin(long) # z <- cos(lat)*cos(long) z <- cos(long)*sin(lat) y <- cos(lat) x <- sin(long)*sin(lat) tmp.i <- rep( seq(along=x), each=2) tmp.i <- c(tmp.i[-1],1) rgl.lines(x[tmp.i], y[tmp.i], z[tmp.i],...) }) invisible() } TeachingDemos/R/petals.R0000644000176000001440000000325711700374422014637 0ustar ripleyuserspetals <- 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/dots2.R0000644000176000001440000000112611270200463014366 0ustar ripleyusers"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/cal.R0000644000176000001440000000650611667306170014115 0ustar ripleyuserscal <- 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/sliderv.R0000644000176000001440000000304611726220074015014 0ustar ripleyusers"sliderv" <- function(refresh.code,names,minima,maxima,resolutions,starts, title="control",no=0, set.no.value=0) { if(no!=0) return(as.numeric(tclvalue(get(paste("slider",no,sep=""),envir=slider.env)))) if(set.no.value[1]!=0){ try(eval(parse(text=paste("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<-tktoplevel(); tkwm.title(nt,title); tkwm.geometry(nt,"+0+0") for(i in seq(names)) eval(parse(text=paste("assign(\"slider",i,"\",tclVar(starts[i]),envir=slider.env)",sep=""))) for(i in seq(names)){ tkpack(fr<-tkframe(nt),side='left'); lab<-tklabel(fr, text=names[i], width="1") sc<-tkscale(fr, command=refresh.code, from=minima[i], to=maxima[i], showvalue=T, resolution=resolutions[i]) assign("sc",sc,envir=slider.env); tkpack(lab,sc,side="top") eval(parse(text=paste("tkconfigure(sc,variable=slider",i,")",sep="")), envir=slider.env) } tkpack(fr<-tkframe(nt),fill="x") tkpack(tkbutton(fr, text="Exit", command=function()tkdestroy(nt)), side="right") tkpack(tkbutton(fr, text="Reset", command=function(){ for(i in seq(starts)) eval(parse(text=paste("tclvalue(slider",i,")<-",starts[i],sep="")),envir=slider.env) refresh.code() } ),side="left") } TeachingDemos/R/dynIdentify.R0000644000176000001440000002072111435561331015632 0ustar ripleyusersdynIdentify <- 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( !require(tkrplot) ) 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 <- tktoplevel() tkwm.title(tt, "TkIdentify") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack( tkbutton(tt, text='Quit', command=function() 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(tcl('image','width',tkcget(img,'-image'))) ih <- as.numeric(tcl('image','height',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] 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 } tkbind(img, '', mouse.move) tkbind(img, '', mouse.down) tkbind(img, '', mouse.up) 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/flip.rgl.coin.R0000644000176000001440000000024711270200463016002 0ustar ripleyusersflip.rgl.coin <- function(side=sample(2,1), steps=150) { for (i in seq(0,(5+side)*180, length=steps*(5+side)) ){ rgl.viewpoint(i,0) } return(side) } TeachingDemos/R/lattice.demo.R0000644000176000001440000000661411726220074015720 0ustar ripleyusers"lattice.demo" <- function(x,y,z, show3d=TRUE){ if(!require(tcltk)){stop('The tcltk package is needed')} if(!exists('slider.env')) slider.env <<- new.env() if(!require(lattice)) stop('The lattice package is needed') center <- mean(z); assign('center',tclVar(center), envir=slider.env) width <- diff(range(z))/20*3; assign('width',tclVar(width), envir=slider.env) s3d <- 1; assign('s3d', tclVar(s3d), envir=slider.env) lattice.refresh <- function(...){ center <- as.numeric(evalq(tclvalue(center), envir=slider.env)) width <- as.numeric(evalq(tclvalue(width), envir=slider.env)) s3d <- as.numeric(evalq(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(xyplot(y~x|shingle(z,rbind(range(z),c(shingle.min,shingle.max))), index.cond=list(2), strip=strip.custom(strip.names=TRUE,strip.levels=TRUE), par.strip.text=list(cex=0.75)), split=c(1,1,1,2), more=T) print(cloud(y~z+x, panel=function(x,y,z,...){ panel.cloud(x,y,z,panel.3d.cloud=function(x,y,z,groups,...){ panel.3dscatter(x,y,z, groups= factor(x>shingle.scaled.range[1] & x 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/range.R0000644000176000001440000000202111270200463014422 0ustar ripleyusers`%<%` <- 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/clt.examp.R0000644000176000001440000000521311270200463015227 0ustar ripleyusers"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/simfun.R0000644000176000001440000000143411757052235014652 0ustar ripleyuserssimfun <- 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/hpd.R0000644000176000001440000000155511270200463014114 0ustar ripleyusers# These functions were written by Greg Snow (greg.snow@ihc.com) # They are free to use, but come with no warrenty whatsoever # use at your own risk (not that I can think of anything bad that # they would do). hpd <- function(posterior.icdf, conf=0.95, tol=0.00000001,...){ conf <- min( conf, 1-conf ) f <- function(x,posterior.icdf,conf,...){ posterior.icdf(1-conf+x,...) - posterior.icdf(x,...) } out <- optimize(f, c(0,conf), posterior.icdf = posterior.icdf, conf=conf, tol=tol, ...) return( c( posterior.icdf(out$minimum,...), posterior.icdf(1-conf+out$minimum,...) ) ) } emp.hpd <- function(x, conf=0.95){ conf <- min(conf, 1-conf) n <- length(x) nn <- round( n*conf ) x <- sort(x) xx <- x[ (n-nn+1):n ] - x[1:nn] m <- min(xx) nnn <- which(xx==m)[1] return( c( x[ nnn ], x[ n-nn+nnn ] ) ) } TeachingDemos/R/col2grey.R0000644000176000001440000000031111270200463015054 0ustar ripleyuserscol2grey <- 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/fagan.R0000644000176000001440000002500311270200463014407 0ustar ripleyusersfagan.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( !require(tkrplot) ) stop('This function depends on the tkrplot package being available') ppt <- tclVar() tclvalue(ppt) <- 0.5 lr <- tclVar() tclvalue(lr) <- 1 tr <- tclVar() tclvalue(tr) <- '+' hsc <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() tclvalue(vsc) <- hscale replot <- function(...) { probs.pre.test <- as.numeric(tclvalue(ppt)) LR <- as.numeric(tclvalue(lr)) test.result <- tclvalue(tr) fagan.plot(probs.pre.test, LR, test.result) } tt <- tktoplevel() tkwm.title(tt, "Fagan Plot Demo") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr, text='Pre Test Probability: '), side='left', anchor='s') tkpack(tkscale(fr, variable=ppt, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr, text='Likelihood Ratio: '), side='left', anchor='s') tkpack(tkscale(fr, variable=lr, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0.01, to=100, resolution=.01), side='right') tkpack(fr <- tkframe(tt), side='top') tkpack(tkcheckbutton(fr, text='Positive Test Result', variable=tr, onvalue='+', offvalue='-', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function() tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left',anchor='s') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tkwait.window(tt) return( list(ppt = as.numeric(tclvalue(ppt)), lr = as.numeric(tclvalue(lr)), tr = tclvalue(tr) )) } else { return(invisible(NULL)) } } plotFagan2 <- function(hscale=1.5, vscale=1.5, wait=FALSE) { if( !require(tkrplot) ) stop('This function depends on the tkrplot package being available') ppt <- tclVar() tclvalue(ppt) <- 0.5 sens <- tclVar() tclvalue(sens) <- 0.5 spec <- tclVar() tclvalue(spec) <- 0.5 tr <- tclVar() tclvalue(tr) <- '+' hsc <- tclVar() tclvalue(hsc) <- hscale vsc <- tclVar() tclvalue(vsc) <- hscale replot <- function(...) { probs.pre.test <- as.numeric(tclvalue(ppt)) sns <- as.numeric(tclvalue(sens)) spc <- as.numeric(tclvalue(spec)) test.result <- tclvalue(tr) fagan.plot(probs.pre.test, sns/(1-spc), test.result) } tt <- tktoplevel() tkwm.title(tt, "Fagan Plot Demo") img <- tkrplot(tt, replot, vscale=vscale, hscale=hscale) tkpack(img, side='top') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr, text='Pre Test Probability: '), side='left', anchor='s') tkpack(tkscale(fr, variable=ppt, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr, text='Sensitivity: '), side='left', anchor='s') tkpack(tkscale(fr, variable=sens, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tkpack(fr <- tkframe(tt), side='top') tkpack(tklabel(fr, text='Specificity: '), side='left', anchor='s') tkpack(tkscale(fr, variable=spec, orient='horizontal', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ), from=0, to=1, resolution=.01), side='right') tkpack(fr <- tkframe(tt), side='top') tkpack(tkcheckbutton(fr, text='Positive Test Result', variable=tr, onvalue='+', offvalue='-', command=function(...) tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tkbutton(tfr, text="Refresh", command=function() tkrreplot(img, hscale=as.numeric(tclvalue(hsc)), vscale=as.numeric(tclvalue(vsc)) ) ), side='left',anchor='s') tkpack(tkbutton(tfr, text="Exit", command=function()tkdestroy(tt)), side='right',anchor='s') tkpack(tfr <- tkframe(tt), side='bottom', fill='x') tkpack(tklabel(tfr,text="Hscale: "), side='left') tkpack(tkentry(tfr,textvariable=hsc,width=6), side='left') tkpack(tklabel(tfr,text=" Vscale: "), side='left') tkpack(tkentry(tfr,textvariable=vsc,width=6), side='left') if(wait) { tkwait.window(tt) return( list(ppt = as.numeric(tclvalue(ppt)), sens = as.numeric(tclvalue(sens)), spec = as.numeric(tclvalue(spec)), tr = tclvalue(tr) )) } else { return(invisible(NULL)) } } TeachingDemos/data/0000755000176000001440000000000012077040011013715 5ustar ripleyusersTeachingDemos/data/USCrimes.rda0000644000176000001440000031240412077041110016104 0ustar ripleyusers7zXZi"6!XԒ])TW"nRʟXg%>e@I Ծ.:~R/@/ ay*mhwsL=V[M<(Jа6zAJǠe|[FN'`{͸t}H3;p<>wc6F"E>IP4dtŁB Փ0UT<%)ه$=q,ob/K~cvF/qv~l.5\o.oS̄B+Di <)V@MQq06N$Η>>7 Vc`掿dh!ߟ c˳iVKp)K jdhδ~},B(&r$Mi&䡏\\R'%.pqU2)_拻Ʌp&BIY;g;4wvN0?/SU"-R0Y[Ng`nJBϘFVQӗg+IѢ[,{l{hXjsӨ'HfHqǜOA{0;FS[6>}'@g:MJ;t2i`[x3sQHyg>jbl{yLz>Z&-Ia&dy 7nk$uZ!s̍8fދK'%AבG#6ݠ@ Y3]ݽRe[@\"Py<ڳKIP[ mKH3W,0ڈ w"fҶHbϰs ]!S=Q@Tbd%?>u螕!g[?Yn@V*ϢI$o`EyiH'ЧeYf}B6h}zV9@p_4IOJǦ5q_ǑB$eM٥'l>'d2g+;Li1<yqbWX1^z`Vf4v0hİB31͎s/4SOLa5}ǁb U(x +~A0sf^\ `iom36@ 9nL31aOhjٜxrw5LlwJLx27O.޶0(Gx?}0T)8ԐWT X@u<[QufS8ٙ0n5;$ 3;3BYN7Qn_Wf23B hbyEɣ G:OA}Nk*K 2'B1ů9G(HE0ZCMoj _#j,1(A;Ǵ "ȯ@1([d;/`zk3L0]dA°C7qː.=v5ު:}1c4Ǣ5+;U]NS\/}n-+Q8E" X`hb\& Y@bHwHayDs>ꊤOot%0e2{a) Z"L̔I;V$-?)m]FoӹX-\2+$q?>VmTժ6kXI䫒ٲ-)VbE6tG u@nT{E!ٸ(U[Q.>Y dVBh_1`}`8 @STϜ|)"ҾZ{$J0(?03NX+m%7no:4ckSTnv9-?a0q<U:V̢h W眣qF}j*Dl^׽BV3-OTlxܗ\ 2\öGǰUU]b.xqۼ=> BSj_ڸ$f=TG*QHb&8PT8+A_PKMm4촽0ʋ&a_jTT.ў=ʑlHa!@ vFT%Kz\T\df6lU$ae XRbj(r -28djP?ldIZ`_8V+CQj'l:Y謃YU^C/{a!F$R@v,++\lҝ~;֏pEKxK!{5㜦Ӱ0HV\.' B Tޞ:8:2X; ҴOit-H3Dh ַhn\\=bbؠyhD”u{yRRp154 %0q @v$w{DXJ 3J=BJ4F+ĭۃEۡ% wU ZA&S8W.PeNAjf7Vr*soޚɞu= i.R(->ɛQ`?+V4ɸd9MAL-uF5sβtŽg~`ؘ?KpXA M J³錐xg(EMWTy7 5ajֈa2k1MYvb*AǑ{TT'M-zU7>j1u'bmqgq1ZΒ?._δư{=rU~x1"+DBy![T$ZM*~mUi%z"=D^-( › mӮq'U  ]l /ˑF_Nt̶jdVQ2夤ZP`:T1BzB:!:7 xtLvq }Y}m)B~Vm`Ym^.lS)صQV2-g][=U9#j''YoCj!!fraڶ2EҵXLU)5\-9Q 1 !)G@cXUV8"]>ɽddrnFA]O(r9fG|~"DK@Xk'%]@#r3ZG(Ѹ}Ou7"$kogR: b=A1Nh*Ht'C{/k@"q ׾0[ .?:ftf܀'컳v`b?Дi2S>* B JI ^?qMO|^{%i풭J50NM[+ W]S2p[̾rE[=Mw&4’uxo]~R+1f{gmW|3AJ#5/nu pbٌRZ/oو`[+wQeF[cӴ.ǩO5-їFPaZ_UQ4Xĉl,AdϻɓlOŭ42P?㊶bH1.Bk=^b0rsӨpĹjyHHcew(z5-E|܂ly-M3Ƞ3OzvC?1@ e#: U;f,:Ir_kc!uP!vGtNbu=}aX:ç1-U,y!σx#7Ft+eZ^^Zg )M{i;/y5*\WU:Ƈ0-cu7Ӎ4)FBw 2+-{&?s Y0Bw D>r=DoNBjL 1h`z<ݘҌm ? x#As#!JS{RėkZ>aJrz45d_ Qmm@=h:g[+N742phHIϞN(ՀPjVk]h:_t#;RjapquwCeGd,+S)1X0x3;憱ĺ'\wm[IRYR}01(=DF$WgAg0gt踤RWM LB>_"W3| %n+#wϪVjHz4ohEFqbstכ]J[:Uݘ%+מR{O,[ 0[zqf(6ǛЬ*̗h}g: eg'1,ИTDl0HV U5C cҩ)_/넇UʦKhApW01em3[^jxcv/?\CdK9N ;{f!Ttc#XZ LsɄ@ۂ1Nw1z ,raTRYЮ_mY+a9]Kb!_gSm>9! &jI@V Q #Y p~Swz?;C^-]2%V}(9 ?mB^~C0;B3 g atC[aTJv"VOL܈L69umQHb/lgQǵwξrzn/$BK܉>[P921!|07<E<)b&$w^U:xzpˈ\wMAZצ{MJr.3rUդ!f +0ux{jQ?Ka4W!=&DL2]a+RPVADSPJ+D1T\T,/]Βf.W_KY4lg(8wиaa^(H7{s 6]\ 2iŒG$9*G,C7k{(?$ԃڟ#|am5kiNg4L08D* p{ȜP;dLgS7OzԪcQW&:2pZb-h &{cUS$7*PAXf 9;_"lrpzŅeYQq;U(v&Շy;Q=aw!8Ӧ8V9XIscVW €GGD\(ID͝$]9^=DQ\@*BK!Urc=W(bǖ]YXL-Y'@'ѱQr y1TͦOs1c_UG5[yGߘB?zrK^.xdեyPu|&/ b)(R\FU m3x\Җ_Kiv8 6SEZJ(V?NA*$E,gL!^_EM֜Mr3ӱP"O.%̀+㧒 |TAd~ rUrI;8~[¯VH[~2^1b[؝QI;:ӵLq@(ESr_}paLlAk)H6~0*Ѝ&RȲYm,[TL͕{ YmaVɟ">҅,*m >5Րa#ZF}0) ~x">RUB4p9LgJ j?!X[j4q0 fWԩ98xmTN8Yh± ~ p$BpZ@3k2f.Uk~>.:i4!0%\۵~lLjE5 ƴcTdwPG,^l 6a*2y#ſ*#.4":v@0@,j~uPW샥7F?ڷOg-MgY"UmѢWSދx-7_]"&fjdž+CTL {+wQV8q!PdW]g qϞ˅0TB[<FGn|:QYsU`RVBJV띗ax@M@؍a-ɡ4g2B]d2l#q>!<{s:X/5!c 3W7~[|_d~Feydfcc?ߺ=']ZƯZ 9ГB,D1#]ޘS6: oM@鵴_,RV0D1?Pzw~m߃, '%;@^)$&qu/U+=:!H Ttxr3~=O)"9Q d"־4HM,Pc|NU=Z7Hs0j1We6 jT=ң!Là`<켓Ap9ভ#$$`_>;TZIUj/g eփb2{alt!$?9UASk1a \pҏPp}j+U$*jX)=N}ٷq2oI\ aI%ʀU_bH)Bx&`$$H"+c[M:C$eex|Pkec/b~HbLRw6ͨpPKLZ.v";M^6g@Sd:|;O@ D] T;>R2Y;'tGf re*KxUs%/ y?_E0k >J2ՠe 0^ӦOn1~U̹} %^PF?L=lh7б@v1Wxic[!W߱Xe0_OJi˔ (ގf-%b~F`[!r+,?S~q㌇^iU E7SףDL>qn>P<˶-jn.Cl/+m(p$jKU<{ I RXk%t oΟޞoن+:,6.'FwC ӗF0`;8L} >"]"#1 @/2Xb{"d['.͇n<\; 1RnױG_T*\DN̰PP$!֚g)ؿuי/vQ&eyV$߇5vw{C-pMhpM=wo-  Emk^F(a1 wi_PX#9|KnPbjM@\AA79M3Cb)~@vJ| /mU1[^',\Se„PRqJK8oA #RqVbZdNv%vg}Gkk9k6✁Ov&Ɲb2'(]S\^ڈvΔ{h{}Go}G@3FyO@++JgUk^ o%g9'}aZ׮<ٝɛ8Ю >=pfTk?Beo$ghLN+-s|"|)j?(T[B =uHcʬ9IZO^LY{|:jjNzKH56.7nv8\3wOVZGxu䭿EKڶj3"W٭t71ʙZ$PۄT9:Wa1JeeDl3  F%{P7]ld?⒧ :/*grH=&r۩V8V6ZX85.5MW>jKPlzyh:|Rͫvjm1Ôa8`j8&ZMp #%k}4i]k| PG$Wgh!-vytFږm7Rѓ3&SѮt < E'bIFK.' VϢ 43.a{I)$D-'^^bΈ|kk!l .K\m~%$T{y%Z Qo$#m9Ua̵|NՐ<㰑C`շ7)?èo$A)ls< ;Fc Ѐ]N1[]O(KQ"-'[{+JΑ6L~UTO.l~˕Y`saj-l ދNˢiS8~9$PuCV}GQ\4q7l3i}лGcP.Qֻܴ0n?$0} 0\3r$k[$(i#'@r[F k2:1y=_۰P$Rׂj]횩jHIhW{?AWBTδ-J7b!!K}]WOXO٬U8\'fh~GJ &q>Ta:+_0Nҟ Yl$G&q%My)NF9=l**\"m\8D$dTDCVb\E9547L5؈?x k=.xlW6}2bIxwt`c̦}2ĵѾ&6=l 2BE~܃їoj5~i!XL8vN)}TnHF}4qB&I e(2eL)LEJ_"s' ]3Tio0q 1ؚ.J8=}x 0kމdmG*D rq j̖ʷ:pP :3寧Ta}zgNSȁ]LFae8>[I2VhlmE~ޯR)]Kvt+:LGYJG.\`OѪ@a?դ1MvE.G0A[Qe\û?v\0RE.Vtd0xk \xgh1pȃ (=2G(ih2Q,Aݤs]ˢX%Y j\K$$&2yQm;#J+C} {7o-LeW'(YYo d*=1&qu@[t5&}7#pEklIrhz)(DS~ii.X(V#18)Ҕa>sLgz9N ge(.!{}bB8]:Q'XY)4N>gPZΤNk.}ѫxJ#qEs 1q1CMr*'p_>*]}@slPQC}1Y!+4 W ^NGS 'Ğ> /qԣ#BB&= ;rh<4RZt99UM9 gvr8s`4mJױX8;˦qsLV@vcXm a B0Y-8V 3-3A4$pw*8J}ٟ΅b+osrkc 8h0;p-;Q/Ip_n,7jSRg$lj4;:w-_ܿ}ԑ!RQ[w>F0~&wQ)`nQvTrLQi'C4oc9FSS4/uP8n4R݈ ARHwcѦe^7t< )jBBU6iG` y+o[LE5^蜯VJpmH8@–yI&^tV%ADgo$sߕXQPT -- 'лj(m I4x+<qǤ6X{'Ap/=Tl 4&.%^2ayM_9ϼ,?Pui k0{u|l:Su0U(I}טRJv)$^2wHT-aȯ6|σH? vSQGQI،4dP.;(b𐐏&n8~xt[}0)6ru'XG3Y8;DKcD%{/be-`qmqrv.s/wO_[ë2SC]!k)-ІJ/m/eh`ܯWޣnGC=+:_]liE(㞚+t?aRT^/?FR],^.#lcL&@!x𪍳v𠽟9%%Y4@(p uVQp-f<7cALqҎ]7 М|;U7V0w(qUۭ+?t㕏ؓ&CjI>>]K=5JkTJ͇ͽGjYWwЕW[YN(Cχ RޭMssWkcT8Bbe,w`<%A}@-;`{yTWGc "\gd2r ~n[jMݐ+ؘx"[B:=C|UoCy6V6QVy;۴ʎKWH*#!&+ۍ6ca'ȷޕœr1aK¨eORji^SbҬKtM.&66ICX/ȱm;g-ymoP {(9G:O̰y֙A⮃ LHm;:ga++j`ߺvLaw3w$89wݻmQ47I\fcYTNAmf`Ȱ21X$RWj2ov11^6*eFij4U!( 7KԘM.ڜWm^д6_y>I !e5Q+_n+ʞ";yT"Dzm⼗sahqU( cGJUz+OĆ@7*-=Yɓ^yqԧ ;u(ƜQDJjfn[:gQ~/4lQ3WRD \>%gf) ˉ/[&=DL]'+fζ+5U.-1Xh:&@яk-ɡ\̅F:t d:K>$.#)9K&,iph?(É@h|V#2oGppEUb?nX1O+!1>ߴNeZrK&HׂnK^V{$n4^`3'"ZV`_jU^;77BbS݉" cӞ UT+{w?Cuˊڭ@fiiwkWwpPTtqpx"SdڃK6}*TJO(?$U]Tf_YkBbqڬ#)vnӫ%]&Wq~O͘S6Jbn1x6 4mjCaW@[Z_ +{25}#I!/\ݪeCSb*Y8Z@xdý/Z7&H$w6c< N^ŭ́̎KϳS*79LdM\@[cwҀr%AКDcZB66튑\*g/z~Q rLx$Sn_Ӥ3``&{G${K߃Zܶ:߅HR]&t Ojv'b$?|tOqmdW(6KOV塂7큏UmqLmB:%VkB2{#W9uվ]?Fj]g=)y{ZbNw +-C&ptu~F~BL0ܥYnh]$ eL쇼3$NOblzd'83\ LF Vqi!e xLQT#$6EA;_iOC jgs^q0$o@H+uz _3Vd\nN| X2n 5{_^*}Vv8ߎI|&Iu;N BzJYΛx^ Pdl%Dɷ]"#trBG% ?Z'QS1(VԟՄ[ko/>2&Pf@1[],q ',}#_B>1qOUΫN\By ү yD6<!ƴ8JQ(M`p^<;OzF½8Rz 1x+?,^SuBY;)8_c3|< 8>װR\¤PƔNx}"s`MȂ{xHt`cmc(Jl;2z(-T}@I!%7b…tqzI=ǂ&1F*h%7-\i9RKƎoHÉ,oJy72{GK96ٱ4# ̆Q-E?GPG= m"6XDBSkѣ 0s .Is/3h+gu)'`$,ҩr449Seq_=XwK~=p?MWm%n £&Zɭx(e`H4<:8,,#{!_pi452+_ PaCy'H_7F;T c.2#pMW1^c7cDSS~CcҲmKzLIU>3EGpY6މ^G֦^TX;&ґ[U;y8WvFjrNmH<])ՐrE6,+TȭI)ZU6]T0>+&U,c%.wEB7z>i.H!q>tPo+w 'JT1Of4.y cD=b^ JiF2lL] k|Qde<'{O)]xێ>R/>MXFDm=rLчۄG/q`km?!8<K TtBBw_ecLmX]!^BqF|Bf;Yxŵj{45A񦅖emb>.#\B9/Y ʸffVUCq;Ak1=;/،Z.=m{!!W^tCA4u+b8{|L_TbD]Q_O3G\A$ 2f<)pQ*@2HQ4{kY{?s[L lኟT=1WYI~s}kv4,pLǹ~/ݼWZEiJ`W9WjQ0 Ʒ,@^pÔ྇X;c"9燃 TҽR`MԒw"n2F-@@{dT/>.&4FGd*ux# 7h\Q4b̆#MS" uu}w%n1Y^K&Ov"W: ҮZda@o6PwP3޿^Ȓ i:3zs{5s?4x ɳ&PѮ:\?yE;zrHX̳;R8*˜ez곜Sw<!{[` _*ֈRFD =d8nV =PKm<1h?r]X.~f$q CQR,cEeט2N)epMqSg38 D/\w?3Gbf`bL kN"r=v3_,>Jۯ`>Sq$:],="d kǰW>y~]/0R_̮tiW_1{CnHu䔤T:L,ਥ[#Z4X|_$ Y2m4KH]qBWDԎWءb`s*W%pp!p,$3k>b%.ii|07lbo1)SNvXRvإ5Nzeo^JэhR{x)ta1khCՎϨȆX3^4+A/g~|Wc32%0NM#Aj:~ɕPb*l {ꐲߤy~|jcǰRLƁ&*PA``_'z'ǤK`aߕ 4sF.' Zk8l*䇿^, UFjM٪%fã{ǂ|!T+x-E;Ǧ .r8 >S1=r %C"gc-JX^:ղNT-[$3,)hT2 жؘDՕT"CrBnT$ۍ5 @!)^0HN`<( HfUydXbUjl+(~x1nv:'ׯ?O{1ٯ}.Q {#Efd&M0Kl|m`C#!/ ^"+TLC}VtXy^ߺ DDE`EN A~ qU٨DmVCuI7p2TvnPe~"ԳNNv>Vs>Q' :ו8& ă3)'{e;EC=6fi2|=q7ؘ¯9=AC=Hw6ƅ= uD !V`%-+H& 3R8:{r"`ZܑJyPTd/WK}ҎS0J0TOqU揱sLϖk?ж2pSJ 96iGP!ݞFߖRygDhjw8JvQ;C#EгDaMC݂.Ӽl@=<s۴byy[Ԋ?~+X9W%QPXh,;I{p`VR__BAb|&wo) @4Q؃EmB%t{M8=ʤuE 2h |әD7lLvl3Yly~YITҒjَҔ&`&ќp7Y1\b1QlWMs zEґpc2cyOޛ/i %2XmAwf|FTyh}6VDvN6}~y"2Wn8fUUхZ]ySq YOaUh-A8D>>.ksѯ396>L>8_*724"Nj׭]~U8ۢeCgb`/8 =ީ#ܥ]q.PcwX/aM9}!:!efT6(D`48!E6͟A=vT9nC{ 㧃ZWO RS֐pɨ+{iLYa%} ɺE!kpw܂4<\vì=d:7Vٳ)\0BF-dVAl"ZA߱j\|TYcuY>[_vGRu_e6(ņZoYiF> 8g]R_20+OEd}70\h `FcڦJso5  TIdIlv D܎o87{ᑱ DדJU8/rLW V˙÷ C KRb.  IT]^LuA%> u%? ["Jq-L5cc|d6 jۈn7 :\H6" [Bfq䐸Ia&`OM/Ƞ ] (kW%lya!:q5>Vn+Irb$Hn f̎󭳖ī'$3~gaS& S+syzKHQ^p6!Dykj>1]/ƞ Ky_d[{iʁT"gszZu^m$wo ptxl(̦XqEΰ4eU}7+/KPަ\XB=P 0863q6ol T]Sد6s9dD\X\sqelp9R.$:Np_GNOdmZηȻ-kv8=[O4_ ,G.d;4. 1:dSp+JTbQ h "I\xk5 ;\XF,.]&"OP?OԅNo6\p^Άѓ]lr9 86 Lm\g2i&;z"%Ԧ~^Z9҃vC`eip]' 4ga1dʑ/MTސ; rS}!n$2@ # oɊB`e΋2KdHBfX)S۶KJC[kUOCYo^uV[*dgP~Z2q#ӧs60 i*/-h"V%\W.j'T:2e$>u_hv1q8:3|c]Z5_[%nʠ]m !YW !ڞcH@!bj[Ef(e^Kgq ,f7˶Fs^90/`tSIl|Qt|uS1>krKа]5L*Ls."x7GZ9T % l5j&x&zlr0RE_m0}{b21] S!0ȈzT:dScHD?%LJ#:*Jژͦ@Ⱥl|;"y;$bOW/V}X E=X384|umkMl=Vv- g^Aik7H4}ef2Ԝ(WAGq^o^5dzط![[Q %H I?,BAvԿ[/~ΛwfX_zr ~^_lJQ%H LC%JMEAeb6#'8_rT^Xrb+4Ŝ6:υ ΧL X)cpnxUi=i90N.BRbC7˃fI\ـbvjO۾._Q*8]`%mK1( \H#'K h㦢?m)}_Vku]ƔPr{neE WFYPVxe}*'F3u,b^KY8ل g1&gi/aÎ>NR'62&iEn=o=nr qi6 :ōF1Q5Җ^՞QFKN62D<>yAb@z̮҅q<}l۪=z9ZIqÕe-$G.`zUMteAPMƤiX"]aeK `Z3d…2>dko*dֺP3q9 ݿR~U}\yZOg_WS֮KׇMJ+T'wx`2W()@r>exﷀ ]XUNDݲ$A>, Q%(>{c0q\.?r&rF+0Әl h.Sٱ&ײXH\͐ESYp YgL6x5}5 = Au3xf6n8/oi;o D *eu^^@G1iὃAĻ(e.HL֪ueQ0BCjOi]{gҽ.TsOnj*9qw;d(^\xBmT\ZWT9FCtT묖T (wi)ڜQ^gsneCH!o>Zܱ]\.3TAj37~O ܟjv6D #Z4x$JMo'Ph"~\m@I$~>OBi |/^-/kqUhŐ +,gsV_gGuIAky uDPΚ!+\-ʟ6]ȃps 8> Z8k } Fo!ZPIt % o`irj ):o@Tn)Dlz49V~ GI#w`p܂h ;:%BTV• 䊡R.dƵ=Nr!)+K3xtE>~MjoeH,- 7i"uˀҡ<:XGjfafݲm0MOx~n (ZdƔ׶3eC'[B}XrDG]!"kK2 u?d\fuщD@HUxYT>ɕ_@P}#1)/*ri$ݽ-*xOiz{rX#hm2&\)!'FJgcˆgMupHUE)J< 'BSdl8Os1)j77͗4(h5XM%/r3Vii'r/WB4'iye2h˭4֦ǁWLv'r(F` nоgvoCŖ`\Z?$HR%:3yZ>gE%Ph)㜟3<憼7q[mx䆩#[RՀH~Bߤ0|鍮}/S$cRq8{[8,{@0<1rc5W[U7eK!wI\sY-ۼE_Y{MxoxXj@Z/7imM9Δth:nU}K:پ*OM/&.9,^']ʊEZDu%QL@+H% ɤC,Ƹރx5CrGٯXR88䱩 @gN!rwjrxFA4m8wߠѸZc.!qh{RK : VB!1ߛ#Hbj͐KWdx;q.aҿI9yGc/Rv Yw,Y-Ry:b7,[H#뢎CN1 \l&wA{jM$yNF~sehHA+gwVEtX/)༅$Kb_?|r~3ה"cAv?ղJ=dߊw::<$ՏWGt Hb=Ŝ Dqe%stnͯK?D%X"o;})HbF/BD,| QHdF"[v%E-0)Nu@丸Oyl1SEQ52t;CdY[G-޾n_RɺZ rѝ&?&8Dq f#z6rDWDqUյ%&YB=k[jdglàU+T<$NFn PA\C1^I@S, g5sǏ*r{5:fSMB gҴ]$z5kY_rꨌ6'+Ɔo-4vR-NLU|;d-ϵo;%ql.bJ_Nmq3 tn(Fi DUb lH$8r (_sÖa3_xFxJ.7EY>N^nP؁+*˝@8_-`Pa -QU0:OC{v l{ChŁX% ]W T$\V3\uduZ'3au4]Fcsti ג7nUN3 Ԣ@ڽ Pľ Vu$430>u#G#uꉫ*_ha|]173b$+K(nXƹճef^XqTomqzpDŽZA 0vv_ p_WKrG /p&n;R/tоi]&@f& bYj$N`L^xH)@R1T+PxMR5Kɲ!0BMemX9Δٵx: 9VŁyy'Ĝ%[-gyHpH3# a t?xۆp1;50iZ :4 f<^nMpSK6@UD ؞$駽MuPfŪrTpشKl|7sq;bՓx'QFLeMb0rbמ>65˕xrɒEĒg ?LX_7%-X/zr%BQ~$oŦAAVx{|-Nq3#li:p8|{3=^YEvGeX,{rF.)5# 6KE8SO7;^A>`O VV¯s: ! E;f P&(e8b0ގs<)}@W߇_XOWCD%jgrhB@! KOyI3RIEV(gQq?CWlj!~Ł>9pzbG# Od}}TIcI~q3ǥDrxqse3pH(q-#aV";n԰1FY= V vg\ -N,kӶL/"Dh~s(܂ ^D9mt vn>!x#mAckHJuW%P/mzK~(uap{]+KN U'Ez :^ByqYtnp@f)NiJ5(ZϬ}XuCɄ%B90rk35t{Of5ە\yF{S:`-ޭV;}V6᰸3Nux@z7 ҇ؤd5iP#Pf*Uk*Ppuҵ DU4(t,4cIo`I9]UȮ֮feAut='3aBl$hoRKuwwJ"5AizS볻957]P: PFEfW"-%Raƻ^;L2ڟBfڙR1QL4*:\LB]j >AϢHlc0 3mb5IG)C!*!K<7 EA,t(2j}Ӈ6{L=JGfd\O-Q*e(>8r#:Exi7u>[ V\+%1$Q>>kI! qX6P3JbbL~(];BeÆӥqWBDﶵn珡?Ʌ n]ϬwŝdQU!1b0$k?,}9' "p<&#pCOifʿzkMkbH aPUJk651xׁBkGLL])jP݂u Cw ZB7]=3aƶ05a \Z>e kkƉ 1 #S)a+ ]@j}@GnЌ&5#fr۔bݔa񫧠?B g/C]6ȋRtFn_h#X[ٹ[*[j;V7pd늰t#"wwsI?, t']TYr)U!Lċ;>%oBtX XI/ xkl#q?m{#WӀ& Ĩ3R!k,2(-&RITY;G`jH+%.Lp$\/U='5eۍCG&)%'܃GNy SXaPi[qm }K.dT(;4Pk=M Dm#̍ X 75ihcHKrGZKt Ϟ}`͙E jc{, ǘ}y&pnp}`Wz d{Zr 2n; t#s#E_9U*wcf9PRs)ߡbfX!_ $y]rVÏ$f2X79U# 'a.$yG~9[\HOXIyF ke ㋯E">>"1MKKfwtFȯexŬ'&A.Z[e5<"CtܜzBlduٳP_'Zir ']"B&7ʡ;0*K9P*Iƀ)5>L>g0AlquC⤱Dj #8K&Nvfh~?Fҕc|x򤄄O28 ֖ǥG4i]EFF(<hG,Vzm2MeJd>ΘmfͦPjKzVbnh> A& 3Է^奾 i(jvgj2 SXL6&J&V2j=3xHv:qvK*w4`].S-|ȼ88:KeMF-T6*"6UL#7Z.`se h&I~ߺoȩc#wO|'GA,l0?-KBޏe YvDQ08wӾ6I xA%!UP hK7uTBW`M 0p/1!"%<%Fl/¢ U>ht@0ڔZ_=Lp8]/Kp9~PCΆ _9a#ZxTs_Z2%0HE0/-[::zI38R?g£#+M~!|4 Ë}nT$9sfܴ&nքςj-ZMzE:)F$m3,<*G.|`|q.Ӛ9WMF[$;ϕl{G#<ͅ[c7};,!_k\rz3:{A',xWiDs.\Z-z8AQHIWBtbjȣQU#4'4XVyNnH7y-ю_Kb~`nAIfd7z/Te^<0Y^<[]-nw8 hú &GeeRf+;1*T`v%6w-Sw|eĉa02R>!&5| .PXy=NZ|k@-| U ɦ YJ7{d qg.‘s_ܚpGphIp:5qPg\ts b)JYom 8(@ijfS +Wz{D~mZK;=ϑ~L&tmV nD0HF۶pT堏{7:B/SP[%=hZM74~@ s:1/Uv&IbNWЀ 3V@Mc@Ouy*CKNgqWsu#U >xCR `0$l#c_4$`$:7MYZcCzxρ.>YO}[cЮFxX*P|7Y $^Q@J)k ;*.E;]jf @p1vN:"Yc{1t]يwQw#c&OyF9GQ4}Nhф$j8(n18(D%?B&ɺ J/D ħAZ&2\Gj$Ԥ(!) !yq-}|csޕѻ,/ &IIQu|1%X7(6$Cyo9_tu)%vcTjI/ юcF-* ,~BEcctA2`^O ވ<1j@+$ }^Y`Ge\z}6GרDdk>!c7:-I~'N]"8$CDs/c,)et)P>^V BHiFY +R3b dԪ^X*Ľb*躿;*7cp#&퉧 ~_Uel9{`tU7hcdS›%:chK 2ĊώV-ΥuƻW ?F$:(ګRfbto2}_m#7lD(|S(/HlH>hY(&gݷSTVdT"HQ[Z9uDGz@?(K"AVUF|/BgqM; ^56& ("Q8\@֫ ߅3 .Lo&iQ,ͼ;bi`m7jOLWR]I2Y`1kcj{~!%¿m>w@Ѽ8XT{R2vJkM#\̬M5xF;}dmO)DlHNv~٤zWvX :Fۋ]D`FnO}R<{я-'B"iYTk| '5S$f}O .5H_4yj)#C H,ݡ~HwG3Pbƍgt6tT 葶"f $-ΒL)I?Tq`Y.ɄZ?-&93Gjv yRR9 6#]9KRSxg,ϔiRU۬_e햢}kPLmH?9-l_Dl [fJ4/î{b Qwp'Sl& }l*s'U7,=4O> S*Ep'uBJ_@%h13G +Ax#Au\( $[?Ink+ƍ_ >#>K!}(\͋MTWh.=Z;:?+B=ڮ[ U֋k:=y#:eRv'(ct{%)p!J5^:;Xn+mDdNĿc<%\ӦӦr@Sq{8J%mFyؠ4`;>R\Keqv^,XWΑ~SwB|cB=12{}F+D@}Wp~zJ[ݐ꽙N&1!B綞xGQuC+/L7XA /JI"' ~6M'G_vV ̓+N0IrtRL_#+bЍX}' :?SwOLs7Gt($zZh7#:wϱK!RtjS->NYiK`B"fɌZ$^=PPXcN? yɯdls,_{`[njN:L&<<`TmLBGB@a;AՇ ߭TVnOMIrP!UgIMdmJ}xO5ztDQws^V 20._O㑉M؄Ň!L"Ės7iv\T)?j4l+tџ,b)mD6EDS[>=FT5騔7$U PUC\+<[10@!r,‹FA%emerd&Xz[{EFE@ >Wg= wߋkKk. "aivSņ&L[=فoJCD0pIH'( !n,lU9L/JAqj4tyobZrx &X ?pivM܋, @G*CQYcjRHLӮqhHYG%2<8#J CNGq?3<έ\lQ$ y{{ <#qm-jMO/<tĎi[[oBx}㰑 ξ s4,@8^ck_͞-~EL=nun[P͚R~\_$ɝ<`ݻkQeima֕Y_{?T(w;KCb)I+v Ttr)JdlV/fz:uӸBݼ^{ psOGHq-sYLFcFnrU93? 1 oFGI|Xjj }M: 7>ew`xMp;?x !Uּ]\"bNR{eS>!:t3PJqziSvm*wliUMS.IkO}Ht}FxFiھ\,j`zccc9k2m ~QzyE-mg|Lՠ?peW;3}gg…ADh2~s].;GƠzkSdZIE\Xp8/HK٤:SfBq2/뽃N;ݚ>q¢Rx}gYq1̂w\]3MPm`+]4Tzn:-( ddG_=FFJ~]_wDb~Ҿq1hd'0d'ZigYJ*p]` NOv4cSm m 'v$]*˯˕R!2*Gd^lM i/芩AT!#SFt"݌bm L91.U@ JΤ'I2@4;G==v,kpp 2IIG$Ug'q54Rs84UFqjZXGX"xV'qGԅZ"\\nu]҂\TĔs:q7FaŨ;`ڇx^+=ڏpTzE nSz)ĸ;< [_pj[ף\ӷ o0t9 Yx!b{."8K":BJsn4M7YрzOfO.ϋ44Kgv_ctw7#J]w9$?T|`\[{Fy ^{~#)p49#(j~!E 5 F*eQh2^nzRPUFXR>-g>voB<ACEzEљt6 .fCp!7WUs\ v:O;Xa9`yQDԡp~PD_vBӎSjBjiPjh S}`:w8r(yJ=#ъʔ)v=/cbt]RmXK(ڷD4Ig#;0/4k_mYت(NqKG<aY'&b\o)hK\'JX6'Ms"TF{ U:W}a@vi!iu+m  b/9w| 2 e"|Y[]>ߚbb&vO*s%:UY[u-fml0/;BĬ6+>_XYd]jd2g\*NXtWS>F/r..3呗u }2#ә,b4=YnT_oc*77SڗYT1iL@Id̉!GjfQ rCm;=uKz OS)r-ŘwyڽT>#wHGM97eTKe~J}zȹN&ָQ "E4vDTyؓ))@a9%Pd¼JtNZkqokd\AbF4=U^.x?Pgc sHy=P0/^Vb} ?]7EDJH;9m.}4Β<粍{m~:=Eʆ13'd*Pt*0|Ѡ=Y. yFgne-R#2}p5ڃn+>ugZ,pRTVèoOnl}CIa{|ł3L]+ u%sKs άG7_oK4yIF> f*S!S;0ڦؓևy9˒@[1/:9p_ʕGSLP?[¤?:}Rl7\w:wX&&ڴ(w880^$,qt,Z,vƟ`uԡ.cK.3D:,`:rMV?)#lk8j1-vY9tζ Z#`L}ZvPMϧN2R%:@O&I4Hge9x%f2 xp P-`'A4ǯ*v 'l%%0=m5~"i:[Ng Cُevj1B;`.'#J"%V>4yΙ<(yNR6yC[!:Z31|˿hb$OW5 ֵ bʧ|dn ʃ%(吗@]+$ V Yn%!H/|쾿=2HNE=x9- 3c"Hc#xa{5'Ʌi5*CG.a*$4=qa&BQC)I9+9CX ri7 WU_+P'׊i䭾+n15 W҂?e4UDeHx<#xs2HpdqQB$̱bAWnT̹QQD;̑2|KF]}2=v^ ,rԎiU JqL ,J$4C" =Q\S[&PVN?zƶVB_XYr؉ a]N{vv6:!]^?68iҕXWN:bIy9=zNH$6gsa!$;t?%kWO[$U&Imֽ' CC, -<ZB_IEs4P1Uj7(!ϧKb**a`mlqɘY{5kw |/(V{?3*}>#Sݢ 6?Cc0DFs HhS[:g\rēNeS/-O`w%CSm/VN~B{O/x:glt&y %nzďCvܮ$dZi%xh1v64-6p!;9Apc {TlnE}cťZ7D$E e4@gxCfx (r5ClËd h2tM0"kd~>0GnZ'L'$z]n0#%b~}8pz7>HGD1OŜ/C HJJN hIZE'}A`]:ZV.ąP(5hkuL~ d([ן:FK/Hh7 XP<'fSLH*3'@mtIb5[ir]73(dYbՆXJ{E߾J>AwąyIjK 3uGonspSnS@չK>(&1aP# rd<BGPqj M;z@VfoP=Yֲ ͊6:T;a'V &YE< oD loFª[}7eσ`uyc;{Zύ:"v J' B~xD*Kzi?c0~hz+'Bj h+ҙk]= ,tE>VT2&#qZ6gLyڗQpJS{,Mfyńt ZZuI nXIqWnnH_qI#5(8ۉu#sfdh H U^SL_o".">ME>2*a~F' K]?'frLR $Vޫ؂8#Vltg qxZ P4zvM5frj\k|UM{!@oaH@;4`<.Q6#+fid:k0Jʔ_!u&%1*%W[߹[g3z 9N 5I @2iPS=ɥA:eumN'qёb'rwlxfG=ws)8U)ԺB93 svhGlR_$°iO{_:O 2mO60O]vpmr .͋b}֨?=WVc!kI?؝ ioqb_*2 V+ځ ?_shkz4{I3C,} d=J ɥ5b7xpXWSh'*GlmM֔.("=Mѷ Jԏꃶy |`oU;L:D@R W0n^d2Vë>w gwAK$}x]7AIX; WO"jvUw@#Ю2qM7Gә+}91Hd3X2GPG&&Yqp/"B]X>fUF_k 52 %wq!K n'S'aپ` G* S3n{c6ĒZ t&"EGJl1vȟV-A A !v||+`oQ l0iA|~=_}&"Bfܣ26WZk3ނneqˢMjb Y`LpɈkk'!3$EcTAοQ#ӻ|ЩU*v.$(pEBwZM@cˆ{*ZȤnP<4[pߐ.gxC[mҋQZ8RR4C:yxpt8wz/&C)&Tb?!4<ZlFvі֭%@1X}'YvF2/3e&WnPRYoBD1q?md6Cܹt뚺v<'mJPe{zi~5pU1DLMROCWwa.T~Y:L,OAbcMz{,~Mjr>LHr&)?כJ.\_b7kkƂ:n}+;S3JQhb4z igvG. eqaϹJgVɘU#[Sm$j%Q> ?|ser#::ȜWp.2xH]860Ԯ(չx㍉9.[eY-x`](R"5'b_[z\@9^V2O2"[ox\3Ko%*y٥䭳wK!SrY/4WWqc{# RIhÐu78I{~[L]OnSDW-CW"`GoQ=0wu xofpS`f,G=OTrnalR;V8BcZbeO6ezcKZ SǍKjO .&Om΅pU ;12R2L"! WdFI!U.7\l砺a^GS$ mXo-]>2f%7גvvU6omj>-D'Q }pw/4[a]1y8 GBhGzgS=5 &=fjAD]';|H[#rt-[Yz+tDG凇=}VG9e/|HJ"0;mzĊ |IZ's$Ԉ\*ht$xٰ.}=QS ݥ[l;'ຬ_AfT?VWg!¸vanT;e0 ܚ;^UZ-e![;[m>I.N6;{DZl{Nvԗjnm !%=Kpٝ]c:L4r'-A*Uo;}_Gȁ:$bpr^Kg9.ݕ]v>Żc>j~Ts.ϽqЂlPPI Jy7<߲"ض#YQ=.ְ*{liqVtcx ntNvQ# |mklrNh29l#rPgAgB'&83,{O%JI_ۼѻW= yI8XVӇGˑ*{cD*aLjPjXe!{,efY+Qgsݼ`""*ed;]ӑb G֝kԍ=rT#Sq8'IϢ'Yt';'7O{rTd5>9{쥧FCМLBdm'<%G7!E}{ ء#G)hBe3&K< 9v,b& UqP9!XgħdgxCmuixAOXM]/; XÚi|3-;Y,w( Z՝Es@-S2T a3Uu s0;.ϲWHdGa/ Ю_o$tXxZ`0ƪ[t;yƶݘ}bmJfq ޞStat!/6UװRJ/i.xO]xT7\KyJY)dEw`0k. 1-ZH߰$0|q(|/U[S^nBŽ"?#D`dأ0KՔ8ARbR|{^HDtύm\|`[c1ߩfKF~1"IձřbE%L\+?XN46qƜ ΄;=)s s=wLSx\2ZȫNNßKOM' ,,WAcDoN⧕ܕ]LN#r`yvr 6i5p~YCn7P N/ңomkBCS|ڧ[X`>4"q}ȶ d^AQU=Z\и z<6>4zӲEE"Ns,Zm{O΋C#xy j?SD Ǔ 4C8XYo\>j饼 BFfv!pu٢k%G4]`KƮe믚rm$ImsʵkxZηկ e %"ЦP ,3SVď: ڻX|)sH=JƤ@^\Ьۨsh >G%ٍm\ATkZ_7Bo$$-@ H-ϛPy~l a-LЈ#0!mg$CAdJ,~=ƺH[t"iQԵUPƺV˧*U~Aؐ40+`|kа6#A- R]`cN"rTh3HNɸwxp|_vyrOluӮ{oƷ8ѷ\ v{r+&~ouROP!TSlأ}ay9cp"5-Nd"LFRQHcc1DQ[-3MIex uW=>:}gkjϿ[7(NAhfeUtd$G?I4Ȕ~ e˷"a$CʷsIV` |z6QvdAp;+JQ%Y(O|>Z܋y+x@?D}]kQu 5±)&Մ=~D[ЋT YyV3]X:JH+GawHhqeF-t?Rv?Xba 8R4]n=Mq^ gq8g3D){YU-tAG =+? Bj+X.~baG(1}SpS^@qNK%"p-M~/@ 2`?F9a|}(O=A 8@li.DRĥFKOoT$|MR"O>"rrrx R@_kn}:̋b<%0l;^ 3˂%7' +<EXţ+u^,}?eWv0dXh>Xh=_O-Zhtʽ\Xdr 楋;t׈A _2$Jh~RnV0^E)^I쒛J[0};u[&RTA')֬ ?Ka}+nՅwqf˕' TX&Pt 3Eu=" G\ip^-MC%6}cYII(-ԇՈt[a8?X\`Ȭ\rcv-֎Ɂ &>j$W:# 1a^+ڏ+o׉_nB 'eoDp Gq1"e{`6fOkrbɾyRrrk*@ٝ4 K+[$; >pqH5;xS\8(& kW{*6OTzO2%mStwY%/ Z>eԣSyQS/o<e`F֓`输Á9,xߢ FUElb=%AmMc;6xo돴R>7~kH,8}g66෱[yYTGSOGmbɫ-tc8}I[q4V2;׹Ig4:1Þ}/l[izyv{*kcB8-~;ib4~;1UF!_شn^<4F!VUQL Mr*_.%3dJֈ9!)ʭ&'7C&Z!BȺ Jں Jg%5 |u $(?;|nKH}ȭl&=~Kg˴J1b)>k`ZP Ƨ:y_Ͳ¶AmצxcTIi;Xo.ۮ ʵC#9i=8&RGOPyJ!'&vɰ|ї|4hy_TfD{'VJ",>!q)p 5:KV9DF0BSmy5P7]̦Ml klYDև**E1kIIxh;sfZ0OSϦ+M|ba1hDXVD{_%pxM/!RkxgZ&`}t\EFT.YQf{lxكbޱ9a_j[ OiX·D\\u_ }}:'KW!!YvOpw-m1v,1l]xTy|i6Yz."@lspHk=xԯx׶Y_) cj7\8hs1s!1>-lFF߫g }Rr4aK?E7DA؃Tt9{~1\<]V:تxrx4zEpGq;=S;荤z2ybuy;:ғ1֒)\M|nʫiUT>B$N@Cs= [=MAVfs8M ]&fFB}'6᪭k@ f`HqSl+0od;s( R:fbF 55ms9ևAN,uPh[o&ѥк-86 ͚X%=`xI˺69vW AS*q+?S7YI\A&!渑.Bv6oo޸IWfP l6`+BER:R_~;-uL, naJw ٯUmBƯJm} NQtV˛se;Z6YR핲b}LgIf{PI_e)lmĶ_ǧh@4i!4@ѤM *<:h1}"|YXUVJ${8;J؆_y=mhhLn ؛?6j[̱Lo}xBL+tQfX9N-%(*Թ4|[-M\y jM5Ncs^, Y|%`cf3z8V*ZHhblALɻ] *uM;xQܦjan+kKiY^"-?I1B1c'dmDL$ˤ/u7rgc|ZKJx4[bm^oq̚Y` ͂`ԽBǩ5[[TJUtqrLo9nlSzv f&!3z)Srl٘?ǷBnDb[ޟt:)<\ O^QrVM+r ɸnl*~"uֿXeZ_e!mpW>yH!R3}lP P_Ƶ9 >Rv"Vxxu~Z{)K9Agmv2:r})E N{U$mDMo >R_*FUoD7|sB l"umwy.7QT{14A.m շB&KP &\8*%[,&f>knX^ $걻Zf'AP|e^ڤy:,6 ޵:f\bZy*W=0jUSpQ!y="_m)^bB9 *9C5efa/0 oRTMQ)^ e3=wJ6T,2ԡ㢩06k/ 5:**Vpj!6)34:HM A%hqIeJF?d\j,RGڛ$[g$ӥ泥T(+chn<7٠6=C2c֙TnkHA71mM>8J`HꨛQCn&sŻk1}Z(k/^T1MwCM)A$]Y}j/\/Sm涟Xu_F!ӫ;1- cG| _۩ xm U?_!zj?5O]m}*S-wo8wD/*S}SS2~\]-sY^ZLǭxt#Jܾ:m6bnA'W!A۴巢ZˢXa-;ڸtIIr)ƴSSeJ}XkC u*Ecɫ\Ϯy nP2NOVZ:W8T=qwOY1Tb(Ύj[r{[*wdBRDeP.:{ ]zVj`ڍ_ܺ% ߽.l#A|=K3w܀ fyEx2`լd]k$v%o ܗ8Z5F EF8+tO(1._ǖ,;B#0Oo(pº4'ׇI/҉FRX۹ r1vGnU z]rJ8U vAp8>'!wo;i#MC RJT^Qc(Me)lX!)۽&g tRhfvD^I& $S**`&9ix7z;ЃY- mg| m:/}1b˝CZɰ:q,%电Z"5(%<2*#ѲjGֺI %B~xk^ }GEՎO쓃/&8kMlCĊ@LOGPDmU#-P1s1-ŶԼgl-jՏV:܆ r*0XˆuhOIP GYØ /hZx2z[ N7hAHRG`9c=pc6OjǯE~U5|kr7zp r4nB)B$iV CPwU +7Uk3)ڦzؙ|AKGZN^KxZs26+;_"o([>аB@KtTC 3`i1;/lD_Ha#0qU7P=p")tKc0s>jqfc'*»* :/>(?c87@:$2F8ȨF?e#n@MiFZ +mʱz1w7=\e 0C)har ?Sp~݈F\gVn%e9cu@sn,4gK`v.I)ڑ)Ș x*QM7İ *H>iG tͨJͦ5:B遶}i+qU<^g-nӅ̊εE< skL =* A`hS(1@,$ς([H6h tϽz<!9n*Fw %-7Dsv1˃9ۈ!|ELatUإ凔tGO8waYPJ`02LS}L~|h$dk'iZ2^ V)anŀ0 '3t 8Ekc*(sǑN@\xpge,ND@=1ŰN,8<ӯdE3#V{RHj sXaļ.t|LٽD2vWDq+q<%8P>?(\ulmf%fQI/#'a7<.LV*}ޙffom%HeC9lW~ƀOn謭ꡭO]cA_狍*b cl7chvt(!:mHd)Ms!V5灋| s|:ɞkVװ0?Bk SY9MoH]8 vTXwy-zc{Â,;ʽI] "g׀|g@Su& œ.8Qcfo[1 k p[Ƴ {N4b$̉C}?-vY9`5Ġ Yd˞WÒ2; "N^oWG,8ULuya.1]ݠ5hrwZv_hOoB51C|[:vgC̦l'CxY*5t݇N6^6y q$~PXYp[弢<{5R+b="afc/6$~RC^6sh? 焨>F>$A b0zR-nNpږʬ'3W+M^9E TB܌jy c?ջK88Z%YGƔãЎ/s禗_#Sptiszq=ImBIQ/jdaG9Z ~Nc]|4?F5Pk /5)7\@*Sya]e*EI:rBYc&X 8k.WpS;rC0A) ]F8G5GނIvFW@ ζ*XC742"ZPH㱿9 y[bcSJ'<"ʿĦwB[pWlck?LQR>\ݶ_[v,B)}ak,澙{D/b$ JR~ye`/ >=)ˢG, +M]䵺gԌ_B6X u1S?$Փ\dW&{{Wk8)}jR&pTRФ[R.,XR]86k 3\2m}:, 7[+YXU`*ߤ>!L5iBt{]g2q >1e!v{j =_k4WLGK9l#R;6J*kRysAIs wΖЊc8~%~M0xMj71Y 䁅}[?6VQb.:|R]fsSX rޖ dH+y1/䠮a=es$aZK]C_dcfDԢ<'*p譾0ϢR(܏bO@9/kZΜT#k+:0V_Sbjڛ6ZtK7ʆ2ϟ 9J =CC"d &c]!ufǥCCA } FH,&f "&_E@~nͷ,J^OZl%4+:ZNnI^‚3m$"3fZ(p;K^PukfWoj {w <#40jaxq &g@xjS ^jx7ⱽ*l?D>KtTVS2::iKː; z]ZgfLؒ*weLB,C_b#Dۊ^W@ Y0dAhXb(l0eʔyrɴEHnݘSmǺU*0#ꐛl3}=K/f!d:zG/9|7&S;6Չ0%w}#Niu.d07nv+DTcc/g>]/7fۺH󆾊Ʊޭk<8"x3ۅuW@a8#="u~>dJ<79:`<jQ`W[(lоrޥhΐꐍnm$/nU˕ XS*Zz )If/7wϝD~IWSHҴ e6?B h eIߪedވeHڲl6-CtNEKbK0DTMG(7ʼn 'E9|G6ۏVO'Z +SF sBflBnuLU`AStrU݋.`U;[,INkN 9,0#":n}܅li_J:e V:z^Ovs:z:T>?p0%WDm(+: +?Q$/lSA|=.h0/0}[kzIz)z)Gfm+Ժ#me#+꣮ ^bN Y0U}'oN#~VjFyrːr`Lasi?E7Ez|#ʌFixĿ4CwY c'acUH'<]3QAxyB%rwg+!YH$4q^D BY5 I5RX? ;-%34NPПHZx IJ-s_Wθt$и 3D< Rʫ?G5Ꮼ@=`FKC8&xPN)(g ufcq51fB~g|vME@CE̞i< -a-י@O9Jg; :¢CJ!3tŠu$~K|rǢ׽W?. LapIQO0p<ʟq.4[yqOxM[/3W.b`dV#V6Jkk:2ݍQ˲HhQJv7k CI55]H(Fj''r^Qy]J7=P/Rrz:U ۹bCho5 |+I 2IBɈir=nlYvy{W RVFI s>w@BFYY]PlNgN'>pOw/bo -J΍s0;x Ks:, }fsUDOVx$ZE'Ď};#Y"!=$ђFtYhZlmjSS[ iSCMtPq>NIY= pJpݲ*噆{"c=$]iWvV ,mڈA풩l힒!|(T!^aEbm d%\"./9/ C ck|/,G'e{|fcզ)BK7 xO-p zIU*$|u;kSnrd0/=K`0c}I¢\rԬh{.xQESLqc(܉2 mC k[v;o\tj'HfSb%M-AR8|AeuuxznpOf}O 6!D:3A,R ʏuD_8=˄Y1|t0̂ > lcڅ9h,n]\ABH6f8'-˜5,f+!~ة; UJ^vj+{OV9tQEmt=;z(|,UEJ_vWeJ

-fUuऽc!,{@8%shpe;ƽ BkוK۬ԕ{N&'-%8 I[]%+ĻPO?vP l_38=f~pO"" : 1xw7Y¡S.,נr2F"a#{IK=_g(:V M+@{U 9* 0xAif, ][UT?6fW,䛔4֙y-5Üo3W+yˌtrqJ %e*tn9 4r1p*Up=)20BNvkWJ~%o2ۤ/mW>u*m\rD:ݕ{uIB!zNw9YNo^z;~X{k - l1nP2c8@pڿJ*]>觗d}PzcE2X7k$=G?f;cD/n.dFFL%wcre&f%R!aW(^<'xAWjk{:lއnm&R-O`V^('X{ ۧmDVm#gê٨F>sGH f"Y)jg\?Q);&)^dLYK81k%ZZz`mS:E|7TYm2ޞ6;L\T}UHvm4( d [A[iLH\ly]8V_Zr M^% ot}i}\K=ƃ [1O+ X wJ Kbh 4-$F¸ƴr)ȳkw16OrL5;vcܭ 5n)8 b*_:CsƢx-8IE(6.U䃲x]D81:4eapQjQ Ё: ))ucT`]OAbf B͘&yWg#i[z j,qc҅D`?%.JqUB=[&X`Xb"!6/nƿ"\~葬RcdCF7:+[ϴP9{}D3n0c٘l[~,&X|Dy[_rsR @ʫPοx#P&h#Id &!0‘19>F;ʗ`rM-\xU*9ݰ+ # 6Kd|BZ@Y]Ѣ FM! xes-I긞:EΐKS1`}?'+şlvP=jXCaґABUꡩ$ϸF^"}K# ϲ$}g"Ϝ3ۋzɓcd&18e uVVv\*4Vdz8dVǩ&N8'>v+ZF=̆Jw*˽ŻZ:06x//acӕ2rm"ww`$xH)ՍE@Ygբ1YZ֍B:h ]eHK xH4K@5iQ6ŎvOUNjq #dq?0/}3M 99NرI_!)jg]{`k75/>LU؜@T!־?Ds74+8'! =6ЁSfT0HA)[&:y3?H6H+ɱtъx3h?hV>H$$DU1W7Q?ɸRCosXDIjzJgxDM0^ڄ"HmIh #W`Gޠh;jGtnɛTJ685:4P]d0;( סN. Ywt|J2GJ$[K{xh|UX%Tc1?:dBi."B>|y1IBtPc4} 렾P}4[&^pafDž{p1"&I փB"cc@DnyKËLŶ^ ڧi(7&jSjpW/w|i͑4ԧ'TL< R5C^WaϣHcZ'Ō4T[HZ,9Xx=V@HS2rsfLzPja0EQ R/1.i749l U)8㨱z!;P~{:hICrANC9&B$QP\@S_ Cd-[o0(ILe|.hj^KF~gkjG#_BmbSUseEkR]9R'3ݟqGo9| QCgM$M7 @hsOkv,o|Uu\C퉥XP$3rg|->sIfS rZMV"r_}s-l'.C:@/C`.V[#p}mSnƛ:QLwnF#QL)@x #h`D RVw-{3qoõ5goJɢEwi9mj87H}|$'B<ʧ7yW^TMWnR裂`׋e6%6apACrrgHw8INK%%"d3i=bCUiN_,P֊Fm<2 q=;xsGj[Z(w+_qBT/j1uRK-~1Ľལ>fu)pb9Wg@m1<0lFdA! OYA@k$~KNr%M)HU:073Z71DaC-O%mwIcz'<oߐr)pAg ] Íh|D뭾`椽,0ʓ'BE63UL߈tF] 3d :iLZ.E9b ET0뮸JcSFQVJ@o|Pϧ5 =<<$bXl&N$o1.G9 InvlknUfCTOb?0h4 4YxFyWUoUO2)sOXqF&C;qfƒQb#z]t{$P`/J-&y=C>Ԉ<$apLy0{aHQ%Z mz!o,}0m1QܒX\򎐇Y[ܢ'T83? 7).qG HWM8yME3?̳ EjBF>=TbЩ̮˪&KD6[V nz\{²5md[Eϝx+qy+zB-;ĞzgsM{Ԥ}]_x8Uplp_pvrj"&ՑѪYL$ݷj^)%U&{<|M HI"RďxǮjd *rrg*cA.TWPO •%rS5 65Qװ%KXQlĶ7OH,#~vQٙ $XFϏ{* 0a٨ߝQ4S21R{5(V7Kjrdq^ % Ԥ.3>-h\/%*? ݎu}ԗP011uR͐1;Jk :>5̻lIOUT?½}iC;D+73~NcѥL!Gָ0}3zd0ϚcXS/ԥ̞ >.8+'w¥4rV+nKOV~ 9xDY-ѢS|:r.S{9mMֹ.\>&)/u:U/QamΠצPq"Z" b+2h_;+L*dD`N'w0m:,B $r,Ę+tçs嶐f^1GS#fX⽅ZGmybS%=pm },^DTtzr$ SЈjf\K`4w%ed`Lx[t# qy}  RFybJXqHi,F^QQ xm,Xu@G?G)9q[`ۙrUgg^_E;[ȸ&\{W=>eSnE&0@40V+օ"(X=/e4͇-Oe }" }-Nwey#n7rġ^<aaD+~-\]{3fvv55'2dSĨ-r@菧A 8 rdFߧ_B>X)P$mܮr-Iɛ>; i(.\΁[v%;DQYeK1ff4:ibG gH쉃!L P,1#̳Pp"B쮰5deBP -NiLyh#T+O;+W}Nh v{Sq({,.'ۻ9_XɊZRaAY'dXNr6$9(_/X :1VrPTO6yX٫K=_%#'XϻJ(ں5VrsLqW5_/ Oi к *>uwG_kWq^<`RCm!Z&twjt>Ub( :Ҕe~`WDNƑO)S5cZus$rQ%'ѫ2.^X 2? n,ϖ >ۙHzRaՏ#+s7w@5|, jeBl/N(3 #xQS@MoͺxC;|wj^"ko'AaA /̽l_SCOX Me 07kuf7X.[2_uf뜁9c9P/R`, PUrgۦo k}SVA=E<+vڦX P#T˹5.a7fZ$~9x[ƴ&_fJRV/s7&x>Blr]ahP$a3em1@?ᾧCMH&aq8E;zprrŷ G{8`1:f XRvqiVDīlC/)vȀ8J5du*02:we eM3Pg6d_Ds5Y!j 7y w,QV9]mB gp[€ m\;XgJtݩs' ЁͺRvAU8 {AWӎ9Go=r ~[s|$7X+ˢt1m*P<7JU︲6!BQ&DIf84xoT hN!YAf_]i0x1 *K]^on6Xv6ś^iJ0/\ck jp)Qcf]q#7#O?4bl#zRcZc٦-j# yoJT޾6oKeZPɹ>.yM\xQ5f2HX\^<0<thq%iK=<M h՞4Cɒ?Ho+!# R~]OZ M5*ujK^p&@n U軂E "ASlG^6 ]a>f{m;M~ZdX),.,h"M4[ABF V'/@GIk( kЀlWK寧׳ijу_. A|(.Bٍ58]T,ɑ[a6˴%7յeJ4 ("CQN֜ ىmG diGY;58cSBf[ i&RڛX2r~EJ޹ۙ]3¹ z Z6@@O> "5`BsGe*ϻAhJsqI6? $qÛQH)6\a^S/T\Ar5yCpnQ,XNGӭA<  Q-HKX <]аhJR\1){iGXkuf˳`pm-$JGE7NPB}Myp?ֵo݂1}{y۱<#˂5!v}Ҝr91IPTHv"ҡzhOSoZ*tf R% /e}CKU$ y(BLpV<ޔo%ݵ-{-F%RTn(Xܣ6o<{27 T|PVkg ?3FS:|ϬH9b VD-u q's R⿤K(O30ȹmӷ϶.ۻ%79_w7Aҝʹ֌ .{ѻB V>"MP}Ø+ǙFB`q- B /2wf@<۫טӑdp/; y-7}Tz,lG_FPJEw%Є9-a=0u\*Yz]gOuA^Yğ !zLEO.aqㅡvr4$yy95 <Ҫ=Q+0v8^@c0봿J|17EpG\⯄,Х<OtJ/c:yS%A/"/S`R_.g.ic*!)dxFvXj ij<xYsmt7]֚~~s-͞_?Dd`_Ƞ*|Xj)~l=KPą1<ĀH:T L-Q1ϣ|c_}iW{0= ǧ3$_\LUŕe7zE-e;!IUsFCu{s9"u+W7LC0-Ka@#=f]وґAS_xZHn2w(CC/i1sD' {*4;NDVW]baء AN]YV`Uی೑Ky\{oU?`irx mW ïf'^viM2_cQ.3k0cEPUwk?=>ҁXJE6) H# GuSv Q`7YܵFM z4r/kr. jyTU81+BWe?@gEx:X5 ԶV盺:w' ߈.0 .Z92OYEՇU841 *XW_o L7jV+iY"wbN$R!YVmgq7,pIAd3e4 n%GX_,=\UxMN g]-ΐ t27AJϢ(l !iDBS1EqO-23 Dq<ly"TUq(3j074ej'ou& _LuUJl<5*jЪY+kT(O<,%jx竻?J LO 8 *Feru4F31Zr5:{[(5 OXTqH8azҺ+TZXvx/%7n6'_lHŎ H8)j7~9ʜ[q~AG|04 ޥmJ6 V7jx̒tݲ 2CDS;>67z]P* rxwiamL)N'i7j:c!$B}Z j.p#y7?蒻M !y`Rcgp}|[H0".-.2B _U3>p5.rF~3טA}'mA/ T˄j1HD{g *Ïs ; *.욘@Ҭ( x>gŘlGʯ[20| d0yMɼ vXcEm?uf]N~.wq?& 2+KjFĺWVF'HמQ5>Oq!1 u}yrXv%˹4QgIǢ2јz¿:=@zX٤s}/}څP/[S }E+ۢnzUeIBX;^3DpWL=ZۡAuDD]5@R$*%˛6ĿcOA+0 G} 3)͡rb ?AAf2Čw} 7 áv RLHXtLP<^SoZKc[wPf1Q]K7ܠW0#=dw*) Bz$"Ï;Ca͌GeB  ⟯۞űg0?sÔD#n/q S"3S\`+} ]sU Yٺ9%VV#h;S:.}~N[_Y:;;me] 2K,!4+"2]F KZX^ ‡A8ysx! D}kL.o|4 84ar^'v+:AudW@ݫ@IcEɭlF ɾ|noP) uy`E+X-*16?okd"tZ`s {"FD*X]ItMXU,HmWNtkA)jR۞^[#&lwn>uʰ< H+c`k, Ɩq$&PFPǎMKp&I^9iuj; v6[[kNXoAH9[ntYy.nC68*ɩoYNE~>j/^N5WW ,gI?B^ꖉ{5{b . ij́4T?l*us8X<x|>V?Ta[vCŅ?,u(yY=~OqTZnї8V6bQAEM#^W!EsՀev [(='0ƻKcÔ:MR@H%'vʷyh g3L4N[Pqp x#@ZHz24g!egff *ux[ͯ1oLGMQtZ?6}-y* (~UH,EU^?"+196i9Ua V&H"12F 3&b 8jPGɅQhQ5nw`#-ҥxLo=*j>Jа^︪4 u03 r6Zx(w9+\);Wk7`tUGt|6}WS3jwe7.w(45E[ +OK)~C>r 2'NҭSL+&JI 1|wRp8!bc)`ŞU9a52?gȋ9WNA ~GPĵi,Gsf,ivBmCMXFUZ /6\ud~O΃HGx''g!~1"lLmtJ3~D>\GH, L|l&.ZuA7[EA\I1A[c~GیQMe^TEB)A>"qؿPPlS28:x >Nw\J_rŶ͙~9i M&R}gE|z ܣ=z* DUŔUVrMjvNԸmZne]nmdkS~5T9i-UmTVIq"r~5\h4 ).{K+ 1j(Bi5^6r_Uղ띫?)›KӤ),j(9mEdFCg%Ƨs:t%6k('Ce%$d_cғ|C2B).Qc.2Kg* MOT"%9+:c+p7դ'J3 NaQ);&zv%e[ XyJ?AhnNx(.psf \P crzxJxeء* DghnBrЧu (a7]ؽ&7X]=/g;V=$ݨ4S,J`Ȱ].Cإ8 #RS' b}JGi)\okկκWCҔa#`Y$Rrt?иWh>YH(VO @08 N\qSpSgꡠxk#0f^y&}0Abaۂk6[$sqoxKTh "l&`.{,,N b]P?'Mqn00QO4ԙEŜ[ϵ3 n6Cic;KH@Mߧsmb;8WW1 ]+tZtIPt!Ko~&CӋt(f8b 4>r(; wEXjߌxla.](Z%FOvuxTݾR4?76e[OE"bs?5x ?Xob5ʾ^!ĝM>Av9L7}vgE8nrs˜y"φy;GZrCn—:3zr3DRCz8AGKxfh&1je<>08Ez XrjN'?Y؈Kցh\:(G`GB&QT8 A<_eɊ5 D),0(M|L7Ek?jPjD hymj\lq% `3s5\b_HXFDΊ"3_= ۯ,6|Hĉ+8%1l4PO*lW_f7`Y)]h?8nMɔZ:HʭcLJ]GC7ˋ7!*Sf%@/Iu1Xwq(k+h3Զw,w|BJA%-43w2eN煞@-jL94ut}B).E3 u&kz]ŗO[Wzf:VCU,k}B_l(89^||ݡΤ{]Wc /؅E!+5Na,Og+I6Y~ēձWROȞ6Kٔ`N|2['x\r?\ Y͞! 훜m ,ok`"I )fK9rJIHM( V*Aѓci;M YSZb f81O9˰|Lާ$lmJ 9)!%eUk1Y r2S@T5%V=ۨ)<7e((j=~Qk?[ hlc1j~2H&̻eh\偢3w7' vDX{?Icߊ50f!uSklҘ&?(܁@S^-ܜ)|斃5b%1٦2 HCaӐTrl{b>6Y)n2 w<^O5ӕ9Ι&-=ۄR(ͥƮq}6#ްE'Xn<``+ј 豔 ~i#$AXD63gl)>Ba j0( Zs͍|X(xl:+2e6ekذdǀ18wgBP6"$4w#5#~d,ˎq*j!kZ{3ȊlΐD&`KY4wmJVژ^>xS2B$6WA3}UQNӨ&+"w2{NYIrV)7:RP=և4DYǼ;I69I 1S>*͇1/ b s/&dJj/?0mɨ̚yYImTxI VnPf6UPv$Q;NZO{S?#1Rܰ_m(B|Jd] Ye?sQ ?t82}:5j=-:(4U_ QאhimD_mmB'iU?8CBsފѾ2Ȓ%}v2J}D(W၌G'B!2SCx|k*ݷҦ ,?tV?6mayw<-8RX>CmB, i¡fKq9LPQ]HG|WbV0tef?zOg4ϩFQ+1#5#q;.2~qD'62,IK'G[z[V!QYknbXީ)q$pKܦ+#<% ʿJm8=8Suy1uV|k[fBBww/@ߎ =:O1Wan٭+ȇ?\krcgTzv}8S}OS헻42wཕEȠa]qA3=6bcbMATٓ?uaP66 R VldFoѰZOm?4:'Ӟf`=_/B#EEȭyU ]x.d|h|*MTȸӉZ^t|n 8U,JVud}+:  /0Υo"k"4Кo(ʂ= 5qRij6JLW#6σ4m D&| , w aʂo,~MfO\T;V:։4:@pi- T3zd"s3t=O&tj4D>Of/537,}[L/.[;`=a 7sIq?)NgJu]Gb9)"aF~jQ skX^`t^?}Fx!BMhmw@i*)_+ođD31݊cfeY?t&Ҧ,ns Nn 9dRF B7!ʟbݰ', n mD`F3 9cy6`EMNǘ:Wixdc\7$"amE獏$P\kۄjKG Ͽ_is21FdT;s=) wL[{H??̣rtA;PeMI| LҧFYJI!::K{QuG hcS}^WSˠ<@nO՟scВw1LyKt#SQ:r6bܬ(n{NTlJg`&Ij53gT}?1ݜbFmgF+Rׅy)5 mXvcCֿЬ&1NH*_#bAX_yQ6-iwuLՋgz *AHf&FB?LpE&\IVpP: ٺ4H+m>~;> #$J :_۳:MhnF-YdmJsA8FDW1kʲ%1} >a)MCrGu]+>qw8S#2|&]5,ZQEPS,L%)NE_Pp5}8h;,x Y>:c}Mɼ`O5u9*VT}'yL}ej[K3O,X?&wjt;hpaT9^M:oPjeM'9R w^-5cS #`7a r,~lHN4.&"HM|BJT'V9 #Bzi~&= ,:[ =E2aw1i(x|M6+(?< ZUZ8)wj%L(") do&1R[!t ZOx}r3P6W;0h~즫b.m$ޮ hQ gRxG^H7kB_h5¦EvADoyt]SK(ʂ&/VgD# K-4|419:$<_Jpؤd biB370P mJy?%Ū˽J̪5*!Ca2i':qf~UH; >BZFBeCrDeaw"E"s=GIBZ(ZԊo"jdUIpje 9^! sI1o iOsiz+U[is]t!2SPF]:4Y3w|+wTG\W)fz)$8Oxރw>k8~:^0s!. UceC }^50|4hJl<);P띛C  iwIsT z`8s_ƔJSO6C |f!+@uB0{۸bQTvI\ſ"&]Os TepIu1>QP2Mofdl8uAa`̿uO2uv?Pf8(/[[/5C~hG||;ڿ7&g"-asYtHҺ9coѰ8:dB(hYr/ElL]A7V´ahH"tq4!D!u N4FXqqˣw30Q=RC,1bNwT1Ñ}qwYI9➁.v9bQ(Fxq/>}M3}RtڴAW\ @R%}GxOy7YQw f6"@F@= O^Ry+!$ MfYtz%JȜ~4I{(TjfϠh6ؑ:>NAY(m4L]/x0csUYR KRW^mΰ!'Fc D&% QTmQ-Wvx菸ɾ^N/2Uxb6itZd9T>RWW홤 J /Ci݀hDrԕ5ouT U`#3{amPYS@<>@BQѣs3~|g 2omQ(jE~tB:7u5dz$VK"O( wKB7]!5UmGLBv!>>h~r29缗i.Ř"o?+2v;UO^͘ҙm 5XRίH5jhB<Ö&PU(`f[Tk@gP7=wݺb䆧}l>YF81_N:a80;;XW)s7(WkeQtmA鮞ovgyV i=fPm&/Q,XIM^)MvFU HʾbXp&bU<_t}hqއ ~BDasY6z y-F'C7+YfHӾž~CDZsmUozW) stޫq*\bڣizTa9'&)Q2\fƈ Tw^^uל{A{NsT7Ҋa|ټ1WܧA.H&zb 鿾Kэ)B^_Ȩ"iݷ*k菪%ϾOX=#{fΎBΛޜx2S=or_(WV}XU@Q(:|r\b ng/쾾W*e^LE,",j^cY옯ԘA&׆wYzϵdAYC iw̨UC⫎ON K6$P]Ȕ+`e"&\KmC'TAP-jFhf2OGg* ʹZzaMEW)1߾WZѻsa)3qZЖ|? =|Y 6/ӊD, {cotޗiܰh[6 Ĕ|y S bkIh2&o+ZU{^542 q'Y]xXZy|Gf䥘:4tNI3GWYQP( ؝YfR2,_vKpئ $lbzVEYSܺ/kj;\sYӣX%&գq 惔JNt9$P5(YhX &?>Zq>+O\:Z <2He̪4ZL[v$?\XYXȌ+e'Ԅ9m .ʼGoxQ  6 !Z`V)BtXLcqK!:wu/^ Rм`^NI2ʣ2>/2 t)h戙TGh܆¶c$ =RGg> O"Uu/>\HH2/j$/QzQfu3>ߏg#x9n~IAorH䆌Y(vnZOuuZ".ϛsqrwbMMZ s Ϩa:ck?OGሏF#oqTPMw[2_V}@CO †4_Y"FNɦ nԲdc`"׽izPwd^-ESCB0ZPp`8{ CH4ah^9tBYXbrY᱕NR@_ch8Es&gVFî}m}ǓGKO5gϑ@W"rGab |B)Vˀ5k)-R*\+|2ⷪ0Us9ᏄoF/ O4;6O[DC!,MvKZ1_WRqlq*;#%fuHI6rxPGxS/ I_sah1*g_wjv4QT 6C.+i_@s࿍ XJK`wrߴKvIJy%;P0eyj[cseT$. :P>_EJc0I$Ǡ:ЃwLs!TKSl.V{lt8E\ ֍qk)#7awk>a !?5TnY@յj:6z%3 Re13y5(F_\Eל@cJ 1+g H'%"oZHҹpT{2n6.ު&iCەJ§9b&iLVЯӘ4G)YF(9v?\UQfEfA6q(H-ZOwjv'.jQ0-;`d`  v%H.ۮ#EiwKe^_xa'ju Kɵ.tQï'h6;,uʞ Ad|ҍf"c {l N9?'{CSz܎MuXȹjqq&ړ+8m1oɿ@+v*` +uOOg2kEcBޚO@[!|md(?_mrZ[\MV"7T|grw(qS T`|&uU:z`bp% z8;MݼT)SE`{BKG6Hf/,iG蹣<{΁ܰNEm%?'b(#Ӊ WK8ie: a>9[Tx}Bos8:ȿn`> &Vr>v ȋ} nߌ6[@G n1cHKz>gIcŪE3eFH\DacG43u~1 ^@q }cZcW%7Q >RW.0')yu9 /$(PQ:wLA7{M=eyq;+?Nj_v0OuGY*PodN WS#8np,v`!S?,:ouw\"ru`YZyMo@i,(K@9[p/;O%Vlf)O)Qѱ)/\V;dZ^l;MWh1}L=! XHo!rvMpʏOx)[js Mk[*?I JN_;0pCrМCnjSQq+YT:vvzċ$!0@anߟGNqKyzԷpJv⮩y`g/ĕ:C 7. K6_Q 4w|,$-^@MI"WЩmN;R|B18 `ӹ! =Co+;}qe~:*ݹ}@7OB1t|ĶzWr.~! oןwH4#7Gs?u#?N q3wJ+6\Q 6eK'|#߫ٶ%f'zN>#WbYk?Fn %[ٜ%QTNu۝d7a6Π/$0L0L⻗kckŶ"wR RLQh}aΗuJ l?h=)Y \$̅P~ٓm_cJe 6l} ~_EwtZ'G| EQ~LLvFԧT@_K}hDwg=-=BBF=}gܛGLScz.$|:E~E,W$xC@Xow\[<{< HWD6o̥4Dxjh%[3Ԓ]?rNY1󄢲 {0Ӓ+m7RIԁEkpMP i+M C4j&>//zoP^}\-%+.#Nl M%ʱcQ3Y Y8>')֮%EA! Y=b@8zM3㱣˹C.vϦ>j/MimĶ##6Ii>[1;*$yݘD`v'@./GhlvCKe.&Fִ=<ځ4h1/аpfbĎo.AXX?˫hA>)yWaW@cl~νr.o`&%Ψ٣ gצS4_^I^-+/uLqJ,O%| Bf.%@xi s&ټYeڏZRs鋰gd6]ri1Nh#,8 m}@dEJ'3 hXWĩmؽhSlv'YzdrOh O& QV]}{9h,lzB@Fn $]hK~4TVs ho4|"+f@ˢ1F=7`?V-]λҋ.FsZ5S>F9[ʻ #^} XdOSc EyiOUKEN[?[+"i-8%~)˦u`69pF1Od sv>4CGr/Z)X.J 9 a7ڼXPiߥԴm/H+4ںdf`ޠM΄\?>0 &&E G&^/۝ t6 w,vNtp?cP3 24l*|Lfou_;ŸčL&KiUN$u8B *~RȊBn*wv’l8V9]H6Rv,_k.76x]/A4 D񳬍Rq1.oUWWSA5s vX~f9畑̎n|ryBvzEޑ] yw,6h0/}&FDRۮD?$,9OV*Xh%zg<2|a*cX#DKPR8\þT]H/4b}zy rl:!#{@ZbhXMj"W=Ӊbp̡ J"x4 fz{\ D8)"6\Y $g~xۑV+м"(FÚxSXt"̎&U! cWbBs1m:fXĊKJɷ1ŅaY!)(ΐ) k3XJ.U3Ḡ|EK;<ڱTdT.qum"mA`7Z*)>`ڤ?N Zoo Gz#r~(8|2W'+ FdU^`|*p 7Ql/Eg#V8&REPW;IJ~i{jьX)Àh O)BGxI`P:Smh.DDlxy7Cdn\"Ck|yS|g2{jw.FuʧTo #]!X7uQz&cF2q^k:ǽ{PJmn ظο}s>3SJ/a3exZ;!BWBVzd W'nGulC4XIư,9ӺtγTuxi -^9,K Lڔ=?dE pemj|מlr}"ZϒKcT,PlSJ7#xt%Cߩ)^=g[Vѳ?Ǝ? =/1caC*Oj3bcYqw U"N$E!GpH>!m"TƎxfcfڠ|.ӉW1KMiwqSSۘsH-ݲ?lS5NdJڧQ iV' (6zl~ K~EOW $ݦi|Vbk N7!S 't8싱e^^r 2 t{jezA U:AR6S!Tu.v"c|e﷐i=k" -;eL]1 ŅMV1A}+$:R9}Dwtפ 9JЈ9Ԡކ*5l;LC{:%vcUwїD^S=sL@ĴV<ֽ BV6JQzrNhab"Hy}krRb>Sẃw]"B^csZSJ"WG#C$9 {I 8~{Y{Vp˾8>݉[h >N%\%W&)i$ŸR\e#ږ"o&ޅ/='C1E^wWX!<3rgh{ k 5rHcޡ"?]=gK0p-WV hmvє.T`(Bɂ5/޻2E~Mv=[8u^uAٓ##t,?x#[fEH1Q;8*9tYb P?q=RL _U)}2EXNgyM8\~ PٝyNR(`w;fDxME9{ F3"l-Fe5) 69=3\cXj` #l?.C^ [v w𤐎s܎:ٗo{ 73Sx3⑂DÚpGR1@=h$vw0&뙭c!G jYp V r _s7fӰ Ks8,* .aԱiwN۩5 l.q|RdkLJ`_שE :9_$iѰpW~+y(&s4"\ 4Z|XhdHW0z6r=;q8s>l nw&?-G.+nR0~c=SW;*} C3M,5*֍-u PSG2 G֥@<%DZ4JRWso+e|!We{)4C>8>Z~eނ7: M^oa /dsZ|aभѝ_}?lQۗgpӆ~+zf(08w-Oxo;@#}cUկ߶Ph@IfWFDU[(ԁP `τm |{g0^?*,/@*\y'Mʯ'@mlֈH#Xo>Cͩ'  {9y/kVS]UKZG%~c/T%%:iŀ3ŀ8z qyH ;IH:{ Csd)^履," j =c[-eN)t> 3:>l3ƥ@B1[QSI./w͕8 GržnV&k /FtN3f٦G>ums8a1u\*]ϧI~P<.+j=$t A\25UZ=| FN~R!/J'Խ.jFs9IT1b n{jxF 9U *yGϞ$8]xtYj,'`,GJ6A058Ƥح2+'fO(L^u=م3@j[]&hxC۬0br.aO]&@ GROhR @;)hx9ЀJ|I-sƴs!(縂0¡cp6=.iS sώ܏_Ѥ(oidYЙ:وMt3b<޵?^-dxQ}5l--cYY&ⅮJ.x<^J%"\iȥV[} \n- HgU2m2Np[@rw63#wyt~@Oˣb)ric( r"WQ8ީ:ae #s/J|v͢ipAoEd=Kcqg 0+:4Rj#pl-`9{2ιQ'̫DzXA[yagw |J U@!%l_qy2`'Dn}fU&bhmZ#g CZl]7P)1=:AKsu:fzC.u76ĆZa&n!;9s||(l]usZalt],AwPe|ڮ&KaT $5 fXsiQd*8us yU6]sF>"H`zfeL+)8%D]M `N8Q\3;Firar8)ݖjp{jn-tw=WߔMϪ\ucLX8n^XY ]sA}x=,5,H8/>DV}-B;|^d_dKg_Nb ruXb!).!'QL-}"Yٷi\T|6{ڿ^:hP% (ݏFa 4x{5Z\DW}tӐ7 P ̹]3:FLeU0寘>#Lgao%ttsv |8CA.B/J=Bزl10 Q-zxG$α CX1Jm^{ B^a0nACF*ޠրg(L6Kاh//` 3\m1ѥZUxZaEhgCI|K -V&§!nlwv!Gȶ~?vBppqpXJ&ဪԍ?@7 Fr{cV72VpX  Qo@ӡ$ukv?s@ N<' HXšݩ >0 YZTeachingDemos/data/coin.faces.rda0000644000176000001440000000363112077041110016421 0ustar ripleyusersuV XGArx֥E[YEEފz"l+H(nYcG`U@H*ʑ@BrBP<Lw|$s=8Bd8K>88¢FE7tXHmwUYyoF>}O!,}6v4 sݖVlܙ0z&RvsxBD>`76_}1~9GBH 1@T.yB //x6"716lH]K)@BAcDK0Sf)۞y80IY _&Nѩz 40&ZnvueO4L< ßژGG0~%W;㷝t[[)h΂.ٰSM!0$ڰbc~w A70|tϏwkZ>[p39;a8~~ ~e埜igUCSְYyPNrm^?B]vz^Eޖ)gu 50oZ aȏ&M6,Zoh-5'-z|О/K\vRc@ Kh5$GY_<A󨂋IZz߽ɨ{ϟmJb}(`*gL@9=>L[Wz;ik92y4D't{Ne#qշ-}uh|rGWnz3(NemaVE l﫿AyQrB{ yC;,q6=kl.On0rgǹ0 î ފ44)%WcѣIAu7@e9/wvj~NivAPs6Mx?ڴ/_6a"AІlqh* i\Y&`ڧb_W(]e^&(5τAGo63 QkGPwغ <UsOBX2UuFJRrnmEnoŸgB4㯓 m/ɧ` 8 ˃ZFvM0 "FQbhShlOm`e"v) !ax&k6'?G#5WY=7]}Fgi UBÃԯ:~wdG(6[(D8 欘P%}I:XR`3KZ%2tfӝ#/_D`Ռ}βuhX<; -d94\:M&odL<4&;-%.> 7Q~t$yF~c!CG^P:E`#-'C,:'ZV ߦ{;+#=ik-¢جwޗпx{t.)aWEX~Ǣ]kY_a敡7<26-a?z: z~t9sphI`P<3ɍYÎ63#3 w77k TeachingDemos/data/gps.rda0000644000176000001440000003276012077041110015207 0ustar ripleyusers7zXZi"6!X 5])TW"nRʟXg%>e@Beh rl"R}0pbT;a5z $QZbԶKk+Hɲ\+>X`Ե߈^,cm Հ zcu+0X1]HDާlnj'^We}diaBvsUPq*`Ta!n!;(kITU[ M?]J,Yx6D' In_XO Vm9RJrT 1wf>fg o eK L OF; ")Uuܔg'D0u$߳"Mn"k$(u/a"3SNb{ (aGQXGỴ &n(N0K NY6˜' 3KrSy0:VfT4ϯmƼ{PI/O={7'f1>W1Wvel=h' nw[5~Ug -DWX!Ѹ}'e0};àrU/.y!'G!>.tu РK!+"gCx^H14B\ǒ0䐦 wtC3O(8.},K~6Brf=KVH;0Io.MXguZdc1o3By2#uYB1dёϨ>`Mem]h8!{9|4 r7l AD -}.S1\#aOv!y ^xh<恌j}⃎C:eXZ<>~'Vw! Gk*L#--;&~9 bNcv'sSCأSnθ9 nDKNYYDD"t(pFؠ&MN(שey-YQgG`3v]E+dTA5=ts-fK37ލOu1O@aڻ&JU~.Am0#86=)>w#/"~5Ie; 2 >.(x|N⌯b /[uw|];؜@ ῤ:^ofc2߼Zﯩϵʟmޤ}潳4* Zxl n6A; l?1 DfW@+ڍM@ K~R(JߖʐQ"p؍lF:Q.OwێOᑠ)zTI;v#IDZBRGd]8&g=ȵ[5y| hw9i$ v ;yk-1v)YF#ylmޓSc4 #(#@ccž-J(cD)玼epɭsJ_!֒مn/~B|=WSnI$|e2=)%%->j>_̎Mr5v!seIMʦ'*Xib*=+p6%&DTcEzWh;Y Ҏ'"!I PQ,i7]R[e>W (ϢS."%hŖ zEOcErLѪO^JQ,ʝbGc i{P'囀 B 6X1xz=+G2n|ņE?>NaqsH1ӏ,6p;Z8Y@xFS!l X9̽)48' vEZ(N%EBn@Kp@ʌ_ZVbswuum[- f݈Q{2yL3-lKe8ˎ4CGi;piᏈL9eoXL}ӂ,gPLKnhG+A#)Nj͌[R𒈯+qP6]3s= 2u7G(VwH!<Sz$VYc M xۗxhS4=?O*FH@V3~gldز8^˲ﺟ1mHZ Q7tS֗4Kc;F%v sB(^Nہ;VY7 "sFdڕ`4 瑕eIf;?wTBc}bq/.Cˍ=TUyWMtR@b+QB{lHob睇 x&n m2+ 4FGCvd D;)ןd އ<+OPf 8B" \AfnQx'BÚ'~37T߭;/ʱZ&UcM36JЫTՃV?J cyo^À-F mu}ӽ?X u _̶xZM4 (sHs:"f ly* "#8o0-{֌Qc#,ƥseyVܵ=UErs%Eع/&˄{=/>yL{ŴUۡN@ T)Tf9I$5i:UpYd}[FLpY;8~Q(-scy" {$l_AEc|jYj㛛gb|ҼUHRvgںDFaHkwUeM d9A:BEh!W<~3)yQ4-˚rOĸ1M\5}HN} 6jm$9$: OeO>vɜw]wKTU #IqB%4N~m@;61mf57Stou!K]A ͐e !?l[*vDG`>$6 !>\+6_uWmt!Cb0S~ZJ+!;L<1˞IzOE;KJO."\CY)_eѪld>B$$:6k)q ܾXcPL_$g:˨H<{>ܱAsRіG&.\n bI๖]Kz)P؉ㇿg?23B?|@7\]ɷU^o ٩@l{@^}c0m3`Ҭe$Wx<94$P_Q}%4FÍC^ݛjH_R%o _mEMwsFDy <PWfڟ\|[ޖ:oH[UΔwutM:(4FFbd^iq/an0+Gd2"3l^ b)]-uC݃.!Ĺr1>nGu<[:M"5>` M.C}d߶0^URqF^PoYHNiI3b ߅~픙X[y8c%e}{1cs0LGTY9h>tkd)HNˣɄU}0^fܐ87$X8mt^p$Et4C +{9+N&y҄*;' Uf6~C;zu ۗrx@9Kq_y^Nj498pCW΁h#ڱχTsęɚN& 3V9Xclh+6βDX) ;6r{Iafj݅ǶX4ܠ{S?[ys c8qڷ7քUBeEP  E蛅еlߦ-haMP#gùl4ÎNڐTef >yˊ6v _s5EJʜM0VR'[ M߶/ ${f(ݠZwBGdܯ9/pCj54nBSo>q׍q-m}>f>Krʴ˃kyY 8E-47`7KeG,߁+N('=gu+p[9_HtݧZc@5ș :lQx60|X*_&H`C%u8& њa6!ٰ+gK|T<婵1Aʣ-R-P^ߋSq^}zv?]lA[pc`7+#"e0lnwPx݊Ng0Z8;P@?IV5d()hbaIa/qBu`eK^c[>Ъȡކa`1+ \J,k،oqJs(Pq5SOrySg{(%FT3hS$*o^%J--yv묹< R|/¬]} Q *zZIG/zljcmב Z#x^+.$d&`FVFo4XdIlvl)8pY*bG`anJ0L E(;O8 oׯsg:{[:f:Uӯ}`HGnI7$ȿ`KMaspv CM-plL-)}mo h a|0 e6OfT/nb۹ с9Ô_zztm+(R>3|M3iZֆoAĵE>!5wsJ1"l^?F.7=5 ʡugT“ݓx|0[Ü߷PIvp5k_tL (;WŠ&pNX_#%+\#³Y-r A'#Qӹؚ*A`]TdOũ,AGa9h<ˆa򠕍 -O`]qHQnN-=*hs=8?&@4],dhC__-3[w[#⹀ bݷk7K`EGnw?@^ ʉf2\")T6@B>p{vEwYm]ڳG?=R!05tjlGΊL3B\[)߼p;Nƽ9~ָ'MS2\S{3&*gg3hv&p*mKLH6h{zusDi[S6݋MLRWW ~L;Xigkɑ IxHq"xdRLXs3 G},[W|>f0É8trV?g< sޕKxRV[N?N!n }b mF_Fv^`VD PYRF( ΠgY7uZZΩ魯X> ęV:z 3O%lnvPKZq`|Y@IA6!O4ao{3XF:MR n>.DDIS4*NEOax(kǦ9g3B- P& ;I 21Y~C'DnxRc Џ/ B{lN;&XKk`/<(XS7^24w;zwuI .&"9-'iG UHụ xzlTdV!\@Qwl&6{*MSh "VpY7V >K /7{OD9$Զv<)F;zѵa ȼ[Ю%Hxdֻ-I}S6h`/:8&H' AjQָ6FÖ}KXc)T`AhHmJY} @;]U=8M{3>sYRqZI~"ъ?Tƛ값\`S${\X=J.tԓ21^ {[]U { =k?&`[[BXGczMIQ)TE` %G& ?՚];lMƂ6+ kmZ/_n``.؈u0p4pɢPGU M5B*N*SR:ge]67TáŊ"]Bm&I!g Y/ =C B]*dժ՜#=­w,,/%0^@"DHƇt,}|gD])f!I@R=[x*ߜ(4I:+Rri`s8竦7ta~E9Ą^^ђBP9 M2`h+gyU;`xLQ_HPǍ x%tp`(m`R(T){v[Oa #i," TwJȹK•6@6c͔Y!?OK(dskCJ4 &Ǚ H|`o&r[NK낊! >^-W,X7"ZjqV[mgCmbnyDApCh.} YX5~PJME$Y+bhD1qsU4M%,Qu. Xd5,ZK- \!%[Hi%_}?Dߌ{yڻ,Heiq MO8Y\`0"$='msV5{(.&ӌv5 YKo|K3S*GAJxqq U姠< Z|} ^F{kXaS{ɖ/HŒCܥ01J~e9WM$q= DUj-D,(qe`Ųo^\" Φr)]8X\鹤j/PBSPӲv?S&c/ǥSu0s; `Y.pCϔ8#bY!Y`TΝ?/聫Xda~#M--MMC@ƳA^6 IILpIڛZ(1dΝxF~N1wgɭY .n# _9I"g(DR[!`L԰jcQZ/ԕ9Q9>T1j/w, IC8ߐ5Gg}cBVH_wR@d 9 E2r#(#9O< Azw[Ulôx+-ˍs;J=_,!2D+k~'ć9W"?5$u/RHLE%Kĉ=pdl&![X(~IAۈ<=-kiPDܐ%\/VI3cf=q?*#opBu6=G]^)qu"3 ^)o:Ԕ\UB bmeIj̵ޑTMY^ǡgDe\:fdL  @ҒCJ~gQG?@':jJ֗(h HRqoW+Jρ7|p`buCG=uE y֥:Qw*Z",2ߘIʧ^ Ut&#>aq\K^1ٛ+5ے@WH彭}Z?$M:GQT%]3LhC\ܲTD  1uԟY0%/,-tߖ)l*pT-oZ cptȑȭx&$mzV5eba+ N G\%lX{3tM߯cBlK`%}9er'#GҪM@4eʶ:m--0%a8)q$_A3784;c& wM^$U[%T)#orfR} `r Φ.A|<4: T@Sihq %й;w n:YκnARPJZPoB߷%]bA':/a!QA{چLGh>ۜŃ.!qS8R)R|/C[{vGbXK!6Oۙ%2B>/{)?x ?AէB,znDz EQ*6s%eM|w)63|,pt|T#9yא$q./|P-Z BxTЭI%sXKaN-q%p0vOr[>/eEW7NU9#1>鼹k|/ܓdp&/Bhsv3:z&ä%x".%,e @zt״ ~4RwꄃÍP{e@`=,̽jM5Qo~74LcĖ ==$f=ԏy7Tu)l$DP4SO{㞒4iS1Q%iGk[Ń<ϖ9~ևJ XoD4 --A ,l=eHt0>X,ڲ^1: ա͂L޵K}🤏K`͡v cؐ-1Vʒq Ǟ?oűpm ܉Jr_ |}gԈsU!J\w{<~*|f}St[d_֊@1ۭd4m'#CЕpT :o5mg=oWgBA8ޘ߷p6]:iwey}fTwyڃTl^"k ]l%L綖]OA9Ul+}nOb?%!&X˗dsu7!RWM3jοd9΂QQ{ksލlwK=Ae^?I]=ڱŻQaqVߘd'G}y8m~hׯݤ+ş?O-XNށ<9 ٨>,Ŀ78J45͎o_|"1j-7@O9[r1Y/ñ ɊT"*r~^[!3,W`%k&; 1B3j]61a(-ڂC╄ P8]2er c-@YCSz[ܻb[Vh&P+D0hvǔnnLܫ*J dz hAOl(,ox}THrW8l8[k[[Mb2tk{ ` gIBO~s+l('¸>aky|g&hIX>-XZ5M/6Xl";2 ҁnH#`"u&Vz)cu7y+<}?'=<T|y~WYQ\s5")^K=/'sp S7tAf0ȫE=l$YǙ$0{:pXk_]"lE`Jīj] M;SlY(eK.S$Agt) (zoz.Sep%]<9IK n/& >^}WD G@Ԯ8>8>":.l@y3Jt QԷ}59!|jPs\%0Uh? :}n(Ě{@${Hf][DzX/"`%|QJ>i׌v1:zC9iʪsv |T[de/iY؇φ3M[cc<%sx8IN+F̝ghf~o' 9Є3Z@W{(/Ϻ%VRfX[hpbk>0 YZTeachingDemos/data/outliers.rda0000644000176000001440000000155612077041110016263 0ustar ripleyusersWRDX2 X  outliersdmfQ?Fo3ib?9+I%ۛMٟÿ"( a?ĸ2?nM?dnN?#x0? g:?CNې(?$[@_?&?&B?oLDޭ=,@ ?4P?AD@4֒k p*4K@k6ZMu>F@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>'@ ˡ+*`0 p5 0F5p-080&d(` A1mt3fl(*`̅Ja7-!̇P VEp,~ wr ~w X Oa5p/`6FM~[a <O@7mWga'< ^`7oe `?U-~A 8uLfÿ)YR6w/M]iv"㯒}.U眷ezu{"GV{u ^A5tFeLԸg419޵O%KwhvZUf沓ZлJ5kɓeZ:C}"Kֽ8Y3kӉ!=qt[gOh;2MFt;΁& z*4OhBg" Ϛt@ Zi uZԣ8xGnzGzĹ[۾ WwEW,:gZF[:a[5R',s[f9R5[jX4ߢǖ|E,Zcߒϖܶ'XK>y"-C=/>ke-OK!b!jGQBz{йzBC_`fjV00~[S]} hWW;|GHk??q%eD#9MbW2vJFD_5@૴cR:~O6 F1oLjm2!M Mf3d[6[PZ򽭰k.ֶ.ck5;I]ޙRs㫰Pj1l[d4bjqP}&q\z !osԿn3AaG7K_ ;lqsʭGy6 K]zJ}ĽD~qAz'L#MtLrIIM%zÄFFѣX'zo"@ G_.c MCлf9#wzm>v:M0`=ZYrq{>61BP WBm8 c0W&LT];7ףB> 1$Fo&F~wbdrӉ8O8A%&)xlq' $ԏX) ?֔U#I|'$Z[$Ͽx&Dڍ &@GC;$o:ڼe3_CjFmNANRGE{$6 ?ym.O\S1*Tb_]/ k7Ǡ!A+ 7CȺ *3L?1'JM0~wEuv0A~tt{OguZ [l3j{& En<F5Ώ=#j5~_wC ztv]&ONha4}#,`˾ţxƣN{X:ѧy8C-h[Tyz2v^Ǻ>ǧu<壇>z-Y,볼Accc=rhN[#+_"ZZ쿂^)4-(#C4®h|zLLl5ob -E6簶\ln}4"{'z}gb CП!ptCO[Xweؤ }.e!Ə5 '$ U_z1UXZ\8.c qҐ+.,/G)Q? VQ1my;/,NYX6~1VT8SI9+7峫:W:w\ #gCTeachingDemos/data/evap.rda0000644000176000001440000000176112077041110015346 0ustar ripleyusersBZh91AY&SY].sDUU\@@@@@@@@PX7cɔ?SM=#iޒl2i y 7^p$ I7TT֙ZYE>9ӵqT"%@Oqj`el6x+݄B M] h(f53fJxkBS)$@i4'"I93̄@v1Nms@"/O}nWVE9s MJ!R&b2 Hd E}~įE&NYSC-G\3*Zw1IQrE8P].TeachingDemos/data/stork.rda0000644000176000001440000000077612077041110015562 0ustar ripleyusersK,AǶ]oQUoXo7 $ˢBЕprqvQ8;;;D욵:ɯo37mgazyH^ !J_G4?e6!Jte&E+D6^. A[WJA( *P j@-:P@#P@fZAht=00\@|o' , e |4ߵK5sU\b.1.kKLCc$h@Ey?(7v.KX>~׍Lsm/3ᣧY<[Se:b\OD^nOWb?#}skYidOJn2Lj^`fyȧ,黉$t5s,ƪHUC3ܙ2ͬc}mGKݹ)kn(6=d*/+J;