[r-cran-teachingdemos] 12/14: New upstream version 2.10
Andreas Tille
tille at debian.org
Fri Sep 29 14:28:11 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-teachingdemos.
commit 24bd60464cf9894d56d6ef2e9c2af058f6a40e3a
Author: Andreas Tille <tille at debian.org>
Date: Fri Sep 29 16:25:29 2017 +0200
New upstream version 2.10
---
DESCRIPTION | 16 +
MD5 | 178 ++++++++++++
NAMESPACE | 61 ++++
NEWS | 227 +++++++++++++++
R/00vars.R | 2 +
R/HWidentify.R | 94 ++++++
R/Pvalue.sim.R | 143 +++++++++
R/R2txt.R | 677 +++++++++++++++++++++++++++++++++++++++++++
R/SensSpec.demo.R | 47 +++
R/TkApprox.R | 126 ++++++++
R/TkBuildDist.R | 208 +++++++++++++
R/TkListView.R | 149 ++++++++++
R/TkPredict.R | 122 ++++++++
R/TkSpline.R | 144 +++++++++
R/bct.R | 11 +
R/cal.R | 107 +++++++
R/char2seed.R | 20 ++
R/chisq.detail.R | 45 +++
R/ci.examp.R | 78 +++++
R/clipplot.R | 24 ++
R/clt.examp.R | 73 +++++
R/cnvrt.coords.R | 133 +++++++++
R/col2grey.R | 9 +
R/correct.R | 45 +++
R/dice.R | 25 ++
R/digits.R | 15 +
R/dots.R | 9 +
R/dots2.R | 22 ++
R/dynIdentify.R | 284 ++++++++++++++++++
R/face2.plot.R | 109 +++++++
R/faces.R | 221 ++++++++++++++
R/faces2.R | 70 +++++
R/fagan.R | 286 ++++++++++++++++++
R/flip.rgl.coin.R | 7 +
R/gnuplot.R | 41 +++
R/gp.splot.R | 19 ++
R/hpd.R | 27 ++
R/ineq.R | 65 +++++
R/lattice.demo.R | 94 ++++++
R/limits.g.R | 23 ++
R/loess.demo.R | 80 +++++
R/manipulate.cor.examp.R | 28 ++
R/mle.demo.R | 91 ++++++
R/ms.face.R | 201 +++++++++++++
R/mysymbols.R | 316 ++++++++++++++++++++
R/pairs2.R | 111 +++++++
R/panel.dice.R | 29 ++
R/panel.mysymbols.R | 97 +++++++
R/petals.R | 59 ++++
R/plot.dice.R | 21 ++
R/plot.rgl.coin.R | 41 +++
R/plot.rgl.die.R | 67 +++++
R/plot2script.R | 63 ++++
R/power.examp.R | 64 ++++
R/power.refresh.R | 6 +
R/prepanel.dice.R | 7 +
R/prob.axis.R | 4 +
R/put.points.demo.R | 104 +++++++
R/range.R | 76 +++++
R/rgl.Map.R | 26 ++
R/roc.demo.R | 96 ++++++
R/roll.rgl.die.R | 38 +++
R/rotate.cloud.R | 89 ++++++
R/rotate.persp.R | 23 ++
R/rotate.wireframe.R | 90 ++++++
R/run.ci.examp.R | 73 +++++
R/run.cor.examp.R | 109 +++++++
R/run.cor2.examp.R | 149 ++++++++++
R/run.hist.demo.R | 53 ++++
R/run.old.cor.examp.R | 29 ++
R/run.old.cor2.examp.R | 47 +++
R/run.power.examp.R | 122 ++++++++
R/shadowtext.R | 19 ++
R/sigma.test.R | 35 +++
R/simfun.R | 34 +++
R/slideRule.R | 68 +++++
R/slider.R | 84 ++++++
R/sliderv.R | 38 +++
R/spread.labs.R | 32 ++
R/squishplot.R | 39 +++
R/subplot.R | 71 +++++
R/tdspinner.R | 14 +
R/tests.R | 61 ++++
R/tkBrush.R | 173 +++++++++++
R/tkexamp.R | 469 ++++++++++++++++++++++++++++++
R/tree.demo.R | 33 +++
R/triplot.R | 111 +++++++
R/updateusr.R | 21 ++
R/vis.binom.R | 106 +++++++
R/vis.boxcox.R | 134 +++++++++
R/vis.boxcoxu.R | 143 +++++++++
R/vis.gamma.R | 278 ++++++++++++++++++
R/vis.normal.R | 126 ++++++++
R/vis.t.R | 100 +++++++
R/vis.test.R | 142 +++++++++
R/z.test.R | 39 +++
data/USCrimes.rda | Bin 0 -> 151562 bytes
data/coin.faces.rda | Bin 0 -> 1947 bytes
data/evap.rda | Bin 0 -> 1186 bytes
data/gps.rda | Bin 0 -> 19326 bytes
data/ldsgrowth.rda | Bin 0 -> 2543 bytes
data/outliers.rda | Bin 0 -> 878 bytes
data/steps.rda | Bin 0 -> 17838 bytes
data/stork.rda | Bin 0 -> 522 bytes
debian/README.test | 7 -
debian/changelog | 48 ---
debian/compat | 1 -
debian/control | 23 --
debian/copyright | 24 --
debian/rules | 4 -
debian/source/format | 1 -
debian/watch | 2 -
man/HWidentify.Rd | 72 +++++
man/Pvalue.sim.Rd | 86 ++++++
man/R2txt.Rd | 247 ++++++++++++++++
man/SensSpec.demo.Rd | 61 ++++
man/TeachingDemos-package.Rd | 133 +++++++++
man/TkApprox.Rd | 68 +++++
man/TkBuildDist.Rd | 89 ++++++
man/TkListView.Rd | 86 ++++++
man/TkPredict.Rd | 123 ++++++++
man/TkSpline.Rd | 67 +++++
man/USCrimes.Rd | 111 +++++++
man/bct.Rd | 47 +++
man/cal.Rd | 93 ++++++
man/ccc.Rd | 62 ++++
man/char2seed.Rd | 58 ++++
man/chisq.detail.Rd | 49 ++++
man/ci.examp.Rd | 80 +++++
man/clipplot.Rd | 72 +++++
man/clt.examp.Rd | 65 +++++
man/cnvrt.coords.Rd | 142 +++++++++
man/coin.faces.Rd | 35 +++
man/col2grey.Rd | 40 +++
man/correct.Rd | 94 ++++++
man/cortest.Rd | 81 ++++++
man/dice.Rd | 98 +++++++
man/digits.Rd | 68 +++++
man/dots.Rd | 47 +++
man/dynIdentify.Rd | 73 +++++
man/evap.Rd | 54 ++++
man/faces.Rd | 82 ++++++
man/faces2.Rd | 94 ++++++
man/fagan.Rd | 74 +++++
man/gp.open.Rd | 85 ++++++
man/hpd.Rd | 51 ++++
man/ineq.Rd | 86 ++++++
man/lattice.demo.Rd | 56 ++++
man/ldsgrowth.Rd | 40 +++
man/loess.demo.Rd | 89 ++++++
man/mle.demo.Rd | 65 +++++
man/ms.polygram.Rd | 114 ++++++++
man/mysymbols.Rd | 177 +++++++++++
man/normtest.Rd | 76 +++++
man/outliers.Rd | 85 ++++++
man/pairs2.Rd | 66 +++++
man/panel.mysymbols.Rd | 100 +++++++
man/petals.Rd | 103 +++++++
man/plot.rgl.coin.Rd | 106 +++++++
man/plot2script.Rd | 70 +++++
man/power.examp.Rd | 81 ++++++
man/put.points.demo.Rd | 63 ++++
man/rgl.Map.Rd | 47 +++
man/roc.demo.Rd | 57 ++++
man/rotate.cloud.Rd | 64 ++++
man/run.cor.examp.Rd | 65 +++++
man/run.hist.demo.Rd | 36 +++
man/shadowtext.Rd | 65 +++++
man/sigma.test.Rd | 47 +++
man/simfun.Rd | 243 ++++++++++++++++
man/slider.Rd | 191 ++++++++++++
man/sliderv.Rd | 65 +++++
man/spread.labs.Rd | 80 +++++
man/squishplot.Rd | 70 +++++
man/steps.Rd | 126 ++++++++
man/stork.Rd | 43 +++
man/subplot.Rd | 155 ++++++++++
man/tkBrush.Rd | 115 ++++++++
man/tkexamp.Rd | 269 +++++++++++++++++
man/tree.demo.Rd | 53 ++++
man/triplot.Rd | 75 +++++
man/updateusr.Rd | 71 +++++
man/vis.binom.Rd | 55 ++++
man/vis.boxcox.Rd | 70 +++++
man/vis.test.Rd | 186 ++++++++++++
man/z.test.Rd | 54 ++++
man/zoomplot.Rd | 71 +++++
187 files changed, 15372 insertions(+), 110 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..359a64e
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,16 @@
+Package: TeachingDemos
+Title: Demonstrations for Teaching and Learning
+Version: 2.10
+Author: Greg Snow
+Description: Demonstration functions that can be used in a classroom to demonstrate statistical concepts, or on your own to better understand the concepts or the programming.
+Maintainer: Greg Snow <538280 at gmail.com>
+License: Artistic-2.0
+Date: 2016-02-08
+Suggests: tkrplot, lattice, MASS, rgl, tcltk, tcltk2, png, ggplot2,
+ logspline, maptools, R2wd, manipulate
+LazyData: true
+KeepSource: true
+NeedsCompilation: no
+Packaged: 2016-02-12 01:53:42 UTC; Family
+Repository: CRAN
+Date/Publication: 2016-02-12 07:40:49
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..25746ee
--- /dev/null
+++ b/MD5
@@ -0,0 +1,178 @@
+897fb4c8d60dcae56807599ab32193dc *DESCRIPTION
+76e7aa439672adf69fd8da2ba0c84df7 *NAMESPACE
+904252f50c7633e5be44bf05a91805ef *NEWS
+af63983980ef4756e1654375eab35a56 *R/00vars.R
+58fd3ea73ca7a7c3486668e43b19563c *R/HWidentify.R
+83ca905a7ae454a8a35245beb2ec5d16 *R/Pvalue.sim.R
+b64f269e29a814182cd25210b7f54075 *R/R2txt.R
+7ecfb3aa2895a43029ea4888fb432a35 *R/SensSpec.demo.R
+da2a1db1065a61ef8bc02e4a3e36b9bc *R/TkApprox.R
+f4d7768737addab71a699ca254b94e4d *R/TkBuildDist.R
+ea8920c7c069178ad87f9fa9af5d4ac5 *R/TkListView.R
+fa736158ba3b4465d70d9105c26dd972 *R/TkPredict.R
+aa1c6ad9e146171976268f56da32b250 *R/TkSpline.R
+b3da80c8325f04b7141b8ea4a5040f5f *R/bct.R
+5d8f83b5b0d203d17c2bab5e76814beb *R/cal.R
+3bf191e3cd5bee2f9cf34a0a52cae178 *R/char2seed.R
+ded1da2b4851c1cd43e895b92c5c35e0 *R/chisq.detail.R
+ad00af800f75ed5bebf3268804de9359 *R/ci.examp.R
+d07ebfa8a3e8a6f170e4f7019ed91b7d *R/clipplot.R
+d2f8b6e9ef63ce007d9865dc1b3b3616 *R/clt.examp.R
+6b42497aba4b3d5d9976c019eae86d9f *R/cnvrt.coords.R
+d077092b97db985c273e60ca7f7e3aec *R/col2grey.R
+27beddffee77d82783b1bdb52848ac13 *R/correct.R
+521784d55179c115f4f710f7f826bdd1 *R/dice.R
+8a72f33197f97c16bfeef20b86e65f88 *R/digits.R
+cfb05736198fa3001b3cd2404f1c0863 *R/dots.R
+75c43e07e0ba4d2168a5b89753ae60c9 *R/dots2.R
+4cfbb70e2f2644d8edc6671947055485 *R/dynIdentify.R
+f46e5b70e090c67c76c66a8dd617030f *R/face2.plot.R
+23bd6d628aa18b7aff73a6a454a61f97 *R/faces.R
+60a3c70e663c040ee28c2914e730d187 *R/faces2.R
+aa2ae4b7f9114fc851d21ed8c800980f *R/fagan.R
+1375c2a419b5f7af16791bcd2f35408a *R/flip.rgl.coin.R
+16973a33ec9bc005787bf9c04f9f0b53 *R/gnuplot.R
+e15423f4e966dfd9a1f2cc6f7a8cb1fc *R/gp.splot.R
+18616d8ebd4e9df7de968d762d8d86e3 *R/hpd.R
+4ab586b3ac5e572617665aa96e83994f *R/ineq.R
+0ee8908da5fee534ab3e9f71571888b1 *R/lattice.demo.R
+3fced4b2f6f50518b502001c205d8e84 *R/limits.g.R
+a9b444dc84c8d8d9f9cefe675c0ff729 *R/loess.demo.R
+1b57c7b1278eee080d9dc9448e3e34c1 *R/manipulate.cor.examp.R
+fd3a9345dc6847100d79c5e4c051ff41 *R/mle.demo.R
+9a1cc2a1fb484564769868e675218c60 *R/ms.face.R
+fd89f48b106c0f5963f46e94498f8c5e *R/mysymbols.R
+328876dd059347545fba20628ff66a92 *R/pairs2.R
+66cb855dc651716e748e728ab3457f18 *R/panel.dice.R
+51a96cd6123764909485f51bcb608d11 *R/panel.mysymbols.R
+f9de73949f5e9682758562fd25e89378 *R/petals.R
+61fc27009a114aa40306245ec6bc42de *R/plot.dice.R
+fe9b50be472a74f950adc25b34f1aaa4 *R/plot.rgl.coin.R
+261909b3574bc6babd34398085646bb4 *R/plot.rgl.die.R
+66ecfb67374c2e5931c35ec2af0d1ae3 *R/plot2script.R
+66d727e6a19bcad4aaca00d6e5edd8e9 *R/power.examp.R
+e4149e1707642de82e7371d1893e4666 *R/power.refresh.R
+94e4fea63f54415ceb14ee4e0b2de636 *R/prepanel.dice.R
+b70c65b54e5477b6ce8353b9f22371a4 *R/prob.axis.R
+b990be3cd99f047779b3d3c94d12bdad *R/put.points.demo.R
+3f05484a77cdd8965c89610f91944787 *R/range.R
+298d939b4107f2eca43e2bc3fc9a0c3c *R/rgl.Map.R
+783f81158c7604f6704ee598a5f6eeca *R/roc.demo.R
+65687e4db1d1b21fd623cfca72dcbbbb *R/roll.rgl.die.R
+309f330913e0924d41f66fbad83a4c3a *R/rotate.cloud.R
+560f882be4e4c4c551eeb606c0b44ea7 *R/rotate.persp.R
+98e7e44e566a8e8aea76eb15ce6b7538 *R/rotate.wireframe.R
+b43e6bdd9bccebe28a60fb4a8ee976a3 *R/run.ci.examp.R
+9d343d9739881c6c41d035bf51ecaac0 *R/run.cor.examp.R
+bd9cf51e1d3fa2d3c8d568ca43ea53ed *R/run.cor2.examp.R
+466c41a7e55779a3d1e436305d01cb16 *R/run.hist.demo.R
+27b3349075beafc9e2146ad55994c818 *R/run.old.cor.examp.R
+be7764047a007d578b54cbd8521fdaf8 *R/run.old.cor2.examp.R
+40ed2c2be2eeb61304d3bb23b0e9199c *R/run.power.examp.R
+32cc8235b557c88bc1822498cd14de25 *R/shadowtext.R
+4a6219248da317cb6468c6bd1ecd8b9e *R/sigma.test.R
+dd1193805d3e6d1ef0f67a58013dd73a *R/simfun.R
+3aa38aa3dc9f7be125ea33ed8dce8361 *R/slideRule.R
+6f9694d01a32cc57f655b3f936fa63c4 *R/slider.R
+f1e776f9d7f22892de2a3c703cd40efb *R/sliderv.R
+c279ead2d78b0935f7f48baef12328aa *R/spread.labs.R
+a790112260956733a2cd64248dae7482 *R/squishplot.R
+31888877ea06f40d7043eed3f8e05472 *R/subplot.R
+74deea904dd26a06835bc33e960e96bf *R/tdspinner.R
+9a381b4e07d68970477905a3b89515d1 *R/tests.R
+8dcb11459e1a32582cb2876222a8b814 *R/tkBrush.R
+f5566e1117e42151d99112291d370fd4 *R/tkexamp.R
+9b5c7069c94891cb5eaf6a33bade4776 *R/tree.demo.R
+43bb666e82429e68a64edd21936bf965 *R/triplot.R
+c013c03f9282e177b78ec3f31d1e4b06 *R/updateusr.R
+e1e613de99adcc9666ab3b739cbd1817 *R/vis.binom.R
+a3310256ff9d8f4feb69a7d5b24a157e *R/vis.boxcox.R
+cae45074402fdf654a0587683bfd571e *R/vis.boxcoxu.R
+c083f2708a48d4de7dede001a72eeed7 *R/vis.gamma.R
+dd8376f2c70caf5327aba7008bf7ac0f *R/vis.normal.R
+143535152aa5ce70dc38a034d91d9af1 *R/vis.t.R
+bb9b7dbe8e5cd644987625fc15169537 *R/vis.test.R
+16cdaf4ccf9e19061d3421c9767cc748 *R/z.test.R
+de2db1801d9946cae7ef584b15e57460 *data/USCrimes.rda
+409c99a3ec4d294667f2793cf3599e09 *data/coin.faces.rda
+26639abf4a55f99cd06ebdf9ff2d66b9 *data/evap.rda
+578018c8e779a12d0dc6a6bc2c221856 *data/gps.rda
+71f326dddd0da705a6713a04f266a624 *data/ldsgrowth.rda
+832fd98ba287b6f910493fdd082990c4 *data/outliers.rda
+d14d598615dfb3a21a6b09f9643aac83 *data/steps.rda
+a7827043a84362dca95610c2b7c82b92 *data/stork.rda
+bf0350619f5b1c35007854fb709c0878 *man/HWidentify.Rd
+d2101e3256d7046e7173a48028220001 *man/Pvalue.sim.Rd
+76475b1797094a5cc8b05a1f2553200f *man/R2txt.Rd
+9665a0a0f562021b137b7b7888a26a64 *man/SensSpec.demo.Rd
+2909f310ddf48911e75f60f221d6bf55 *man/TeachingDemos-package.Rd
+b8999431ef804a11be37925559935b8f *man/TkApprox.Rd
+2dd60e5129058668181186714c0540d5 *man/TkBuildDist.Rd
+61281ae4682c84945788a79240547c97 *man/TkListView.Rd
+d652b08eaef94ea3676c0e44e96aa4dd *man/TkPredict.Rd
+11fcb9cd2d53698e6538a4c7888a866d *man/TkSpline.Rd
+f5ec21d2bad43aa79c83f50bfb56521d *man/USCrimes.Rd
+5eeec237c1c216684a04bb2a795f0511 *man/bct.Rd
+197be677a8d19f38fcb9014e55d8631c *man/cal.Rd
+9e251af8547372c52f9f087aa9aa5998 *man/ccc.Rd
+3fdf7f16d0b34c0b1b7adaab354452a7 *man/char2seed.Rd
+cd550ee11ffb26b5262755b1f737da2f *man/chisq.detail.Rd
+4ccec473e61229ec7e6b07a4711c739f *man/ci.examp.Rd
+5aa4c2a8245494b0cb986d0c7cfa253a *man/clipplot.Rd
+95d9c3e171f7b9b486e08a253c2ee7b3 *man/clt.examp.Rd
+684811e24e463e1bd8068f17434faf95 *man/cnvrt.coords.Rd
+df72d98529a4ce786e9562812618341d *man/coin.faces.Rd
+95ab530538c9f1eda87d981b3eb5de8a *man/col2grey.Rd
+9e40a9b87438c4dd2cd83db0441487cb *man/correct.Rd
+57349eaaaf61f0bd5492dcc11ce412b0 *man/cortest.Rd
+98a0303cbf75b7bb4966e1e33fd2c9b8 *man/dice.Rd
+abfadb70a2ffc9c9958972b525705f80 *man/digits.Rd
+39e92d82ff1bbd4b3853489f3aa2b12f *man/dots.Rd
+2eedae3e076ebd7a0b93dc1fb7002cc1 *man/dynIdentify.Rd
+5c38ef7c17f19b90e608b66ef3885197 *man/evap.Rd
+57210d622965fa97cb029ce8c4d9927e *man/faces.Rd
+c29f8b7dbb02e9d82f4a81023ff41526 *man/faces2.Rd
+0be6959275894d5390b113de9426bcdf *man/fagan.Rd
+54e5b86f884518916f846d6c44e3c5d1 *man/gp.open.Rd
+8bb57d2f34ab917727ee742d71e01112 *man/hpd.Rd
+6a6581ff9412ae6d48a319d6fcdcffdd *man/ineq.Rd
+4db985a54544231e90e2bd322db848f7 *man/lattice.demo.Rd
+93342564a8107e5efcd2f4abd4f7492e *man/ldsgrowth.Rd
+c57775c407aad1049016bdae0f1ac7d3 *man/loess.demo.Rd
+5c1c0fae52246c842c89f622d9dcbe3b *man/mle.demo.Rd
+239ac8d633ed64b9c7febbad3057c69a *man/ms.polygram.Rd
+fd995437a8b589cc4d6dd580a8d3470c *man/mysymbols.Rd
+07488c70ff6003a98a6c6fa279bc9d1e *man/normtest.Rd
+56de9a1a4dc69c5ed1a0fbf2441f1459 *man/outliers.Rd
+4e920e179b5556f2ffc6bdf6fe2c52b6 *man/pairs2.Rd
+d85cd64b5890228b09068f982ccf6d9e *man/panel.mysymbols.Rd
+7e3182717d8b1e5a2562a43cdf707cde *man/petals.Rd
+c2e16ef8481dc28a4321e052afdf4e22 *man/plot.rgl.coin.Rd
+da0f417b8f49753c1ffaee8e1cee2951 *man/plot2script.Rd
+597aaddc7c24dffabd8b547892eb16ae *man/power.examp.Rd
+351cbefc6c4d6b4f45c5b19247bac709 *man/put.points.demo.Rd
+7cb2453b961a967c7f82ef32a0f4ca2e *man/rgl.Map.Rd
+899582bf2feb1c16c6f86f74261bc76b *man/roc.demo.Rd
+9fbc32b81cf7e1a4431d4a87be39b6b3 *man/rotate.cloud.Rd
+96c57bab8a79e3e7bb4a6971a2219650 *man/run.cor.examp.Rd
+61b081ee568fc38aea4f2a402c493ff0 *man/run.hist.demo.Rd
+ba8dcd3f9a14f1d706f5b927c63c3649 *man/shadowtext.Rd
+5435bae8bddb23dc81677cf0fec4c7d8 *man/sigma.test.Rd
+42e0eca92792d8bdce21be8fecece772 *man/simfun.Rd
+ea8ff131017333137f3fefebd969173c *man/slider.Rd
+b9cdb4d73d75f6d8db56b8a456866a06 *man/sliderv.Rd
+082f9656600a1ec4b291b961094737e1 *man/spread.labs.Rd
+5b1ac4a906bff3dd390b626b64042280 *man/squishplot.Rd
+a0f02b9530a79681925970402fd61d52 *man/steps.Rd
+939e0eda45e163643a0011bf565e66ff *man/stork.Rd
+85e77faaf5cf24a276fbf850d3b7969c *man/subplot.Rd
+7adf8ab5c65775a51b7c84b133e12301 *man/tkBrush.Rd
+bc4df3320f86f835966550efb2873e1c *man/tkexamp.Rd
+133b0eb9442c1f391f1e03e292b5d01c *man/tree.demo.Rd
+e4a6314717717c3f185f8b40e7a7af69 *man/triplot.Rd
+217013a384af5f18052a0e2e6711760f *man/updateusr.Rd
+4f0979515e942b48c031573fb99df73a *man/vis.binom.Rd
+dcf864aed54b2a7f79b2a253e90d07fb *man/vis.boxcox.Rd
+36ca5f5af58b296c32b7c1badf2fb10c *man/vis.test.Rd
+f48dd2affc24842c20e062214fdfef64 *man/z.test.Rd
+e6da88e86d010a603b64dabf1d8309de *man/zoomplot.Rd
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..be755ae
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,61 @@
+ export(bct,char2seed,chisq.detail,ci.examp,clipplot,clt.examp,cnvrt.coords,
+ dice,dots,dots2,emp.hpd,faces,faces2,fagan.plot,
+ flip.rgl.coin,gp.close,gp.open,gp.plot,gp.splot,gp.send,hpd,
+ Pvalue.norm.sim,Pvalue.binom.sim,simfun,
+ run.Pvalue.norm.sim,run.Pvalue.binom.sim,
+ lattice.demo,loess.demo,mle.demo, digits,
+ ms.arrows,ms.female,ms.filled.polygon,ms.male,ms.polygon,ms.polygram,
+ ms.sunflowers,ms.image,my.symbols,panel.dice,plot.dice,rgl.coin,
+ rgl.die,plot2script,plotFagan,plotFagan2,plotFagan.old,ms.face,
+ plotFagan2.old,power.examp,updateusr,pairs2,
+ prepanel.dice,put.points.demo,shadowtext,
+ rgl.Map,roc.demo,roll.rgl.die,rotate.cloud,cor.rect.plot,
+ rotate.persp,rotate.wireframe,run.ci.examp,run.cor.examp,
+ run.cor2.examp,run.old.cor.examp,run.old.cor2.examp,
+ run.hist.demo,run.power.examp,run.power.examp.old,slider,
+ sliderv,squishplot,SensSpec.demo,spread.labs,
+ subplot,TkListView,HWidentify,HTKidentify,
+ tkBrush,tree.demo,triplot,vis.binom,vis.boxcox,vis.boxcoxu,
+ vis.boxcox.old, vis.boxcoxu.old, sigma.test,
+ vis.gamma,vis.normal,vis.t,z.test,zoomplot,oldzoomplot,
+ tkexamp,col2grey,col2gray,
+ TkApprox,TkSpline,txtStart,txtStop,txtComment,txtSkip,etxtStart,
+ etxtStop,etxtComment,etxtSkip,etxtPlot,wdtxtStart,wdtxtStop,
+ wdtxtComment,wdtxtSkip,wdtxtPlot,mdtxtStart,mdtxtStop,mdtxtComment,
+ mdtxtSkip,mdtxtPlot,
+ dynIdentify,TkIdentify,
+ Predict.Plot, TkPredict, "%<%", "%<=%", panel.my.symbols,
+ SnowsPenultimateNormalityTest,vis.test,vt.qqnorm,vt.normhist,
+ vt.scatterpermute,vt.tspermute,vt.residpermute,vt.residsim,
+ SnowsCorrectlySizedButOtherwiseUselessTestOfAnything,petals,cal,
+ TkBuildDist,TkBuildDist2)
+
+
+ importFrom("grDevices", "chull", "col2rgb", "colors", "dev.copy",
+ "dev.copy2eps", "dev.cur", "dev.new", "dev.off",
+ "getGraphicsEvent", "nclass.Sturges", "png", "recordPlot",
+ "replayPlot", "rgb", "xy.coords")
+ importFrom("graphics", "Axis", "abline", "arrows", "axis", "barplot",
+ "box", "curve", "frame", "grconvertX", "grconvertY", "hist",
+ "image", "layout", "legend", "lines", "locator", "mtext",
+ "pairs", "par", "persp", "plot", "plot.new", "plot.window",
+ "points", "polygon", "rect", "rug", "segments", "strheight",
+ "strwidth", "symbols", "text", "title")
+ importFrom("stats", "approxfun", "coef", "cor", "dbinom", "dchisq",
+ "delete.response", "density", "dexp", "dgamma", "dnorm",
+ "dpois", "dt", "fitted", "get_all_vars", "lm", "loess",
+ "loess.control", "median", "optimize", "pbinom", "pchisq",
+ "pnorm", "predict", "pt", "qchisq", "qgeom", "qnorm",
+ "qqline", "qqnorm", "qqplot", "qt", "quantile", "rbinom",
+ "resid", "rnorm", "runif", "scatter.smooth", "sd",
+ "splinefun", "terms", "var")
+ importFrom("utils", "capture.output", "file_test", "flush.console",
+ "str", "tail", "write.table")
+
+
+S3method(plot, dice)
+
+
+
+
+
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..b389e35
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,227 @@
+New in TeachingDemos version 2.10
+
+* Modified z.test so that you can provide a sample mean and sample
+ size instead of the raw data.
+
+* Added digits function to compute digits of an integer
+
+* Fixed zoomplot to work with R 3.0
+
+* Fixed subplot function to work better in multi frame plots with type='fig'.
+
+* Fixed minor (and potentially major) bugs in TkListView
+
+New in TeachingDemos version 2.9
+
+* Removed sd.g, limits.g, and stats.g functions that work with the qcc
+ package as they are now included in qcc and don't need to be here
+ any more.
+
+* Added functions mdtxtStart, mdtxtStop, mdtxtComment, mdtxtSkip, and
+ mdtxtPlot to create transcript files using MarkDown which can then
+ be converted to common formats (pdf, MS Word, html, etc.) using the
+ pandoc program.
+
+* Changed names of plot.rgl.coin and plot.rgl.die to rgl.coin and
+ rgl.die to prevent confusion with S3 methods for plot generic
+ function.
+
+* added function cor.rect.plot to demonstrate concept of correlation.
+
+* Added USCrimes dataset
+
+* Added linesfun argument to my.symbols so that the user can use
+ functions like polygon in place of lines.
+
+* Added function simfun to help with creating simulated data sets.
+
+* Modified squishplot function to remove missing values in case the
+ entire data is submitted as xlim and ylim.
+
+
+New in TeachingDemos version 2.8
+
+* Changed many functions to no longer use partial match of arguments,
+ this makes the newer versions happy and results in better code.
+
+* Internal changes to R2txt.R and gnuplot.R to use an environment
+ rather than a list for storing package local variables, this
+ eliminated the need for "<<-" and unlocking of bindings and makes
+ the code cleaner.
+
+* arguments xsize and ysize added to my.symbols to allow setting the
+ size of the symbols using the scale of the x or y variable.
+
+* new functions TkBuildDist and TkBuildDist2 to interactively create a
+ (prior) distrbution.
+
+* new function cal to plot calendars
+
+* new 'animate' option for tkexamp
+
+* new function 'petals' to play the petals around the rose game (and
+ demonstrate a simple code obscuration).
+
+* fixed bug in subplot when subplotting inside mfrow/mfcol figures.
+
+* Added ldsgrowth dataset
+
+* Modified subplot and other functions to no longer need cnvrt.coords.
+
+* cnvert.coords is now depricated, use grconvertX and grconvertY from
+ the graphics package instead.
+
+* Functions identify.Map, identify.polylist, recenter.Map, and
+ project.Map have been removed as there is now better functionality
+ in the sp package.
+
+* The state.vbm object has been moved to the maptools package.
+
+New in TeachingDemos version 2.7
+
+* new function ms.image for plotting images using my.symbols.
+
+* new functions wdtxtStart and friends to insert transcript into MS Word.
+
+* function vt.residsim to work with vis.test.
+
+* fixed several functions that depend on tcltk but did not load it.
+
+* Updated HWidentify and HTKidentify to give more control and clean up after.
+
+* Removed exaple in subplot using rimage package since it is not
+ current and potentially causes problems.
+
+New in TeachingDemos version 2.6
+
+* function vis.test and friends made available (was present before,
+ but not in the Namespace).
+
+* Fixed bug in tkexamp with checkboxes.
+
+* Added 'outliers' dataset
+
+New in TeachingDemos version 2.5
+
+* New functions HWidentify and HTKidentify to label points being hovered over.
+
+* Turned off clipping (par(xpd=TRUE)) inside of my.symbols so that
+ subsequent points are plotted
+
+* New function sigma.test for testing a single variance.
+
+
+New in TeachingDemos version 2.4
+
+* The squishplot function now calls plot.new before doing the
+ calculations, fixs a bug when things have not been reset or if fig
+ regions are not all the same size. There is an argument that will
+ turn this off if needed.
+
+* New functions Pvalue.norm.sim, Pvalue.binom.sim,
+ run.Pvalue.norm.sim, and run.Pvalue.binom.sim to simulate p-values.
+
+* The subplot function can now accept strings such as "topleft" or
+ "bottom" as the x argument (and does the appropriate thing).
+
+* New function gp.splot to send surface plot info to gnuplot
+
+* Changed the write char commands in the etxtStart family to remove
+ warnings in 2.8.0
+
+* Changed par settings in my.symbols. Old way reset all pars which
+ could cause some plotting in the wrong areas. Now it only resets
+ the pars that it changes.
+
+* updated plot2script to use dput rather than deparse which does
+ better line wrapping. Also fixed the problem with the "box" command
+ (though other functions could still have the same problem).
+
+* Removed strip.shingle function as it no longer works and its
+ intended purpose has been available in lattice for a while.
+
+* tkexamp now has a 'print' option (defaults to FALSE) that will
+ automatically print the results of the function evaluation. This is
+ useful for ggplot2 or lattice graphics that must be printed to be seen.
+
+* Function TkPredict for visualizing predicted values from a
+ regression model adjusting for other terms in the model.
+
+* New datasets 'evap' and 'stork'
+
+* state.vbm updated to spatial polygon data frame.
+
+New in TeachingDemos version 2.3
+
+* etxt* functions updated to use rawToChar(as.raw(0)) rather than '\000'
+
+* new function TkListView for interactively looking at list structures.
+
+* Removed strict dependence on the Tk packages, will only be loaded for functions that use them.
+
+* new function updateusr to update usr coordinate system.
+
+* new function pairs2 that works like the pairs function, but with 2
+ matricies and plots the pairwise scatterplots between the matricies.
+
+New in TeachingDemos version 2.2
+
+* tkprogress was removed, use tkProgressBar in utils package (by
+ Prof. Ripley) as a better version.
+
+* New function spread.labs to spread coordinates out for adding labels
+ to a plot.
+
+For TeachingDemos version 2.1
+
+* Removed dependence on rgl and tcltk2 packages
+
+
+New to TeachingDemos version 2.0
+
+* TeachingDemos now has a NAMESPACE so you can access just parts of
+ the package without loading everything. Fewer packages are now
+ loaded with it, so it should load smaller and faster.
+
+* Some of the gui demonstrations (e.g. run.cor.examp) were rewritten
+ using the tkrplot package so that the graph shows up in the same
+ window as the controls. Old versions will remain, but with the word
+ "old" inserted into the name. More will change eventually.
+
+* Many of the examples sections have replaced \dontrun with
+ if(interactive()) so that the examples can be run using the
+ "examples" function (recommended to use ask=FALSE).
+
+* clt.demo function will now allow you to specify parameters of the
+ distributions and the exponential was replaced with a gamma (the
+ defaults match the prior information).
+
+* New function "tkexamp" for creating interactive
+ examples/demonstrations of the effect of changing parameter values
+ on a graph.
+
+* New functions "dynIdentify" and "TkIdentify" which create a
+ scatterplot, place labels on the points, then allow you to drag the
+ labels to new locations.
+
+* New function "col2grey" for getting an idea of how a graph will look
+ if printed or copied to greyscale.
+
+* New function "SensSpec.demo" to show how to move from Sensitivity
+ and Specificity to predictive power positive and negative using an
+ intuitive virtual population method rather than the explicit math of
+ Bayes formula.
+
+* New functions "TkApprox" and "TkSpline" to interactivly interpolate
+ on graphs and find values, differences, derivatives.
+
+* New function "tkprogress" for a popup progress bar window to show
+ you how a loop is progressing.
+
+* New functions "txtStart", "etxtStart", etc to create transcript
+ files and script files of your session. Final result is a text file
+ or a text file that can be converted to postscript and others via
+ the enscript program. The later version can include copies of
+ graphs.
+
+
diff --git a/R/00vars.R b/R/00vars.R
new file mode 100644
index 0000000..3c5be8c
--- /dev/null
+++ b/R/00vars.R
@@ -0,0 +1,2 @@
+slider.env <- new.env()
+
diff --git a/R/HWidentify.R b/R/HWidentify.R
new file mode 100644
index 0000000..0adde55
--- /dev/null
+++ b/R/HWidentify.R
@@ -0,0 +1,94 @@
+HWidentify <- function(x,y,label=seq_along(x), lab.col='darkgreen',
+ pt.col='red', adj=c(0,0), clean=TRUE,
+ xlab=deparse(substitute(x)),
+ ylab=deparse(substitute(y)), ...) {
+
+ plot(x,y,xlab=xlab, ylab=ylab,...)
+
+ dx <- grconvertX(x,to='ndc')
+ dy <- grconvertY(y,to='ndc')
+
+ mm <- function(buttons, xx, yy) {
+ d <- (xx-dx)^2 + (yy-dy)^2
+ if ( all( d > .01 ) ){
+ plot(x,y,xlab=xlab,ylab=ylab,...)
+ return()
+ }
+ w <- which.min(d)
+ plot(x,y,xlab=xlab,ylab=ylab,...)
+ points(x[w],y[w], cex=2, col=pt.col)
+ text(grconvertX(xx,from='ndc'),grconvertY(yy,from='ndc'),
+ label[w], col=lab.col, adj=adj)
+ return()
+ }
+
+ md <- function(buttons, xx, yy) {
+ if (any(buttons=='2')) return(1)
+ return()
+ }
+
+ getGraphicsEvent('Right Click to exit', onMouseMove = mm, onMouseDown=md)
+ if(clean) mm( , Inf, Inf )
+ invisible()
+}
+
+# tmpx <- runif(25)
+# tmpy <- rnorm(25)
+# HWidentify(tmpx,tmpy,LETTERS[1:25], pch=letters)
+
+
+
+
+HTKidentify <- function(x,y,label=seq_along(x), lab.col='darkgreen',
+ pt.col='red', adj=c(0,0),
+ xlab=deparse(substitute(x)),
+ ylab=deparse(substitute(y)), ...) {
+
+ if( !requireNamespace("tkrplot", quietly=TRUE) ) stop ('tkrplot package is required')
+
+ dx <- numeric(0)
+ dy <- numeric(0)
+
+ xx <- yy <- 0
+
+ replot <- function() {
+ d <- (xx-dx)^2 + (yy-dy)^2
+ if ( all( d > .01 ) ) {
+ plot(x,y,xlab=xlab,ylab=ylab,...)
+ if( length(dx)==0 ) {
+ dx <<- grconvertX(x, to='ndc')
+ dy <<- grconvertY(y, to='ndc')
+ }
+ return()
+ }
+ w <- which.min(d)
+ plot(x,y,xlab=xlab,ylab=ylab,...)
+ points(x[w],y[w], cex=2, col=pt.col)
+ text(grconvertX(xx,from='ndc'),grconvertY(yy,from='ndc'),
+ label[w], col=lab.col, adj=adj)
+ }
+
+ tt <- tcltk::tktoplevel()
+ img <- tkrplot::tkrplot(tt, replot, hscale=1.5, vscale=1.5)
+ tcltk::tkpack(img, side='top')
+ iw <- as.numeric(tcltk::tcl("image","width", tcltk::tkcget(img, "-image")))
+ ih <- as.numeric(tcltk::tcl("image","height", tcltk::tkcget(img, "-image")))
+
+ cc <- function(x,y) {
+ x <- (as.double(x) -1)/iw
+ y <- 1-(as.double(y)-1)/ih
+ c(x,y)
+ }
+
+ mm <- function(x, y) {
+ xy <- cc(x,y)
+ xx <<- xy[1]
+ yy <<- xy[2]
+ tkrplot::tkrreplot(img)
+ }
+
+ tcltk::tkbind(img, "<Motion>", mm)
+
+ invisible()
+}
+
diff --git a/R/Pvalue.sim.R b/R/Pvalue.sim.R
new file mode 100644
index 0000000..2f2a057
--- /dev/null
+++ b/R/Pvalue.sim.R
@@ -0,0 +1,143 @@
+Pvalue.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')
+}
+
diff --git a/R/R2txt.R b/R/R2txt.R
new file mode 100644
index 0000000..59ba134
--- /dev/null
+++ b/R/R2txt.R
@@ -0,0 +1,677 @@
+### consider adding option to include errors Can implement by using
+### options(error=newfunction) and newfunction would use the
+### savehistory command to get the expression and geterrmessage to get
+### the error message. Warnings can be included by checking to see if
+### last.warning has changed, use print.warnings to format.
+
+R2txt.vars <- new.env()
+
+R2txt <- function(cmd,res,s,vis) {
+ if(R2txt.vars$first) {
+ R2txt.vars$first <- FALSE
+ if( R2txt.vars$res ) {
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ } else {
+
+ if( R2txt.vars$cmd ){
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', paste("\n",R2txt.vars$continue, sep=''),
+ cmdline)
+ cmdline <- gsub('}', paste("\n",R2txt.vars$continue,"}", sep=''),
+ cmdline)
+ cat(R2txt.vars$prompt, cmdline, "\n", sep='',
+ file=R2txt.vars$con)
+ }
+ if( R2txt.vars$cmdfile ) {
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', "\n ", cmdline)
+ cmdline <- gsub('}', "\n}", cmdline)
+ cat(cmdline,"\n", file=R2txt.vars$con2)
+ }
+
+ if( R2txt.vars$res ) {
+ tmp <- textConnectionValue(R2txt.vars$outcon)
+ if(length(tmp)) {
+ cat(tmp,sep='\n',file=R2txt.vars$con)
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ }
+ }
+
+ TRUE
+}
+
+txtStart <- function(file, commands=TRUE, results=TRUE, append=FALSE,
+ cmdfile, visible.only=TRUE) {
+
+ tmp <- TRUE
+ if(is.character(file)){
+ if(append){
+ con <- file(file,open='a')
+ } else {
+ con <- file(file,open='w')
+ }
+ tmp <- FALSE
+ } else if( any( class(file) == 'connection' ) ) {
+ con <- file
+ } else {
+ stop('file must be a character string or connection')
+ }
+ if( tmp && isOpen(con) ) {
+ R2txt.vars$closecon <- FALSE
+ } else {
+ R2txt.vars$closecon <- TRUE
+ if(tmp){
+ if(append) {
+ open(con, open='a')
+ } else {
+ open(con, open='w')
+ }
+ }
+ }
+ R2txt.vars$vis <- visible.only
+ R2txt.vars$cmd <- commands
+ R2txt.vars$res <- results
+ R2txt.vars$con <- con
+ R2txt.vars$first <- TRUE
+
+ if(results) {
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+
+ if( !missing(cmdfile) ) {
+ tmp <- TRUE
+ if(is.character(cmdfile)) {
+ con2 <- file(cmdfile, open='w')
+ tmp <- FALSE
+ } else if( any( class(cmdfile) == 'connection' ) ) {
+ con2 <- cmdfile
+ }
+ if( tmp && isOpen(con2) ) {
+ R2txt.vars$closecon2 <- FALSE
+ } else {
+ R2txt.vars$closecon2 <- TRUE
+ if(tmp) {
+ open(con2, open='w')
+ }
+ }
+ R2txt.vars$con2 <- con2
+ R2txt.vars$cmdfile <- TRUE
+ } else {
+ R2txt.vars$cmdfile <- FALSE
+ }
+
+ R2txt.vars$prompt <- unlist(options('prompt'))
+ R2txt.vars$continue <- unlist(options('continue'))
+
+ options(prompt= paste('txt',R2txt.vars$prompt,sep=''),
+ continue= paste('txt',R2txt.vars$continue,sep='') )
+
+ cat('Output being copied to text file,\nuse txtStop to end\n')
+ addTaskCallback(R2txt, name='r2txt')
+ invisible(NULL)
+}
+
+txtStop <- function() {
+ removeTaskCallback('r2txt')
+ if( R2txt.vars$closecon ) {
+ close( R2txt.vars$con )
+ }
+ if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) {
+ close( R2txt.vars$con2 )
+ }
+ options( prompt=R2txt.vars$prompt,
+ continue=R2txt.vars$continue )
+ if(R2txt.vars$res) {
+ sink()
+ close(R2txt.vars$outcon)
+ }
+ evalq( rm(list=ls()), envir=R2txt.vars )
+ invisible(NULL)
+}
+
+txtComment <- function(txt,cmdtxt) {
+ R2txt.vars$first <- TRUE
+ if(!missing(txt)) {
+ cat("\n",txt,"\n\n", file=R2txt.vars$con)
+ }
+ if(!missing(cmdtxt)) {
+ cat("# ",cmdtxt,"\n", file=R2txt.vars$con2)
+ }
+}
+
+txtSkip <- function(expr) {
+ R2txt.vars$first <- TRUE
+ expr
+}
+
+
+######### etxt extended or enscriptable
+
+R2etxt <- function(cmd,res,s,vis) {
+ if(R2txt.vars$first) {
+ R2txt.vars$first <- FALSE
+ if( R2txt.vars$res ) {
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ } else {
+
+ if( R2txt.vars$cmd ) {
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', "\n", cmdline)
+ cmdline <- gsub('}', "\n}", cmdline)
+ writeChar("",R2txt.vars$con)
+ cat(R2txt.vars$cmdbg,file=R2txt.vars$con)
+ writeChar("",R2txt.vars$con)
+ cat(R2txt.vars$cmdcol,file=R2txt.vars$con)
+ cat(R2txt.vars$prompt, cmdline, "\n", sep='',
+ file=R2txt.vars$con)
+ }
+ if( R2txt.vars$cmdfile ) {
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', "\n ", cmdline)
+ cmdline <- gsub('}', "\n}", cmdline)
+ cat(cmdline,"\n", file=R2txt.vars$con2)
+ }
+ if( R2txt.vars$res ) {
+ tmp <- textConnectionValue(R2txt.vars$outcon)
+ if(length(tmp)) {
+ writeChar("",R2txt.vars$con)
+ cat(R2txt.vars$resbg, file=R2txt.vars$con)
+ writeChar("",R2txt.vars$con)
+ cat(R2txt.vars$rescol,file=R2txt.vars$con)
+ cat(tmp,sep='\n',file=R2txt.vars$con)
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ }
+ }
+
+ TRUE
+}
+
+etxtStart <- function(dir=tempfile('etxt'), file='transcript.txt',
+ commands=TRUE, results=TRUE, append=FALSE,
+ cmdbg='white',cmdcol='red', resbg='white',
+ rescol='navy',combg='cyan',comcol='black',
+ cmdfile, visible.only=TRUE) {
+
+ if( !file_test("-d", dir) ) {
+ dir.create(dir)
+ }
+ tmp <- TRUE
+ if(is.character(file)){
+ file2 <- file.path(dir,file)
+ if(append){
+ con <- file(file2,open='a')
+ } else {
+ con <- file(file2,open='w')
+ }
+ tmp <- FALSE
+ R2txt.vars$file2 <- file2
+ } else if( any( class(file) == 'connection' ) ) {
+ con <- file
+ } else {
+ stop('file must be a character string or connection')
+ }
+ if(tmp && isOpen(con)) {
+ R2txt.vars$closecon <- FALSE
+ } else {
+ R2txt.vars$closecon <- TRUE
+ if(tmp) {
+ if(append) {
+ open(con, open='a')
+ } else {
+ open(con, open='w')
+ }
+ }
+ }
+ R2txt.vars$dir <- dir
+ R2txt.vars$vis <- visible.only
+ R2txt.vars$cmd <- commands
+ R2txt.vars$res <- results
+ R2txt.vars$con <- con
+ R2txt.vars$first <- TRUE
+
+ tmp <- round( col2rgb( c(cmdbg,cmdcol,resbg,rescol,combg,comcol) )/255,
+ 3)
+ tmp2 <- paste( rep(c('bgcolor{','color{'),3),
+ tmp[1,], ' ', tmp[2,], ' ', tmp[3,], '}',
+ sep='' )
+
+ R2txt.vars$cmdbg <- tmp2[1]
+ R2txt.vars$cmdcol <- tmp2[2]
+ R2txt.vars$resbg <- tmp2[3]
+ R2txt.vars$rescol <- tmp2[4]
+ R2txt.vars$combg <- tmp2[5]
+ R2txt.vars$comcol <- tmp2[6]
+
+ if(results) {
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ tmp3 <- TRUE
+ if( !missing(cmdfile) ) {
+ if(is.character(cmdfile)) {
+ con2 <- file(cmdfile, open='w')
+ tmp3 <- FALSE
+ } else if( any( class(cmdfile) == 'connection' ) ) {
+ con2 <- cmdfile
+ }
+ if( tmp3 && isOpen(con2) ) {
+ R2txt.vars$closecon2 <- FALSE
+ } else {
+ R2txt.vars$closecon2 <- TRUE
+ if(tmp3) {
+ open(con2, open='w')
+ }
+ }
+ R2txt.vars$con2 <- con2
+ R2txt.vars$cmdfile <- TRUE
+ } else {
+ R2txt.vars$cmdfile <- FALSE
+ }
+
+ R2txt.vars$prompt <- unlist(options('prompt'))
+ R2txt.vars$continue <- unlist(options('continue'))
+
+ options(prompt= paste('etxt',R2txt.vars$prompt,sep=''),
+ continue= paste('etxt',R2txt.vars$continue,sep='') )
+
+ cat('Output being copied to text file,\nuse etxtStop to end\n')
+ addTaskCallback(R2etxt, name='r2etxt')
+ invisible(NULL)
+}
+
+etxtStop <- function() {
+ removeTaskCallback('r2etxt')
+ if( R2txt.vars$closecon ) {
+ close( R2txt.vars$con )
+ }
+ if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) {
+ close( R2txt.vars$con2 )
+ }
+ options( prompt=R2txt.vars$prompt,
+ continue=R2txt.vars$continue )
+ if(R2txt.vars$res) {
+ sink()
+ close(R2txt.vars$outcon)
+ }
+
+ if( 'file2' %in% names(R2txt.vars) ) {
+ out <- R2txt.vars$file2
+ } else {
+ out <- invisible(NULL)
+ }
+ evalq( rm(list=ls()), envir=R2txt.vars )
+ out
+}
+
+etxtComment <- function(txt,cmdtxt) {
+ R2txt.vars$first <- TRUE
+ if(!missing(txt)) {
+ writeChar("",R2txt.vars$con)
+ cat(R2txt.vars$combg,file=R2txt.vars$con)
+ writeChar("",R2txt.vars$con)
+ cat(R2txt.vars$comcol,file=R2txt.vars$con)
+ cat("\n",txt,"\n\n", file=R2txt.vars$con)
+ }
+ if(!missing(cmdtxt)) {
+ cat("# ",cmdtxt,"\n", file=R2txt.vars$con2)
+ }
+}
+
+etxtSkip <- function(expr) {
+ R2txt.vars$first <- TRUE
+ expr
+}
+
+etxtPlot <- function(file=paste(tempfile('plot',R2txt.vars$dir),'.eps',sep=''),
+ width=4, height=4) {
+ dev.copy2eps(file=file, height=height, width=width)
+ writeChar("",R2txt.vars$con)
+ cat('epsf{',file,'}\n', sep='', file=R2txt.vars$con)
+ R2txt.vars$first <- TRUE
+ invisible(NULL)
+}
+
+#### version for sending output to MSword
+
+R2wdtxt <- function(cmd,res,s,vis) {
+
+ requireNamespace('R2wd', quietly = TRUE)
+ if(R2txt.vars$first) {
+ R2txt.vars$first <- FALSE
+ if( R2txt.vars$res ) {
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ } else {
+
+ if( R2txt.vars$cmd ){
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', paste("\n",R2txt.vars$continue, sep=''),
+ cmdline)
+ cmdline <- gsub('}', paste("\n",R2txt.vars$continue,"}", sep=''),
+ cmdline)
+ R2wd::wdVerbatim( paste(R2txt.vars$prompt, cmdline, sep=''),
+ fontsize=R2txt.vars$fontsize )
+ }
+ if( R2txt.vars$cmdfile ) {
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', "\n ", cmdline)
+ cmdline <- gsub('}', "\n}", cmdline)
+ cat(cmdline,"\n", file=R2txt.vars$con2)
+ }
+
+ if( R2txt.vars$res ) {
+ tmp <- textConnectionValue(R2txt.vars$outcon)
+ if(length(tmp)) {
+ R2wd::wdVerbatim(paste(tmp,sep='\n'), fontsize=R2txt.vars$fontsize)
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ }
+ }
+
+ TRUE
+}
+
+wdtxtStart <- function(commands=TRUE, results=TRUE, fontsize=9,
+ cmdfile, visible.only=TRUE) {
+
+ if( !requireNamespace('R2wd', quietly = TRUE) ) stop('the R2wd package is required')
+
+ R2wd::wdGet()
+
+ R2txt.vars$vis <- visible.only
+ R2txt.vars$cmd <- commands
+ R2txt.vars$res <- results
+ R2txt.vars$first <- TRUE
+ R2txt.vars$fontsize <- fontsize
+
+ if(results) {
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+
+ if( !missing(cmdfile) ) {
+ tmp <- TRUE
+ if(is.character(cmdfile)) {
+ con2 <- file(cmdfile, open='w')
+ tmp <- FALSE
+ } else if( any( class(cmdfile) == 'connection' ) ) {
+ con2 <- cmdfile
+ }
+ if( tmp && isOpen(con2) ) {
+ R2txt.vars$closecon2 <- FALSE
+ } else {
+ R2txt.vars$closecon2 <- TRUE
+ if(tmp) {
+ open(con2, open='w')
+ }
+ }
+ R2txt.vars$con2 <- con2
+ R2txt.vars$cmdfile <- TRUE
+ } else {
+ R2txt.vars$cmdfile <- FALSE
+ }
+
+ R2txt.vars$prompt <- unlist(options('prompt'))
+ R2txt.vars$continue <- unlist(options('continue'))
+
+ options(prompt= paste('wdTxt',R2txt.vars$prompt,sep=''),
+ continue= paste('wdTxt',R2txt.vars$continue,sep='') )
+
+ cat('Output being copied to text file,\nuse wdtxtStop to end\n')
+ addTaskCallback(R2wdtxt, name='r2wdtxt')
+ invisible(NULL)
+}
+
+wdtxtStop <- function() {
+ removeTaskCallback('r2wdtxt')
+
+ if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) {
+ close( R2txt.vars$con2 )
+ }
+ options( prompt=R2txt.vars$prompt,
+ continue=R2txt.vars$continue )
+ if(R2txt.vars$res) {
+ sink()
+ close(R2txt.vars$outcon)
+ }
+ evalq( rm(list=ls()), envir=R2txt.vars )
+ invisible(NULL)
+}
+
+wdtxtComment <- function(txt,cmdtxt) {
+ requireNamespace('R2wd', quietly = TRUE)
+ R2txt.vars$first <- TRUE
+ if(!missing(txt)) {
+ R2wd::wdParagraph()
+ R2wd::wdBody(txt)
+ R2wd::wdParagraph()
+ }
+ if(!missing(cmdtxt)) {
+ cat("# ",cmdtxt,"\n", file=R2txt.vars$con2)
+ }
+}
+
+wdtxtSkip <- function(expr) {
+
+ R2txt.vars$first <- TRUE
+ expr
+}
+
+wdtxtPlot <- function(height=5, width=5, pointsize=10) {
+ requireNamespace('R2wd', quietly = TRUE)
+ R2txt.vars$first <- TRUE
+
+ tmp <- recordPlot()
+ R2wd::wdPlot(tmp, plotfun=replayPlot, height=height, width=width,
+ pointsize=pointsize)
+}
+
+
+########## mdtxt Use markdown
+
+R2mdtxt <- function(cmd,res,s,vis) {
+ if(R2txt.vars$first) {
+ R2txt.vars$first <- FALSE
+ if( R2txt.vars$res ) {
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ } else {
+
+ if( R2txt.vars$cmd ){
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', "\n", cmdline)
+ cmdline <- gsub('}', "\n}", cmdline)
+ cat("```r\n",file=R2txt.vars$con)
+ cat(R2txt.vars$prompt, cmdline, "\n", sep='',
+ file=R2txt.vars$con)
+ cat("```\n\n", file=R2txt.vars$con)
+ }
+ if( R2txt.vars$cmdfile ) {
+ cmdline <- deparse(cmd)
+ cmdline <- gsub(' ', "\n ", cmdline)
+ cmdline <- gsub('}', "\n}", cmdline)
+ cat(cmdline,"\n", file=R2txt.vars$con2)
+ }
+ if( R2txt.vars$res ) {
+ tmp <- textConnectionValue(R2txt.vars$outcon)
+ if(length(tmp)) {
+ cmdline <- deparse(cmd)
+ if( grepl("^\\s*pand(er|oc)", cmdline)[1] ) {
+ cat("\n",file=R2txt.vars$con)
+ cat(tmp,sep='\n',file=R2txt.vars$con)
+ cat("\n\n",file=R2txt.vars$con)
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ } else {
+ cat("```\n",file=R2txt.vars$con)
+ cat(tmp,sep='\n',file=R2txt.vars$con)
+ cat("```\n\n",file=R2txt.vars$con)
+ sink()
+ close(R2txt.vars$outcon)
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ }
+ }
+ }
+
+ TRUE
+}
+
+mdtxtStart <- function(dir=tempfile('mdtxt'), file='transcript.md',
+ commands=TRUE, results=TRUE, append=FALSE,
+ cmdfile, visible.only=TRUE) {
+
+ if( !file_test("-d", dir) ) {
+ dir.create(dir)
+ }
+ tmp <- TRUE
+ if(is.character(file)){
+ file2 <- file.path(dir,file)
+ if(append){
+ con <- file(file2,open='a')
+ } else {
+ con <- file(file2,open='w')
+ }
+ tmp <- FALSE
+ R2txt.vars$file2 <- file2
+ } else if( any( class(file) == 'connection' ) ) {
+ con <- file
+ } else {
+ stop('file must be a character string or connection')
+ }
+ if(tmp && isOpen(con)) {
+ R2txt.vars$closecon <- FALSE
+ } else {
+ R2txt.vars$closecon <- TRUE
+ if(tmp) {
+ if(append) {
+ open(con, open='a')
+ } else {
+ open(con, open='w')
+ }
+ }
+ }
+ R2txt.vars$dir <- dir
+ R2txt.vars$vis <- visible.only
+ R2txt.vars$cmd <- commands
+ R2txt.vars$res <- results
+ R2txt.vars$con <- con
+ R2txt.vars$first <- TRUE
+
+ if(results) {
+ R2txt.vars$outcon <- textConnection(NULL, open='w')
+ sink(R2txt.vars$outcon, split=TRUE)
+ }
+ tmp3 <- TRUE
+ if( !missing(cmdfile) ) {
+ if(is.character(cmdfile)) {
+ con2 <- file(cmdfile, open='w')
+ tmp3 <- FALSE
+ } else if( any( class(cmdfile) == 'connection' ) ) {
+ con2 <- cmdfile
+ }
+ if( tmp3 && isOpen(con2) ) {
+ R2txt.vars$closecon2 <- FALSE
+ } else {
+ R2txt.vars$closecon2 <- TRUE
+ if(tmp3) {
+ open(con2, open='w')
+ }
+ }
+ R2txt.vars$con2 <- con2
+ R2txt.vars$cmdfile <- TRUE
+ } else {
+ R2txt.vars$cmdfile <- FALSE
+ }
+
+ R2txt.vars$prompt <- unlist(options('prompt'))
+ R2txt.vars$continue <- unlist(options('continue'))
+
+ options(prompt= paste('mdtxt',R2txt.vars$prompt,sep=''),
+ continue= paste('mdtxt',R2txt.vars$continue,sep='') )
+
+ cat('Output being copied to text file,\nuse mdtxtStop to end\n')
+ addTaskCallback(R2mdtxt, name='r2mdtxt')
+ invisible(NULL)
+}
+
+mdtxtStop <- function() {
+ removeTaskCallback('r2mdtxt')
+ if( R2txt.vars$closecon ) {
+ close( R2txt.vars$con )
+ }
+ if( R2txt.vars$cmdfile && R2txt.vars$closecon2 ) {
+ close( R2txt.vars$con2 )
+ }
+ options( prompt=R2txt.vars$prompt,
+ continue=R2txt.vars$continue )
+ if(R2txt.vars$res) {
+ sink()
+ close(R2txt.vars$outcon)
+ }
+
+ if( 'file2' %in% names(R2txt.vars) ) {
+ out <- R2txt.vars$file2
+ } else {
+ out <- invisible(NULL)
+ }
+ evalq( rm(list=ls()), envir=R2txt.vars )
+ out
+}
+
+mdtxtComment <- function(txt,cmdtxt) {
+ R2txt.vars$first <- TRUE
+ if(!missing(txt)) {
+ cat("\n",txt,"\n\n", file=R2txt.vars$con)
+ }
+ if(!missing(cmdtxt)) {
+ cat("# ",cmdtxt,"\n", file=R2txt.vars$con2)
+ }
+}
+
+mdtxtSkip <- function(expr) {
+ R2txt.vars$first <- TRUE
+ expr
+}
+
+mdtxtPlot <- function(file=tempfile('plot',R2txt.vars$dir,'.png'),
+ width=4, height=4) {
+ file <- gsub("\\\\","/",file)
+ dev.copy(png, file=file, height=height, width=width, units='in',
+ res=300)
+ dev.off()
+ cat(' \\\n\n', sep='', file=R2txt.vars$con)
+ R2txt.vars$first <- TRUE
+ invisible(NULL)
+}
+
+
diff --git a/R/SensSpec.demo.R b/R/SensSpec.demo.R
new file mode 100644
index 0000000..72e2503
--- /dev/null
+++ b/R/SensSpec.demo.R
@@ -0,0 +1,47 @@
+SensSpec.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])
+}
+
diff --git a/R/TkApprox.R b/R/TkApprox.R
new file mode 100644
index 0000000..ad09640
--- /dev/null
+++ b/R/TkApprox.R
@@ -0,0 +1,126 @@
+TkApprox <- function(x, y, type='b', snap.to.x=FALSE, digits=4,
+ cols=c('red','#009900','blue'),
+ xlab=deparse(substitute(x)), ylab=deparse(substitute(y)),
+ hscale=1.5, vscale=1.5, wait=TRUE,
+ ...) {
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ snap.x <- tcltk::tclVar()
+ tcltk::tclvalue(snap.x) <- ifelse(snap.to.x,"T","F")
+
+ xxx <- as.numeric(x)
+ ax <- min(x)
+ cx <- max(x)
+ bx <- (ax+cx)/2
+
+ xx <- c(ax,bx,cx)
+
+ af <- approxfun(x,y)
+
+ ay <- af(ax)
+ by <- af(bx)
+ cy <- af(cx)
+
+ yy <- c(ay,by,cy)
+
+ txtvar <- tcltk::tclVar()
+ tcltk::tclvalue(txtvar) <- " \n \n "
+
+ first <- TRUE
+ ul <- ur <- 0
+
+ replot <- function() {
+ par(mar=c(5,4,4,4)+0.1)
+ plot(x, y, type=type, xlab=xlab, ylab=ylab, ...)
+ u <- par('usr')
+ lines( c(xx[1],xx[1],u[1]), c(u[3],yy[1],yy[1]), col=cols[1] )
+ lines( c(xx[2],xx[2],u[1]), c(u[3],yy[2],yy[2]), col=cols[2] )
+ lines( c(xx[3],xx[3],u[1]), c(u[3],yy[3],yy[3]), col=cols[3] )
+ mtext( format( xx, digits=digits), side=3, at=xx,
+ line=1:3, col=cols)
+ mtext( format( yy, digits=digits), side=4, at=yy,
+ line=1:3, col=cols)
+ tcltk::tclvalue(txtvar) <<- paste( c('A:B ','B:C ','A:C '),
+ format(pmax( xx[c(1,2,1)], xx[c(2,3,3)] ), digits=digits),
+ '-',
+ format(pmin( xx[c(1,2,1)], xx[c(2,3,3)] ), digits=digits),
+ '=',
+ format(abs( xx[c(1,2,1)] - xx[c(2,3,3)] ), digits=digits),
+ ' ',
+ format(pmax( yy[c(1,2,1)], yy[c(2,3,3)] ), digits=digits),
+ '-',
+ format(pmin( yy[c(1,2,1)], yy[c(2,3,3)] ), digits=digits),
+ '=',
+ format(abs( yy[c(1,2,1)] - yy[c(2,3,3)] ), digits=digits),
+ collapse="\n"
+ )
+ if(first) {
+ first <<- FALSE
+ tmpx <- grconvertX(c(0,1), from='ndc')
+ ul <<- tmpx[1]
+ ur <<- tmpx[2]
+ }
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "TkApprox")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack(tcltk::tklabel(tt, textvariable=txtvar), side='top')
+
+ tcltk::tkpack(tcltk::tkcheckbutton(tt,variable=snap.x, onvalue="T", offvalue="F",
+ text="Snap to points"),
+ side='left')
+ tcltk::tkpack(tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)),
+ side='right')
+
+ md <- FALSE
+ iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image')))
+ ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image')))
+ ccx <- ccy <- 0
+ ci <- 0
+
+ mouse.move <- function(x,y) {
+ if(md) {
+ tx <- (as.numeric(x)-1)/iw
+ ccx <<- tx*ur + (1-tx)*ul
+ if(as.logical(tcltk::tclvalue(snap.x))) {
+ ccx <<- xxx[ which.min( abs(ccx-xxx) ) ]
+ }
+ xx[ci] <<- ccx
+ ccy <<- af(ccx)
+ yy[ci] <<- ccy
+
+ tkrplot::tkrreplot(img)
+ }
+ }
+
+ mouse.down <- function(x,y) {
+ tx <- (as.numeric(x)-1)/iw
+ txx <- tx*ur + (1-tx)*ul
+ ci <<- which.min( abs( txx - xx ) )
+ md <<- TRUE
+ mouse.move(x,y)
+ }
+
+ mouse.up <- function(x,y) {
+ md <<- FALSE
+ }
+
+ tcltk::tkbind(img, '<Motion>', mouse.move)
+ tcltk::tkbind(img, '<ButtonPress-1>', mouse.down)
+ tcltk::tkbind(img, '<ButtonRelease-1>', mouse.up)
+
+ if(wait) {
+ tcltk::tkwait.window(tt)
+ out <- list( x=xx, y=yy )
+ } else {
+ out <- NULL
+ }
+
+ invisible(out)
+
+}
+
diff --git a/R/TkBuildDist.R b/R/TkBuildDist.R
new file mode 100644
index 0000000..a4deb90
--- /dev/null
+++ b/R/TkBuildDist.R
@@ -0,0 +1,208 @@
+TkBuildDist <- function( x=seq(min+(max-min)/nbin/2,
+ max-(max-min)/nbin/2,
+ length.out=nbin),
+ min=0, max=10, nbin=10, logspline=TRUE,
+ intervals=FALSE) {
+
+ if(logspline) logspline <- requireNamespace('logspline', quietly=TRUE)
+ requireNamespace('tkrplot', quietly = TRUE)
+
+ xxx <- x
+
+ brks <- seq(min, max, length.out=nbin+1)
+ nx <- seq( min(brks), max(brks), length.out=250 )
+
+ lx <- ux <- 0
+ first <- TRUE
+
+ replot <- if(logspline) {
+ if(intervals) {
+ function() {
+ hist(xxx, breaks=brks, probability=TRUE,xlab='', main='')
+ xx <- cut(xxx, brks, labels=FALSE)
+ fit <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )
+ lines( nx, logspline::doldlogspline(nx,fit), lwd=3 )
+ if(first) {
+ first <<- FALSE
+ lx <<- grconvertX(min, to='ndc')
+ ux <<- grconvertX(max, to='ndc')
+ }
+ }
+ } else {
+ function() {
+ hist(xxx, breaks=brks, probability=TRUE,xlab='', main='')
+ fit <- logspline::logspline( xxx )
+ lines( nx, logspline::dlogspline(nx,fit), lwd=3 )
+ if(first) {
+ first <<- FALSE
+ lx <<- grconvertX(min, to='ndc')
+ ux <<- grconvertX(max, to='ndc')
+ }
+ }
+ }
+ } else {
+ function() {
+ hist(xxx, breaks=brks, probability=TRUE,xlab='',main='')
+ if(first) {
+ first <<- FALSE
+ lx <<- grconvertX(min, to='ndc')
+ ux <<- grconvertX(max, to='ndc')
+ }
+ }
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Distribution Builder")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=1.5, hscale=1.5)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)),
+ side='right')
+
+ iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image')))
+
+ mouse1.down <- function(x,y) {
+ tx <- (as.numeric(x)-1)/iw
+ ux <- (tx-lx)/(ux-lx)*(max-min)+min
+ xxx <<- c(xxx,ux)
+ tkrplot::tkrreplot(img)
+ }
+
+ mouse2.down <- function(x,y) {
+ if(length(xxx)) {
+ tx <- (as.numeric(x)-1)/iw
+ ux <- (tx-lx)/(ux-lx)*(max-min)+min
+ w <- which.min( abs(xxx-ux) )
+ xxx <<- xxx[-w]
+ tkrplot::tkrreplot(img)
+ }
+ }
+
+ tcltk::tkbind(img, '<ButtonPress-1>', mouse1.down)
+ tcltk::tkbind(img, '<ButtonPress-2>', mouse2.down)
+ tcltk::tkbind(img, '<ButtonPress-3>', mouse2.down)
+
+ tcltk::tkwait.window(tt)
+
+ out <- list(x=xxx)
+ if(logspline) {
+ if( intervals ) {
+ xx <- cut(xxx, brks, labels=FALSE)
+ out$logspline <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )
+ } else {
+ out$logspline <- logspline::logspline(xxx)
+ }
+ }
+
+ if(intervals) {
+ out$intervals <- table(cut(xxx, brks))
+ }
+
+ out$breaks <- brks
+
+ return(out)
+}
+
+
+
+
+TkBuildDist2 <- function( min=0, max=1, nbin=10, logspline=TRUE) {
+ if(logspline) logspline <- requireNamespace(logspline, quietly=TRUE)
+ requireNamespace('tkrplot', quietly=TRUE)
+
+ xxx <- rep( 1/nbin, nbin )
+
+ brks <- seq(min, max, length.out=nbin+1)
+ nx <- seq( min, max, length.out=250 )
+
+ lx <- ux <- ly <- uy <- 0
+ first <- TRUE
+
+ replot <- if(logspline) {
+ function() {
+ barplot(xxx, width=diff(brks), xlim=c(min,max), space=0,
+ ylim=c(0,0.5), col=NA)
+ axis(1,at=brks)
+ xx <- rep( 1:nbin, round(xxx*100) )
+ capture.output(fit <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) ))
+ lines( nx, logspline::doldlogspline(nx,fit)*(max-min)/nbin, lwd=3 )
+
+ if(first) {
+ first <<- FALSE
+ lx <<- grconvertX(min, to='ndc')
+ ly <<- grconvertY(0, to='ndc')
+ ux <<- grconvertX(max, to='ndc')
+ uy <<- grconvertY(0.5, to='ndc')
+ }
+ }
+ } else {
+ function() {
+ barplot(xxx, width=diff(brks), xlim=range(brks), space=0,
+ ylim=c(0,0.5), col=NA)
+ axis(at=brks)
+ if(first) {
+ first <<- FALSE
+ lx <<- grconvertX(min, to='ndc')
+ ly <<- grconvertY(0, to='ndc')
+ ux <<- grconvertX(max, to='ndc')
+ uy <<- grconvertY(0.5, to='ndc')
+ }
+ }
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Distribution Builder")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=1.5, hscale=1.5)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)),
+ side='right')
+
+ iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image')))
+ ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image')))
+
+
+
+ md <- FALSE
+
+ mouse.move <- function(x,y) {
+ if(md) {
+ tx <- (as.numeric(x)-1)/iw
+ ty <- 1-(as.numeric(y)-1)/ih
+
+ w <- findInterval(tx, seq(lx,ux, length=nbin+1))
+
+ if( w > 0 && w <= nbin && ty >= ly && ty <= uy ) {
+ xxx[w] <<- 0.5*(ty-ly)/(uy-ly)
+ xxx[-w] <<- (1-xxx[w])*xxx[-w]/sum(xxx[-w])
+
+ tkrplot::tkrreplot(img)
+ }
+ }
+ }
+
+ mouse.down <- function(x,y) {
+ md <<- TRUE
+ mouse.move(x,y)
+ }
+
+ mouse.up <- function(x,y) {
+ md <<- FALSE
+ }
+
+ tcltk::tkbind(img, '<Motion>', mouse.move)
+ tcltk::tkbind(img, '<ButtonPress-1>', mouse.down)
+ tcltk::tkbind(img, '<ButtonRelease-1>', mouse.up)
+
+ tcltk::tkwait.window(tt)
+
+ out <- list(breaks=brks, probs=xxx)
+ if(logspline) {
+ xx <- rep( 1:nbin, round(xxx*100) )
+ out$logspline <- logspline::oldlogspline( interval = cbind(brks[xx], brks[xx+1]) )
+ }
+
+ return(out)
+}
diff --git a/R/TkListView.R b/R/TkListView.R
new file mode 100644
index 0000000..6715d96
--- /dev/null
+++ b/R/TkListView.R
@@ -0,0 +1,149 @@
+TkListView <- function(list) {
+
+ if( !requireNamespace('tcltk', quietly = TRUE) ) {
+ stop('This function is dependent on the tcltk package')
+ }
+ if( !have.ttk() ) {
+ stop('this function depends on having tcl 8.5 or higher')
+ }
+
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, deparse(substitute(list)))
+
+ fr1 <- tcltk::tkframe(tt)
+
+ tcltk::tkpack(fr1, '-side', 'left', '-fill', 'both', '-expand', 0)
+ Sys.sleep(.1) ## needed for some strange reason.
+ tree <- tcltk::ttktreeview(fr1, '-selectmode','browse','-columns',1,height=21)
+
+ scrtree1 <- tcltk::tkscrollbar(fr1, command=function(...)tcltk::tkyview(tree,...))
+ scrtree2 <- tcltk::tkscrollbar(fr1, command=function(...)tcltk::tkxview(tree,...), orient='horizontal')
+ tcltk::tkconfigure(tree, yscrollcommand=function(...)tcltk::tkset(scrtree1,...),
+ xscrollcommand=function(...)tcltk::tkset(scrtree2,...))
+
+# tkpack(scrtree1, side='right', fill='y',expand=1)
+# tkpack(tree, side='right',fill='both',expand=1)
+ tcltk::tkgrid(tree,scrtree1,sticky='nsew')
+ tcltk::tkgrid(scrtree2,sticky='nsew')
+ tcltk::tkgrid.columnconfigure(fr1, 0, weight=1)
+ tcltk::tkgrid.rowconfigure(fr1,0,weight=1)
+
+ fr2 <- tcltk::tkframe(tt)
+ tcltk::tkpack(fr2, '-side','top','-fill','both','-expand',1)
+
+ txt <- tcltk::tktext(fr2, bg="white", font="courier", wrap='none', width=40)
+ scrtxt1 <- tcltk::tkscrollbar(fr2, command=function(...)tcltk::tkyview(txt,...))
+ scrtxt2 <- tcltk::tkscrollbar(fr2, command=function(...)tcltk::tkxview(txt,...), orient='horizontal')
+ tcltk::tkconfigure(txt, yscrollcommand=function(...)tcltk::tkset(scrtxt1,...),
+ xscrollcommand=function(...)tcltk::tkset(scrtxt2,...))
+
+ tcltk::tkgrid(txt,scrtxt1, sticky='nsew')
+ tcltk::tkgrid(scrtxt2,sticky='nsew')
+ tcltk::tkgrid.columnconfigure(fr2, 0, weight=1)
+ tcltk::tkgrid.rowconfigure(fr2, 0, weight=1)
+
+
+
+ buildtree <- function(list, tree, parent) {
+ str.info <- capture.output( str(list, max.level=1, give.attr=FALSE,
+ no.list=TRUE) )
+ str.info <- gsub(' |\t','\\\\ ',str.info)
+
+ n <- length(list)
+ nms <- names(list)
+ if( is.null(nms) ) nms <- rep('', n)
+
+ if( n < length(str.info) ) {
+ str.info <- tail(str.info, n)
+ }
+
+ for( i in seq(length.out=n) ){
+ id <- paste(parent, '.', i, sep='')
+ nm <- nms[i]
+ if(is.na(nm) || nm == '') nm <- paste0('[[',i,']]')
+ tcltk::tkinsert(tree, parent, 'end', '-id', id, '-text', nm, '-values', str.info[i])
+ if( is.list(list[[i]]) ){
+ Recall( list[[i]], tree, id )
+ } else if( !is.null(attributes(list[[i]])) ) {
+ tcltk::tkinsert(tree, id, 'end','-id', paste(id,'.a',sep=''), '-text', '<<Attributes>>')
+ Recall( attributes(list[[i]]), tree, paste(id,'.a',sep='') )
+ }
+ }
+ tmp <- as.list(attributes(list))
+ tmp$names <- NULL
+ if( length(tmp) ) {
+ tcltk::tkinsert(tree, parent, 'end', '-id', paste(parent,'.aa',sep=''), '-text', '<<Attributes>>')
+ Recall( tmp, tree, paste(parent,'.aa',sep='') )
+ }
+ }
+
+ tmpvals <- capture.output(str(list,max.level=0))
+ tmpvals <- gsub(' ','\\\\ ',tmpvals)
+ tcltk::tkinsert(tree,'','end','-id', 0, '-text', deparse(substitute(list)), '-values', tmpvals)
+
+
+ buildtree(list, tree, '0')
+
+
+ getx <- function(list){
+ tmp <- tcltk::tclvalue(tcltk::tkselect(tree))
+ tmp2 <- strsplit(tmp, '\\.')[[1]][-1]
+ if(length(tmp2)==0) return(list)
+ sb <- function(y, list) {
+ if (any( y %in% c('a','aa') ) ) {
+ a <- which(y %in% c('a','aa'))[1]
+ tmp <- if( a==1 ) {
+ as.list(attributes( list ) )
+ } else {
+ y1 <- y[ seq(length.out=a-1) ]
+ as.list(attributes( list[[ as.numeric(y1) ]] ))
+ }
+ if( a == length(y) ) return(tmp)
+ y2 <- y[ seq( from=a+1, length.out = length(y) - a) ]
+ if( y[a] == 'aa' ) tmp$names <- NULL
+ Recall(y2,tmp)
+ } else {
+ tmp <- as.numeric(y)
+ list[[tmp]]
+ }
+ }
+ sb(tmp2,list)
+ }
+
+ pr <- tcltk::tkbutton(tt, text='print', command=function(...) {
+ tmp <- capture.output(print(getx(list)))
+ tcltk::tkdelete(txt, '1.0','end')
+ tcltk::tkinsert(txt, 'end', paste(tmp, collapse='\n'))
+ }
+ )
+ st <- tcltk::tkbutton(tt, text='str', command=function(...) {
+ tmp <- capture.output(print(str(getx(list))))
+ tcltk::tkdelete(txt, '1.0','end')
+ tcltk::tkinsert(txt, 'end', paste(tmp, collapse='\n'))
+ }
+ )
+
+ tcltk::tkpack(pr, side='top', anchor='w')
+ tcltk::tkpack(st, side='top', anchor='w')
+
+ fr3 <- tcltk::tkframe(tt)
+ tcltk::tkpack(fr3, side='top', expand=1, fill='x')
+
+ cmd <- tcltk::tclVar('summary(x)')
+ eve <- tcltk::tkentry(fr3, textvariable=cmd)
+ ev <- tcltk::tkbutton(fr3, text='Eval:', command=function(...) {
+ tmp <- capture.output( eval(parse(text=tcltk::tclvalue(cmd)), list(x=getx(list))))
+ tcltk::tkdelete(txt, '1.0', 'end')
+ tcltk::tkinsert(txt, 'end', paste(tmp, collapse='\n'))
+ }
+ )
+
+ tcltk::tkpack(ev, side='left')
+ tcltk::tkpack(eve, side='left')
+
+ tcltk::tkpack(tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)),
+ side='bottom', anchor='e')
+
+ invisible(NULL)
+}
diff --git a/R/TkPredict.R b/R/TkPredict.R
new file mode 100644
index 0000000..ca4189c
--- /dev/null
+++ b/R/TkPredict.R
@@ -0,0 +1,122 @@
+Predict.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' )))
+
+}
+
+
+
+
diff --git a/R/TkSpline.R b/R/TkSpline.R
new file mode 100644
index 0000000..faa6f9d
--- /dev/null
+++ b/R/TkSpline.R
@@ -0,0 +1,144 @@
+### 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( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ snap.x <- tcltk::tclVar()
+ tcltk::tclvalue(snap.x) <- ifelse(snap.to.x,"T","F")
+ d1 <- tcltk::tclVar()
+ d2 <- tcltk::tclVar()
+ d3 <- tcltk::tclVar()
+ tcltk::tclvalue(d1) <- 'F'
+ tcltk::tclvalue(d2) <- 'F'
+ tcltk::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 <- tcltk::tclVar()
+ tcltk::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(tcltk::tclvalue(d1))) {
+ curve( ay+(x-ax)*yy[2], from=u[1], to=u[2], add=TRUE, col=col[2])
+ }
+ if(as.logical(tcltk::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(tcltk::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])
+ }
+
+ tcltk::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 <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "TkSpline")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='left')
+ tcltk::tkpack(tcltk::tkcheckbutton(fr,variable=d1, onvalue="T", offvalue="F",
+ text="Show d1", command=function()tkrplot::tkrreplot(img)),
+ side='top')
+ tcltk::tkpack(tcltk::tkcheckbutton(fr,variable=d2, onvalue="T", offvalue="F",
+ text="Show d2", command=function()tkrplot::tkrreplot(img)),
+ side='top')
+ tcltk::tkpack(tcltk::tkcheckbutton(fr,variable=d3, onvalue="T", offvalue="F",
+ text="Show d3", command=function()tkrplot::tkrreplot(img)),
+ side='top')
+
+
+
+ tcltk::tkpack(tcltk::tklabel(tt, textvariable=txtvar), side='top')
+
+ tcltk::tkpack(tcltk::tkcheckbutton(fr,variable=snap.x, onvalue="T", offvalue="F",
+ text="Snap to points"),
+ side='top')
+
+ tcltk::tkpack(tcltk::tkbutton(tt,text='Quit', command=function() tcltk::tkdestroy(tt)),
+ side='right')
+
+ md <- FALSE
+ iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image')))
+ ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image')))
+
+ ccx <- ccy <- 0
+ ci <- 0
+
+ mouse.move <- function(x,y) {
+ if(md) {
+ tx <- (as.numeric(x)-1)/iw
+ ccx <<- tx*ur + (1-tx)*ul
+ if(as.logical(tcltk::tclvalue(snap.x))) {
+ ccx <<- xxx[ which.min( abs(ccx-xxx) ) ]
+ }
+
+ ax <<- ccx
+ ccy <<- sf(ccx)
+ yy <<- c( ccy, sf(ccx,1), sf(ccx,2), sf(ccx,3) )
+ ay <<- ccy
+
+ tkrplot::tkrreplot(img)
+ }
+ }
+
+ mouse.down <- function(x,y) {
+ md <<- TRUE
+ mouse.move(x,y)
+ }
+
+ mouse.up <- function(x,y) {
+ md <<- FALSE
+ }
+
+ tcltk::tkbind(img, '<Motion>', mouse.move)
+ tcltk::tkbind(img, '<ButtonPress-1>', mouse.down)
+ tcltk::tkbind(img, '<ButtonRelease-1>', mouse.up)
+
+ if(wait) {
+ tcltk::tkwait.window(tt)
+ out <- list( x=ccx, y=yy )
+ } else {
+ out <- NULL
+ }
+
+ invisible(out)
+}
diff --git a/R/bct.R b/R/bct.R
new file mode 100644
index 0000000..6f0f25b
--- /dev/null
+++ b/R/bct.R
@@ -0,0 +1,11 @@
+"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)
+}
+
diff --git a/R/cal.R b/R/cal.R
new file mode 100644
index 0000000..d346329
--- /dev/null
+++ b/R/cal.R
@@ -0,0 +1,107 @@
+cal <- 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)
+###
+
+
+
+
+
diff --git a/R/char2seed.R b/R/char2seed.R
new file mode 100644
index 0000000..a43d73e
--- /dev/null
+++ b/R/char2seed.R
@@ -0,0 +1,20 @@
+char2seed <- 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)
+ }
+}
+
diff --git a/R/chisq.detail.R b/R/chisq.detail.R
new file mode 100644
index 0000000..b01e9bc
--- /dev/null
+++ b/R/chisq.detail.R
@@ -0,0 +1,45 @@
+"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) ) )
+}
+
diff --git a/R/ci.examp.R b/R/ci.examp.R
new file mode 100644
index 0000000..872d428
--- /dev/null
+++ b/R/ci.examp.R
@@ -0,0 +1,78 @@
+"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)
+}
+
diff --git a/R/clipplot.R b/R/clipplot.R
new file mode 100644
index 0000000..63e008b
--- /dev/null
+++ b/R/clipplot.R
@@ -0,0 +1,24 @@
+clipplot <- 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)
+}
+
diff --git a/R/clt.examp.R b/R/clt.examp.R
new file mode 100644
index 0000000..4dbfb01
--- /dev/null
+++ b/R/clt.examp.R
@@ -0,0 +1,73 @@
+"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)
+}
+
diff --git a/R/cnvrt.coords.R b/R/cnvrt.coords.R
new file mode 100644
index 0000000..b8fbafd
--- /dev/null
+++ b/R/cnvrt.coords.R
@@ -0,0 +1,133 @@
+"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 ) )
+ }
+
+}
+
diff --git a/R/col2grey.R b/R/col2grey.R
new file mode 100644
index 0000000..44ab52b
--- /dev/null
+++ b/R/col2grey.R
@@ -0,0 +1,9 @@
+col2grey <- 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)
+}
diff --git a/R/correct.R b/R/correct.R
new file mode 100644
index 0000000..a36b6f7
--- /dev/null
+++ b/R/correct.R
@@ -0,0 +1,45 @@
+cor.rect.plot <- function(x,y, corr=TRUE,
+ xlab=deparse(substitute(x)),
+ ylab=deparse(substitute(y)),
+ col=c('#ff000055','#0000ff55'),
+ ... ) {
+ xy <- xy.coords(x,y,xlab=xlab, ylab=ylab)
+ xm <- mean(xy$x)
+ ym <- mean(xy$y)
+
+ op <- par(mar=c(5,4,4,4))
+ on.exit(par(op))
+
+ plot(xy$x, xy$y, xlab=xlab, ylab=ylab, pty='s')
+
+ xt <- scale(xy$x, scale=corr)
+ yt <- scale(xy$y, scale=corr)
+
+ xtt <- pretty(xt)
+ ytt <- pretty(yt)
+
+ xut <- if(corr) {
+ xtt * attr(xt, 'scaled:scale') + attr(xt, 'scaled:center')
+ } else {
+ xtt + attr(xt, 'scaled:center')
+ }
+ yut <- if(corr) {
+ ytt * attr(yt, 'scaled:scale') + attr(yt, 'scaled:center')
+ } else {
+ ytt + attr(yt, 'scaled:center')
+ }
+
+ axis(3,at=xut, labels=xtt)
+ axis(4,at=yut, labels=ytt)
+
+ abline(h=ym)
+ abline(v=xm)
+
+
+ ord <- order( xt^2+yt^2, decreasing=TRUE )
+ w <- xt[ord]*yt[ord] > 0
+ rect(xm, ym, xy$x[ord][w], xy$y[ord][w], col= col[1] )
+ rect(xm, ym, xy$x[ord][!w], xy$y[ord][!w], col= col[2] )
+ points(xy$x,xy$y)
+}
+
diff --git a/R/dice.R b/R/dice.R
new file mode 100644
index 0000000..782547d
--- /dev/null
+++ b/R/dice.R
@@ -0,0 +1,25 @@
+"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
+}
+
diff --git a/R/digits.R b/R/digits.R
new file mode 100644
index 0000000..1cba2f6
--- /dev/null
+++ b/R/digits.R
@@ -0,0 +1,15 @@
+digits <- function(x, n=NULL, simplify = FALSE) {
+ if(length(x) > 1) {
+ if(is.null(n) & simplify) {
+ n <- floor(max(log10(x))) + 1
+ }
+ sapply(x,digits, simplify=simplify, n=n)
+ } else {
+ if(is.null(n)) {
+ n <- floor(log10(x))
+ } else {
+ n <- n - 1
+ }
+ x %/% 10^seq(n,0) %% 10
+ }
+}
diff --git a/R/dots.R b/R/dots.R
new file mode 100644
index 0000000..3ba794f
--- /dev/null
+++ b/R/dots.R
@@ -0,0 +1,9 @@
+"dots" <-
+function(x,...){
+
+ sx <- sort(x)
+ sy <- unlist(lapply(table(sx),seq))
+ plot(sx,sy, xlab=deparse(substitute(x)), ylab="Count",...)
+
+}
+
diff --git a/R/dots2.R b/R/dots2.R
new file mode 100644
index 0000000..c4f22bf
--- /dev/null
+++ b/R/dots2.R
@@ -0,0 +1,22 @@
+"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)
+
+}
+
diff --git a/R/dynIdentify.R b/R/dynIdentify.R
new file mode 100644
index 0000000..99f1717
--- /dev/null
+++ b/R/dynIdentify.R
@@ -0,0 +1,284 @@
+dynIdentify <- function(x,y,labels=seq_along(x),
+ corners = cbind( c(-1,0,1,-1,1,-1,0,1),
+ c(1,1,1,0,0,-1,-1,-1) ),
+ ...) {
+
+ lx <- x # label positions
+ ly <- y
+ lx[ is.na(labels) ] <- NA
+ ly[ is.na(labels) ] <- NA
+
+ llx <- lx # line end positions
+ lly <- ly
+
+ replot <- function() {
+ plot(x,y,...)
+ segments(x,y, llx,lly)
+ text(lx,ly,labels)
+ }
+
+ replot()
+
+# tmp <- cnvrt.coords(x,y, input='usr')$dev
+ dx <- grconvertX(x, to='ndc')
+ dy <- grconvertY(y, to='ndc') # device coordinates of points
+
+ widths <- strwidth(labels)/2
+ heights <- strheight(labels)/2
+
+ ci <- 0 # current label
+
+ mouse.down <- function(buttons, x, y){
+
+ if( any(buttons==2) ){
+ out <- list( labels=list(x=lx, y=ly),
+ lineends=list(x=llx, y=lly) )
+ return(out)
+ }
+# tmp <- cnvrt.coords(lx,ly, input='usr')$dev
+ i <- which.min( (grconvertX(lx,to='ndc')-x)^2 + (grconvertY(ly,to='ndc')-y)^2 )
+ ci <<- i
+ NULL
+ }
+
+ mouse.up <- function(buttons, x, y){
+# tmp <- cnvrt.coords(x,y, input='dev')$usr
+ cx <- grconvertX(x, from='ndc')
+ cy <- grconvertY(y, from='ndc')
+
+ tmpx <- cx + corners[,1]*widths[ci]
+ tmpy <- cy + corners[,2]*heights[ci]
+# tmp <- cnvrt.coords(tmpx,tmpy, input='usr')$dev
+ i <- which.min( (dx[ci] - grconvertX(tmpx,to='ndc'))^2 +
+ (dy[ci] - grconvertY(tmpy, to='ndc'))^2 )
+# tmp <- lx; tmp[ci] <- cx; lx <<- tmp
+# tmp <- ly; tmp[ci] <- cy; ly <<- tmp
+# tmp <- llx; tmp[ci] <- tmpx[i]; llx <<- tmp
+# tmp <- lly; tmp[ci] <- tmpy[i]; lly <<- tmp
+ lx[ci] <<- cx
+ ly[ci] <<- cy
+ llx[ci] <<- tmpx[i]
+ lly[ci] <<- tmpy[i]
+ replot()
+
+ NULL
+ }
+
+ out <- getGraphicsEvent( prompt= "Click on points and drag label to position. \nRight click to exit\n",
+ onMouseDown=mouse.down,
+ onMouseUp=mouse.up)
+
+ invisible(out)
+}
+
+
+
+TkIdentify <- function(x,y,labels=seq_along(x), hscale=1.75, vscale=1.75,
+ corners = cbind( c(-1,0,1,-1,1,-1,0,1),
+ c(1,1,1,0,0,-1,-1,-1) ),
+ ...) {
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ md <- FALSE
+
+ lx <- x # label positions
+ ly <- y
+ lx[ is.na(labels) ] <- NA
+ ly[ is.na(labels) ] <- NA
+
+ llx <- lx # line end positions
+ lly <- ly
+
+ first <- TRUE
+ dx <- dy <- dlx <- dly <- widths <- heights <- numeric(0)
+ ul <- ur <- ut <- ub <- 0
+
+ replot <- function() {
+
+ plot(x,y,...)
+ segments(x,y, llx,lly)
+ text(lx,ly,labels)
+ if(first) {
+ first <<- FALSE
+# tmp <- cnvrt.coords(x,y, input='usr')$dev
+ dx <<- grconvertX(x, to='ndc')
+ dy <<- grconvertY(y, to='ndc')
+ widths <<- strwidth(labels)/2
+ heights <<- strheight(labels)/2
+# tmp <- cnvrt.coords(c(0,1),c(0,1), input='dev')$usr
+ ul <<- grconvertX(0, from='ndc')
+ ur <<- grconvertX(1, from='ndc')
+ ub <<- grconvertY(0, from='ndc')
+ ut <<- grconvertY(1, from='ndc')
+ }
+# tmp <- cnvrt.coords(lx,ly, input='usr')$dev
+ dlx <<- grconvertX(lx, to='ndc')
+ dly <<- grconvertY(ly, to='ndc')
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "TkIdentify")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function() tcltk::tkdestroy(tt)),
+ side='right')
+
+ corners <- cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) )
+
+ ci <- 0 # current label
+ cx <- cy <- 0
+
+ iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image')))
+ ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image')))
+
+ mouse.move <- function(x,y) {
+ if(md){
+ tx <- (as.numeric(x)-1)/iw
+ ty <- 1-(as.numeric(y)-1)/ih
+ cx <<- tx*ur + (1-tx)*ul
+ cy <<- ty*ut + (1-ty)*ub
+
+# tmp <- lx; tmp[ci] <- cx; lx <<- tmp
+# tmp <- ly; tmp[ci] <- cy; ly <<- tmp
+ lx[ci] <<- cx
+ ly[ci] <<- cy
+
+ tmpx <- cx + corners[,1]*widths[ci]
+ tmpy <- cy + corners[,2]*heights[ci]
+
+ tmpxx <- (tmpx - ul)/(ur-ul)
+ tmpyy <- (tmpy - ub)/(ut-ub)
+
+ i <- which.min( (dx[ci] - tmpxx)^2 +
+ (dy[ci] - tmpyy)^2 )
+
+# tmp <- lx; tmp[ci] <- cx; lx <<- tmp
+# tmp <- ly; tmp[ci] <- cy; ly <<- tmp
+# tmp <- llx; tmp[ci] <- tmpx[i]; llx <<- tmp
+# tmp <- lly; tmp[ci] <- tmpy[i]; lly <<- tmp
+ lx[ci] <<- cx
+ ly[ci] <<- cy
+ llx[ci] <<- tmpx[i]
+ lly[ci] <<- tmpy[i]
+
+ tkrplot::tkrreplot(img)
+ }
+ }
+
+ mouse.down <- function(x,y){
+ tx <- (as.numeric(x)-1)/iw
+ ty <- 1-(as.numeric(y)-1)/ih
+
+ ci <<- which.min( (tx - dlx)^2 + (ty - dly)^2 )
+ md <<- TRUE
+ mouse.move(x,y)
+ }
+
+ mouse.up <- function(x,y){
+ md <<- FALSE
+ }
+
+ tcltk::tkbind(img, '<Motion>', mouse.move)
+ tcltk::tkbind(img, '<ButtonPress-1>', mouse.down)
+ tcltk::tkbind(img, '<ButtonRelease-1>', mouse.up)
+
+ tcltk::tkwait.window(tt)
+ out <- list( labels=list(x=lx, y=ly),
+ lineends=list(x=llx, y=lly) )
+ invisible(out)
+}
+
+### old version, possibilities for the Tk version
+## dynIdentify <- function(x,y,labels=seq_along(x), ...) {
+## plot(x,y,...)
+##
+## tmp <- cnvrt.coords(x,y, input='usr')$dev
+## dx <- tmp$x
+## dy <- tmp$y # device coordinates of points
+##
+## print(dx)
+## print(dy)
+##
+## lx <- rep(NA, length(x) ) # label positions
+## ly <- rep(NA, length(y) )
+## llx <- lx # line end positions
+## lly <- ly
+##
+## widths <- strwidth(labels)/2
+## heights <- strheight(labels)/2
+##
+## corners <- cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) )
+##
+## md <- FALSE # mouse button down
+##
+## cx <- 0 # current
+## cy <- 0
+## ci <- 0
+##
+## replot <- function() {
+## if(!md){return()}
+## plot(x,y,...)
+## segments(x,y, llx,lly)
+## text(lx,ly,labels)
+## }
+##
+## mouse.move <- function(buttons, x, y){
+##
+## tmp <- cnvrt.coords(x,y, input='dev')$usr
+## cx <<- tmp$x
+## cy <<- tmp$y
+## if(md){
+##
+## tmpx <- cx + corners[,1]*widths[ci]
+## tmpy <- cy + corners[,2]*heights[ci]
+## tmp <- cnvrt.coords(tmpx,tmpy, input='usr')$dev
+## i <- which.min( (dx[ci] - tmp$x)^2 +
+## (dy[ci] - tmp$y)^2 )
+## tmp <- lx; tmp[ci] <- cx; lx <<- tmp
+## tmp <- ly; tmp[ci] <- cy; ly <<- tmp
+## tmp <- llx; tmp[ci] <- tmpx[i]; llx <<- tmp
+## tmp <- lly; tmp[ci] <- tmpy[i]; lly <<- tmp
+## replot()
+## }
+## NULL
+## }
+##
+## mouse.down <- function(buttons, x, y){
+##
+## if( any(buttons==2) ){
+## out <- list( labels=list(x=lx, y=ly),
+## lineends=list(x=llx, y=lly) )
+## return(out)
+## }
+## i <- which.min( (dx-x)^2 + (dy-y)^2 )
+## ci <<- i
+## md <<- TRUE
+## mouse.move(buttons, x, y)
+## NULL
+## }
+##
+## mouse.up <- function(buttons, x, y){
+##
+## tmp <- dx; tmp[ci] <- NA; dx <<- tmp
+## tmp <- dy; tmp[ci] <- NA; dy <<- tmp
+##
+## if(all(is.na(dx))) {
+## out <- list( labels=list(x=lx, y=ly),
+## lineends=list(x=llx, y=lly) )
+## return(out)
+## }
+##
+## md <<- FALSE
+## ci <<- 0
+## NULL
+## }
+##
+## out <- getGraphicsEvent( prompt= "Click on points and drag label to position.\nRight click to exit\n",
+## onMouseDown=mouse.down,
+## onMouseMove=mouse.move,
+## onMouseUp=mouse.up)
+##
+## invisible(out)
+## }
diff --git a/R/face2.plot.R b/R/face2.plot.R
new file mode 100644
index 0000000..785f92d
--- /dev/null
+++ b/R/face2.plot.R
@@ -0,0 +1,109 @@
+"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)
+}
+
diff --git a/R/faces.R b/R/faces.R
new file mode 100644
index 0000000..4ad6148
--- /dev/null
+++ b/R/faces.R
@@ -0,0 +1,221 @@
+#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
+
diff --git a/R/faces2.R b/R/faces2.R
new file mode 100644
index 0000000..80c94d0
--- /dev/null
+++ b/R/faces2.R
@@ -0,0 +1,70 @@
+"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()
+}
+
diff --git a/R/fagan.R b/R/fagan.R
new file mode 100644
index 0000000..5f74472
--- /dev/null
+++ b/R/fagan.R
@@ -0,0 +1,286 @@
+fagan.plot<-function(probs.pre.test, LR, test.result="+") {
+ opar <- par(no.readonly = T)
+ on.exit(par(opar))
+ par(mar = c(1.5, 6, 2, 6))
+ stato <- ifelse(test.result == "+", "disease", "no disease")
+ if (probs.pre.test > 1 | probs.pre.test < 0 | LR < 0 | is.infinite(LR) |
+ is.nan(LR) | test.result %in% c("+", "-") == F) {
+ stop("wrong values !!")
+ } else {
+ logits <- function(p) log(p/(1 - p))
+ }
+ logits.pre <- logits(probs.pre.test)
+ logits.post <- log(LR) + logits.pre
+ probs.post.test <- exp(logits.post)/(1 + exp(logits.post))
+ compl.logit.pre <- logits(1 - probs.pre.test)
+ LR.vec <- c(0.001, 0.002, 0.005, 0.01, 0.02, 0.05, 0.1, 0.2,
+ 0.5, 1, 2, 5, 10, 20, 50, 100, 200, 500, 1000)
+ prob.vec <- c(0.001, 0.002, 0.003, 0.005, 0.007, 0.01, 0.02,
+ 0.03, 0.05, 0.07, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7,
+ 0.8, 0.9, 0.93, 0.95, 0.97, 0.98, 0.99, 0.993, 0.995,
+ 0.997, 0.998, 0.999)
+ plot(0, 0, type = "n", ylim = range(logits(prob.vec)), axes = F,
+ xlab = "", ylab = "")
+ axis(2, rev(logits(prob.vec)), 100 * prob.vec, pos = -1,
+ las = 1, cex.axis = 0.7)
+ axis(2, rev(logits(prob.vec)), 100 * prob.vec, pos = -1,
+ tck = 0.03, labels = F)
+ axis(4, logits(prob.vec), 100 * prob.vec, pos = 1, las = 1,
+ cex.axis = 0.7)
+ axis(4, logits(prob.vec), 100 * prob.vec, pos = 1, tck = 0.03,
+ labels = F)
+ axis(2, log(LR.vec[1:10])/2, LR.vec[1:10], pos = 0, las = 1,
+ cex.axis = 0.7)
+ axis(2, log(LR.vec[1:10])/2, LR.vec[1:10], pos = 0, tck = 0.03,
+ labels = F)
+ axis(4, log(LR.vec[10:19])/2, LR.vec[10:19], pos = 0, las = 1,
+ cex.axis = 0.7)
+ axis(4, log(LR.vec[10:19])/2, LR.vec[10:19], pos = 0, tck = 0.03,
+ labels = F)
+ text(0, 4.5, "Likelihood ratio", cex = 1.2)
+ segments(-1, compl.logit.pre, 1, logits.post, lwd = 1.5,
+ col = 2)
+ mtext(side = 2, text = "Pre test probability(%)", line = 2,
+ cex = 1.2)
+ mtext(side = 4, text = "Post test probability(%)", line = 2,
+ cex = 1.2, las = 3)
+ title(main = "Fagan's nomogram")
+ text(0, -6.3, paste("Pre test prob. of disease =", round(100 *
+ probs.pre.test, 2), "% \n", "Likelihood ratio ", "=",
+ round(LR, 2), "\n", "Post test prob. of", stato, "=",
+ ifelse(test.result == "+", round(100 * probs.post.test,
+ 2), round(100 * (1 - probs.post.test), 2)), "%"),
+ cex = 0.7)
+}
+
+
+
+plotFagan.old<-function(){
+ refresh.code <- function(...) {
+ probs.pre.test <- slider(no = 1)
+ LR <- slider(no = 2)
+ test.result <- slider(obj.name = "test.result")
+ fagan.plot(probs.pre.test, LR, test.result)
+ }
+ slider(refresh.code, sl.names =
+ c("pre test probability", "Likelihood Ratio"),
+ sl.mins = c(0, 0.01), sl.maxs = c(1, 100),
+ title = "Bayes nomogram",
+ sl.defaults = c(0.5, 1),
+ sl.deltas = c(0.01, 0.01), but.functions = list(function(...) {
+ slider(obj.name = "test.result", obj.value = "+")
+ refresh.code()
+ }, function(...) {
+ slider(obj.name = "test.result", obj.value = "-")
+ refresh.code()
+ }), but.names = c("positive result", "negative result"))
+ slider(obj.name = "test.result", obj.value = "+")
+ invisible(NULL)
+}
+
+
+plotFagan2.old<-function(){
+ refresh.code <- function(...) {
+ probs.pre.test <- slider(no = 1)
+ LR <- slider(no=2)/(1-slider(no=3))
+ test.result <- slider(obj.name = "test.result")
+ fagan.plot(probs.pre.test, LR, test.result)
+ }
+ slider(refresh.code, sl.names = c("pre test probability",
+ "Sensitivity","Specificity"), sl.mins = c(0, 0, 0),
+ sl.maxs = c(1, 1, 1), title = "Bayes nomogram",
+ sl.defaults = c(0.5, 0.95, 0.95),
+ sl.deltas = c(0.01, 0.001, 0.001),
+ but.functions = list(function(...) {
+ slider(obj.name = "test.result", obj.value = "+")
+ refresh.code()
+ }, function(...) {
+ slider(obj.name = "test.result", obj.value = "-")
+ refresh.code()
+ }), but.names = c("positive result", "negative result"))
+ slider(obj.name = "test.result", obj.value = "+")
+ invisible(NULL)
+}
+
+
+plotFagan <- function(hscale=1.5, vscale=1.5, wait=FALSE) {
+
+ if( !requireNamespace('tkrplot', quietly=TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ ppt <- tcltk::tclVar()
+ tcltk::tclvalue(ppt) <- 0.5
+ lr <- tcltk::tclVar()
+ tcltk::tclvalue(lr) <- 1
+ tr <- tcltk::tclVar()
+ tcltk::tclvalue(tr) <- '+'
+
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- hscale
+
+ replot <- function(...) {
+ probs.pre.test <- as.numeric(tcltk::tclvalue(ppt))
+ LR <- as.numeric(tcltk::tclvalue(lr))
+ test.result <- tcltk::tclvalue(tr)
+ fagan.plot(probs.pre.test, LR, test.result)
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Fagan Plot Demo")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Pre Test Probability: '), side='left', anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=ppt, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0, to=1, resolution=.01), side='right')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Likelihood Ratio: '), side='left', anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=lr, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0.01, to=100, resolution=.01), side='right')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tkcheckbutton(fr, text='Positive Test Result', variable=tr,
+ onvalue='+', offvalue='-',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) )
+ ),
+ side='left')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ) ),
+ side='left',anchor='s')
+
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ if(wait) {
+ tcltk::tkwait.window(tt)
+ return( list(ppt = as.numeric(tcltk::tclvalue(ppt)),
+ lr = as.numeric(tcltk::tclvalue(lr)),
+ tr = tcltk::tclvalue(tr)
+ ))
+ } else {
+ return(invisible(NULL))
+ }
+}
+
+
+
+
+
+plotFagan2 <- function(hscale=1.5, vscale=1.5, wait=FALSE) {
+
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ ppt <- tcltk::tclVar()
+ tcltk::tclvalue(ppt) <- 0.5
+ sens <- tcltk::tclVar()
+ tcltk::tclvalue(sens) <- 0.5
+ spec <- tcltk::tclVar()
+ tcltk::tclvalue(spec) <- 0.5
+ tr <- tcltk::tclVar()
+ tcltk::tclvalue(tr) <- '+'
+
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- hscale
+
+ replot <- function(...) {
+ probs.pre.test <- as.numeric(tcltk::tclvalue(ppt))
+ sns <- as.numeric(tcltk::tclvalue(sens))
+ spc <- as.numeric(tcltk::tclvalue(spec))
+ test.result <- tcltk::tclvalue(tr)
+ fagan.plot(probs.pre.test, sns/(1-spc), test.result)
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Fagan Plot Demo")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Pre Test Probability: '), side='left', anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=ppt, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0, to=1, resolution=.01), side='right')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Sensitivity: '), side='left', anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=sens, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0, to=1, resolution=.01), side='right')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Specificity: '), side='left', anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=spec, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0, to=1, resolution=.01), side='right')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tkcheckbutton(fr, text='Positive Test Result', variable=tr,
+ onvalue='+', offvalue='-',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) )
+ ),
+ side='left')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ) ),
+ side='left',anchor='s')
+
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ if(wait) {
+ tcltk::tkwait.window(tt)
+ return( list(ppt = as.numeric(tcltk::tclvalue(ppt)),
+ sens = as.numeric(tcltk::tclvalue(sens)),
+ spec = as.numeric(tcltk::tclvalue(spec)),
+ tr = tcltk::tclvalue(tr)
+ ))
+ } else {
+ return(invisible(NULL))
+ }
+}
+
+
+
+
diff --git a/R/flip.rgl.coin.R b/R/flip.rgl.coin.R
new file mode 100644
index 0000000..90550e2
--- /dev/null
+++ b/R/flip.rgl.coin.R
@@ -0,0 +1,7 @@
+flip.rgl.coin <- function(side=sample(2,1), steps=150) {
+
+ for (i in seq(0,(5+side)*180, length=steps*(5+side)) ){
+ rgl::rgl.viewpoint(i,0)
+ }
+ return(side)
+}
diff --git a/R/gnuplot.R b/R/gnuplot.R
new file mode 100644
index 0000000..4d81ab7
--- /dev/null
+++ b/R/gnuplot.R
@@ -0,0 +1,41 @@
+gpenv <- 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()
+}
diff --git a/R/gp.splot.R b/R/gp.splot.R
new file mode 100644
index 0000000..84eb55c
--- /dev/null
+++ b/R/gp.splot.R
@@ -0,0 +1,19 @@
+gp.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()
+}
+
diff --git a/R/hpd.R b/R/hpd.R
new file mode 100644
index 0000000..32c0e99
--- /dev/null
+++ b/R/hpd.R
@@ -0,0 +1,27 @@
+# These functions were written by Greg Snow (greg.snow at 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 ] ) )
+}
diff --git a/R/ineq.R b/R/ineq.R
new file mode 100644
index 0000000..9e4b883
--- /dev/null
+++ b/R/ineq.R
@@ -0,0 +1,65 @@
+#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
diff --git a/R/lattice.demo.R b/R/lattice.demo.R
new file mode 100644
index 0000000..08d5d33
--- /dev/null
+++ b/R/lattice.demo.R
@@ -0,0 +1,94 @@
+"lattice.demo" <-
+function(x,y,z, show3d=TRUE){
+
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+ if(!requireNamespace('lattice', quietly=TRUE)){stop('the lattice package is needed')}
+ if(!exists('slider.env')) slider.env <<- new.env()
+
+
+ center <- mean(z); assign('center',tcltk::tclVar(center), envir=slider.env)
+ width <- diff(range(z))/20*3; assign('width',tcltk::tclVar(width), envir=slider.env)
+
+ s3d <- 1; assign('s3d', tcltk::tclVar(s3d), envir=slider.env)
+
+ lattice.refresh <- function(...){
+ center <- as.numeric(evalq(tcltk::tclvalue(center), envir=slider.env))
+ width <- as.numeric(evalq(tcltk::tclvalue(width), envir=slider.env))
+
+ s3d <- as.numeric(evalq(tcltk::tclvalue(s3d), envir=slider.env))
+
+ shingle.min <- max(min(z), center-width/2)
+ shingle.max <- min(max(z), center+width/2)
+
+ shingle.scaled.range <- c( (shingle.min-min(z))/diff(range(z)),
+ (shingle.max-min(z))/diff(range(z))) - 0.5
+
+ if(s3d){
+ print(lattice::xyplot(y~x|shingle(z,rbind(range(z),c(shingle.min,shingle.max))),
+ index.cond=list(2),
+ strip=lattice::strip.custom(strip.names=TRUE,strip.levels=TRUE),
+ par.strip.text=list(cex=0.75)),
+ split=c(1,1,1,2), more=T)
+
+ print(lattice::cloud(y~z+x, panel=function(x,y,z,...){
+ lattice::panel.cloud(x,y,z,panel.3d.cloud=function(x,y,z,groups,...){
+ lattice::panel.3dscatter(x,y,z,
+ groups= factor(x>shingle.scaled.range[1] & x <shingle.scaled.range[2]),
+ ...)
+ lattice::panel.3dwire(x=shingle.scaled.range,
+ y=c(-.5,.5), z=rep(-.5,4), at=c(-.57,.57), ...)
+ },...) }), split=c(1,2,1,2),more=F)
+
+ } else {
+ print(lattice::xyplot(y~x|shingle(z,rbind(range(z),c(shingle.min,shingle.max))),
+ index.cond=list(2),
+ strip=lattice::strip.custom(strip.names=TRUE,strip.levels=TRUE),
+ par.strip.text=list(cex=0.75)
+ ),
+ split=c(1,1,1,1), more=F)
+
+ }
+
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Trellis/Lattice Demo')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ # center
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='center', width='10'), side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=lattice.refresh, from=min(z), to=max(z),
+ orient='horiz',
+ resolution=diff(range(z))/25, showvalue=T),
+ side='left')
+
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=center),envir=slider.env)
+
+ # width
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='width', width='10'), side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=lattice.refresh, from=diff(range(z))/20,
+ to=diff(range(z)),orient='horiz',
+ resolution=diff(range(z))/20, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=width), envir=slider.env)
+
+ # show 3d
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=lattice.refresh),
+ side='left')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Show 3-D plot', width='25'),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=s3d), envir=slider.env)
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=lattice.refresh),side='left')
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
diff --git a/R/limits.g.R b/R/limits.g.R
new file mode 100644
index 0000000..73764b9
--- /dev/null
+++ b/R/limits.g.R
@@ -0,0 +1,23 @@
+"limits.g" <-
+ function (center, std.dev, sizes, conf)
+{
+ if (conf >= 1) {
+ p <- 1/center
+ lcl <- center - conf * sqrt(1-p)/p
+ lcl[lcl < 0] <- 0
+ ucl <- center + conf * sqrt(1-p)/p
+ warning("The Geometric distribution is quite skewed, it is better to set conf at the required confidence level (0 < conf < 1) instead of as a multiplier of sigma.")
+ }
+ else {
+ if (conf > 0 & conf < 1) {
+ p <- 1/center
+ ucl <- qgeom(1 - (1 - conf)/2, p)
+ lcl <- qgeom((1 - conf)/2, p)
+ }
+ else stop("invalid conf argument. See help.")
+ }
+ limits <- matrix(c(lcl, ucl), ncol = 2)
+ rownames(limits) <- rep("", length = nrow(limits))
+ colnames(limits) <- c("LCL", "UCL")
+ return(limits)
+}
diff --git a/R/loess.demo.R b/R/loess.demo.R
new file mode 100644
index 0000000..24b71a4
--- /dev/null
+++ b/R/loess.demo.R
@@ -0,0 +1,80 @@
+"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 at byu.edu now greg.snow at imail.org
+ # Modified by Henrik Aa. Nielsen, IMM, DTU (han at 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)
+ }
+}
+
diff --git a/R/manipulate.cor.examp.R b/R/manipulate.cor.examp.R
new file mode 100644
index 0000000..9c43502
--- /dev/null
+++ b/R/manipulate.cor.examp.R
@@ -0,0 +1,28 @@
+manipulate.cor.examp <- function(n=100,
+ seed) {
+ if(!requireNamespace('manipulate', quietly = TRUE)) stop("This function depends on the manipulate package within Rstudio")
+
+ if(!missing(seed)) set.seed(seed)
+
+ x <- scale(matrix(rnorm(2*n,0,1), ncol=2))
+ x <- x %*% solve( chol( cor(x)))
+ xr <- range(x,-x)
+
+ replot <- function(r) {
+ if( r >= 1 ) {
+ cmat <- matrix( c(1,0,1,0), 2 )
+ } else if( r <= -1 ) {
+ cmat <- matrix( c(1,0,-1,0), 2 )
+ } else {
+ cmat <- chol( matrix(c(1,r,r,1),2) )
+ }
+ new.x <- x %*% cmat
+ plot(new.x, xlab='x',ylab='y',
+ xlim=xr,ylim=xr)
+ title(paste("r =", round(r,3)))
+ }
+
+ r <- NA # so that following function does not complain about global var
+ manipulate::manipulate(replot(r),r=manipulate::slider(-1,1,0,step=0.005))
+
+}
\ No newline at end of file
diff --git a/R/mle.demo.R b/R/mle.demo.R
new file mode 100644
index 0000000..51091f0
--- /dev/null
+++ b/R/mle.demo.R
@@ -0,0 +1,91 @@
+"mle.demo" <-
+function(x=rnorm(10, 10, 2), start.mean = mean(x)-start.sd,
+ start.sd = 1.2* sqrt(var(x)) ){
+
+ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package.')
+
+ if(!exists('slider.env')) slider.env <<- new.env()
+
+ mu <- start.mean; assign('mu',tcltk::tclVar(mu),envir=slider.env)
+ sig <- start.sd; assign('sig',tcltk::tclVar(sig),envir=slider.env)
+
+ .mu <- .sig <- .ll <- numeric(0)
+
+ mle.refresh <- function(...){
+ mu <- as.numeric(evalq(tcltk::tclvalue(mu), envir=slider.env))
+ sig <- as.numeric(evalq(tcltk::tclvalue(sig), envir=slider.env))
+
+ old.par <- par(no.readonly=T)
+ on.exit(par(old.par))
+
+ par(mar=c(5,4,0,2)+.1)
+
+ .mu <<- c(.mu, mu)
+ .sig <<- c(.sig, sig)
+
+ ll <- sum( dnorm(x, mu, sig, TRUE) )
+ .ll <<- c(.ll,ll)
+
+ layout( matrix( 1:3, ncol=1 ), heights=c(2,1,1))
+
+ xx <- seq( min(x) - 1.2 * (max(x)-min(x)),
+ max(x) + 1.2 * (max(x)-min(x)), length=250)
+ plot(xx, dnorm(xx, mu, sig), type='l',
+ ylim=c(0,dnorm(0,0,0.5*sqrt(var(x)))),xlab='x', ylab='Likelihood')
+ segments(x, 0, x, dnorm(x, mu, sig))
+ points(x,dnorm(x, mu, sig))
+ points(x,rep(0,length(x)))
+
+ text(xx[1], dnorm(0,0,0.5*sqrt(var(x)))*.9, paste("Log Likelihood =",
+ format(ll, digit=5)),
+ adj=0,cex=3)
+
+ plot(.mu, .ll, xlab=expression(mu), ylab='Log Likelihood')
+ points(mu,ll, pch=16, col='red')
+ plot(.sig, .ll, xlab=expression(sigma), ylab='Log Likelihood')
+ points(sig, ll, pch=16, col='red')
+
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Maximum Likelihood Estimation')
+ tcltk::tkwm.geometry(m, '+0+0')
+
+ # mu
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='mu', width='10'), side='right')
+
+ tmp <- pretty( c( start.mean - 2*start.sd, start.mean + 3*start.sd),
+ 100)
+
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=mle.refresh, from=min(tmp),
+ to=max(tmp),
+ orient='horiz',
+ resolution=tmp[2] - tmp[1],showvalue=T),
+ side='left')
+ assign('sc',sc, envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=mu), envir=slider.env)
+
+ # sigma
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='sigma', width='10'), side='right')
+
+ tmp <- pretty( c( 0.5*start.sd, 2*start.sd), 100)
+
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=mle.refresh, from=min(tmp),
+ to=max(tmp),
+ orient='horiz',
+ resolution=tmp[2]-tmp[1], showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sig), envir=slider.env)
+
+
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=mle.refresh), side='left')
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+ return(invisible(x))
+}
+
diff --git a/R/ms.face.R b/R/ms.face.R
new file mode 100644
index 0000000..f21b155
--- /dev/null
+++ b/R/ms.face.R
@@ -0,0 +1,201 @@
+#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
+
diff --git a/R/mysymbols.R b/R/mysymbols.R
new file mode 100644
index 0000000..7b01767
--- /dev/null
+++ b/R/mysymbols.R
@@ -0,0 +1,316 @@
+my.symbols <- function(x, y=NULL, symb, inches=1, xsize, ysize,
+ add=TRUE,
+ vadj=0.5, hadj=0.5,
+ symb.plots=FALSE,
+ xlab=deparse(substitute(x)),
+ ylab=deparse(substitute(y)), main=NULL,
+ xlim=NULL, ylim=NULL, linesfun=lines,
+ ..., MoreArgs ) {
+
+ if(!add){
+ plot(x,y, type='n', xlab=xlab,ylab=ylab,
+ xlim=xlim,ylim=ylim,main=main)
+ }
+
+ xy <- xy.coords(x,y,recycle=TRUE)
+
+ pin <- par('pin')
+ usr <- par('usr')
+ usr.x <- usr[2] - usr[1]
+ usr.y <- usr[4] - usr[3]
+
+# tmp <- cnvrt.coords(xy,input='usr')$plt
+ tmp <- list()
+ tmp$x <- grconvertX(xy$x, to='npc')
+ tmp$y <- grconvertY(xy$y, to='npc')
+
+ tmp.xlen <- length(tmp$x)
+
+ if( (length(inches) != 1) && (length(inches) != tmp.xlen) ) {
+ inches <- rep(inches, length.out=tmp.xlen)
+ }
+ if( (length(hadj) != 1) && (length(hadj) != tmp.xlen) ) {
+ hadj <- rep(hadj, length.out=tmp.xlen)
+ }
+ if( (length(vadj) != 1) && (length(vadj) != tmp.xlen) ) {
+ vadj <- rep(vadj, length.out=tmp.xlen)
+ }
+
+ if( missing(xsize) ) {
+ if( missing(ysize) ) { # use inches
+ x.low <- tmp$x - hadj *inches/pin[1]
+ x.high <- tmp$x + (1-hadj)*inches/pin[1]
+ y.low <- tmp$y - vadj *inches/pin[2]
+ y.high <- tmp$y + (1-vadj)*inches/pin[2]
+ } else { # ysize only
+ y.low <- tmp$y - vadj*ysize/usr.y
+ y.high <- tmp$y + (1-vadj)*ysize/usr.y
+ x.low <- tmp$x - hadj/pin[1]*pin[2]/usr.y*ysize
+ x.high <- tmp$x + (1-hadj)/pin[1]*pin[2]/usr.y*ysize
+ }
+ } else {
+ if( missing(ysize) ) { # xsize only
+ x.low <- tmp$x - hadj*xsize/usr.x
+ x.high <- tmp$x + (1-hadj)*xsize/usr.x
+ y.low <- tmp$y - vadj/pin[2]*pin[1]/usr.x*xsize
+ y.high <- tmp$y + (1-vadj)/pin[2]*pin[1]/usr.x*xsize
+ } else { # both xsize and ysize
+ x.low <- tmp$x - hadj*xsize/usr.x
+ x.high <- tmp$x + (1-hadj)*xsize/usr.x
+ y.low <- tmp$y - vadj*ysize/usr.y
+ y.high <- tmp$y + (1-vadj)*ysize/usr.y
+ }
+ }
+
+
+# xy.low <- cnvrt.coords(x.low, y.low, 'plt')$fig
+# xy.high <- cnvrt.coords(x.high, y.high, 'plt')$fig
+
+ xy.low <- list()
+ xy.low$x <- grconvertX(x.low, from='npc', to='nfc')
+ xy.low$y <- grconvertY(y.low, from='npc', to='nfc')
+
+ xy.high <- list()
+ xy.high$x <- grconvertX(x.high, from='npc', to='nfc')
+ xy.high$y <- grconvertY(y.high, from='npc', to='nfc')
+
+
+ plotfun <- if( is.function(symb) ) {
+ if(symb.plots) {
+ function(xlow,xhigh,ylow,yhigh,symb, ...) {
+ op <- par(c('plt','usr','xpd'))
+ on.exit(par(op))
+ par(xpd=TRUE)
+ par(plt=c(xlow,xhigh,ylow,yhigh), new=TRUE)
+ par(usr=c(-1,1,-1,1))
+ symb(...)
+ }
+ } else {
+ function(xlow,xhigh,ylow,yhigh,symb, ...) {
+ op <- par(c('plt','usr','xpd'))
+ on.exit(par(op))
+ par(xpd=TRUE)
+ par(plt=c(xlow,xhigh,ylow,yhigh))
+ par(usr=c(-1,1,-1,1))
+ suppressWarnings(
+ linesfun( symb(...), ... )
+ )
+ }
+ }
+ } else {
+ function(xlow,xhigh,ylow,yhigh,symb, ...) {
+ op <- par(c('plt','usr','xpd'))
+ on.exit(par(op))
+ par(xpd=TRUE)
+ par(plt=c(xlow,xhigh,ylow,yhigh))
+ par(usr=c(-1,1,-1,1))
+ linesfun(symb, ...)
+ }
+ }
+
+ funargs <- list(xlow=xy.low$x, xhigh=xy.high$x,
+ ylow=xy.low$y, yhigh=xy.high$y)
+ if( length(list(...)) ) {
+ funargs <- c(funargs,
+ lapply(list(...), function(x) rep(x,length.out=tmp.xlen) )
+ )
+ }
+
+ funargs$FUN <- plotfun
+ if (missing(MoreArgs)) {
+ funargs$MoreArgs <- list(symb=symb)
+ } else {
+ funargs$MoreArgs <- c(MoreArgs, list(symb=symb))
+ }
+
+ do.call(mapply, funargs)
+
+ invisible(NULL)
+}
+
+
+
+ms.male <- structure(c(0, 0.022, 0.0439, 0.0657, 0.0874, 0.109, 0.1303,
+0.1514, 0.1722, 0.1926, 0.2127, 0.2324, 0.2516, 0.2703, 0.2885,
+0.3062, 0.3233, 0.3397, 0.3555, 0.3706, 0.385, 0.3986, 0.4115,
+0.4236, 0.4348, 0.4453, 0.4548, 0.4635, 0.4713, 0.4782, 0.4841,
+0.4891, 0.4932, 0.4964, 0.4985, 0.4997, 0.5, 0.4992, 0.4976,
+0.4949, 0.4913, 0.4868, 0.4813, 0.4748, 0.4675, 0.4593, 0.4501,
+0.4401, 0.4293, 0.4176, 0.4052, 0.3919, 0.3779, 0.3631, 0.3477,
+0.3316, 0.3148, 0.2974, 0.2795, 0.261, 0.242, 0.2226, 0.2027,
+0.1824, 0.1618, 0.1409, 0.1197, 0.0982, 0.0766, 0.0548, 0.0329,
+0.011, -0.011, -0.0329, -0.0548, -0.0766, -0.0982, -0.1197, -0.1409,
+-0.1618, -0.1824, -0.2027, -0.2226, -0.242, -0.261, -0.2795,
+-0.2974, -0.3148, -0.3316, -0.3477, -0.3631, -0.3779, -0.3919,
+-0.4052, -0.4176, -0.4293, -0.4401, -0.4501, -0.4593, -0.4675,
+-0.4748, -0.4813, -0.4868, -0.4913, -0.4949, -0.4976, -0.4992,
+-0.5, -0.4997, -0.4985, -0.4964, -0.4932, -0.4891, -0.4841, -0.4782,
+-0.4713, -0.4635, -0.4548, -0.4453, -0.4348, -0.4236, -0.4115,
+-0.3986, -0.385, -0.3706, -0.3555, -0.3397, -0.3233, -0.3062,
+-0.2885, -0.2703, -0.2516, -0.2324, -0.2127, -0.1926, -0.1722,
+-0.1514, -0.1303, -0.109, -0.0874, -0.0657, -0.0439, -0.022,
+0, NA, 0.3536, 1, 0.6, NA, 1, 1, 0.5, 0.4995, 0.4981, 0.4957,
+0.4923, 0.488, 0.4827, 0.4765, 0.4694, 0.4614, 0.4525, 0.4427,
+0.4321, 0.4206, 0.4083, 0.3953, 0.3814, 0.3669, 0.3516, 0.3357,
+0.3191, 0.3018, 0.284, 0.2657, 0.2468, 0.2275, 0.2077, 0.1875,
+0.167, 0.1461, 0.125, 0.1036, 0.082, 0.0603, 0.0384, 0.0165,
+-0.0055, -0.0274, -0.0494, -0.0712, -0.0928, -0.1143, -0.1356,
+-0.1566, -0.1773, -0.1977, -0.2176, -0.2372, -0.2563, -0.2749,
+-0.293, -0.3105, -0.3274, -0.3437, -0.3593, -0.3743, -0.3885,
+-0.4019, -0.4146, -0.4265, -0.4375, -0.4477, -0.4571, -0.4655,
+-0.4731, -0.4797, -0.4855, -0.4903, -0.4941, -0.497, -0.4989,
+-0.4999, -0.4999, -0.4989, -0.497, -0.4941, -0.4903, -0.4855,
+-0.4797, -0.4731, -0.4655, -0.4571, -0.4477, -0.4375, -0.4265,
+-0.4146, -0.4019, -0.3885, -0.3743, -0.3593, -0.3437, -0.3274,
+-0.3105, -0.293, -0.2749, -0.2563, -0.2372, -0.2176, -0.1977,
+-0.1773, -0.1566, -0.1356, -0.1143, -0.0928, -0.0712, -0.0494,
+-0.0274, -0.0055, 0.0165, 0.0384, 0.0603, 0.082, 0.1036, 0.125,
+0.1461, 0.167, 0.1875, 0.2077, 0.2275, 0.2468, 0.2657, 0.284,
+0.3018, 0.3191, 0.3357, 0.3516, 0.3669, 0.3814, 0.3953, 0.4083,
+0.4206, 0.4321, 0.4427, 0.4525, 0.4614, 0.4694, 0.4765, 0.4827,
+0.488, 0.4923, 0.4957, 0.4981, 0.4995, 0.5, NA, 0.3536, 1, 1,
+NA, 1, 0.6), .Dim = as.integer(c(151, 2)))
+
+ms.female <- structure(c(0, 0.022, 0.0439, 0.0657, 0.0874, 0.109, 0.1303,
+0.1514, 0.1722, 0.1926, 0.2127, 0.2324, 0.2516, 0.2703, 0.2885,
+0.3062, 0.3233, 0.3397, 0.3555, 0.3706, 0.385, 0.3986, 0.4115,
+0.4236, 0.4348, 0.4453, 0.4548, 0.4635, 0.4713, 0.4782, 0.4841,
+0.4891, 0.4932, 0.4964, 0.4985, 0.4997, 0.5, 0.4992, 0.4976,
+0.4949, 0.4913, 0.4868, 0.4813, 0.4748, 0.4675, 0.4593, 0.4501,
+0.4401, 0.4293, 0.4176, 0.4052, 0.3919, 0.3779, 0.3631, 0.3477,
+0.3316, 0.3148, 0.2974, 0.2795, 0.261, 0.242, 0.2226, 0.2027,
+0.1824, 0.1618, 0.1409, 0.1197, 0.0982, 0.0766, 0.0548, 0.0329,
+0.011, -0.011, -0.0329, -0.0548, -0.0766, -0.0982, -0.1197, -0.1409,
+-0.1618, -0.1824, -0.2027, -0.2226, -0.242, -0.261, -0.2795,
+-0.2974, -0.3148, -0.3316, -0.3477, -0.3631, -0.3779, -0.3919,
+-0.4052, -0.4176, -0.4293, -0.4401, -0.4501, -0.4593, -0.4675,
+-0.4748, -0.4813, -0.4868, -0.4913, -0.4949, -0.4976, -0.4992,
+-0.5, -0.4997, -0.4985, -0.4964, -0.4932, -0.4891, -0.4841, -0.4782,
+-0.4713, -0.4635, -0.4548, -0.4453, -0.4348, -0.4236, -0.4115,
+-0.3986, -0.385, -0.3706, -0.3555, -0.3397, -0.3233, -0.3062,
+-0.2885, -0.2703, -0.2516, -0.2324, -0.2127, -0.1926, -0.1722,
+-0.1514, -0.1303, -0.109, -0.0874, -0.0657, -0.0439, -0.022,
+0, NA, 0, 0, NA, -0.25, 0.25, 0.5, 0.4995, 0.4981, 0.4957, 0.4923,
+0.488, 0.4827, 0.4765, 0.4694, 0.4614, 0.4525, 0.4427, 0.4321,
+0.4206, 0.4083, 0.3953, 0.3814, 0.3669, 0.3516, 0.3357, 0.3191,
+0.3018, 0.284, 0.2657, 0.2468, 0.2275, 0.2077, 0.1875, 0.167,
+0.1461, 0.125, 0.1036, 0.082, 0.0603, 0.0384, 0.0165, -0.0055,
+-0.0274, -0.0494, -0.0712, -0.0928, -0.1143, -0.1356, -0.1566,
+-0.1773, -0.1977, -0.2176, -0.2372, -0.2563, -0.2749, -0.293,
+-0.3105, -0.3274, -0.3437, -0.3593, -0.3743, -0.3885, -0.4019,
+-0.4146, -0.4265, -0.4375, -0.4477, -0.4571, -0.4655, -0.4731,
+-0.4797, -0.4855, -0.4903, -0.4941, -0.497, -0.4989, -0.4999,
+-0.4999, -0.4989, -0.497, -0.4941, -0.4903, -0.4855, -0.4797,
+-0.4731, -0.4655, -0.4571, -0.4477, -0.4375, -0.4265, -0.4146,
+-0.4019, -0.3885, -0.3743, -0.3593, -0.3437, -0.3274, -0.3105,
+-0.293, -0.2749, -0.2563, -0.2372, -0.2176, -0.1977, -0.1773,
+-0.1566, -0.1356, -0.1143, -0.0928, -0.0712, -0.0494, -0.0274,
+-0.0055, 0.0165, 0.0384, 0.0603, 0.082, 0.1036, 0.125, 0.1461,
+0.167, 0.1875, 0.2077, 0.2275, 0.2468, 0.2657, 0.284, 0.3018,
+0.3191, 0.3357, 0.3516, 0.3669, 0.3814, 0.3953, 0.4083, 0.4206,
+0.4321, 0.4427, 0.4525, 0.4614, 0.4694, 0.4765, 0.4827, 0.488,
+0.4923, 0.4957, 0.4981, 0.4995, 0.5, NA, -0.5, -1, NA, -0.8,
+-0.8), .Dim = as.integer(c(150, 2)))
+
+ms.polygon <- function(n, r=1, adj=pi/2, ...) {
+ tmp <- seq(0,2*pi, length.out=n+1) + adj
+ cbind(cos(tmp), sin(tmp)) * r
+}
+
+ms.filled.polygon <- function(n, r=1, adj=pi/2, fg=par('fg'),
+ bg=par('fg'), ... ) {
+ tmp <- seq(0,2*pi, length.out=n+1) + adj
+ polygon(cos(tmp)*r,sin(tmp)*r, col=bg, border=fg, ...)
+ NULL
+}
+
+
+ms.polygram <- function(n, r=1, adj=pi/2, ...) {
+ if (n == 1) {
+ return(rbind( c(0,0), c(cos(adj),sin(adj))*r))
+ }
+ if (n == 2) {
+ return(rbind( c(cos(adj),sin(adj)), c(cos(adj+pi),sin(adj+pi))) * r)
+ }
+ if (n == 3) {
+ return(rbind(
+ c(0,0),
+ c(cos(adj),sin(adj)),
+ NA,
+ c(0,0),
+ c(cos(adj+2*pi/3), sin(adj+2*pi/3)),
+ NA,
+ c(0,0),
+ c(cos(adj+4*pi/3), sin(adj+4*pi/3)))*r)
+ }
+ if (n == 4) {
+ return(rbind(
+ c(cos(adj),sin(adj)),
+ c(cos(adj+pi),sin(adj+pi)),
+ NA,
+ c(cos(adj+pi/2), sin(adj+pi/2)),
+ c(cos(adj+3*pi/2), sin(adj+3*pi/2))) * r )
+ }
+ if (n == 6) {
+ tmp <- c( 0, 2*pi/3, 4*pi/3, 2*pi )
+ tmp <- c(tmp, NA, tmp+pi/3)+adj
+ return( cbind( cos(tmp), sin(tmp) )*r )
+ }
+ skp <- floor( n/2 - 0.1 )
+ tmp <- seq( 0, skp*2*pi, length.out=n+1 ) + adj
+ tmp2 <- cbind(cos(tmp), sin(tmp))*r
+ while( any( duplicated( round( tmp2[-1,], 5 ) ) ) ){
+ skp <- skp - 1
+ tmp <- seq( 0, skp*2*pi, length.out=n+1 ) + adj
+ tmp2 <- cbind( cos(tmp), sin(tmp))*r
+ }
+ return(tmp2)
+}
+
+ms.arrows <- function(angle, r=1, adj=0.5, length=0.1, ...) {
+ fr <- c( cos(angle), sin(angle) ) * (-r) * adj
+ to <- c( cos(angle), sin(angle) ) * r * (1-adj)
+ arrows(fr[1],fr[2],to[1],to[2], length=length, ...)
+ NULL
+}
+
+ms.sunflowers <- function(n,r=0.3,adj=pi/2, ...) {
+ tmp <- seq(0,2*pi, length.out=36)
+ tmp2 <- cbind( cos(tmp), sin(tmp) ) * r
+ tmp <- seq( 0, 2*pi, length.out=n+1 )[-(n+1)] + adj
+ tmp.x <- c(rbind(NA,cos(tmp)*r, cos(tmp)))
+ tmp.y <- c(rbind(NA,sin(tmp)*r, sin(tmp)))
+ rbind(tmp2, cbind(tmp.x, tmp.y) )
+}
+
+
+ms.image <- function(img, transpose=TRUE, ...) {
+ d <- dim(img)
+
+ cols <- if(d[3] == 3) {
+ rgb(img[,,1], img[,,2], img[,,3])
+ } else if(d[3] == 4) {
+ rgb(img[,,1], img[,,2], img[,,3], img[,,4])
+ } else {
+ stop('image must be array with 3rd dimension equal to 3 or 4')
+ }
+
+ if(transpose) {
+ tmp <- matrix( seq(length=d[1]*d[2]), ncol=d[1], byrow=TRUE)
+ tmp <- tmp[ , rev(seq(length=d[1])) ]
+ } else {
+ tmp <- matrix( seq(length=d[1]*d[2]), ncol=d[2] )
+ tmp <- tmp[ , rev(seq(length=d[2])) ]
+ }
+
+ image(tmp, col=cols, axes=FALSE, xlab='', ylab='')
+}
+
+
+
+# do ms.raster that uses rasterImage
+
+
+
+
+
diff --git a/R/pairs2.R b/R/pairs2.R
new file mode 100644
index 0000000..d166fb4
--- /dev/null
+++ b/R/pairs2.R
@@ -0,0 +1,111 @@
+pairs2 <- 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)
+}
diff --git a/R/panel.dice.R b/R/panel.dice.R
new file mode 100644
index 0000000..bf9d635
--- /dev/null
+++ b/R/panel.dice.R
@@ -0,0 +1,29 @@
+"panel.dice" <-
+function(x,y){
+ tmp.cols <- c("Red","Green","Blue","Black","Yellow",
+ "Purple","Orange","Brown","Grey","White")
+ box.x <- c( 0.1, 0.9, 0.9, 0.1, 0.1 )
+ box.y <- c( 0.1, 0.1, 0.9, 0.9, 0.1 )
+ pips.x <- c( 0.5, 0.3, 0.7, 0.3, 0.7, 0.3, 0.7 )
+ pips.y <- c( 0.5, 0.7, 0.3, 0.3, 0.7, 0.5, 0.5 )
+ xx <- ceiling(sqrt(length(x)))
+ yy <- ceiling( length(x)/xx )
+ for( i in seq(along=x) ){
+ xo <- y[i] %% xx
+ yo <- yy-1-(y[i] %/% xx)
+ lattice::llines( box.x+xo, box.y+yo,col=tmp.cols[i] )
+ which <- c( x[i] %%2 == 1, x[i] > c(1,1,3,3,5,5) )
+ tmp.x <- pips.x[which]
+ tmp.y <- pips.y[which]
+ if( runif(1) < 0.5 ) {
+ tmp.x <- 1-tmp.x
+ }
+ if( runif(1) < 0.5 ) {
+ tmp <- tmp.x
+ tmp.x <- tmp.y
+ tmp.y <- tmp
+ }
+ lattice::lpoints( tmp.x+xo, tmp.y+yo, pch=16,col='black')
+ }
+}
+
diff --git a/R/panel.mysymbols.R b/R/panel.mysymbols.R
new file mode 100644
index 0000000..c5ea0c4
--- /dev/null
+++ b/R/panel.mysymbols.R
@@ -0,0 +1,97 @@
+panel.my.symbols <- function(x, y, symb, inches=1, polygon = FALSE,
+ ..., symb.plots=FALSE, subscripts, MoreArgs ) {
+ if(symb.plots) {
+ stop('self plotting symbols (symb.plots=TRUE) is not implemented yet')
+ }
+
+ dots <- list(...)
+ tmp <- sapply(dots, is.null)
+ dots[tmp] <- NULL
+ if ( 'type' %in% names(dots) ) dots$type <- 'l'
+ tmp.xlen <- length(x)
+
+ if( (length(inches) != 1) && (length(inches) != tmp.xlen) ) {
+ inches <- rep(inches[subscripts], length.out=tmp.xlen)
+ }
+
+ dots <- lapply(dots, function(x) {
+ if( (length(x) != 1) && (length(x) != tmp.xlen) ) {
+ x <- rep(x[subscripts], length.out=tmp.xlen)
+ }
+ x } )
+
+ plotfun <- if( is.function(symb) ) {
+ function(x,y,inches,polygon,symb, ...) {
+ dots1 <- list(...)
+ sargs <- setdiff(names(formals(symb)),'...')
+ dots2 <- dots1[sargs]
+ dots1[sargs] <- NULL
+ symb2 <- xy.coords(do.call(symb,dots2))
+ xx <- grid::convertWidth( grid::unit(symb2$x*inches/2, 'inches'),
+ 'native', TRUE )
+ yy <- grid::convertHeight( grid::unit(symb2$y*inches/2, 'inches'),
+ 'native', TRUE )
+ dots1$x <- x+xx
+ dots1$y <- y+yy
+ if(polygon) {
+ do.call(lattice::lpolygon, dots1)
+ } else {
+ do.call(lattice::llines, dots1)
+ }
+ }
+ } else {
+ function(x,y,inches,polygon,symb, ...) {
+ dots <- list(...)
+ symb2 <- xy.coords(symb)
+ xx <- grid::convertWidth( grid::unit(symb2$x*inches/2, 'inches'),
+ 'native', TRUE )
+ yy <- grid::convertHeight( grid::unit(symb2$y*inches/2, 'inches'),
+ 'native', TRUE )
+ dots$x <- x+xx
+ dots$y <- y+yy
+ if(polygon) {
+ do.call(lattice::lpolygon, dots)
+ } else {
+ do.call(lattice::llines, dots)
+ }
+ }
+ }
+
+ funargs <- c(list(x=x, y=y, inches=inches, polygon=polygon),
+ dots)
+ funargs$FUN <- plotfun
+ if(missing(MoreArgs)) {
+ funargs$MoreArgs <- list(symb=symb)
+ } else {
+ funargs$MoreArgs <- c(MoreArgs, list(symb=symb))
+ }
+
+ do.call(mapply, funargs)
+
+ invisible(NULL)
+
+}
+
+
+
+
+
+### original code
+if(FALSE) {
+
+my.df <- data.frame( x=runif(10), y=runif(10) )
+
+xyplot(y~x, my.df, panel=function(x,y,...) {
+ xx <- grid::convertX( grid::unit(ms.male[,1]/5, 'inches'), 'native', TRUE )
+ yy <- grid::convertY( grid::unit(ms.male[,2]/5, 'inches'), 'native', TRUE )
+
+ xx <- c(xx,NA); yy <- c(yy, NA)
+
+ llines( outer(xx, x, '+'), outer(yy, y, '+') )
+ }
+
+)
+
+}
+
+# convert and unit from grid package
diff --git a/R/petals.R b/R/petals.R
new file mode 100644
index 0000000..c85e32a
--- /dev/null
+++ b/R/petals.R
@@ -0,0 +1,59 @@
+petals <- 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')
+#}
diff --git a/R/plot.dice.R b/R/plot.dice.R
new file mode 100644
index 0000000..e0e8d23
--- /dev/null
+++ b/R/plot.dice.R
@@ -0,0 +1,21 @@
+"plot.dice" <-
+function(x,...){
+ if(!requireNamespace('lattice', quietly = TRUE)) stop('The lattice package is needed')
+
+ old.trellis.par <- lattice::trellis.par.get()
+ on.exit(lattice::trellis.par.set(old.trellis.par))
+ lattice::trellis.par.set(theme=lattice::col.whitebg())
+ df <- as.matrix(x)
+ x <- c(df)
+ y <- c(col(df)) - 1
+ g <- factor(c(row(df)))
+
+ xx <- ceiling(sqrt(dim(df)[2]))
+ yy <- ceiling( dim(df)[2]/xx )
+
+ invisible(print(lattice::xyplot( y~x|g, prepanel=prepanel.dice, panel=panel.dice,
+ scales=list(draw=FALSE), aspect=yy/xx, strip=FALSE,
+ as.table=TRUE,
+ xlab="", ylab="",...)))
+}
+
diff --git a/R/plot.rgl.coin.R b/R/plot.rgl.coin.R
new file mode 100644
index 0000000..fc8c013
--- /dev/null
+++ b/R/plot.rgl.coin.R
@@ -0,0 +1,41 @@
+rgl.coin <- function(x, col='black', heads=x[[1]],
+ tails=x[[2]], ... ) {
+ if(!requireNamespace('rgl', quietly = TRUE)) stop("This function depends on the 'rgl' library which is not available")
+
+ if(missing(x)) x <- TeachingDemos::coin.faces
+
+ rgl::rgl.viewpoint(0,0)
+
+ for(i in 0:39) {
+ rgl::rgl.triangles(c(.5, cos(pi/20*i)/2+0.5, cos(pi/20*(i+1))/2+0.5),
+ c(.5, sin(pi/20*i)/2+0.5, sin(pi/20*(i+1))/2+0.5),
+ c(0,0,0))
+ rgl::rgl.triangles(c(.5, cos(pi/20*i)/2+0.5, cos(pi/20*(i+1))/2+0.5),
+ c(.5, sin(pi/20*i)/2+0.5, sin(pi/20*(i+1))/2+0.5),
+ c(0.03,0.03,0.03))
+ rgl::rgl.quads( c(cos(pi/20*i)/2+0.5, cos(pi/20*i)/2+0.5,
+ cos(pi/20*(i+1))/2+0.5, cos(pi/20*(i+1))/2+0.5),
+ c(sin(pi/20*i)/2+0.5, sin(pi/20*i)/2+0.5,
+ sin(pi/20*(i+1))/2+0.5, sin(pi/20*(i+1))/2+0.5),
+ c(0,0.03,0.03,0)
+ )
+ }
+
+ tmp <- rep( 1:nrow(heads), each=2 )
+ tmp <- c(tmp[-1],1)
+
+ rgl::rgl.lines( heads[tmp,1], heads[tmp,2], rep(0.035, length(tmp) ),
+ col=col, lit=FALSE)
+
+ tmp <- rep( 1:nrow(tails), each=2 )
+ tmp <- c(tmp[-1],1)
+
+ rgl::rgl.lines( tails[tmp,1], tails[tmp,2], rep(-0.005, length(tmp) ),
+ col=col, lit=FALSE)
+
+}
+
+
+#coin.faces <- list( qh=cbind( c(.5,.5), c(.75,.25) ),
+# qt=cbind( c(.5, .25, .5, .75, .5),
+# c(.75, .5, .25, .5, .75)) )
diff --git a/R/plot.rgl.die.R b/R/plot.rgl.die.R
new file mode 100644
index 0000000..c0bfd14
--- /dev/null
+++ b/R/plot.rgl.die.R
@@ -0,0 +1,67 @@
+rgl.die <- function(x = 1:6, col.cube='white',col.pip='black',sides=x, ...) {
+
+ if(!requireNamespace('rgl', quietly = TRUE)) stop("This function depends on the 'rgl' package wich is not available")
+
+ rgl::rgl.viewpoint(45,45)
+
+ pip.coords <- function( x,y ) {
+ xc <- yc <- numeric(0)
+ for(i in 0:39){
+ xc <- c(xc, x, 0.05*cos(pi/20*i)+x, 0.05*cos(pi/20*(i+1))+x)
+ yc <- c(yc, y, 0.05*sin(pi/20*i)+y, 0.05*sin(pi/20*(i+1))+y)
+ }
+ cbind(xc,yc)
+ }
+
+ pip.loc <- list(matrix( 0.5, ncol=2, nrow=1),
+ cbind( c(.25, .75), c(.25, .75)),
+ cbind( c(.25, .5, .75), c(.25, .5, .75)),
+ cbind( c(.25, .25, .75, .75), c(.25, .75, .75, .25)),
+ cbind( c(.25, .25, .75, .75, .5), c(.25, .75, .75, .25, .5)),
+ cbind( c(.25, .25, .25, .75, .75, .75),
+ c(.25, .5, .75, .75, .5, .25)))
+
+ rgl::rgl.quads( c(0,0,1,1), c(0,1,1,0), c(0,0,0,0), col=col.cube)
+ rgl::rgl.quads( c(0,0,1,1), c(0,1,1,0), c(1,1,1,1), col=col.cube)
+ rgl::rgl.quads( c(0,0,0,0), c(0,1,1,0), c(0,0,1,1), col=col.cube)
+ rgl::rgl.quads( c(1,1,1,1), c(0,1,1,0), c(0,0,1,1), col=col.cube)
+ rgl::rgl.quads( c(0,0,1,1), c(0,0,0,0), c(0,1,1,0), col=col.cube)
+ rgl::rgl.quads( c(0,0,1,1), c(1,1,1,1), c(0,1,1,0), col=col.cube)
+
+ tmp <- pip.loc[[ sides[1] ]]
+ for( i in 1:nrow(tmp) ){
+ xy <- pip.coords( tmp[i,1], tmp[i,2] )
+ rgl::rgl.triangles(xy[,1], rep(1.001, nrow(xy)), xy[,2], col=col.pip,lit=FALSE)
+ }
+
+ tmp <- pip.loc[[ sides[2] ]]
+ for( i in 1:nrow(tmp) ){
+ xy <- pip.coords( tmp[i,1], tmp[i,2] )
+ rgl::rgl.triangles(xy[,1], xy[,2], rep(1.001, nrow(xy)), col=col.pip,lit=FALSE)
+ }
+
+ tmp <- pip.loc[[ sides[3] ]]
+ for( i in 1:nrow(tmp) ){
+ xy <- pip.coords( tmp[i,1], tmp[i,2] )
+ rgl::rgl.triangles( rep(1.001, nrow(xy)), xy[,1], xy[,2], col=col.pip,lit=FALSE)
+ }
+
+ tmp <- pip.loc[[ sides[4] ]]
+ for( i in 1:nrow(tmp) ){
+ xy <- pip.coords( tmp[i,1], tmp[i,2] )
+ rgl::rgl.triangles( rep(-0.001, nrow(xy)), xy[,1], xy[,2], col=col.pip,lit=FALSE)
+ }
+
+ tmp <- pip.loc[[ sides[5] ]]
+ for( i in 1:nrow(tmp) ){
+ xy <- pip.coords( tmp[i,1], tmp[i,2] )
+ rgl::rgl.triangles(xy[,1], xy[,2], rep(-0.001, nrow(xy)), col=col.pip,lit=FALSE)
+ }
+
+ tmp <- pip.loc[[ sides[6] ]]
+ for( i in 1:nrow(tmp) ){
+ xy <- pip.coords( tmp[i,1], tmp[i,2] )
+ rgl::rgl.triangles(xy[,1], rep(-0.001, nrow(xy)), xy[,2], col=col.pip,lit=FALSE)
+ }
+
+}
diff --git a/R/plot2script.R b/R/plot2script.R
new file mode 100644
index 0000000..cba1fc3
--- /dev/null
+++ b/R/plot2script.R
@@ -0,0 +1,63 @@
+plot2script <- function(file='clipboard'){
+ con <- file(file)
+ open(con, open='a')
+ tmp <- recordPlot()[[1]]
+ for (i in seq(along.with=tmp)){
+ fn <- tmp[[i]][[1]]
+ args <- tmp[[i]][[2]]
+ fns <- deparse(fn)
+ m <- sub('^.*"(.*)".*$', '\\1', fns, perl=TRUE)
+ c2 <- as.list(c(m,args))
+ tmp2 <- do.call('call',c2)
+ tmp3 <- match.call(get(m), call=tmp2)
+ if(tmp3[[1]] == 'box'){
+ tmp3$which <- c("plot", "figure", "inner",
+ "outer")[ tmp3$which ]
+ }
+ dput(tmp3, file=con)
+ }
+ close(con)
+}
+
+oldzoomplot <- function( xlim, ylim=NULL ){
+ xy <- xy.coords(xlim,ylim)
+ xlim <- range(xy$x)
+ ylim <- range(xy$y)
+
+ tmp <- recordPlot()[[1]]
+ for(i in seq(along=tmp)){
+ fn <- tmp[[i]][[1]]
+ alst <- as.list(tmp[[i]][[2]])
+ tmp2 <- all.equal( '.Primitive("locator")', deparse(fn) )
+ if(is.logical(tmp2) && tmp2){
+ next
+ }
+ tmp2 <- all.equal( '.Primitive("plot.window")', deparse(fn) )
+ if(is.logical(tmp2) && tmp2) {
+ alst[[1]] <- xlim
+ alst[[2]] <- ylim
+ }
+
+ do.call(fn, alst)
+ }
+}
+
+
+
+zoomplot <- function( xlim, ylim=NULL ){
+ xy <- xy.coords(xlim,ylim)
+ xlim <- range(xy$x)
+ ylim <- range(xy$y)
+
+ tmp <- recordPlot()
+ for(i in seq(along=tmp[[1]])){
+ fn <- tmp[[1]][[i]][[2]][[1]]
+ if(fn$name == 'C_plot_window') {
+ tmp[[1]][[i]][[2]][[2]] <- xlim
+ tmp[[1]][[i]][[2]][[3]] <- ylim
+ }
+ }
+ replayPlot(tmp)
+}
+
+
diff --git a/R/power.examp.R b/R/power.examp.R
new file mode 100644
index 0000000..962146d
--- /dev/null
+++ b/R/power.examp.R
@@ -0,0 +1,64 @@
+power.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) )
+}
+
diff --git a/R/power.refresh.R b/R/power.refresh.R
new file mode 100644
index 0000000..65a43d9
--- /dev/null
+++ b/R/power.refresh.R
@@ -0,0 +1,6 @@
+"power.refresh" <-
+function(...) {
+ power.examp(n=slider(no=1), stdev=slider(no=2), diff=slider(no=3),
+ alpha=slider(no=4) )
+}
+
diff --git a/R/prepanel.dice.R b/R/prepanel.dice.R
new file mode 100644
index 0000000..8114fa6
--- /dev/null
+++ b/R/prepanel.dice.R
@@ -0,0 +1,7 @@
+"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)) )
+}
+
diff --git a/R/prob.axis.R b/R/prob.axis.R
new file mode 100644
index 0000000..dff2311
--- /dev/null
+++ b/R/prob.axis.R
@@ -0,0 +1,4 @@
+prob.axis <- function(side, dist, dist.args, at=NULL, labels=TRUE, ...) {
+
+
+}
diff --git a/R/put.points.demo.R b/R/put.points.demo.R
new file mode 100644
index 0000000..90a27e0
--- /dev/null
+++ b/R/put.points.demo.R
@@ -0,0 +1,104 @@
+"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
+
+}
+
diff --git a/R/range.R b/R/range.R
new file mode 100644
index 0000000..f6811e6
--- /dev/null
+++ b/R/range.R
@@ -0,0 +1,76 @@
+`%<%` <- 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
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/R/rgl.Map.R b/R/rgl.Map.R
new file mode 100644
index 0000000..a48473a
--- /dev/null
+++ b/R/rgl.Map.R
@@ -0,0 +1,26 @@
+"rgl.Map" <-
+function(Map,which,...) {
+ if (missing(which)) which <- TRUE
+ if(!requireNamespace('rgl', quietly = TRUE)) stop("This function depends on the 'rgl' package which is not available")
+
+ lapply(Map$Shapes[which], function(shape) {
+ long <- shape$verts[,1] * pi/180
+ lat <- pi/2 - shape$verts[,2] * pi/180
+
+ z <- cos(long)*sin(lat)
+ y <- cos(lat)
+ x <- sin(long)*sin(lat)
+
+
+ mapply(function(pfrom, pto) {
+ tmp.i <- rep( seq(along=x[pfrom:pto]), each=2 )
+ tmp.i <- c(tmp.i[-1], 1)
+
+ rgl::rgl.lines(x[tmp.i], y[tmp.i], z[tmp.i], ...)
+ }, shape$Pstart + 1, c(shape$Pstart[-1], shape$nVerts + 1))
+
+ })
+
+ invisible()
+}
+
diff --git a/R/roc.demo.R b/R/roc.demo.R
new file mode 100644
index 0000000..5b61d77
--- /dev/null
+++ b/R/roc.demo.R
@@ -0,0 +1,96 @@
+"roc.demo" <-
+function(x=rnorm(25,10,1), y=rnorm(25,11,1.5) ){
+
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+ if(!exists('slider.env')) slider.env <<- new.env()
+
+ range.min <- min(x,y) - 0.1 * diff(range(x,y))
+ range.max <- max(x,y) + 0.1 * diff(range(x,y))
+
+ cutoff <- range.max; assign('cutoff', tcltk::tclVar(cutoff), envir=slider.env)
+
+ .sens <-c(0,1)
+ .spec <-c(0,1)
+
+ dx <- density(x)
+ dy <- density(y)
+
+ roc.refresh <- function(...){
+ cutoff <- as.numeric(evalq(tcltk::tclvalue(cutoff), envir=slider.env))
+
+ old.par <- par(no.readonly=T)
+ on.exit(par(old.par))
+
+ sens <- mean( y > cutoff )
+ spec <- mean( x > cutoff )
+
+ .sens <<- c(.sens, sens)
+ .spec <<- c(.spec, spec)
+
+
+ par(mar=c(5,4,0,1)+.1)
+ layout( matrix(c(1,2), ncol=1), heights=c(2,1))
+
+ op <- par(pty="s")
+ plot(.spec,.sens, xlab="1-Specificity",ylab="Sensitivity",
+ xlim=c(0,1),ylim=c(0,1))
+ par(pty="m")
+
+ tmp <- chull(c(1,.spec),c(0,.sens))
+ lines(c(NA,.spec)[tmp],c(NA,.sens)[tmp])
+ points(spec,sens, col='red',pch=16)
+
+ specdiff <- diff( c(NA,.spec)[tmp] )
+ specdiff <- specdiff[!is.na(specdiff)]
+ sensmean <- (c(c(NA,.sens)[tmp][-1],NA) + c(NA,.sens)[tmp])/2
+ sensmean <- sensmean[!is.na(sensmean)]
+ auc <- sum( specdiff*sensmean )
+ text(1,0.1, paste("Area Under Curve =", round(auc,3)), cex=1.7, adj=1)
+
+ d <- (1-.sens)^2 + (.spec)^2
+ dd <- which.min(d)
+ lines(c(0,.spec[dd]),c(1,.sens[dd]), col='purple')
+
+
+ plot( dx$x, dx$y, type='l', col='red', xlim=c(range.min,range.max),
+ xlab=paste("Sensitivity = ",round(sens,3),", Specificity = ",round(1-spec,3),sep=''),
+ ylab="Densities",ylim=c(0,max(dx$y,dy$y)))
+ if(any(x <= cutoff))
+ rug(x[x<=cutoff], col='red', ticksize=.3)
+ if(any(x > cutoff))
+ rug(x[x>cutoff], col='red', ticksize=.3, side=3)
+
+ lines( dy$x, dy$y, col='blue')
+ if(any(y<=cutoff))
+ rug(y[y<=cutoff], col='blue',ticksize=.3)
+ if(any(y>cutoff))
+ rug(y[y>cutoff], col='blue',ticksize=.3, side=3)
+
+ abline(v=cutoff, col='green')
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'ROC curve demo')
+ tcltk::tkwm.geometry(m, '+0+0')
+
+ # cutoff
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='cutoff', width='10'), side='right')
+
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=roc.refresh, from=range.min,
+ to=range.max, orient='horiz',
+ resolution = (range.max-range.min)/100,
+ showvalue=T),
+ side='left')
+
+ assign('sc',sc, envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=cutoff), envir=slider.env)
+
+
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=roc.refresh), side='left')
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
diff --git a/R/roll.rgl.die.R b/R/roll.rgl.die.R
new file mode 100644
index 0000000..ba5301b
--- /dev/null
+++ b/R/roll.rgl.die.R
@@ -0,0 +1,38 @@
+roll.rgl.die <- function( side=sample(6,1), steps=250 ) {
+
+ rgl::rgl.viewpoint(45,45)
+
+
+ tmp <- seq(45, by=90, length=4)
+ tmp2 <- c(-1,1,-1,1)
+
+ for (j in 1:4) {
+ for (i in seq(0,90,length=steps)) {
+ rgl::rgl.viewpoint(tmp[j]+i, -tmp2[j]*45+tmp2[j]*i)
+ }
+ }
+
+ if( side==1 ){
+ for(i in seq(0,45, length=steps/2)) {
+ rgl::rgl.viewpoint(45+i, 45+i)
+ }
+ } else if( side==6 ) {
+ for(i in seq(0,90, length=steps)) {
+ rgl::rgl.viewpoint(45+i, 45-i)
+ }
+ for(i in seq(0,45, length=steps/2)) {
+ rgl::rgl.viewpoint(135+i, -45-i)
+ }
+ } else {
+ tmp3 <- c(NA,3,0,2,1)[side]
+ for(j in seq(1,length=tmp3)){
+ for(i in seq(0,90,length=steps)) {
+ rgl::rgl.viewpoint(tmp[j]+i, -tmp2[j]*45+tmp2[j]*i)
+ }
+ }
+ for(i in seq(0,45, length=steps/2)) {
+ rgl::rgl.viewpoint(tmp[tmp3+1]+i, -tmp2[tmp3+1]*45+tmp2[tmp3+1]*i)
+ }
+ }
+ return(side)
+}
diff --git a/R/rotate.cloud.R b/R/rotate.cloud.R
new file mode 100644
index 0000000..64b5b0d
--- /dev/null
+++ b/R/rotate.cloud.R
@@ -0,0 +1,89 @@
+"rotate.cloud" <-
+function(x, ...){
+
+ if(!requireNamespace('tcltk', quietly=TRUE)){stop('The tcltk package is needed')}
+ if(!exists('slider.env')) slider.env <<-new.env()
+
+ lab1 <- 'z'; assign('lab1', tcltk::tclVar(lab1), envir=slider.env)
+ lab2 <- 'y'; assign('lab2', tcltk::tclVar(lab2), envir=slider.env)
+ lab3 <- 'x'; assign('lab3', tcltk::tclVar(lab3), envir=slider.env)
+
+ val1 <- 40; assign('val1', tcltk::tclVar(val1), envir=slider.env)
+ val2 <- 0; assign('val2', tcltk::tclVar(val2), envir=slider.env)
+ val3 <- -60; assign('val3', tcltk::tclVar(val3), envir=slider.env)
+
+ cloud.options <- list(...)
+
+ cloud.refresh <- function(...){
+
+ lab1 <- evalq(tcltk::tclvalue(lab1), envir=slider.env)
+ lab2 <- evalq(tcltk::tclvalue(lab2), envir=slider.env)
+ lab3 <- evalq(tcltk::tclvalue(lab3), envir=slider.env)
+
+ val1 <- as.numeric(evalq(tcltk::tclvalue(val1), envir=slider.env))
+ val2 <- as.numeric(evalq(tcltk::tclvalue(val2), envir=slider.env))
+ val3 <- as.numeric(evalq(tcltk::tclvalue(val3), envir=slider.env))
+
+
+ sl <- list(val1,val2,val3)
+ names(sl) <- c(lab1,lab2,lab3)
+
+ cloud.options$x <- x
+ cloud.options$screen <- sl
+
+ print( do.call('cloud',cloud.options) )
+
+
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Rotate Cloud plot')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ # one
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=cloud.refresh, from=-180, to=180,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=val1), envir=slider.env)
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e,textvariable=lab1), envir=slider.env)
+
+ # two
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=cloud.refresh, from=-180, to=180,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=val2), envir=slider.env)
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e,textvariable=lab2), envir=slider.env)
+
+ # three
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=cloud.refresh, from=-180, to=180,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=val3), envir=slider.env)
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e,textvariable=lab3), envir=slider.env)
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=cloud.refresh),side='left')
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+
+}
+
diff --git a/R/rotate.persp.R b/R/rotate.persp.R
new file mode 100644
index 0000000..d4ca4cd
--- /dev/null
+++ b/R/rotate.persp.R
@@ -0,0 +1,23 @@
+"rotate.persp" <-
+function(x,y,z){
+
+ if(!requireNamespace('tcltk', quietly = TRUE)){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')
+
+}
+
diff --git a/R/rotate.wireframe.R b/R/rotate.wireframe.R
new file mode 100644
index 0000000..199064e
--- /dev/null
+++ b/R/rotate.wireframe.R
@@ -0,0 +1,90 @@
+"rotate.wireframe" <-
+function(x, ...){
+
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+ if(!exists('slider.env')) slider.env <<-new.env()
+ if(!requireNamespace('lattice', quietly = TRUE)){stop('The lattice package is needed')}
+
+ lab1 <- 'z'; assign('lab1', tcltk::tclVar(lab1), envir=slider.env)
+ lab2 <- 'y'; assign('lab2', tcltk::tclVar(lab2), envir=slider.env)
+ lab3 <- 'x'; assign('lab3', tcltk::tclVar(lab3), envir=slider.env)
+
+ val1 <- 40; assign('val1', tcltk::tclVar(val1), envir=slider.env)
+ val2 <- 0; assign('val2', tcltk::tclVar(val2), envir=slider.env)
+ val3 <- -60; assign('val3', tcltk::tclVar(val3), envir=slider.env)
+
+ wire.options <- list(...)
+
+ wire.refresh <- function(...){
+
+ lab1 <- evalq(tcltk::tclvalue(lab1), envir=slider.env)
+ lab2 <- evalq(tcltk::tclvalue(lab2), envir=slider.env)
+ lab3 <- evalq(tcltk::tclvalue(lab3), envir=slider.env)
+
+ val1 <- as.numeric(evalq(tcltk::tclvalue(val1), envir=slider.env))
+ val2 <- as.numeric(evalq(tcltk::tclvalue(val2), envir=slider.env))
+ val3 <- as.numeric(evalq(tcltk::tclvalue(val3), envir=slider.env))
+
+
+ sl <- list(val1,val2,val3)
+ names(sl) <- c(lab1,lab2,lab3)
+
+ wire.options$x <- x
+ wire.options$screen <- sl
+
+ print( do.call(lattice::wireframe,wire.options) )
+
+
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Rotate Wireframe plot')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ # one
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=wire.refresh, from=-180, to=180,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=val1), envir=slider.env)
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e,textvariable=lab1), envir=slider.env)
+
+ # two
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=wire.refresh, from=-180, to=180,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=val2), envir=slider.env)
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e,textvariable=lab2), envir=slider.env)
+
+ # three
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(e <- tcltk::tkentry(fr, width=2), side='left')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=wire.refresh, from=-180, to=180,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=val3), envir=slider.env)
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e,textvariable=lab3), envir=slider.env)
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=wire.refresh),side='left')
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+
+}
+
diff --git a/R/run.ci.examp.R b/R/run.ci.examp.R
new file mode 100644
index 0000000..be00d9a
--- /dev/null
+++ b/R/run.ci.examp.R
@@ -0,0 +1,73 @@
+"run.ci.examp" <-
+function(reps=100,seed, method='z',n=25) {
+
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+ if (!missing(seed)){ set.seed(seed) }
+ data <- matrix( rnorm( n*reps, 100, 10), ncol=n)
+ rmeans <- rowMeans(data)
+
+ ci.refresh <- function(...) {
+ conf.level=slider(no=1)
+ switch(method, Z=,z={
+ lower <- qnorm( (1-conf.level)/2, rmeans, 10/sqrt(n))
+ upper <- qnorm( 1-(1-conf.level)/2, rmeans, 10/sqrt(n))
+ },
+ T=,t= {
+ cv.l <- qt((1-conf.level)/2, n-1)
+ cv.u <- qt(1-(1-conf.level)/2, n-1)
+ rsds <- sqrt(apply(data,1,var))/sqrt(n)
+
+ lower <- rmeans+cv.l*rsds
+ upper <- rmeans+cv.u*rsds
+ },
+ BOTH=, Both=, both={
+ lz <- qnorm( (1-conf.level)/2, rmeans, 10/sqrt(n))
+ uz <- qnorm( 1-(1-conf.level)/2, rmeans, 10/sqrt(n))
+
+ cv.l <- qt((1-conf.level)/2, n-1)
+ cv.u <- qt(1-(1-conf.level)/2, n-1)
+ rsds <- sqrt(apply(data,1,var))/sqrt(n)
+
+ lt <- rmeans+cv.l*rsds
+ ut <- rmeans+cv.u*rsds
+
+ lower <- c(rbind(lt,lz,100))
+ upper <- c(rbind(ut,uz,100))
+
+ reps <- reps*3
+ rmeans <- rep(rmeans, each=3)
+ rmeans[c(F,F,T)] <- NA
+
+ },
+ stop("method must be z, t, or both") )
+
+
+ xr <- 100 + 4.5*c(-1,1)*10/sqrt(n)
+
+ plot(lower,seq(1,reps), type="n", xlim=xr, xlab="Confidence Interval",
+ ylab="Index")
+
+ abline( v= qnorm(c((1-conf.level)/2,1-(1-conf.level)/2), 100,
+ 10/sqrt(n)), col='lightgreen')
+
+ if( method=="both" || method=="Both" || method=="BOTH"){
+ title( main="Confidence intervals based on both distributions",
+ sub="Upper interval is Z in each pair")
+ } else {
+ title( main=paste("Confidence intervals based on",method,"distribution"))
+ }
+
+ colr <- ifelse( lower > 100, 'blue', ifelse( upper < 100, 'red', 'black') )
+
+ abline(v=100)
+
+ segments(lower,1:reps,upper,1:reps, col=colr)
+ points( rmeans, seq(along=rmeans), pch='|', col=colr )
+ invisible(NULL)
+ }
+
+ slider( ci.refresh, 'Confidence Level', 0.5, 0.995, 0.005, 0.95,
+ title="Confidence Interval Demo")
+
+}
+
diff --git a/R/run.cor.examp.R b/R/run.cor.examp.R
new file mode 100644
index 0000000..0f85d60
--- /dev/null
+++ b/R/run.cor.examp.R
@@ -0,0 +1,109 @@
+"run.old.cor.examp" <-
+function(n=100,seed) {
+ if (!missing(seed)){ set.seed(seed) }
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+
+ x <- scale(matrix(rnorm(2*n,0,1), ncol=2))
+ x <- x %*% solve( chol( cor(x) ) )
+ xr <- range(x)
+
+ cor.refresh <- function(...) {
+ r <- slider(no=1)
+ if ( r == 1 ) {
+ cmat <- matrix( c(1,0,1,0),2 )
+ } else if (r == -1) {
+ cmat <- matrix( c(1,0,-1,0),2 )
+ } else {
+ cmat <- chol( matrix( c(1,r,r,1),2) )
+ }
+ new.x <- x %*% cmat
+
+ plot(new.x, xlab='x',ylab='y', xlim=xr, ylim=xr)
+ title(paste("r = ",round(cor(new.x[,1],new.x[,2]),3)))
+ }
+
+ slider( cor.refresh, 'Correlation', -1, 1, 0.01, 0,
+ title="Correlation Demo")
+ cor.refresh()
+}
+
+run.cor.examp <- function(n=100,seed,vscale=1.5,hscale=1.5,wait=FALSE) {
+
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ if(!missing(seed) ) set.seed(seed)
+
+ x <- scale(matrix(rnorm(2*n,0,1), ncol=2))
+ x <- x %*% solve( chol( cor(x) ) )
+ xr <- range(x,-x)
+
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- vscale
+
+ r <- tcltk::tclVar()
+ tcltk::tclvalue(r) <- 0
+
+ replot <- function(...) {
+ tmp.r <- as.numeric(tcltk::tclvalue(r))
+ if( tmp.r == 1 ) {
+ cmat <- matrix( c(1,0,1,0),2 )
+ } else if( tmp.r == -1 ) {
+ cmat <- matrix( c(1,0,-1,0),2 )
+ } else {
+ cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) )
+ }
+ new.x <- x %*% cmat
+
+ plot(new.x, xlab='x', ylab='y', xlim=xr, ylim=xr)
+ title(paste("r =", round( tmp.r, 3)))
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Cor2 Example")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr,text='r: '), side='left',anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=r, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=-1, to=1,
+ resolution=0.01), side='right')
+
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ) ),
+ side='left',anchor='s')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ if(wait){
+ tcltk::tkwait.window(tt)
+ tmp.r <- as.numeric(tcltk::tclvalue(r))
+ if( tmp.r == 1 ) {
+ cmat <- matrix( c(1,0,1,0),2 )
+ } else if( tmp.r == -1 ) {
+ cmat <- matrix( c(1,0,-1,0),2 )
+ } else {
+ cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) )
+ }
+ new.x <- x %*% cmat
+ return( list(x=new.x[,1], y=new.x[,2]) )
+ } else {
+ return(invisible(NULL))
+ }
+}
diff --git a/R/run.cor2.examp.R b/R/run.cor2.examp.R
new file mode 100644
index 0000000..197afb2
--- /dev/null
+++ b/R/run.cor2.examp.R
@@ -0,0 +1,149 @@
+"run.old.cor2.examp" <-
+function(n=100,seed) {
+ if (!missing(seed)){ set.seed(seed) }
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+
+ x <- scale(matrix(rnorm(2*n,0,1), ncol=2))
+ x <- x %*% solve( chol( cor(x) ) )
+ xr <- range(x,-x)
+
+ r.old <- 0
+ r2.old <- 0
+
+ cor.refresh <- function(...) {
+ r <- slider(no=1)
+ r2 <- slider(no=2)
+
+ if (r!=r.old){
+ slider(set.no.value=c(2,r^2))
+ r.old <<- r
+ r2.old <<- r^2
+ } else {
+ slider(set.no.value=c(1, ifelse(r<0, -sqrt(r2), sqrt(r2))))
+ r.old <<- ifelse(r<0, -sqrt(r2), sqrt(r2))
+ r2.old <<-r2
+ r <- r.old
+ }
+
+ if ( r == 1 ) {
+ cmat <- matrix( c(1,0,1,0),2 )
+ } else if (r == -1) {
+ cmat <- matrix( c(1,0,-1,0),2 )
+ } else {
+ cmat <- chol( matrix( c(1,r,r,1),2) )
+ }
+ new.x <- x %*% cmat
+
+ plot(new.x, xlab='x',ylab='y', xlim=xr, ylim=xr)
+ title(paste("r = ",round(cor(new.x[,1],new.x[,2]),3),
+ "\nr^2 = ",round(r^2,3)))
+ }
+
+ slider( cor.refresh, c('Correlation','r^2'), c(-1,0), c(1,1), c(0.01,0.01),
+ c(0,0),
+ title="Correlation Demo")
+
+}
+
+
+
+run.cor2.examp <- function(n=100,seed,vscale=1.5,hscale=1.5,wait=FALSE) {
+
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ if(!missing(seed) ) set.seed(seed)
+
+ x <- scale(matrix(rnorm(2*n,0,1), ncol=2))
+ x <- x %*% solve( chol( cor(x) ) )
+ xr <- range(x)
+
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- vscale
+
+ r <- tcltk::tclVar()
+ tcltk::tclvalue(r) <- 0
+ r2 <- tcltk::tclVar()
+ tcltk::tclvalue(r2) <- 0
+
+ update.r <- function(...) {
+ tmp <- as.numeric(tcltk::tclvalue(r))
+ tmp2 <- as.numeric(tcltk::tclvalue(r2))
+ tcltk::tclvalue(r) <- ifelse( tmp < 0, -1,1) * sqrt(tmp2)
+ tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) )
+ }
+ update.r2 <- function(...) {
+ tmp <- as.numeric(tcltk::tclvalue(r))
+ tcltk::tclvalue(r2) <- tmp^2
+ tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) )
+ }
+
+ replot <- function(...) {
+ tmp.r <- as.numeric(tcltk::tclvalue(r))
+ if( tmp.r == 1 ) {
+ cmat <- matrix( c(1,0,1,0),2 )
+ } else if( tmp.r == -1 ) {
+ cmat <- matrix( c(1,0,-1,0),2 )
+ } else {
+ cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) )
+ }
+ new.x <- x %*% cmat
+
+ plot(new.x, xlab='x', ylab='y', xlim=xr, ylim=xr)
+ title(paste("r =", round( tmp.r, 3),
+ "\nr^2 =",round(tmp.r^2,3)))
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Cor2 Example")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(fr <- tcltk::tkframe(tfr), side='top',fill='x')
+ tcltk::tkpack(tcltk::tklabel(fr,text='r: '), side='left',anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=r, orient='horizontal',
+ command=update.r2, from=-1, to=1,
+ resolution=0.01), side='right')
+ tcltk::tkpack(fr <- tcltk::tkframe(tfr), side='top',fill='x')
+ tcltk::tkpack(tcltk::tklabel(fr,text='r^2: '),side='left',anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=r2, orient='horizontal',
+ command=update.r, from=0, to=1,
+ resolution=0.01), side='right')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ) ),
+ side='left',anchor='s')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ if(wait){
+ tcltk::tkwait.window(tt)
+ tmp.r <- as.numeric(tcltk::tclvalue(r))
+ if( tmp.r == 1 ) {
+ cmat <- matrix( c(1,0,1,0),2 )
+ } else if( tmp.r == -1 ) {
+ cmat <- matrix( c(1,0,-1,0),2 )
+ } else {
+ cmat <- chol( matrix( c(1,tmp.r,tmp.r,1),2) )
+ }
+ new.x <- x %*% cmat
+ return( list(x=new.x[,1], y=new.x[,2]) )
+ } else {
+ return(invisible(NULL))
+ }
+}
diff --git a/R/run.hist.demo.R b/R/run.hist.demo.R
new file mode 100644
index 0000000..550929d
--- /dev/null
+++ b/R/run.hist.demo.R
@@ -0,0 +1,53 @@
+"run.hist.demo" <-
+function(x) {
+
+ if(!requireNamespace('tcltk', quietly=TRUE)){stop('The tcltk package is needed')}
+
+ pr <- pretty(x)
+ xr <- range(pr)
+ xr[1] <- 4*xr[1] - 3*min(x)
+ xr[2] <- 4*xr[2] - 3*max(x)
+
+ hist.refresh <- function(...) {
+
+ hist(x,seq( slider(no=2), slider(no=3), length=slider(no=1)+1),
+ xlim=xr)
+
+ }
+
+ slider(hist.refresh, c('Number of bins','Minimum','Maximum'),
+ c(1, xr[1], max(x)),
+ c(length(x),min(x),xr[2]),
+ c(1, (min(x)-xr[1])/50, (xr[2]-max(x))/50),
+ c(nclass.Sturges(x),min(pr),max(pr)),
+ title="Histogram Demo")
+
+}
+
+
+## # create new version using tkrplot changing min, max, and nbins, include rug
+##
+## hist.demo <- function(x,xmin,xmax,n,xlab=deparse(substitute(x))) {
+## br <- seq(xmin,xmax, length.out=n+1)
+## print(range(x))
+## hist(x,br, xlab=xlab, main='')
+## }
+##
+##
+## run.hist.demo <- function(xx,...) {
+## if(!require(tkrplot)) { stop('The tkrplot package is needed')}
+##
+## xlab <- deparse(substitute(xx))
+##
+## pr <- pretty(xx)
+## h1 <- hist(xx, plot=FALSE)
+## plist <- list( xmin = list('spinbox', from=min(pr), to=min(x),
+## increment=(min(x)-min(pr))/10 ),
+## xmax = list('spinbox', from=max(x), to=max(pr),
+## increment=(max(pr)-max(x))/10, init=max(pr) ),
+## n = list('slider', from=1, to=length(x), resolution=1,
+## init=length(h1$breaks)-1))
+## tkexamp( hist.demo(xx,xlab=xlab), plist )
+## }
+##
+##
diff --git a/R/run.old.cor.examp.R b/R/run.old.cor.examp.R
new file mode 100644
index 0000000..f0557d9
--- /dev/null
+++ b/R/run.old.cor.examp.R
@@ -0,0 +1,29 @@
+"run.old.cor.examp" <-
+function(n=100,seed) {
+ if (!missing(seed)){ set.seed(seed) }
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+
+ x <- scale(matrix(rnorm(2*n,0,1), ncol=2))
+ x <- x %*% solve( chol( cor(x) ) )
+ xr <- range(x)
+
+ cor.refresh <- function(...) {
+ r <- slider(no=1)
+ if ( r == 1 ) {
+ cmat <- matrix( c(1,0,1,0),2 )
+ } else if (r == -1) {
+ cmat <- matrix( c(1,0,-1,0),2 )
+ } else {
+ cmat <- chol( matrix( c(1,r,r,1),2) )
+ }
+ new.x <- x %*% cmat
+
+ plot(new.x, xlab='x',ylab='y', xlim=xr, ylim=xr)
+ title(paste("r = ",round(cor(new.x[,1],new.x[,2]),3)))
+ }
+
+ slider( cor.refresh, 'Correlation', -1, 1, 0.01, 0,
+ title="Correlation Demo")
+ cor.refresh()
+}
+
diff --git a/R/run.old.cor2.examp.R b/R/run.old.cor2.examp.R
new file mode 100644
index 0000000..866a143
--- /dev/null
+++ b/R/run.old.cor2.examp.R
@@ -0,0 +1,47 @@
+"run.old.cor2.examp" <-
+function(n=100,seed) {
+ if (!missing(seed)){ set.seed(seed) }
+ if(!requireNamespace('tcltk', quietly = TRUE)){stop('The tcltk package is needed')}
+
+ x <- scale(matrix(rnorm(2*n,0,1), ncol=2))
+ x <- x %*% solve( chol( cor(x) ) )
+ xr <- range(x)
+
+ 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()
+}
+
diff --git a/R/run.power.examp.R b/R/run.power.examp.R
new file mode 100644
index 0000000..3cb912e
--- /dev/null
+++ b/R/run.power.examp.R
@@ -0,0 +1,122 @@
+run.power.examp.old <-
+function(){
+ if(!requireNamespace('tcltk', quietly = TRUE)){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( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ n <- tcltk::tclVar()
+ stdev <- tcltk::tclVar()
+ diff <- tcltk::tclVar()
+ alpha <- tcltk::tclVar()
+ xmin <- tcltk::tclVar()
+ xmax <- tcltk::tclVar()
+
+ tcltk::tclvalue(n) <- 1
+ tcltk::tclvalue(stdev) <- 1
+ tcltk::tclvalue(diff) <- 1
+ tcltk::tclvalue(alpha) <- 0.05
+ tcltk::tclvalue(xmin) <- -2
+ tcltk::tclvalue(xmax) <- 4
+
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- vscale
+
+ out <- numeric(1)
+
+ replot <- function(...) {
+ out <<- power.examp( as.numeric(tcltk::tclvalue(n)),
+ as.numeric(tcltk::tclvalue(stdev)),
+ as.numeric(tcltk::tclvalue(diff)),
+ as.numeric(tcltk::tclvalue(alpha)),
+ as.numeric(tcltk::tclvalue(xmin)),
+ as.numeric(tcltk::tclvalue(xmax)) )
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Power Demo")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='left')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top', fill='x')
+ tcltk::tkpack(tcltk::tklabel(fr, text="n: "), side='left')
+ tcltk::tkpack(tdspinner(fr, values=c(1,2,3,4,5,10,20,30,40,50),
+ width=5, textvariable=n,
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) )
+ ), side='left')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top',fill='x')
+ tcltk::tkpack(tcltk::tklabel(fr, text="Standard Deviation: "), side='left')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=stdev, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0.1, to=4, resolution=.05), side='right')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top',fill='x')
+ tcltk::tkpack(tcltk::tklabel(fr, text="True Difference: "), side='left')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=diff, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0, to=4, resolution=.05), side='right')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top',fill='x')
+ tcltk::tkpack(tcltk::tklabel(fr, text="alpha: "), side='left')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=alpha, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=0.001, to=0.2, resolution=0.001), side='right')
+
+
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='top', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="x min: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=xmin,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" x max: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=xmax,width=6), side='left')
+
+
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ) ),
+ side='left',anchor='s')
+
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+ if(wait) {
+ tcltk::tkwait.window(tt)
+ return(list( n=as.numeric(tcltk::tclvalue(n)),
+ stdev=as.numeric(tcltk::tclvalue(stdev)),
+ diff=as.numeric(tcltk::tclvalue(diff)),
+ alpha=as.numeric(tcltk::tclvalue(alpha)),
+ power=out
+ ))
+ } else {
+ return(invisible(NULL))
+ }
+}
diff --git a/R/shadowtext.R b/R/shadowtext.R
new file mode 100644
index 0000000..efca2cb
--- /dev/null
+++ b/R/shadowtext.R
@@ -0,0 +1,19 @@
+shadowtext <- 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')
+
diff --git a/R/sigma.test.R b/R/sigma.test.R
new file mode 100644
index 0000000..508f0f3
--- /dev/null
+++ b/R/sigma.test.R
@@ -0,0 +1,35 @@
+sigma.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)}
diff --git a/R/simfun.R b/R/simfun.R
new file mode 100644
index 0000000..8413cf2
--- /dev/null
+++ b/R/simfun.R
@@ -0,0 +1,34 @@
+simfun <- 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
+ }
+}
+
+
+
diff --git a/R/slideRule.R b/R/slideRule.R
new file mode 100644
index 0000000..acf48b8
--- /dev/null
+++ b/R/slideRule.R
@@ -0,0 +1,68 @@
+
+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 )
+}
+
+
+
+
+
+
diff --git a/R/slider.R b/R/slider.R
new file mode 100644
index 0000000..24b4efb
--- /dev/null
+++ b/R/slider.R
@@ -0,0 +1,84 @@
+slider <- function (sl.functions, sl.names, sl.mins, sl.maxs, sl.deltas,
+ sl.defaults, but.functions, but.names, no, set.no.value,
+ obj.name, obj.value, reset.function, title) {
+ # slightly modified by J. Fox from the TeachingDemos package
+ requireNamespace('tcltk', quietly = TRUE)
+
+ if (!missing(no))
+ return(as.numeric(tcltk::tclvalue(get(paste("slider", no, sep = ""),
+ envir = slider.env))))
+ if (!missing(set.no.value)) {
+ try(eval(parse(text = paste("tcltk::tclvalue(slider", set.no.value[1],
+ ")<-", set.no.value[2], sep = "")), envir = slider.env))
+ return(set.no.value[2])
+ }
+ if (!exists("slider.env"))
+ slider.env <<- new.env()
+ if (!missing(obj.name)) {
+ if (!missing(obj.value))
+ assign(obj.name, obj.value, envir = slider.env)
+ else obj.value <- get(obj.name, envir = slider.env)
+ return(obj.value)
+ }
+ if (missing(title))
+ title <- "slider control widget"
+
+ nt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(nt, title)
+ tcltk::tkwm.geometry(nt, "+0+0")
+ if (missing(sl.names))
+ sl.names <- NULL
+ if (missing(sl.functions))
+ sl.functions <- function(...) {
+ }
+ for (i in seq(sl.names)) {
+ eval(parse(text = paste("assign('slider", i,
+ "',tcltk::tclVar(sl.defaults[i]),envir=slider.env)",
+ sep = "")))
+ tcltk::tkpack(fr <- tcltk::tkframe(nt))
+ lab <- tcltk::tklabel(fr, text = sl.names[i], width = "25")
+ sc <- tcltk::tkscale(fr, from = sl.mins[i], to = sl.maxs[i],
+ showvalue = T, resolution = sl.deltas[i], orient = "horiz")
+ tcltk::tkpack(lab, sc, side = "right")
+ assign("sc", sc, envir = slider.env)
+ eval(parse(text = paste("tcltk::tkconfigure(sc,variable=slider",
+ i, ")", sep = "")), envir = slider.env)
+ sl.fun <- if (length(sl.functions) > 1)
+ sl.functions[[i]]
+ else sl.functions
+ if (!is.function(sl.fun))
+ sl.fun <- eval(parse(text = paste("function(...){",
+ sl.fun, "}")))
+ tcltk::tkconfigure(sc, command = sl.fun)
+ }
+ assign("slider.values.old", sl.defaults, envir = slider.env)
+ tcltk::tkpack(f.but <- tcltk::tkframe(nt), fill = "x")
+ tcltk::tkpack(tcltk::tkbutton(f.but, text = "Exit", command = function()
+ tcltk::tkdestroy(nt)),
+ side = "right")
+ if (!missing(reset.function)){
+ if (!is.function(reset.function))
+ reset.function <- eval(parse(text = paste("function(...){",
+ reset.function, "}")))
+ tcltk::tkpack(tcltk::tkbutton(f.but, text = "Reset", command = function() {
+ for (i in seq(sl.names)) eval(parse(text =
+ paste("tcltk::tclvalue(slider",
+ i, ")<-", sl.defaults[i], sep = "")), envir = slider.env)
+ reset.function()
+ }), side = "right")
+ }
+ if (missing(but.names))
+ but.names <- NULL
+ for (i in seq(but.names)) {
+ but.fun <- if (length(but.functions) > 1)
+ but.functions[[i]]
+ else but.functions
+ if (!is.function(but.fun))
+ but.fun <- eval(parse(text = paste("function(...){",
+ but.fun, "}")))
+ tcltk::tkpack(tcltk::tkbutton(f.but, text = but.names[i], command = but.fun),
+ side = "left")
+ cat("button", i, "eingerichtet")
+ }
+ invisible(nt)
+}
diff --git a/R/sliderv.R b/R/sliderv.R
new file mode 100644
index 0000000..c87b20c
--- /dev/null
+++ b/R/sliderv.R
@@ -0,0 +1,38 @@
+"sliderv" <-
+function(refresh.code,names,minima,maxima,resolutions,starts,
+ title="control",no=0, set.no.value=0) {
+
+ if(no!=0)
+ return(as.numeric(tcltk::tclvalue(get(paste("slider",no,sep=""),envir=slider.env))))
+
+ if(set.no.value[1]!=0){
+ try(eval(parse(text=paste("tcltk::tclvalue(slider",set.no.value[1],")<-",
+ set.no.value[2],sep="")),envir=slider.env));
+ return(set.no.value[2])
+ }
+
+ if(!exists("slider.env")) slider.env<<-new.env()
+ #library(tcltk);
+ nt<-tcltk::tktoplevel(); tcltk::tkwm.title(nt,title); tcltk::tkwm.geometry(nt,"+0+0")
+ for(i in seq(names))
+ eval(parse(text=paste("assign(\"slider",i,"\",tcltk::tclVar(starts[i]),envir=slider.env)",sep="")))
+ for(i in seq(names)){
+ tcltk::tkpack(fr<-tcltk::tkframe(nt),side='left');
+ lab<-tcltk::tklabel(fr, text=names[i], width="1")
+ sc<-tcltk::tkscale(fr, command=refresh.code, from=minima[i],
+ to=maxima[i], showvalue=T, resolution=resolutions[i])
+ assign("sc",sc,envir=slider.env); tcltk::tkpack(lab,sc,side="top")
+ eval(parse(text=paste("tcltk::tkconfigure(sc,variable=slider",i,")",sep="")),
+ envir=slider.env)
+ }
+
+ tcltk::tkpack(fr<-tcltk::tkframe(nt),fill="x")
+ tcltk::tkpack(tcltk::tkbutton(fr, text="Exit", command=function()tcltk::tkdestroy(nt)),
+ side="right")
+ tcltk::tkpack(tcltk::tkbutton(fr, text="Reset",
+ command=function(){ for(i in seq(starts))
+ eval(parse(text=paste("tcltk::tclvalue(slider",i,")<-",starts[i],sep="")),envir=slider.env)
+ refresh.code()
+ } ),side="left")
+}
+
diff --git a/R/spread.labs.R b/R/spread.labs.R
new file mode 100644
index 0000000..e1419e6
--- /dev/null
+++ b/R/spread.labs.R
@@ -0,0 +1,32 @@
+spread.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]
+}
diff --git a/R/squishplot.R b/R/squishplot.R
new file mode 100644
index 0000000..84bc6ce
--- /dev/null
+++ b/R/squishplot.R
@@ -0,0 +1,39 @@
+squishplot <- 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']))
+}
+
diff --git a/R/subplot.R b/R/subplot.R
new file mode 100644
index 0000000..38764dc
--- /dev/null
+++ b/R/subplot.R
@@ -0,0 +1,71 @@
+subplot <- function(fun, x, y=NULL, size=c(1,1), vadj=0.5, hadj=0.5,
+ inset=c(0,0), type=c('plt','fig'), pars=NULL){
+
+# old.par <- par(no.readonly=TRUE)
+
+ type <- match.arg(type)
+ old.par <- par( c(type, 'usr', names(pars) ) )
+ on.exit(par(old.par))
+
+ if(missing(x)) x <- locator(2)
+
+ if(is.character(x)) {
+ if(length(inset) == 1) inset <- rep(inset,2)
+ x.char <- x
+ tmp <- par('usr')
+ x <- (tmp[1]+tmp[2])/2
+ y <- (tmp[3]+tmp[4])/2
+
+ if( length(grep('left',x.char, ignore.case=TRUE))) {
+ x <- tmp[1] + inset[1]*(tmp[2]-tmp[1])
+ if(missing(hadj)) hadj <- 0
+ }
+ if( length(grep('right',x.char, ignore.case=TRUE))) {
+ x <- tmp[2] - inset[1]*(tmp[2]-tmp[1])
+ if(missing(hadj)) hadj <- 1
+ }
+ if( length(grep('top',x.char, ignore.case=TRUE))) {
+ y <- tmp[4] - inset[2]*(tmp[4]-tmp[3])
+ if(missing(vadj)) vadj <- 1
+ }
+ if( length(grep('bottom',x.char, ignore.case=TRUE))) {
+ y <- tmp[3] + inset[2]*(tmp[4]-tmp[3])
+ if(missing(vadj)) vadj <- 0
+ }
+ }
+
+ xy <- xy.coords(x,y)
+
+ if(length(xy$x) != 2){
+ pin <- par('pin')
+ # tmp <- cnvrt.coords(xy$x[1],xy$y[1],'usr')$plt
+ tmpx <- grconvertX( xy$x[1], to='npc' )
+ tmpy <- grconvertY( xy$y[1], to='npc' )
+
+ x <- c( tmpx - hadj*size[1]/pin[1],
+ tmpx + (1-hadj)*size[1]/pin[1] )
+ y <- c( tmpy - vadj*size[2]/pin[2],
+ tmpy + (1-vadj)*size[2]/pin[2] )
+
+ # xy <- cnvrt.coords(x,y,'plt')$fig
+ xyx <- grconvertX(x, from='npc', to='nfc')
+ xyy <- grconvertY(y, from='npc', to='nfc')
+ } else {
+# xy <- cnvrt.coords(xy,,'usr')$fig
+ xyx <- grconvertX(x, to='nfc')
+ xyy <- grconvertY(y, to='nfc')
+ }
+
+ par(pars)
+ if(type=='fig'){
+ xyx <- grconvertX(xyx, from='nfc', to='ndc')
+ xyy <- grconvertY(xyy, from='nfc', to='ndc')
+ par(fig=c(xyx,xyy), new=TRUE)
+ } else {
+ par(plt=c(xyx,xyy), new=TRUE)
+ }
+ fun
+ tmp.par <- par(no.readonly=TRUE)
+
+ return(invisible(tmp.par))
+}
diff --git a/R/tdspinner.R b/R/tdspinner.R
new file mode 100644
index 0000000..7ffb015
--- /dev/null
+++ b/R/tdspinner.R
@@ -0,0 +1,14 @@
+# these are utility functions, possibly will be replaced by true internals
+
+
+tdspinner <- function(parent, ...) {
+ # this is a quick hack to provide spinboxes without loading tcltk2
+ tcltk::tkwidget(parent, "spinbox", ...)
+}
+
+
+have.ttk <- function() {
+ # based on e-mail from Prof. Brian Ripley
+ # will work until version 8.10 or 10.0, then may need to update
+ as.character(tcltk::tcl("info","tclversion")) >= "8.5"
+}
diff --git a/R/tests.R b/R/tests.R
new file mode 100644
index 0000000..b5403fe
--- /dev/null
+++ b/R/tests.R
@@ -0,0 +1,61 @@
+SnowsPenultimateNormalityTest <- 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)
+}
+
diff --git a/R/tkBrush.R b/R/tkBrush.R
new file mode 100644
index 0000000..d839f88
--- /dev/null
+++ b/R/tkBrush.R
@@ -0,0 +1,173 @@
+tkBrush <- function(mat,hscale=1.75,vscale=1.75,wait=TRUE,...){
+
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ first <- TRUE
+ bp <- FALSE
+
+ cols <- character(0)
+
+ colhist <- function(x,...){
+ tmp <- hist(x,plot=F)
+ br <- tmp$breaks
+ w <- as.numeric(cut(x,br,include.lowest=TRUE))
+ sy <- unlist(lapply(tmp$counts,function(x)seq(length=x)))
+ my <- max(sy)
+ sy <- sy/my
+ my <- 1/my
+ sy <- sy[order(order(x))]
+ tmp.usr <- par('usr'); on.exit(par(usr=tmp.usr))
+ par(usr=c(tmp.usr[1:2],0,1.5))
+ rect(br[w], sy-my, br[w+1], sy, col=cols, border=NA)
+ rect(br[-length(br)], 0, br[-1], tmp$counts*my)
+ if(first){
+# tmp <- cnvrt.coords((br[w]+br[w+1])/2,sy-my/2,'usr')$tdev
+ tmp <- list(
+ x=grconvertX((br[w]+br[w+1])/2, to='ndc'),
+ y=grconvertY( sy-my/2, to='ndc')
+ )
+ dx <<- c(dx,tmp$x)
+ dy <<- c(dy,tmp$y)
+ di <<- c(di,seq(along=tmp$x))
+ }
+ }
+
+ pcols <- rep('black',nrow(mat))
+ tcols <- rep(NA,nrow(mat))
+
+ ppch <- rep(1,nrow(mat))
+ tpch <- rep(NA,nrow(mat))
+
+ dx <- dy <- di <- numeric(0)
+
+ rx <- ry <- 0.5
+ rw <- rh <- 0.05
+
+ epch<-tcltk::tclVar(16)
+ ecol<-tcltk::tclVar('red')
+
+ devlims <- c(0.05,0.95,0.05,0.95)
+
+ replot <- function(){
+ if(first){
+ cols <<- pcols
+ pairs(mat, #upper.panel=NULL,
+ panel=function(x,y,...){
+ points(x,y,...)
+# tmp <- cnvrt.coords(x,y,'usr')$tdev
+ tmp <- list(
+ x=grconvertX(x,to='ndc'),
+ y=grconvertY(y,to='ndc') )
+ dx <<- c(dx,tmp$x)
+ dy <<- c(dy,tmp$y)
+ di <<- c(di,seq(tmp$x))
+ },
+ diag.panel=colhist)
+ first <<- FALSE
+ } else {
+
+ cols <<- ifelse(is.na(tcols),pcols,tcols)
+
+ pairs(mat, #upper.panel=NULL,
+ diag.panel=colhist,
+ pch=ifelse(is.na(tpch),ppch,tpch),
+ col=ifelse(is.na(tcols),pcols,tcols))
+ par(fig=c(0,1,0,1),plt=c(0,1,0,1),usr=c(0,1,0,1),xpd=TRUE)
+
+ rect(rx-rw,ry,rx,ry+rh,border='green')
+ }
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt,"Tk Brush")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+
+ tcltk::tkpack(img,side='left')
+
+
+ tcltk::tkpack( tcltk::tklabel(tt,text='pch:'),side='top')
+ tcltk::tkpack(tcltk::tkentry(tt,textvariable=epch),side='top')
+
+
+ tcltk::tkpack( tcltk::tklabel(tt,text='Color:'),side='top')
+ tcltk::tkpack( tcltk::tkentry(tt,textvariable=ecol),side='top')
+
+
+ tcltk::tkpack( tcltk::tkbutton(tt, text='Quit', command=function()tcltk::tkdestroy(tt)),
+ side='bottom')
+
+ iw <- as.numeric(tcltk::tcl('image','width',tcltk::tkcget(img,'-image')))
+ ih <- as.numeric(tcltk::tcl('image','height',tcltk::tkcget(img,'-image')))
+
+ mm <- function(x,y){
+ tx <- (as.numeric(x)-1)/iw
+ ty <- 1-(as.numeric(y)-1)/ih
+
+ if(tx-rw < devlims[1]) tx <- devlims[1]+rw
+ if(tx > devlims[2]) tx <- devlims[2]
+ if(ty < devlims[3]) ty <- devlims[3]
+ if(ty+rh > devlims[4]) ty <- devlims[4] - rh
+
+ rx <<- tx
+ ry <<- ty
+
+ tmp <- di[ dx >= rx-rw & dx <= rx & dy >= ry & dy <= ry+rh ]
+
+ tmpc <- rep(NA,nrow(mat))
+ tmpcol <- as.character(tcltk::tclvalue(ecol))
+ if( !( tmpcol %in% colors() ) ) tmpcol <- 'black'
+ tmpc[tmp] <- tmpcol
+ tcols <<- tmpc
+
+ tmpp <- rep(NA,nrow(mat))
+ tmppch <- as.numeric(tcltk::tclvalue(epch))
+ if(is.na(tmppch)) tmppch <- as.character(tcltk::tclvalue(epch))
+ tmpp[tmp] <- tmppch
+ tpch <<- tmpp
+
+ if(bp){
+ ppch <<- ifelse(is.na(tpch),ppch,tpch)
+ pcols <<- ifelse(is.na(tcols),pcols,tcols)
+ }
+ tkrplot::tkrreplot(img)
+ }
+
+ mmm <- function(){
+ tmp <- di[ dx >= rx-rw & dx <= rx & dy >= ry & dy <= ry+rh ]
+
+ tmpc <- rep(NA,nrow(mat))
+ tmpcol <- as.character(tcltk::tclvalue(ecol))
+ if( !( tmpcol %in% colors() ) ) tmpcol <- 'black'
+ tmpc[tmp] <- tmpcol
+ tcols <<- tmpc
+
+ tmpp <- rep(NA,nrow(mat))
+ tmppch <- as.numeric(tcltk::tclvalue(epch))
+ if(is.na(tmppch)) tmppch <- as.character(tcltk::tclvalue(epch))
+ tmpp[tmp] <- tmppch
+ tpch <<- tmpp
+
+ if(bp){
+ ppch <<- ifelse(is.na(tpch),ppch,tpch)
+ pcols <<- ifelse(is.na(tcols),pcols,tcols)
+ }
+ tkrplot::tkrreplot(img)
+ }
+
+ tcltk::tkbind(img, '<Motion>', mm)
+ tcltk::tkbind(img, '<ButtonPress-1>', function() {bp<<-TRUE;mmm()})
+ tcltk::tkbind(img, '<ButtonRelease-1>', function() bp<<-FALSE)
+ tcltk::tkbind(tt, '<Key-Up>',function(){rh <<- rh+0.01;mmm()})
+ tcltk::tkbind(tt, '<Key-Down>',function(){rh <<- rh-0.01;mmm()})
+ tcltk::tkbind(tt, '<Key-Left>',function(){rw <<- rw+0.01;mmm()})
+ tcltk::tkbind(tt, '<Key-Right>',function(){rw <<- rw-0.01;mmm()})
+
+ if(wait){
+ tcltk::tkwait.window(tt)
+ return(list(col=pcols, pch=ppch))
+ } else {
+ return(invisible(NULL))
+ }
+}
+
diff --git a/R/tkexamp.R b/R/tkexamp.R
new file mode 100644
index 0000000..c43a3e4
--- /dev/null
+++ b/R/tkexamp.R
@@ -0,0 +1,469 @@
+
+
+tkexamp <- function(FUN, param.list, vscale=1.5, hscale=1.5, wait=FALSE,
+ plotloc='top', an.play=TRUE, print=FALSE,...) {
+
+ if(!requireNamespace("tkrplot", quietly = TRUE)) {
+ stop('The tkrplot package is needed')
+ }
+
+ tke.tmp.env <- environment()
+
+ ocl <- cl <- substitute(FUN)
+ exargs <- as.list(quote(list()))
+
+ PlotYet <- FALSE
+
+ replot <- if(print){
+ function() {
+ if(PlotYet){
+ print(eval(cl))
+ }
+ }
+ } else {
+ function() {
+ if(PlotYet){
+ eval(cl)
+ }
+ }
+ }
+
+
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt,'Tk Example')
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side=plotloc)
+
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- vscale
+
+ fillframe <- function(frame,lst,pkdir,prfx) {
+ for(i in seq_along(lst)) {
+ vname <- paste(prfx, '.', i, sep='')
+ el <- lst[[i]]
+ eln <- names(lst)[i]
+ if( is.list(el[[1]]) ){
+ fr <- tcltk::tkframe(frame,relief='ridge',borderwidth=3)
+ tcltk::tkpack(fr, side=pkdir)
+ if(length(eln) && nchar(eln)){
+ tcltk::tkpack(tcltk::tklabel(fr, text=eln), side='top',anchor='nw')
+ }
+ Recall(fr,el,ifelse(pkdir=='top','left','top'),vname)
+ next
+ }
+ if( tolower(el[[1]]) == 'numentry' ){
+ tcltk::tkpack(fr <- tcltk::tkframe(frame),side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln),
+ side=ifelse(pkdir=='top','left','top'))
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if ('init' %in% names(el)) el$init else 1
+ alist <- list(fr, textvariable=tmp)
+ el2 <- el[-1]
+ el2$init <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack(do.call(tcltk::tkentry,alist),side=pkdir)
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ next
+ }
+ if( tolower(el[[1]]) == 'entry' ){
+ tcltk::tkpack(fr <- tcltk::tkframe(frame),side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln),
+ side=ifelse(pkdir=='top','left','top'))
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if ('init' %in% names(el)) el$init else ""
+ alist <- list(fr, textvariable=tmp)
+ el2 <- el[-1]
+ el2$init <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack(do.call('tkentry',alist),side=pkdir)
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(tcltk::tclvalue(VNAME),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ next
+ }
+ if( tolower(el[[1]])== 'slider' ){
+ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln), side='left', anchor='s', pady=4)
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else if( 'from' %in% names(el) ) {
+ el$from
+ } else { 1 }
+ alist <- list(fr, variable=tmp, orient='horizontal',
+ command=function(...)tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc))) )
+ el2 <- el[-1]
+ el2$init <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack( do.call('tkscale',alist), side=pkdir)
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ next
+ }
+ if( tolower(el[[1]])== 'vslider' ){
+ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln), side='left')
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else if( 'from' %in% names(el) ) {
+ el$from
+ } else { 1 }
+ alist <- list(fr, variable=tmp, orient='vertical',
+ command=function(...)tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc))) )
+ el2 <- el[-1]
+ el2$init <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack( do.call('tkscale',alist), side=pkdir)
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ next
+ }
+ if( tolower(el[[1]])== 'spinbox' ){
+ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln),
+ side=ifelse(pkdir=='top','left','top'),anchor='nw')
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else if( 'from' %in% names(el) ) {
+ el$from
+ } else { 1 }
+ tmp2 <- tcltk::tclvalue(tmp) # fix strange resetting on first
+ alist <- list(fr, textvariable=tmp,
+ command=function(...)tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc))) )
+ el2 <- el[-1]
+ el2$init <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack( do.call('tdspinner',alist), side=pkdir)
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ tcltk::tclvalue(tmp) <- tmp2 # rest of fix for reset
+ next
+ }
+ if( tolower(el[[1]])== 'checkbox' ){
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else { "F" }
+ alist <- list(frame, variable=tmp,text=eln, onvalue="T",
+ offvalue="F",
+ command=function(...)tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc))) )
+ el2 <- el[-1]
+ el2$init <- NULL
+ tmpvars <- if('values' %in% names(el)){
+ el$values
+ } else { "" }
+ el2$values <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack( do.call(tcltk::tkcheckbutton,alist), side=pkdir)
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(as.logical(tcltk::tclvalue(VNAME)),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ next
+ }
+ if( tolower(el[[1]])== 'combobox' ){
+ if( !have.ttk() ) stop('The combobox depends on having tcl 8.5 or higher, either install tcl 8.5 or rerun the function with a different control')
+ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln),
+ side=ifelse(pkdir=='top','left','top'))
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else { "" }
+ alist <- list(fr, textvariable=tmp)
+ el2 <- el[-1]
+ el2$init <- NULL
+ tmpvars <- if('values' %in% names(el)){
+ el$values
+ } else { "" }
+ el2$values <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack( cb <-do.call(tcltk::ttkcombobox,alist), side=pkdir)
+ tcltk::tkconfigure(cb, values=tmpvars)
+ tcltk::tkconfigure(cb, textvariable=tmp)
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(tcltk::tclvalue(VNAME),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ next
+ }
+ if( tolower(el[[1]])== 'radiobuttons' ){
+ tcltk::tkpack(fr <- tcltk::tkframe(frame,relief='groove',borderwidth=3),
+ side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln), side='top',
+ anchor='nw')
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else {
+ el$values[1]
+ }
+ el2 <- el[-1]
+ tmp.vals <- el2$values
+ el2$values <- NULL
+ el2$init <- NULL
+ alist <- list(fr, variable=tmp,
+ command=function()tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc))) )
+ pkdir2 <- ifelse( pkdir=='top', 'left', 'top' )
+ for( v in tmp.vals ){
+ tcltk::tkpack( do.call(tcltk::tkradiobutton, c(alist, value=v, text=v)),
+ side=pkdir2 )
+ }
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(tcltk::tclvalue(VNAME),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs, tmpl)
+ next
+ }
+ if( tolower(el[[1]])=='animate' ) {
+ if(an.play && requireNamespace('tcltk2',quietly = TRUE)) {
+ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln),side='left',anchor='s',pady=4)
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else if( 'from' %in% names(el) ) {
+ el$from
+ } else { 1 }
+ alist <- list(fr, variable=tmp, orient='horizontal',
+ command=function(...)tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc))) )
+ el2 <- el[-1]
+ tke.tmp.env$an.delay <- if('delay' %in% names(el) ) {
+ el$delay
+ } else {100}
+ el2$delay <- NULL
+ el2$init <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack( do.call(tcltk::tkscale,alist), side='left')
+ tke.tmp.env$an.inc <- an.inc <- if('resolution' %in% names(el)) {
+ el$resolution
+ } else { 1 }
+ tke.tmp.env$tke.tmp <- tmp
+ tke.tmp.env$an.to <- an.to <- el$to
+ tke.tmp.env$img <- img
+ tke.tmp.env$hsc <- hsc
+ tke.tmp.env$vsc <- vsc
+ #tmpc <- as.character(tmp)
+
+ # fname <- paste('tmp.tke.an.',eln, sep='')
+ # tmp.expr <- bquote( {
+ # tcl("set", .(as.character(tmp)), as.numeric(tclvalue(.(as.character(tmp)))) + an.inc)
+ # tkrreplot( img,
+ # hscale=as.numeric(tclvalue(hsc)),
+ # vscale=as.numeric(tclvalue(vsc)))
+ # })
+
+
+# tke.tmp.env$tmp.tke.an <- function() {
+# print(sys.frames())
+# print(sys.calls())
+# n <- ( an.to - as.numeric(tclvalue(tke.tmp)) )/an.inc
+# tclTaskSchedule(an.delay, tmp.expr, redo=n)
+# tclvalue(tke.tmp) <- as.numeric(tclvalue(tke.tmp)) + an.inc
+# tkrreplot( img,
+# hscale=as.numeric(tclvalue(hsc)),
+# vscale=as.numeric(tclvalue(vsc)))
+# }, redo=n)
+# }
+
+ tmpc <- as.character(tmp)
+ tmp.tke.an <- function() {
+ n <- (an.to - as.numeric(tcltk::tclvalue(tmp)))/an.inc
+ seq.val <- seq( as.numeric(tcltk::tclvalue(tmp)), an.to,
+ by=an.inc )
+ seq.wait <- seq( an.delay, by=an.delay, length=n+1)
+ for( i in seq_len(n+1) ) {
+ tmpfun <- eval(bquote(function(){
+ tcltk::tcl("set", .(tmpc), .(seq.val[i]))
+ tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)))
+ }))
+ tcltk2::tclAfter(seq.wait[i], tmpfun)
+ }
+ }
+
+
+
+ tcltk::tkpack( tcltk::tkbutton(fr, text="Play", command=tmp.tke.an),
+ side='left')
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs,tmpl)
+ } else { # using button hold
+ tcltk::tkpack(fr <- tcltk::tkframe(frame), side=pkdir)
+ tcltk::tkpack(tcltk::tklabel(fr,text=eln),side='left',anchor='s',pady=4)
+ tmp <- tcltk::tclVar()
+ tcltk::tclvalue(tmp) <- if('init' %in% names(el)) {
+ el$init
+ } else if( 'from' %in% names(el) ) {
+ el$from
+ } else { 1 }
+ alist <- list(fr, variable=tmp, orient='horizontal',
+ command=function(...)tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc))) )
+ el2 <- el[-1]
+
+ tke.tmp.env$an.delay <- an.delay <- if('delay' %in% names(el) ) {
+ el$delay
+ } else {100}
+ el2$delay <- NULL
+ el2$init <- NULL
+ alist <- c(alist,el2)
+ tcltk::tkpack( do.call(tcltk::tkscale,alist), side='left')
+ tke.tmp.env$an.inc <- an.inc <- if('resolution' %in% names(el)) {
+ el$resolution
+ } else { 1 }
+ tke.tmp.env$an.to <- an.to <- el$to
+ tke.tmp.env$tke.tmp <- tmp
+ tke.tmp.env$img <- img
+ tke.tmp.env$hsc <- hsc
+ tke.tmp.env$vsc <- vsc
+
+ tke.tmp.env$tmp.tke.an <- function() {
+ if( as.numeric(tcltk::tclvalue(tke.tmp)) < an.to ) {
+ tcltk::tclvalue(tke.tmp) <- as.numeric(tcltk::tclvalue(tke.tmp)) + an.inc
+ tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)))
+ }
+ }
+
+ tcltk::tkpack( tcltk::tkbutton(fr, text='Inc', command=tmp.tke.an,
+ repeatdelay=1, repeatinterval=an.delay
+ ), side='left')
+ tmpcl <- as.list(cl)
+ tmpl <- list(substitute(as.numeric(tcltk::tclvalue(VNAME)),
+ list(VNAME=as.character(tmp))))
+ names(tmpl) <- eln
+ cl <<- as.call(c(tmpcl,tmpl))
+ exargs <<- c(exargs,tmpl)
+ }
+ next
+ }
+ }
+ }
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt),side='bottom', fill='x')
+
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function(){tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)))} ),
+ side='left',anchor='s')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Print Call",
+ command=function(){
+ tmp <- c(as.list(ocl),eval(as.call(exargs)))
+ cat(deparse(as.call(tmp)),"\n")
+ flush.console()
+ }),
+ side='left',anchor='s')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ fillframe(tt, param.list, plotloc, 'tkv')
+ PlotYet <- TRUE
+ tkrplot::tkrreplot(img, hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)))
+
+ if(wait){
+ tcltk::tkwait.window(tt)
+ return(eval(as.call(exargs)))
+ } else {
+ return(invisible(NULL))
+ }
+
+}
+
+
+
+# tke.test <- list(Parameters=list(
+# pch=list('spinbox',init=1,values=c(0:25,32:255),width=5),
+# cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1),
+# type=list('radiobuttons',init='b',
+# values=c('p','l','b','o','c','h','s','S','n'),
+# width=5),
+# lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5),
+# lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5),
+# xpd=list('checkbox')
+# ))
+#
+#
+# tke.test3 <- list(Parameters=list(
+# pch=list('spinbox',init=1,from=0,to=255,width=5),
+# cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1),
+# type=list('combobox',init='b',
+# values=c('p','l','b','o','c','h','s','S','n'),
+# width=5),
+# lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5),
+# lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5)
+# ))
+#
+#
+#
+# tke.test2 <- list(pch=list('numentry',init=1,width=3),
+# cex=list('slider',init=1,from=0.2,to=2.5,resolution=0.1),
+# type=list('entry',init='p', width=5))
+#
+#
+#
+# tke.test1 <- list(pch=list('numentry',init=1,width=3),
+# cex=list('numentry',init=1),
+# type=list('entry',init='p', width=5))
+#
+#
+#
diff --git a/R/tree.demo.R b/R/tree.demo.R
new file mode 100644
index 0000000..07820c7
--- /dev/null
+++ b/R/tree.demo.R
@@ -0,0 +1,33 @@
+"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) )
+ }
+
+
+}
+
diff --git a/R/triplot.R b/R/triplot.R
new file mode 100644
index 0000000..524839d
--- /dev/null
+++ b/R/triplot.R
@@ -0,0 +1,111 @@
+"triplot" <-
+function(x, y=NULL, z=NULL,
+ labels=dimnames(x)[[2]],
+ txt=dimnames(x)[[1]], legend=NULL,
+ legend.split=NULL,
+ inner=TRUE, inner.col=c('lightblue','pink'),
+ inner.lty=c(2,3), add=FALSE, main="", ...){
+
+ old.par <- par(xpd=TRUE)
+ on.exit(par(old.par))
+
+ if( is.data.frame(x) ) x <- as.matrix(x)
+ x <- cbind(x,y,z)
+ if( ncol(x) < 2 || ncol(x) > 3 ){
+ stop("need 2 or 3 columns")
+ }
+ if( ncol(x)==3 ){
+ x <- sweep(x,1,FUN="/",apply(x,1,sum))
+ }
+ if( ncol(x)==2 ){
+ x <- cbind(x, 1-x[,1]-x[,2])
+ }
+
+ if(dev.cur()==1){
+ dev.new()
+ add <- FALSE
+ }
+
+ if( !add ){
+
+ pin <- par("pin")
+ xstar <- (pin[1]/pin[2]*sqrt(3)-2)/2
+
+ plot( c(0,1,2,0), c(0,sqrt(3),0,0), type="l",
+ lwd=3, xlim=c(-xstar,2+xstar),
+ xlab="",ylab="",axes=FALSE, main=main)
+
+ if(inner){
+ lines( c(1,1.5,0.5,1), c(0,sqrt(3)/2,sqrt(3)/2,0),
+ lwd=.5, col=inner.col[1], lty=inner.lty[1])
+ lines( c(1.25, 1, .75, 1.25),
+ c(sqrt(3)/4, sqrt(3)/2, sqrt(3)/4, sqrt(3)/4),
+ lwd=0.25, col=inner.col[2],lty=inner.lty[2])
+ }
+
+ if(length(labels)==0){
+ labels <- c("X","Y","Z")
+ }
+
+ ystar <- par("cxy")[2] * 1.1
+ text( c(0,2,1), c(-ystar,-ystar,sqrt(3)+ystar),
+ labels, cex=1.5 )
+ }
+
+ newy <- x[,3] * sqrt(3)
+ newx <- 2-2*x[,1]-x[,3]
+
+ if(length(txt)==length(newx)){
+ text(newx,newy,txt,...)
+ } else {
+ points(newx,newy,...)
+ }
+
+ if(length(legend)==length(newx)){
+ labpos <- function(y){
+ strh <- par("cxy")[2]*1.15
+ y2 <- sort(y)
+ df <- y2[-1] - y2[-length(y2)]
+ i <- 1
+ while(any (df < strh)){
+ y2[c(df < strh, FALSE)] <- y2[ c(df < strh,FALSE)] - strh/10
+ y2[c(FALSE, df < strh)] <- y2[ c(FALSE,df < strh)] + strh/10
+ if(min(y2)<0){y2 <- y2 - min(y2)}
+ y2 <- sort(y2)
+ df <- y2[-1] - y2[ -length(y2)]
+ i <- i+1
+ if(i>100){break}
+ }
+ y2
+ }
+
+ if(length(legend.split)==1){
+ tmp.x <- quantile(newx, legend.split)
+ y1 <- newy[newx <= tmp.x]
+ y1 <- labpos(y1)[order(order(y1))]
+ text(rep(-0.01,length(y1)), y1, legend[newx<=tmp.x], adj=1)
+ segments(rep(0,length(y1)), y1, newx[newx<=tmp.x], newy[newx<=tmp.x])
+
+ y2 <- newy[newx>tmp.x]
+ y2 <- labpos(y2)[order(order(y2))]
+ text(rep(2.01,length(y2)), y2, legend[newx>tmp.x], adj=0)
+ segments(rep(2,length(y2)), y2, newx[newx>tmp.x], newy[newx>tmp.x])
+ } else {
+ if(any(newx <= 1)){
+ y1 <- newy[newx<=1]
+ y1 <- labpos(y1)[order(order(y1))]
+ text(rep(-0.01,length(y1)), y1, legend[newx<=1],adj=1)
+ segments(rep(0,length(y1)), y1, newx[newx<=1], newy[newx<=1])
+ }
+ if(any(newx > 1)){
+ y2 <- newy[newx>1]
+ y2 <- labpos(y2)[order(order(y2))]
+ text(rep(2.01,length(y2)), y2, legend[newx>1],adj=0)
+ segments(rep(2,length(y2)), y2, newx[newx>1], newy[newx>1])
+ }
+ }
+ }
+
+ invisible(cbind(x=newx,y=newy))
+}
+
diff --git a/R/updateusr.R b/R/updateusr.R
new file mode 100644
index 0000000..1298239
--- /dev/null
+++ b/R/updateusr.R
@@ -0,0 +1,21 @@
+updateusr <- 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.
diff --git a/R/vis.binom.R b/R/vis.binom.R
new file mode 100644
index 0000000..55c3da4
--- /dev/null
+++ b/R/vis.binom.R
@@ -0,0 +1,106 @@
+"vis.binom" <-
+function(){
+
+ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package')
+
+ if(!exists('slider.env')) slider.env<<-new.env()
+
+
+ n <- 10 ; assign('n',tcltk::tclVar(n),envir=slider.env)
+ p <- 0.5; assign('p',tcltk::tclVar(p),envir=slider.env)
+
+ sn <- 0 ; assign('sn',tcltk::tclVar(sn), envir=slider.env)
+ sp <- 0 ; assign('sp',tcltk::tclVar(sp), envir=slider.env)
+
+
+ binom.refresh <- function(...){
+ n <- as.numeric(evalq(tcltk::tclvalue(n), envir=slider.env))
+ p <- as.numeric(evalq(tcltk::tclvalue(p), envir=slider.env))
+
+ sn <- as.numeric(evalq(tcltk::tclvalue(sn), envir=slider.env))
+ sp <- as.numeric(evalq(tcltk::tclvalue(sp), envir=slider.env))
+
+ mu <- p*n
+ sd <- sqrt(n*p*(1-p))
+
+ if(sn){
+ xx <- seq(-1,n+1, length=250)
+ plot(xx,dnorm(xx,mu,sd), type='l', col='green',
+ ylim=range(0,dnorm(mu,mu,sd),dbinom( seq(0,n), n, p)),
+ xlab='x', ylab='Probability')
+ if(sp){
+ points( seq(0,n), dpois( seq(0,n), mu ), type='h', col='blue')
+ points( seq(0,n), dpois( seq(0,n), mu ), pch='-', col='blue',cex=2)
+ }
+ abline(h=0)
+ lines(xx, dnorm(xx,mu,sd), col='green')
+ points( seq(0,n), dbinom( seq(0,n), n, p), type='h' )
+ points( seq(0,n), dbinom( seq(0,n), n, p), type='p' )
+
+ } else {
+ if(sp){
+ plot( seq(0,n), dpois( seq(0,n), mu ), type='h', col='blue',
+ xlim=c(-1,n+1), xlab='x', ylab='Probability',
+ ylim=range(0,dpois( seq(0,n), mu), dbinom(seq(0,n),n,p)))
+ points( seq(0,n), dpois( seq(0,n), mu ), pch='-', col='blue',cex=2)
+ points( seq(0,n), dbinom( seq(0,n), n, p), type='h')
+ } else {
+ plot( seq(0,n), dbinom( seq(0,n), n, p), type='h',
+ xlim=c(-1,n+1), xlab='x', ylab='Probability')
+ }
+ abline(h=0)
+ points( seq(0,n), dbinom( seq(0,n), n, p) )
+ }
+
+ title( paste("Mean =",round(mu,3),"Std. Dev. =",round(sd,3)) )
+
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Visualizing the Binomial Distribution')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ # n
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='n', width='10'), side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=binom.refresh, from=1, to=100,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=n), envir=slider.env)
+
+ # p
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='p', width='10'), side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=binom.refresh, from=0, to=1,
+ orient='horiz',
+ resolution=0.01, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=p), envir=slider.env)
+
+ # show normal
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=binom.refresh),
+ side='left')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Show Normal Approximation',width='25'),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sn), envir=slider.env)
+
+ # show poisson
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=binom.refresh),
+ side='left')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Show Poisson Approximation',width='25'),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sp), envir=slider.env)
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=binom.refresh), side='left')
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
diff --git a/R/vis.boxcox.R b/R/vis.boxcox.R
new file mode 100644
index 0000000..8b2b292
--- /dev/null
+++ b/R/vis.boxcox.R
@@ -0,0 +1,134 @@
+vis.boxcox.old <-
+function(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1) ) {
+
+ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package')
+
+
+ x <- runif(100, 1, 10)
+ y <- 3+2*x + rnorm(100)
+ if ( min(y) <= 0 ) y <- y - min(y) + 0.05
+ if (lambda==0) {
+ y <- exp(y)
+ } else {
+ y <- y^(1/lambda)
+ }
+
+ if(!exists('slider.env')) slider.env <<-new.env()
+
+ lam <- 1 ; assign('lam',tcltk::tclVar(lam), envir=slider.env)
+
+ bc.refresh <- function(...){
+ lam <- as.numeric(evalq(tcltk::tclvalue(lam), envir=slider.env))
+
+ old.par <- par(mfcol=c(2,2))
+ on.exit(par(old.par))
+
+ tmp1 <- lm(y~x)
+ tmp2 <- lm(bct(y,lam)~x)
+ plot(x,y,main="Raw Data")
+ abline(tmp1)
+ scatter.smooth(x,resid(tmp1),main="Raw Residuals",ylab='Residuals')
+ abline(h=0, lty=2 )
+ plot(x,bct(y,lam), main=bquote( lambda == .(lam) ),ylab="Transformed y" )
+ abline(tmp2)
+ scatter.smooth(x,resid(tmp2), main=bquote( lambda == .(lam) ),
+ ylab="Residuals")
+ abline(h=0, lty=2)
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m, 'Box Cox Transform')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='lambda', width='10'), side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=bc.refresh, from=-2, to=3, orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=lam), envir=slider.env)
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=bc.refresh), side='left')
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
+vis.boxcox <- function(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1),
+ hscale=1.5, vscale=1.5, wait=FALSE) {
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+ x <- runif(100, 1, 10)
+ y <- 3+2*x + rnorm(100)
+ if( min(y) <= 0 ) y <- y - min(y) + 0.05
+ if(lambda==0) {
+ y <- exp(y)
+ } else {
+ y <- y^(1/lambda)
+ }
+
+ lam <- tcltk::tclVar()
+ tcltk::tclvalue(lam) <- 1
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- hscale
+
+ replot <- function(...) {
+ tmp.l <- as.numeric(tcltk::tclvalue(lam))
+
+ par(mfcol=c(2,2))
+
+ tmp1 <- lm(y~x)
+ tmp2 <- lm( bct(y,tmp.l)~x)
+ plot(x,y,main="Raw Data")
+ abline(tmp1)
+ scatter.smooth(x,resid(tmp1), main="Raw Residuals", ylab='Residuals')
+ abline(h=0, lty=2)
+ plot(x,bct(y,tmp.l), main=bquote( lambda == .(tmp.l) ), ylab="Transformed y")
+ abline(tmp2)
+ scatter.smooth(x,resid(tmp2), main=bquote( lambda == .(tmp.l) ),
+ ylab='Residuals')
+ abline(h=0, lty=2)
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Box Cox Demo")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='lambda: '), side='left', anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=lam, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=-2, to=4, resolution=.05), side='right')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ) ),
+ side='left',anchor='s')
+
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ if(wait) {
+ tcltk::tkwait.window(tt)
+ return( list(lambda = as.numeric(tcltk::tclvalue(lam)),
+ x=x, y=y,
+ ty = bct(y, as.numeric(tcltk::tclvalue(lam)))
+ ))
+ } else {
+ return(invisible(NULL))
+ }
+}
+
diff --git a/R/vis.boxcoxu.R b/R/vis.boxcoxu.R
new file mode 100644
index 0000000..07aa87a
--- /dev/null
+++ b/R/vis.boxcoxu.R
@@ -0,0 +1,143 @@
+vis.boxcoxu.old <-
+function(lambda = sample( c(-1, -0.5, 0, 1/3, 1/2, 1, 2), 1)) {
+
+ if( !requireNamespace('tkrplot', quietly = TRUE) ) stop('This function depends on the tkrplot package being available')
+
+
+ y <- rnorm(1000, 7, 2)
+ if( min(y) <= 0 ) y <- y - min(y)+0.05
+ if (lambda==0) {
+ y <- exp(y)
+ } else {
+ y <- y^(1/lambda)
+ }
+
+ if(!exists('slider.env')) slider.env <<-new.env()
+ #library(tcltk)
+
+ lam <- 1 ; assign('lam',tcltk::tclVar(lam), envir=slider.env)
+
+ bc.refresh <- function(...){
+ lam <- as.numeric(evalq(tcltk::tclvalue(lam), envir=slider.env))
+
+ old.par <- par(mfcol=c(2,2))
+ on.exit(par(old.par))
+
+ ty <- bct(y,lam)
+ hist(y, prob=T, xlab='x', main='Histogram of x')
+ xx <- seq(min(y),max(y), length=250)
+ lines(xx, dnorm( xx, mean(y), sqrt(var(y)) ))
+ qqnorm(y, xlab='x')
+ qqline(y)
+
+ hist(ty, prob=T, xlab='Transformed x', main = 'Histogram of Transformed x')
+ xx <- seq(min(ty),max(ty), length=250)
+ lines(xx,dnorm(xx, mean(ty), sqrt(var(ty)) ) )
+
+ qqnorm(ty, xlab='Transformed x')
+ qqline(ty)
+ }
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m, 'Box Cox Transform')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(m), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='lambda', width='10'), side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=bc.refresh, from=-2, to=3, orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=lam), envir=slider.env)
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=bc.refresh), side='left')
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
+
+
+
+vis.boxcoxu <- function(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1),
+ y, xlab=deparse(substitute(y)),
+ hscale=1.5, vscale=1.5, wait=FALSE) {
+
+ if( missing(y) ) {
+ if(missing(xlab)) xlab <- 'y'
+ y <- rnorm(1000, 7, 2)
+ if( min(y) <= 0 ) y <- y - min(y) + 0.05
+ if(lambda==0) {
+ y <- exp(y)
+ } else {
+ y <- y^(1/lambda)
+ }
+ }
+
+
+ lam <- tcltk::tclVar()
+ tcltk::tclvalue(lam) <- 1
+ hsc <- tcltk::tclVar()
+ tcltk::tclvalue(hsc) <- hscale
+ vsc <- tcltk::tclVar()
+ tcltk::tclvalue(vsc) <- hscale
+
+ replot <- function(...) {
+ tmp.l <- as.numeric(tcltk::tclvalue(lam))
+
+ par(mfcol=c(2,2))
+
+ ty <- bct(y,tmp.l)
+ hist(y, prob=TRUE, xlab=xlab, main = paste('Histogram of',xlab))
+ xx <- seq(min(y),max(y), length=250)
+ lines(xx, dnorm(xx, mean(y), sd(y)) )
+ qqnorm(y, xlab=xlab)
+ qqline(y)
+
+ hist(ty, prob=TRUE, xlab=paste("Transformed",xlab),
+ main=paste("Histogram of Transformed",xlab))
+ xx <- seq(min(ty),max(ty), length=250)
+ lines(xx,dnorm(xx, mean(ty), sd(ty)))
+ qqnorm(ty, xlab=paste("Transformed",xlab))
+ qqline(ty)
+ }
+
+ tt <- tcltk::tktoplevel()
+ tcltk::tkwm.title(tt, "Box Cox Demo")
+
+ img <- tkrplot::tkrplot(tt, replot, vscale=vscale, hscale=hscale)
+ tcltk::tkpack(img, side='top')
+
+ tcltk::tkpack(fr <- tcltk::tkframe(tt), side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='lambda: '), side='left', anchor='s')
+ tcltk::tkpack(tcltk::tkscale(fr, variable=lam, orient='horizontal',
+ command=function(...) tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ),
+ from=-2, to=4, resolution=.05), side='right')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Refresh", command=function() tkrplot::tkrreplot(img,
+ hscale=as.numeric(tcltk::tclvalue(hsc)),
+ vscale=as.numeric(tcltk::tclvalue(vsc)) ) ),
+ side='left',anchor='s')
+
+ tcltk::tkpack(tcltk::tkbutton(tfr, text="Exit", command=function()tcltk::tkdestroy(tt)),
+ side='right',anchor='s')
+
+ tcltk::tkpack(tfr <- tcltk::tkframe(tt), side='bottom', fill='x')
+ tcltk::tkpack(tcltk::tklabel(tfr,text="Hscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=hsc,width=6), side='left')
+ tcltk::tkpack(tcltk::tklabel(tfr,text=" Vscale: "), side='left')
+ tcltk::tkpack(tcltk::tkentry(tfr,textvariable=vsc,width=6), side='left')
+
+ if(wait) {
+ tcltk::tkwait.window(tt)
+ return( list(lambda = as.numeric(tcltk::tclvalue(lam)),
+ y = y,
+ ty = bct(y,as.numeric(tcltk::tclvalue(lam))) ) )
+ } else {
+ return(invisible(NULL))
+ }
+}
+
diff --git a/R/vis.gamma.R b/R/vis.gamma.R
new file mode 100644
index 0000000..7ec9890
--- /dev/null
+++ b/R/vis.gamma.R
@@ -0,0 +1,278 @@
+"vis.gamma" <-
+function(){
+
+ if(!exists('slider.env')) slider.env<<-new.env()
+ if(!requireNamespace('tcltk', quietly = TRUE)) {
+ stop('This function needs the tcltk package')
+ }
+
+ shape <- 1; assign('shape',tcltk::tclVar(shape),envir=slider.env)
+ rate <- 1; assign('rate',tcltk::tclVar(rate),envir=slider.env)
+ scale <- 1; assign('scale',tcltk::tclVar(scale),envir=slider.env)
+ mean <- 1; assign('mean', tcltk::tclVar(mean), envir=slider.env)
+ sd <- 1; assign('sd',tcltk::tclVar(sd), envir=slider.env)
+
+ se <- 0; assign('se', tcltk::tclVar(se), envir=slider.env)
+ sc2 <- 0; assign('sc2', tcltk::tclVar(sc2), envir=slider.env)
+ sg <- 1; assign('sg', tcltk::tclVar(sg), envir=slider.env)
+
+ xmin <- 0; assign('xmin',tcltk::tclVar(xmin),envir=slider.env)
+ xmax <- 5; assign('xmax',tcltk::tclVar(xmax),envir=slider.env)
+ ymin <- 0; assign('ymin',tcltk::tclVar(ymin),envir=slider.env)
+ ymax <- 1; assign('ymax',tcltk::tclVar(ymax),envir=slider.env)
+
+ old.shape <- shape
+ old.rate <- rate
+ old.scale <- scale
+ old.mean <- mean
+ old.sd <- sd
+
+
+ gamma.refresh <- function(...){
+
+ shape <- as.numeric(evalq(tcltk::tclvalue(shape), envir=slider.env))
+ rate <- as.numeric(evalq(tcltk::tclvalue(rate), envir=slider.env))
+ scale <- as.numeric(evalq(tcltk::tclvalue(scale), envir=slider.env))
+ mean <- as.numeric(evalq(tcltk::tclvalue(mean), envir=slider.env))
+ sd <- as.numeric(evalq(tcltk::tclvalue(sd), envir=slider.env))
+
+ if ( shape != old.shape ) {
+
+ mean <- shape * scale
+ sd <- round( sqrt(shape)*scale, 6 );
+
+ try(eval(parse(text=paste("tcltk::tclvalue(mean)<-",
+ mean,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(sd)<-",
+ sd,sep="")),envir=slider.env));
+ old.shape <<- shape; old.mean <<- mean; old.sd <<- sd
+
+ }
+
+ if ( rate != old.rate ) {
+
+ scale <- round(1/rate, 6)
+ mean <- shape * scale
+ sd <- round( sqrt(shape)*scale, 6 );
+
+ try(eval(parse(text=paste("tcltk::tclvalue(scale)<-",
+ scale,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(mean)<-",
+ mean,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(sd)<-",
+ sd,sep="")),envir=slider.env));
+ old.rate <<- rate; old.scale <<- scale;
+ old.mean <<- mean; old.sd <<- sd
+
+ }
+
+ if ( scale != old.scale ) {
+
+ rate <- round(1/scale, 6)
+ mean <- shape * scale
+ sd <- round( sqrt(shape)*scale, 6 );
+
+ try(eval(parse(text=paste("tcltk::tclvalue(rate)<-",
+ rate,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(mean)<-",
+ mean,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(sd)<-",
+ sd,sep="")),envir=slider.env));
+ old.rate <<- rate; old.scale <<- scale;
+ old.mean <<- mean; old.sd <<- sd
+
+ }
+
+ if ( mean != old.mean ) {
+
+ shape <- round( (mean/sd)^2, 6 )
+ scale <- round( mean/shape, 6 )
+ rate <- round(1/scale, 6)
+
+ try(eval(parse(text=paste("tcltk::tclvalue(rate)<-",
+ rate,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(shape)<-",
+ shape,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(scale)<-",
+ scale,sep="")),envir=slider.env));
+ old.shape <<- shape; old.rate <<- rate; old.scale <<- scale;
+ old.mean <<- mean; old.sd <<- sd
+
+ }
+
+
+ if ( sd != old.sd ) {
+
+ shape <- round( (mean/sd)^2, 6 )
+ scale <- round( mean/shape, 6 )
+ rate <- round(1/scale, 6)
+
+ try(eval(parse(text=paste("tcltk::tclvalue(rate)<-",
+ rate,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(shape)<-",
+ shape,sep="")),envir=slider.env));
+ try(eval(parse(text=paste("tcltk::tclvalue(scale)<-",
+ scale,sep="")),envir=slider.env));
+ old.shape <<- shape; old.rate <<- rate; old.scale <<- scale;
+ old.mean <<- mean; old.sd <<- sd
+
+ }
+
+
+ se <- as.numeric(evalq(tcltk::tclvalue(se), envir=slider.env))
+ sc2 <- as.numeric(evalq(tcltk::tclvalue(sc2), envir=slider.env))
+ sg <- as.numeric(evalq(tcltk::tclvalue(sg), envir=slider.env))
+
+ xmin <- as.numeric(evalq(tcltk::tclvalue(xmin), envir=slider.env))
+ xmax <- as.numeric(evalq(tcltk::tclvalue(xmax), envir=slider.env))
+ ymin <- as.numeric(evalq(tcltk::tclvalue(ymin), envir=slider.env))
+ ymax <- as.numeric(evalq(tcltk::tclvalue(ymax), envir=slider.env))
+
+ xx <- seq(xmin,xmax, length=500)
+
+ plot(xx,xx, xlim=c(xmin,xmax),ylim=c(ymin,ymax),
+ xlab='x', ylab='y',type='n')
+
+ if(se) {
+ yye <- dexp(xx,1/mean)
+ lines(xx,yye, lwd=3, col='green')
+ lines(c(mean,mean),c(ymin,dexp(mean,1/mean)), lty=2, col='green')
+ lines(c(mean,mean*2), dexp(mean*2, 1/mean)*c(1,1), lty=2, col='green')
+ }
+
+ if(sc2) {
+ yyc <- dchisq(xx,mean)
+ lines(xx,yyc, lwd=3, col='blue')
+ lines(c(mean,mean),c(ymin,dchisq(mean,mean)), lty=2, col='blue')
+ lines(c(mean,mean+sqrt(2*mean)), dchisq(mean+sqrt(2*mean), mean)*c(1,1),
+ lty=2, col='blue')
+ }
+
+ if(sg) {
+ yyg <- dgamma(xx,shape,rate)
+ lines(xx,yyg, lwd=2)
+ lines(c(mean,mean),c(ymin,dgamma(mean,shape,rate)), lty=2)
+ lines(c(mean,mean+sd), dgamma(mean+sd, shape, rate)*c(1,1),
+ lty=2)
+ }
+
+ }
+
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Visualizing the Gamma Distribution')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ # shape
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Shape', width='10'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=10,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=shape),envir=slider.env)
+
+ # rate
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Rate', width='10'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=10,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=rate),envir=slider.env)
+
+ # scale
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Scale', width='10'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=10,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=scale),envir=slider.env)
+
+ # mean
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Mean', width='10'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=100,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=mean),envir=slider.env)
+
+ # sd
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='S.D.', width='10'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=gamma.refresh, from=0.1, to=40,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sd),envir=slider.env)
+
+
+ # show exponential
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=gamma.refresh),
+ side='left')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Show Exponential Distribution', width='25'),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=se),envir=slider.env)
+
+ # show chisquared
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=gamma.refresh),
+ side='left')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Show Chi-squared Distribution', width='25'),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sc2),envir=slider.env)
+
+ # show gamma
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=gamma.refresh),
+ side='left')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Show Gamma Distribution', width='25'),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sg),envir=slider.env)
+
+
+ # xmin
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Xmin:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=xmin), envir=slider.env)
+
+ # xmax
+ tcltk::tkpack(tcltk::tklabel(fr, text='Xmax:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=xmax), envir=slider.env)
+
+ # ymin
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Ymin:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=ymin), envir=slider.env)
+
+ # ymax
+ tcltk::tkpack(tcltk::tklabel(fr, text='Ymax:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=ymax), envir=slider.env)
+
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=gamma.refresh),side='left')
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
diff --git a/R/vis.normal.R b/R/vis.normal.R
new file mode 100644
index 0000000..1e433bf
--- /dev/null
+++ b/R/vis.normal.R
@@ -0,0 +1,126 @@
+"vis.normal" <-
+function(){
+
+ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package')
+
+
+ if(!exists('slider.env')) slider.env<<-new.env()
+ #library(tcltk)
+
+ mu <- 0; assign('mu',tcltk::tclVar(mu),envir=slider.env)
+ sd <- 1; assign('sd',tcltk::tclVar(sd),envir=slider.env)
+ s2 <- 1; assign('s2',tcltk::tclVar(s2),envir=slider.env)
+ xmin <- -5; assign('xmin',tcltk::tclVar(xmin),envir=slider.env)
+ xmax <- 5; assign('xmax',tcltk::tclVar(xmax),envir=slider.env)
+ ymin <- 0; assign('ymin',tcltk::tclVar(ymin),envir=slider.env)
+ ymax <- round(dnorm(0,0,.5),2); assign('ymax',tcltk::tclVar(ymax),envir=slider.env)
+
+ sd.old <- sd
+ s2.old <- s2
+
+ norm.refresh <- function(...){
+
+ mu <- as.numeric(evalq(tcltk::tclvalue(mu), envir=slider.env))
+ sd <- as.numeric(evalq(tcltk::tclvalue(sd), envir=slider.env))
+ s2 <- as.numeric(evalq(tcltk::tclvalue(s2), envir=slider.env))
+
+ if(sd != sd.old) {
+ s2 <- round(sd^2,5); # assign('s2',tclVar(s2),envir=slider.env)
+ try(eval(parse(text=paste("tcltk::tclvalue(s2)<-",
+ s2,sep="")),envir=slider.env));
+ sd.old <<- sd; s2.old <<- s2
+ }
+
+ if(s2 != s2.old) {
+ s2 <- as.numeric(evalq(tcltk::tclvalue(s2), envir=slider.env))
+ sd <- round(sqrt(s2),5); # assign('sd',tclVar('sd'), envir=slider.env)
+ try(eval(parse(text=paste("tcltk::tclvalue(sd)<-",
+ sd,sep="")),envir=slider.env));
+ sd.old <<- sd; s2.old <<- s2
+ }
+
+ xmin <- as.numeric(evalq(tcltk::tclvalue(xmin), envir=slider.env))
+ xmax <- as.numeric(evalq(tcltk::tclvalue(xmax), envir=slider.env))
+ ymin <- as.numeric(evalq(tcltk::tclvalue(ymin), envir=slider.env))
+ ymax <- as.numeric(evalq(tcltk::tclvalue(ymax), envir=slider.env))
+
+ xx <- seq(xmin,xmax, length=500)
+ yy <- dnorm(xx,mu,sd)
+ plot(xx,yy,type='l', xlim=c(xmin,xmax), ylim=c(ymin,ymax),
+ ylab='',xlab='x')
+ lines(c(mu,mu),c(par('usr')[3],dnorm(0,0,sd)), lty=2, col='blue')
+ lines(c(mu,mu+sd), dnorm(sd,0,sd)*c(1,1), lty=2, col='blue')
+
+ }
+
+
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Visualizing the Normal Distribution')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ # mean
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Mean', width='20'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=norm.refresh, from=-3, to=3,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=mu),envir=slider.env)
+
+ # sd
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Standard Deviation', width='20'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=norm.refresh, from=.5, to=3,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sd),envir=slider.env)
+
+ # variance
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Variance', width='20'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=norm.refresh, from=.25, to=9,
+ orient='horiz',
+ resolution=0.1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=s2),envir=slider.env)
+
+
+ # xmin
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Xmin:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=xmin), envir=slider.env)
+
+ # xmax
+ tcltk::tkpack(tcltk::tklabel(fr, text='Xmax:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=xmax), envir=slider.env)
+
+ # ymin
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Ymin:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=ymin), envir=slider.env)
+
+ # ymax
+ tcltk::tkpack(tcltk::tklabel(fr, text='Ymax:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=ymax), envir=slider.env)
+
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=norm.refresh),side='left')
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
diff --git a/R/vis.t.R b/R/vis.t.R
new file mode 100644
index 0000000..1f159f1
--- /dev/null
+++ b/R/vis.t.R
@@ -0,0 +1,100 @@
+"vis.t" <-
+function(){
+
+ if( !requireNamespace('tcltk', quietly = TRUE) ) stop('This function depends on the tcltk package')
+
+ if(!exists('slider.env')) slider.env<<-new.env()
+
+ df <- 1; assign('df',tcltk::tclVar(df),envir=slider.env)
+ sn <- 0; assign('sn',tcltk::tclVar(sn),envir=slider.env)
+
+ xmin <- -5; assign('xmin',tcltk::tclVar(xmin),envir=slider.env)
+ xmax <- 5; assign('xmax',tcltk::tclVar(xmax),envir=slider.env)
+ ymin <- 0; assign('ymin',tcltk::tclVar(ymin),envir=slider.env)
+ ymax <- round(dnorm(0,0,1),2); assign('ymax',tcltk::tclVar(ymax),envir=slider.env)
+
+
+
+ t.refresh <- function(...){
+
+ df <- as.numeric(evalq(tcltk::tclvalue(df), envir=slider.env))
+ sn <- as.numeric(evalq(tcltk::tclvalue(sn), envir=slider.env))
+
+ xmin <- as.numeric(evalq(tcltk::tclvalue(xmin), envir=slider.env))
+ xmax <- as.numeric(evalq(tcltk::tclvalue(xmax), envir=slider.env))
+ ymin <- as.numeric(evalq(tcltk::tclvalue(ymin), envir=slider.env))
+ ymax <- as.numeric(evalq(tcltk::tclvalue(ymax), envir=slider.env))
+
+ xx <- seq(xmin,xmax, length=500)
+ yyt <- dt(xx,df)
+
+ if(sn){
+ yyn <- dnorm(xx)
+ plot(xx,yyn, lwd=3, col='skyblue', type='l',
+ xlim=c(xmin,xmax), ylim=c(ymin,ymax),
+ xlab='x', ylab='')
+ lines(xx,yyt,lwd=2)
+ } else {
+ plot(xx,yyt,type='l', xlim=c(xmin,xmax), ylim=c(ymin,ymax),
+ ylab='',xlab='x',lwd=2)
+ }
+ }
+
+
+ m <- tcltk::tktoplevel()
+ tcltk::tkwm.title(m,'Visualizing the t-Distribution')
+ tcltk::tkwm.geometry(m,'+0+0')
+
+ # df
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='d.f.', width='5'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkscale(fr, command=t.refresh, from=1, to=50,
+ orient='horiz',
+ resolution=1, showvalue=T),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=df),envir=slider.env)
+
+ # show normal
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Show Normal Distribution', width='25'),side='right')
+ tcltk::tkpack(sc <- tcltk::tkcheckbutton(fr, command=t.refresh),
+ side='left')
+ assign('sc',sc,envir=slider.env)
+ evalq(tcltk::tkconfigure(sc, variable=sn),envir=slider.env)
+
+
+ # xmin
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Xmin:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=xmin), envir=slider.env)
+
+ # xmax
+ tcltk::tkpack(tcltk::tklabel(fr, text='Xmax:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=xmax), envir=slider.env)
+
+ # ymin
+ tcltk::tkpack(fr <- tcltk::tkframe(m),side='top')
+ tcltk::tkpack(tcltk::tklabel(fr, text='Ymin:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=ymin), envir=slider.env)
+
+ # ymax
+ tcltk::tkpack(tcltk::tklabel(fr, text='Ymax:', width=6), side='left')
+ tcltk::tkpack(e <- tcltk::tkentry(fr,width=8), side='left')
+ assign('e',e,envir=slider.env)
+ evalq(tcltk::tkconfigure(e, textvariable=ymax), envir=slider.env)
+
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Refresh", command=t.refresh),side='left')
+
+ tcltk::tkpack(tcltk::tkbutton(m, text="Exit", command=function()tcltk::tkdestroy(m)),
+ side='right')
+
+}
+
diff --git a/R/vis.test.R b/R/vis.test.R
new file mode 100644
index 0000000..869a975
--- /dev/null
+++ b/R/vis.test.R
@@ -0,0 +1,142 @@
+vis.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')
+ }
+}
diff --git a/R/z.test.R b/R/z.test.R
new file mode 100644
index 0000000..2950aa6
--- /dev/null
+++ b/R/z.test.R
@@ -0,0 +1,39 @@
+z.test <- function(x, mu=0, stdev,
+ alternative = c("two.sided", "less", "greater"),
+ sd=stdev, n=length(x),
+ conf.level = 0.95, ... ) {
+
+ if(missing(stdev) && missing(sd)) stop("You must specify a Standard Deviation of the population")
+
+ alternative <- match.arg(alternative)
+
+ z <- (mean(x)-mu)/(sd/sqrt(n))
+
+ out <- list(statistic=c(z=z))
+ class(out) <- 'htest'
+
+ out$parameter <- c(n=n,"Std. Dev." = sd,
+ "Std. Dev. of the sample mean" = sd/sqrt(n))
+
+ out$p.value <- switch(alternative,
+ two.sided = 2*pnorm(abs(z),lower.tail=FALSE),
+ less = pnorm(z),
+ greater = pnorm(z, lower.tail=FALSE) )
+
+ out$conf.int <- switch(alternative,
+ two.sided = mean(x) +
+ c(-1,1)*qnorm(1-(1-conf.level)/2)*sd/sqrt(n),
+ less = c(-Inf, mean(x)+qnorm(conf.level)*sd/sqrt(n)),
+ greater = c(mean(x)-qnorm(conf.level)*sd/sqrt(n), Inf)
+ )
+ attr(out$conf.int, "conf.level") <- conf.level
+
+ out$estimate <- c("mean of x" = mean(x))
+ out$null.value <- c("mean" = mu)
+ out$alternative <- alternative
+ out$method <- "One Sample z-test"
+ out$data.name <- deparse(substitute(x))
+ names(out$estimate) <- paste("mean of", out$data.name)
+
+ return(out)
+}
diff --git a/data/USCrimes.rda b/data/USCrimes.rda
new file mode 100644
index 0000000..39b6843
Binary files /dev/null and b/data/USCrimes.rda differ
diff --git a/data/coin.faces.rda b/data/coin.faces.rda
new file mode 100644
index 0000000..73f4d34
Binary files /dev/null and b/data/coin.faces.rda differ
diff --git a/data/evap.rda b/data/evap.rda
new file mode 100644
index 0000000..ffdb9b6
Binary files /dev/null and b/data/evap.rda differ
diff --git a/data/gps.rda b/data/gps.rda
new file mode 100644
index 0000000..e17bba3
Binary files /dev/null and b/data/gps.rda differ
diff --git a/data/ldsgrowth.rda b/data/ldsgrowth.rda
new file mode 100644
index 0000000..744592b
Binary files /dev/null and b/data/ldsgrowth.rda differ
diff --git a/data/outliers.rda b/data/outliers.rda
new file mode 100644
index 0000000..31614d1
Binary files /dev/null and b/data/outliers.rda differ
diff --git a/data/steps.rda b/data/steps.rda
new file mode 100644
index 0000000..0dd4309
Binary files /dev/null and b/data/steps.rda differ
diff --git a/data/stork.rda b/data/stork.rda
new file mode 100644
index 0000000..8f443d7
Binary files /dev/null and b/data/stork.rda differ
diff --git a/debian/README.test b/debian/README.test
deleted file mode 100644
index 3e5e0fc..0000000
--- a/debian/README.test
+++ /dev/null
@@ -1,7 +0,0 @@
-Notes on how this package can be tested.
-────────────────────────────────────────
-
-This package can be tested by loading it into R with the command
-‘library(TeachingDemos)’ in order to confirm its integrity.
-
- -- Andreas Tille <tille at debian.org> Thu, 05 Aug 2010 14:03:43 +0200
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index d4c4b0b..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,48 +0,0 @@
-r-cran-teachingdemos (2.10-1) unstable; urgency=medium
-
- * New upstream version
- * cme fix dpkg-control
- * debhelper 10
- * Convert to dh-r
- * Canonical homepage for CRAN
- * d/watch: version=4
-
- -- Andreas Tille <tille at debian.org> Thu, 17 Nov 2016 13:13:12 +0100
-
-r-cran-teachingdemos (2.9-1) unstable; urgency=low
-
- * New upstream version
- * debian/control:
- - Standards-Version: 3.9.4 (no changes needed)
- - DM-Upload-Allowed removed
- - debhelper 9 (also debian/compat)
- - normalised format
- * debian/copyright: DEP5
- * Rename README.Debian to README.test
- * debian/rules: Remove unneeded code to obtain R:Depends variable
-
- -- Andreas Tille <tille at debian.org> Fri, 17 May 2013 13:54:08 +0200
-
-r-cran-teachingdemos (2.7-1) unstable; urgency=low
-
- * New upstream version
-
- -- Andreas Tille <tille at debian.org> Wed, 24 Nov 2010 11:31:52 +0100
-
-r-cran-teachingdemos (2.6-1) unstable; urgency=low
-
- * New upstream version
- * Standards-Version: 3.9.1 (no changes needed)
- * debian/source/format: 3.0 (quilt)
- * Depend on a version equal or superior than the R upstream release that
- was used to build this package, using a R:Depends substvar
- (debian/control, debian/rules).
- * debian/README.Debian: explain how to test this package
-
- -- Andreas Tille <tille at debian.org> Thu, 05 Aug 2010 14:03:43 +0200
-
-r-cran-teachingdemos (2.4-1) unstable; urgency=low
-
- * Initial release (closes: #557135).
-
- -- Andreas Tille <tille at debian.org> Thu, 19 Nov 2009 15:38:39 +0100
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index f599e28..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-10
diff --git a/debian/control b/debian/control
deleted file mode 100644
index 9978a2c..0000000
--- a/debian/control
+++ /dev/null
@@ -1,23 +0,0 @@
-Source: r-cran-teachingdemos
-Maintainer: Debian Science Team <debian-science-maintainers at lists.alioth.debian.org>
-Uploaders: Andreas Tille <tille at debian.org>
-Section: gnu-r
-Priority: optional
-Build-Depends: debhelper (>= 10.0),
- dh-r,
- r-base-dev
-Standards-Version: 3.9.8
-Vcs-Browser: https://anonscm.debian.org/viewvc/debian-science/packages/R/r-cran-teachingdemos/trunk/
-Vcs-Svn: svn://anonscm.debian.org/debian-science/packages/R/r-cran-teachingdemos/trunk/
-Homepage: https://cran.r-project.org/package=TeachingDemos
-
-Package: r-cran-teachingdemos
-Architecture: all
-Depends: ${misc:Depends},
- ${R:Depends}
-Recommends: ${R:Recommends}
-Suggests: ${R:Suggests}
-Description: GNU R Demonstrations for teaching and learning
- 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.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index ac894c2..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,24 +0,0 @@
-Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Name: TeachingDemos
-Upstream-Contact: Greg Snow <greg.snow at imail.org>
-Source: https://cran.r-project.org/package=TeachingDemos
-
-Files: *
-Copyright: 2009-2016 Greg Snow <greg.snow at imail.org>
-License: Artistic-2.0
-
-Files: debian/*
-Copyright: 2008-2016 Andreas Tille <tille at debian.org>
- 2009 Charles Plessy <plessy at debian.org>
-License: Artistic-2.0
-
-License: Artistic-2.0
- THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
- .
- This program is free software: you can redistribute it and/or modify
- it under the terms of the Artistic License.
- .
- On Debian systems, the complete text of the Artistic
- License version 2 can be found in `/usr/share/common-licenses/Artistic'.
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 68d9a36..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/usr/bin/make -f
-
-%:
- dh $@ --buildsystem R
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index 020c334..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,2 +0,0 @@
-version=4
-http://cran.r-project.org/src/contrib/TeachingDemos_([-\d.]+)\.tar\.gz
diff --git a/man/HWidentify.Rd b/man/HWidentify.Rd
new file mode 100644
index 0000000..2976d70
--- /dev/null
+++ b/man/HWidentify.Rd
@@ -0,0 +1,72 @@
+\name{HWidentify}
+\Rdversion{1.1}
+\alias{HWidentify}
+\alias{HTKidentify}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Show label for point being Hovered over. }
+\description{
+ These functions create a scatterplot then you Hover the mouse pointer
+ over a point in the plot and it will show an id label for that point.
+}
+\usage{
+HWidentify(x, y, label = seq_along(x), lab.col="darkgreen",
+pt.col="red", adj=c(0,0), clean=TRUE, xlab = deparse(substitute(x)),
+ylab = deparse(substitute(y)), ...)
+HTKidentify(x, y, label = seq_along(x), lab.col="darkgreen",
+pt.col="red", adj=c(0,0), xlab = deparse(substitute(x)),
+ylab = deparse(substitute(y)), ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ x-coordinates to plot }
+ \item{y}{ y-coordinates to plot}
+ \item{label}{ Labels to show for each point }
+ \item{lab.col}{The color to plot the labels}
+ \item{pt.col}{The color of the highlighting point}
+ \item{adj}{The adjustment of the labels relative to the cursor point.
+ The default places the label so that its bottom left corner is at
+ the curser, values below 0 or greater than 1 will move the label to
+ not touch the cursor.}
+ \item{clean}{Logical value, should any labels on the plot be removed
+ at the end of the plotting.}
+ \item{xlab}{ Label for x-axis }
+ \item{ylab}{ Label for y-axis}
+ \item{\dots}{additional arguments passed through to plot}
+}
+\details{
+ This is an alternative to the \code{identify} function. The label
+ only shows up for the point currently closest to the mouse pointer.
+ When the mouse pointer moves closer to a different point, the label
+ changes to the one for the new point. The currently labeled point is
+ also highlighted. HWidentify only works on windows, HTKidentify
+ requires the tkrplot package.
+}
+\value{
+These functions are run for their side effects, nothing meaningful is returned.
+}
+%\references{
+%% ~put references to the literature/web site here ~
+%}
+\author{
+Greg Snow, \email{538280 at gmail.com}
+}
+%\note{
+%% ~~further notes~~
+%}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{identify}}
+}
+\examples{
+if( interactive() ){
+ tmpx <- runif(25)
+ tmpy <- rnorm(25)
+ HTKidentify(tmpx,tmpy, LETTERS[1:25], pch=letters)
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ dynamic }
+\keyword{ iplot }
diff --git a/man/Pvalue.sim.Rd b/man/Pvalue.sim.Rd
new file mode 100644
index 0000000..a0f9cf6
--- /dev/null
+++ b/man/Pvalue.sim.Rd
@@ -0,0 +1,86 @@
+\name{Pvalue.norm.sim}
+\alias{Pvalue.norm.sim}
+\alias{Pvalue.binom.sim}
+\alias{run.Pvalue.norm.sim}
+\alias{run.Pvalue.binom.sim}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Simulate P-values }
+\description{
+ Simulate and plot p-values from a normal or binomial based test under
+ various conditions. When all the assumptions are true, the p-values
+ should follow an approximate uniform distribution. These functions
+ show that along with how violating the assumptions changes the
+ distribution of the p-values.
+}
+\usage{
+Pvalue.norm.sim(n = 50, mu = 0, mu0 = 0, sigma = 1, sigma0 = sigma,
+ test= c("z", "t"), alternative = c("two.sided", "less", "greater", "<>",
+ "!=", "<", ">"), alpha = 0.05, B = 10000)
+Pvalue.binom.sim(n=100, p=0.5, p0=0.5, test=c('exact','approx'),
+ alternative=c('two.sided', 'less', 'greater',
+ '<>','!=','<','>'),
+ alpha=0.05, B=1000)
+run.Pvalue.norm.sim()
+run.Pvalue.binom.sim()
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{n}{Sample Size for each simulated dataset}
+ \item{mu}{Simulation mean for samples}
+ \item{mu0}{Hypothesized mean for tests}
+ \item{sigma}{Simulation SD for samples}
+ \item{sigma0}{Hypothesized SD for tests, if blank or missing, use the
+ sample SD in the tests}
+ \item{p}{Simulation proportion for samples}
+ \item{p0}{Hypothesized proportion for tests}
+ \item{test}{Which test to use, "z" or "t" tests for normal, "exact"
+ (binomial) or "approx" (normal approximation) for binomial }
+ \item{alternative}{Direction for alternative hypothesis }
+ \item{alpha}{alpha level for test (optional) }
+ \item{B}{Number of simulated datasets }
+}
+\details{
+ These functions generate \code{B} samples from either a normal or
+ binomial distribution, then compute the P-values for the test of
+ significance on each sample and plot the P-values.
+
+ The \code{run.Pvalue.norm.sim} and \code{run.Pvalue.binom.sim}
+ functions are GUI wrappers for the other 2 functions allowing you to
+ change the parameters and click on "refresh" to run a new set of
+ simulations.
+
+ Using \code{NA} for \code{sigma0} will result in the sample standard
+ deviations being used (leave blank in the GUI).
+
+ When the simulation conditions and the hypothesized values match, the
+ distributions of the p-values will be approximately uniform.
+ Changing the parameter of interest will show the idea of power.
+ Changing the other parameters can show the effects of assumptions not
+ being met.
+}
+\value{
+ The P-values are invisibly returned.
+}
+\references{ Murdock, D, Tsai, Y, and Adcock, J (2008) _P-Values are
+ Random Variables_. The American Statistician. (62) 242-245.}
+\author{Greg Snow, \email{538280 at gmail.com}}
+\note{
+ Note: the 2-sided p-values for the binomial may not match the results
+ from binom.test and prop.test. The method used here is an
+ approximation for speed.
+}
+\seealso{ \code{\link{t.test}}, \code{\link{z.test}},
+ \code{\link{binom.test}}, \code{\link{prop.test}}, \code{\link{tkexamp}} }
+\examples{
+ if(interactive()) {
+ run.Pvalue.norm.sim()
+ run.Pvalue.binom.sim()
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{hplot}
+\keyword{dynamic}% __ONLY ONE__ keyword per line
+\keyword{datagen}
+\keyword{distribution}
+\keyword{htest}
\ No newline at end of file
diff --git a/man/R2txt.Rd b/man/R2txt.Rd
new file mode 100644
index 0000000..6cb3dd7
--- /dev/null
+++ b/man/R2txt.Rd
@@ -0,0 +1,247 @@
+\name{txtStart}
+\alias{txtStart}
+\alias{txtStop}
+\alias{txtComment}
+\alias{txtSkip}
+\alias{etxtStart}
+\alias{etxtStop}
+\alias{etxtComment}
+\alias{etxtSkip}
+\alias{etxtPlot}
+\alias{wdtxtStart}
+\alias{wdtxtStop}
+\alias{wdtxtComment}
+\alias{wdtxtSkip}
+\alias{wdtxtPlot}
+\alias{mdtxtStart}
+\alias{mdtxtStop}
+\alias{mdtxtComment}
+\alias{mdtxtSkip}
+\alias{mdtxtPlot}
+\title{Save a transcript of commands and/or output to a text file. }
+\description{
+ These functions save a transcript of your commands and their output to
+ a script file, possibly for later processing with the "enscript" or
+ "pandoc"
+ program.
+
+ They work as a combinations of \code{sink} and \code{history} with a
+ couple extra bells and whistles.
+}
+\usage{
+txtStart(file, commands=TRUE, results=TRUE, append=FALSE, cmdfile,
+ visible.only=TRUE)
+
+txtStop()
+
+txtComment(txt,cmdtxt)
+
+txtSkip(expr)
+
+etxtStart(dir = tempfile("etxt"), file = "transcript.txt",
+ commands = TRUE, results = TRUE, append = FALSE,
+ cmdbg = "white", cmdcol = "red", resbg = "white",
+ rescol = "navy", combg = "cyan", comcol = "black",
+ cmdfile, visible.only = TRUE)
+
+etxtStop()
+
+etxtComment(txt, cmdtxt)
+
+etxtSkip(expr)
+
+etxtPlot(file=paste(tempfile('plot',R2txt.vars$dir),'.eps',sep=''),
+ width=4, height=4)
+
+wdtxtStart(commands=TRUE, results=TRUE, fontsize=9, cmdfile,
+ visible.only=TRUE)
+
+wdtxtStop()
+
+wdtxtComment(txt,cmdtxt)
+
+wdtxtSkip(expr)
+
+wdtxtPlot(height=5, width=5, pointsize=10)
+
+mdtxtStart(dir=tempfile('mdtxt'), file='transcript.md',
+ commands=TRUE, results=TRUE, append=FALSE,
+ cmdfile, visible.only=TRUE)
+
+mdtxtStop()
+
+mdtxtComment(txt,cmdtxt)
+
+mdtxtSkip(expr)
+
+mdtxtPlot(file=tempfile('plot',R2txt.vars$dir,'.png'),
+ width=4, height=4)
+
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{dir}{ Directory to store transcript file and any graphics file in }
+ \item{file}{ Text file to save transcript in }
+ \item{commands}{ Logical, should the commands be echoed to the
+ transcript file }
+ \item{results}{ Logical, should the results be saved in the transcript
+ file }
+ \item{append}{ Logical, should we append to \code{file} or replace it }
+ \item{cmdbg}{ Background color for command lines in \code{file} }
+ \item{cmdcol}{ Color of text for command lines in \code{file} }
+ \item{resbg}{ Background color for results sections in \code{file} }
+ \item{rescol}{ Text color of results sections in \code{file} }
+ \item{combg}{ Background color for comments in \code{file} }
+ \item{comcol}{ Text color of comments in \code{file} }
+ \item{cmdfile}{ A filename to store commands such that it can be
+ \code{source}d or copied and pasted from }
+ \item{visible.only}{ Should non-printed output be included, not
+ currently implemented.}
+ \item{txt}{Text of a comment to be inserted into \code{file} }
+ \item{cmdtxt}{Text of a comment to be inserted into \code{cmdfile} }
+ \item{expr}{An expression to be executed without being included in
+ \code{file} or \code{cmdfile} }
+ \item{width}{Width of plot, passed to \code{dev.copy2eps},
+ \code{wdPlot}, or \code{dev.copy}}
+ \item{height}{Height of plot, passed to \code{dev.copy2eps},
+ \code{wdPlot}, or \code{dev.copy}}
+ \item{fontsize}{Size of font to use in MSWord}
+ \item{pointsize}{ passed to \code{wdPlot} }
+}
+\details{
+These functions are used to create transcript/command files of your R
+ session. There are 4 sets of functions, those starting with
+ "txt",those starting with "etxt", and those starting with
+ "wdtxt" and those starting with "mdtxt". The "txt" functions
+ create a plain text transcript while the "etxt" functions
+ create a text file with extra escapes and commands so that it
+ can be post processed with enscript (an external program) to
+ create a postscript file and can include graphics as well. The
+ postscript file can be converted to pdf or other format file.
+
+ The "wdtxt" functions will insert the commands and results into
+ a Microsoft Word document.
+
+ The "mdtxt" functions create a text file but with MarkDown
+ escapes so that it can be post processed with "pandoc" (an
+ external program) to create other formats such as html, pdf, MS
+ Word documents, etc. If the command starts with the string
+ "pander" or "pandoc" (after optional whitespace) then the
+ results will be inserted directly, without escapes, into the
+ transcript file. This assumes that you are using code from the
+ "pander" package which generates markdown formatted output.
+ This will create nicer looking tables and other output.
+
+ If \code{results} is TRUE and \code{commands} is FALSE then the result
+ is similar to the results of \code{sink}. If \code{commands}
+ is true as well then the transcript file will show both the commands
+ and results similar to the output on the screen. If both
+ \code{commands} and \code{results} are FALSE then pretty much
+ the only thing these functions will accomplish is to waste some
+ computing time.
+
+ If \code{cmdfile} is
+ specified then an additional file is created with the commands
+ used (similar to the \code{history} command), this file can be
+ used with \code{source} or copied and
+ pasted to the terminal.
+
+ The Start functions specify the file/directory to create and
+ start the transcript, \code{wdtxtStart} will open Word if it is
+ not already open or create a connection to an open word window.
+ The prompts are changed to remind you
+ that the commands/results are being copied to the transcript.
+ The Stop functions stop the recording and reset the prompts.
+
+ The R parser strips comments and does some reformatting so the
+ transcript file may not match exactly with the terminal
+ output. Use the \code{txtComment}, \code{etxtComment},
+ \code{wdtxtComment}, or \code{mdtxtComment}
+ functions to add a comment. This will show up as a line offset
+ by whitespace in the transcript file, highlighted in the
+ etxt version, and the default font in Word.
+ If \code{cmdtxt} is specified then that line
+ will be inserted into \code{cmdfile} preceded by a \# so it
+ will be skipped if sourced or copied.
+
+ The \code{txtSkip}, \code{etxtSkip}, \code{wdtxtSkip}, and
+ \code{mdtxtSkip} functions will run the code in \code{expr} but
+ will not include the commands or results in the transcript file
+ (this can be used for side computations, or requests for help,
+ etc.).
+
+ The \code{etxtPlot} function calls \code{dev.copy2eps} to
+ create a copy of the current plot and inserts the proper command
+ into the transcript file so that the eps file will be included
+ in the final postscript file after processing.
+
+ The \code{wdtxtPlot} function calls \code{wdPlot} to send a
+ copy of the current graph to MS Word.
+
+ The \code{mdtxtPlot} function calls \code{dev.copy} to create a
+ copy of the current plot as a .png file and inserts the proper
+ command into the transcript file so that the .png file will be
+ included when processing with pandoc.
+}
+\value{
+ Most of these commands do not return anything of use. The exceptions
+ are:
+
+ \code{etxtStop} returns the name of the transcript file (including the
+ directory path).
+
+ \code{txtSkip}, \code{etxtSkip}, \code{wdtxtSkip}, and
+ \code{mdtxtSkip} return the value of \code{expr}.
+
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow, \email{538280 at gmail.com} }
+\note{
+These commands do not do any fancy formatting of output, just what you
+see in the regular terminal window. If you want more formatted output
+then you should look into \code{Sweave}, \code{knitr}, or the R2HTML package.
+
+The MS word functions will insert into the current word document at the
+location of the cursor. This means that if you look at the document and
+move the current location to somewhere in the middle (or have another
+word document open with the location in the middle), when you go back to
+R, the new transcript will be inserted into the middle of the document.
+So be careful to position the cursor at the end of the correct document
+before going back to R. Note that the "wdtxt" functions depend on the
+"R2wd" package which in turn depends on tools that are not free.
+
+Do not use these functions in combination with R2HTML or \code{sink}.
+Only one of these sets of functions will work at a time.
+}
+\seealso{\code{\link{sink}}, \code{\link{history}},
+ \code{\link{Sweave}}, the odfWeave package, the R2HTML package, the
+ R2wd package, the pander package }
+\examples{
+\dontrun{
+etxtStart()
+etxtComment('This is todays transcript')
+date()
+x <- rnorm(25)
+summary(x)
+stem(x)
+etxtSkip(?hist)
+hist(x)
+etxtPlot()
+Sys.Date()
+Sys.time()
+my.file <- etxtStop()
+
+# assumes enscript and ps2pdf are on your path
+system(paste('enscript -e -B -p transcript.ps ', my.file) )
+system('ps2pdf transcript.ps')
+
+# if the above commands used mdtxt instead of etxt and the pandoc
+# program is installed and on your path (and dependent programs) then use:
+system(paste('pandoc -o transcript.docx ', my.file))
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ character }
+\keyword{ IO }% __ONLY ONE__ keyword per line
+\keyword{ utilities }
\ No newline at end of file
diff --git a/man/SensSpec.demo.Rd b/man/SensSpec.demo.Rd
new file mode 100644
index 0000000..c7df69c
--- /dev/null
+++ b/man/SensSpec.demo.Rd
@@ -0,0 +1,61 @@
+\name{SensSpec.demo}
+\alias{SensSpec.demo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Demonstrate Sensitivity, Specificity, PPV, and NPV }
+\description{
+ This function demonstrates how to get PPV and NPV from Sensitivity,
+ Specificity, and Prevalence by using a virtual population rather than
+ a direct application of Bayes Rule. This approach is more intuitive
+ to mathphobes.
+}
+\usage{
+SensSpec.demo(sens, spec, prev, n = 100000, step = 11)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{sens}{ Sensitivity (between 0 and 1) }
+ \item{spec}{ Specificity (between 0 and 1) }
+ \item{prev}{ Prevalence (between 0 and 1) }
+ \item{n}{ Size of the virtual population (large round number) }
+ \item{step}{ which step of the process to display }
+}
+\details{
+ The common way to compute Positive Predictive Value (probability of
+ disease given a positive test (PPV)) and Negative Predictive Value
+ (probability of no disease given negative test (NPV)) is to use Bayes' rule
+ with the Sensitivity, Specificity, and Prevalence.
+
+ This approach can be overwhelming to non-math types, so this
+ demonstration goes through the steps of assuming a virtual population, then
+ filling in a 2x2 table based on the population and given values of
+ Sensitivity, Specificity, and Prevalence. PPV and NPV are then
+ computed from this table. This approach is more intuitive to many
+ people.
+
+ The function can be run multiple times with different values of
+ \code{step} to show the steps in building the table, then rerun with
+ different values to show how changes in the inputs affect the results.
+}
+\value{
+ An invisible matrix with the 2x2 table
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow, \email{538280 at gmail.com} }
+%\note{ ~~further notes~~
+%
+% ~Make other sections like Warning with \section{Warning }{....} ~
+%}
+\seealso{ \code{\link{roc.demo}}, \code{\link{fagan.plot}},
+ the various Epi packages, \code{\link{tkexamp}}}
+\examples{
+for(i in seq(1,11,2)) {
+ SensSpec.demo(sens=0.95, spec=0.99, prev=0.01, step=i)
+ if( interactive() ) {
+ readline("Press Enter to continue")
+ }
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ univar }
+
diff --git a/man/TeachingDemos-package.Rd b/man/TeachingDemos-package.Rd
new file mode 100644
index 0000000..573e9f1
--- /dev/null
+++ b/man/TeachingDemos-package.Rd
@@ -0,0 +1,133 @@
+\name{TeachingDemos-package}
+\alias{TeachingDemos-package}
+\alias{TeachingDemos}
+\docType{package}
+\title{
+ Various functions for demonstration and learning.
+}
+\description{
+ This package provides various demonstrations that can be used in
+ classes or by individuals to better learn statistical concepts and
+ usage of R. Various utility functions are also included}
+\details{
+ \tabular{ll}{
+ Package: \tab TeachingDemos\cr
+ Type: \tab Package\cr
+ Version \tab 2.4\cr
+ Date: \tab 2011-04-10\cr
+ License: \tab Artistic-2.0\cr
+ }
+ Demonstration functions in this package include:
+
+ \tabular{ll}{
+ ci.examp, run.ci.examp \tab Confidence Interval Examples \cr
+ clt.examp \tab Central Limit Theorem Example\cr
+ dice, plot.dice \tab Roll and Plot dice (possibly loaded)\cr
+ faces, faces2 \tab Chernoff face plots\cr
+ fagan.plot \tab Fagan plot for screening designs\cr
+ lattice.demo \tab The 3d slicing idea behind lattice/trellis
+ graphics\cr
+ loess.demo \tab Interactive demo to show ideas of loess smooths\cr
+ mle.demo \tab Interactive demo of Maximum Likelihood Estimation\cr
+ plot.rgl.coin, plot.rgl.die \tab Animate flipping a coin or rolling
+ a die\cr
+ power.examp \tab Demonstrate concepts of Power.\cr
+ put.points.demo \tab Add/move points on a plot and see the effect on
+ correlation and regression.\cr
+ roc.demo \tab Interactive demo of ROC curves.\cr
+ rotate.cloud \tab Interactively rotate 3d plots.\cr
+ run.cor.examp \tab Show plots representing different
+ correlations.\cr
+ run.hist.demo \tab Interactively change parameters for
+ histograms.\cr
+ SensSpec.demo \tab Show relationship between Sensitivity,
+ Specificity, Prevalence and PPV and NPV.\cr
+ TkApprox \tab Interactive linear interpolations of data.\cr
+ tkBrush \tab Brush points in a scatterplot matrix.\cr
+ TkSpline \tab Interactive spline interpolations of data.\cr
+ tree.demo \tab Interactively Recursive partition data (create
+ trees).\cr
+ vis.binom \tab Plot various probability distributions and
+ interactively change parameters.\cr
+ vis.boxcox \tab Interactively change lambda for Box Cox
+ Transforms.\cr
+ z.test \tab Z-test similar to t.test for students who have not
+ learned t tests yet.\cr
+ Pvalue.norm.sim \tab \cr
+ Pvalue.binom.sim \tab Simulate P-values to see how they are
+ distributed.\cr
+ run.Pvalue.norm.sim \tab GUI for above. \cr
+ run.Pvalue.binom.sim \tab \cr
+ HWidentify \tab \cr
+ HTKidentify \tab Identify the point Hovered over with the mouse. \cr
+ vis.test \tab test a null hypothesis by comparing graphs. \cr
+ }
+
+ Utility functions include:
+ \tabular{ll}{
+ bct \tab Box-Cox Transforms.\cr
+ char2seed \tab set or create the random number seed using a
+ character string\cr
+ clipplot \tab clip a plot to a rectangular region within the plot\cr
+ col2grey \tab convert colors to greyscale\cr
+ cnvrt.coords \tab Convert between the different coordinate
+ systems\cr
+ dynIdentify \tab Scatterplot with point labels that can be dragged
+ to a new position \cr
+ TkIdentify \tab Scatterplot with lables that can be dragged to new
+ positions \cr
+ gp.plot gp.splot \tab send commonds to gnuplot\cr
+ hpd \tab Highest Posterior Density intervals\cr
+ my.symbols \tab Create plots using user defined symbols.\cr
+ panel.my.symbols \tab Create lattice plots using user defined symbols.\cr
+ plot2script \tab Create a script file that recreates the current
+ plot.\cr
+ shadowtext \tab plot text with contrasting shadow for better
+ readability. \cr
+ squishplot \tab Set the margins so that a plot has a specific aspect
+ ratio without large whitespace inside.\cr
+ spread.labs \tab Spread out coordinates so that labels do not overlap.\cr
+ subplot \tab create a plot inside of an existing plot.\cr
+ tkexamp \tab create plots that can have parameters adjusted
+ interactively.\cr
+ triplot \tab Trilinear plot for 3 proportions.\cr
+ txtStart/etxtStart/wdtxtStart \tab Save commands and output to a text file
+ (possibly for post processing with enscript).\cr
+ zoomplot \tab recreate the current plot with different x/y limits
+ (zoom in out).\cr
+ %<% %<=% \tab Transtitive inequalities.\cr
+ }
+
+}
+\author{
+ Greg Snow \email{538280 at gmail.com}
+}
+\keyword{package}
+\keyword{aplot}
+\keyword{iplot}
+\keyword{dynamic}
+\seealso{ The tkrplot package }
+\examples{
+ci.examp()
+
+clt.examp()
+clt.examp(5)
+
+plot.dice( expand.grid(1:6,1:6), layout=c(6,6) )
+
+faces(rbind(1:3,5:3,3:5,5:7))
+
+plot(1:10, 1:10)
+my.symbols( 1:10, 1:10, ms.polygram, n=1:10, inches=0.3 )
+
+x <- seq(1,100)
+y <- rnorm(100)
+plot(x,y, type='b', col='blue')
+clipplot( lines(x,y, type='b', col='red'), ylim=c(par('usr')[3],0))
+
+power.examp()
+power.examp(n=25)
+power.examp(alpha=0.1)
+
+
+}
diff --git a/man/TkApprox.Rd b/man/TkApprox.Rd
new file mode 100644
index 0000000..a2b7934
--- /dev/null
+++ b/man/TkApprox.Rd
@@ -0,0 +1,68 @@
+\name{TkApprox}
+\alias{TkApprox}
+\title{Plot a set of data in a Tk window and interactively move lines to
+see predicted y-values corresponding to selected x-values.}
+\description{
+ This function plots a dataset in a Tk window then places 3 lines on
+ the plot which show a predicted y value for the given x value. The
+ lines can be clicked on and dragged to new x-values with the predicted
+ y-values automatically updating. A table at the bottom of the graph
+ shows the differences between the pairs of x-values and y-values.
+}
+\usage{
+TkApprox(x, y, type = "b", snap.to.x = FALSE, digits = 4,
+ cols = c("red", "#009900", "blue"), xlab = deparse(substitute(x)),
+ ylab = deparse(substitute(y)), hscale = 1.5, vscale = 1.5,
+ wait = TRUE, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The x-values of the data, should be sorted }
+ \item{y}{ The corresponding y-values of the data }
+ \item{type}{ Type of plot (lines, points, both) passed to \code{plot} }
+ \item{snap.to.x}{If True then the lines will snap to x-values (can be
+ changed with a checkbox in the Tk window) }
+ \item{digits}{Number of significant digits to display (passed to
+ \code{format}) }
+ \item{cols}{Vector of 3 colors, used for the reference lines }
+ \item{xlab}{ Label for x-axis }
+ \item{ylab}{ Label for y-axis }
+ \item{hscale}{ Horizontal Scale of the plot, passed to \code{tkrplot} }
+ \item{vscale}{ Vertical Scale of the plot, passed to \code{tkrplot} }
+ \item{wait}{ Should R wait for the window to be closed }
+ \item{\dots}{ Additional parameters passed to \code{plot}}
+}
+\details{
+ This provides an interactive way to explore predictions from a set of
+ x and y values. Internally the function \code{approxfun} is used to
+ make the predictions.
+
+ The x-value of the 3 reference lines can be changed by clicking and
+ dragging the line to a new position. The x and y values are shown in
+ the margins of the graph. Below the graph is a table with the
+ differences (absolute value) between the pairs of points.
+
+ This can be used to find peaks/valleys in trends and to see how they
+ differ from starting points, other peaks/valleys, etc..
+}
+\value{
+ If \code{wait} is FALSE then an invisible NULL is returned, if
+ \code{wait} is TRUE then an invisible list with the x and y values of
+ the 3 reference lines is returned.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~
+%
+% ~Make other sections like Warning with \section{Warning }{....} ~
+%}
+\seealso{\code{\link{approxfun}}, \code{\link{TkSpline}} }
+\examples{
+if(interactive()) {
+ with(ccc, TkApprox(Time2,Elevation))
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{dplot }
+\keyword{dynamic }% __ONLY ONE__ keyword per line
diff --git a/man/TkBuildDist.Rd b/man/TkBuildDist.Rd
new file mode 100644
index 0000000..0b06c16
--- /dev/null
+++ b/man/TkBuildDist.Rd
@@ -0,0 +1,89 @@
+\name{TkBuildDist}
+\alias{TkBuildDist}
+\alias{TkBuildDist2}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Interactively create a probability distribution.
+}
+\description{
+Build a probability distribution (one option for creating a prior
+distribution) by clicking or dragging a plot.
+}
+\usage{
+TkBuildDist(x = seq(min + (max - min)/nbin/2, max - (max - min)/nbin/2,
+ length.out = nbin), min = 0, max = 10, nbin = 10, logspline = TRUE,
+ intervals = FALSE)
+
+TkBuildDist2( min=0, max=1, nbin=10, logspline=TRUE)
+}
+\arguments{
+ \item{x}{
+ A starting set of data points, will default to a sequence of uniform values.
+}
+ \item{min}{
+ The minimum value for the histogram
+}
+ \item{max}{
+ The maximum value for the histogram
+}
+ \item{nbin}{
+ The number of bins for the histogram
+}
+ \item{logspline}{
+ Logical, whether to include a logspline curve on the plot and in the output.
+}
+ \item{intervals}{
+ Logical, should the logspline fit be based on the interval counts
+ rather than the clicked data points, also should the interval
+ summary be returned.
+ }
+
+}
+\details{
+ Bothe of these functions will open a Tk window to interact with. The
+ window will show a histogram (the defaults will show a uniform
+ distribution), optionally a logspline fit line will be included as
+ well. Including the logspline will slow things down a bit, so you may
+ want to skip it on slow computers.
+
+ If you use the \code{TkBuildDist} function then a left click on the
+ histogram will add an additional point to the histogram bar clicked on
+ (the actual x-value where clicked will be saved, returned, and used in
+ the optional logspline unless \code{intervals} is TRUE). Right
+ clicking on the histogram will remove the point closest to where
+ clicked (based only on x), which will usually have the effect of
+ decreasing the clicked bar by 1, but could affect the neigboring bar
+ if you click near the edge or click on a bar that is 0.
+
+ If you use the \code{TkBuildDist2} function then the individual bars
+ can be adjusted by clicking at the top of a bar and dragging up or
+ down, or clicking at what you want the new height of the bar to be.
+ As the current bar is adjusted the other bars will adjust in the
+ oposite direction proportional to their current heights.
+
+ The logspline fit assumes the basis for the distribution is the real
+ line, the \code{min} and \code{max} arguments only control the
+ histogram and where values can be changed.
+}
+\value{
+ Both functions return a list with the breaks that were used the
+ logspline fit (if \code{logspline} is TRUE), the x-values clicked on
+ (for \code{TkBuildDist}), and the proportion of the distribution
+ within each interval (for \code{TkBuildDist2} or if \code{intervals}
+ is TRUE).
+}
+\author{Greg Snow \email{538280 at gmail.com}}
+\seealso{
+ The logspline package
+}
+\examples{
+
+if(interactive()){
+tmp1 <- TkBuildDist()
+tmp2 <- TkBuildDist2()
+}
+
+}
+% R documentation directory.
+\keyword{ iplot }
+\keyword{ dynamic }% __ONLY ONE__ keyword per line
diff --git a/man/TkListView.Rd b/man/TkListView.Rd
new file mode 100644
index 0000000..dc4eb4d
--- /dev/null
+++ b/man/TkListView.Rd
@@ -0,0 +1,86 @@
+\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 "<<attributes>>".
+
+ This function works on S3 objects that are stored as lists. Since
+ currently S4 objects are saved as attributes, wrapping them in a list
+ will work with this function to view their structure, see the example below.
+}
+\value{
+ This function is ran for its side effects, it does not return anything
+ of use.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow, \email{538280 at gmail.com} }
+%\note{ ~~further notes~~
+%
+% ~Make other sections like Warning with \section{Warning }{....} ~
+%}
+\seealso{ \code{\link{str}} }
+\examples{
+if(interactive()) {
+ tmp <- list( a=letters, b=list(1:10, 10:1), c=list( x=rnorm(100),
+ z=data.frame(x=rnorm(10),y=rnorm(10))))
+ TkListView(tmp)
+
+ if(require(maptools)){
+ data(state.vbm)
+ TkListView(list(state.vbm))
+ # change the eval box to: plot(x, type='l') and eval the main branches
+ }
+
+ fit <- lm(Petal.Width ~ ., data=iris)
+ TkListView(fit)
+
+
+ if(require(stats4)){
+ # this example is copied almost verbatim from ?mle
+ x <- 0:10
+ y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
+ ll <- function(ymax=15, xhalf=6)
+ -sum(stats::dpois(y, lambda=ymax/(1+x/xhalf), log=TRUE))
+ (fit <- mle(ll))
+ TkListView(list(fit))
+ }
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ manip }
+\keyword{ attribute }% __ONLY ONE__ keyword per line
+\keyword{ list }
diff --git a/man/TkPredict.Rd b/man/TkPredict.Rd
new file mode 100644
index 0000000..3183155
--- /dev/null
+++ b/man/TkPredict.Rd
@@ -0,0 +1,123 @@
+\name{TkPredict}
+\alias{TkPredict}
+\alias{Predict.Plot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+%- cp slider2.Rd /home/wiwi/pwolf/work/work.rtrevive/install.dir/rwined/man/slider.Rd
+\title{Plot predicted values from a model against one of the predictors
+ for a given value of the othe predictors}
+\description{
+ These functions create a plot of predicted values vs. one of the
+ predictors for given values of the other predictors. TkPredict
+ further creates a Tk gui to allow you to change the values of the
+ other predictors.
+}
+\usage{
+Predict.Plot(model, pred.var, ..., type='response', add=FALSE,
+plot.args=list(), n.points=100, ref.val, ref.col='green', ref.lty=1,
+data)
+TkPredict(model, data, pred.var, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{model}{A model of class 'lm' or 'glm' (or possibly others) from
+ which to plot predictions.}
+ \item{pred.var}{A character string indicating which predictor variable
+ to put on the x-axis of the plot.}
+ \item{...}{for \code{Predict.Plot} The predictor variables and their
+ values for the predictions. See below for detail.}
+ \item{type}{The type value passed on to the predict function.}
+ \item{add}{Whether to add a line to the existing plot or start a new
+ plot.}
+ \item{plot.args}{A list of additional options passed on to the
+ plotting function.}
+ \item{n.points}{The number of points to use in the approximation of
+ the curve.}
+ \item{ref.val}{A reference value for the \code{pred.var}, a reference
+ line will be drawn at this value to the corresponding predicted value.}
+ \item{ref.col, ref.lty}{The color and line type of the reference line
+ if plotted.}
+ \item{data}{The data frame or environment where the variables that the
+ model was fit to are found. If missing, the model will be examined
+ for an attempt find the needed data.}
+}
+\details{
+ These functions plot the predicted values from a regression model
+ (\code{lm} or \code{glm}) against one of the predictor variables for
+ given values of the other predictors. The values of the other
+ predictors are passed as the \code{...} argument to
+ \code{Predict.Plot} or are set using gui controls in \code{TkPredict}
+ (initial values are the medians).
+
+ If the variable for the x axis (name put in \code{pred.var}) is not
+ included with the \code{...} variables, then the range will be
+ computed from the \code{data} argument or the data component of the
+ \code{model} argument.
+
+ If the variable passed as \code{pred.var} is also included in the
+ \code{...} arguments and contains a single value, then this value will
+ be used as the \code{ref.val} argument.
+
+ If it contains 2 or more values, then the range of these values will
+ be used as the x-limits for the predictions.
+
+ When running \code{TkPredict} you can click on the "Print Call" button
+ to print out the call of \code{Predict.Plot} that will recreate the
+ same plot. Doing this for different combinations of predictor values
+ and editing the \code{plot.args} and \code{add} arguments will give
+ you a script that will create a static version of the predictions.
+}
+\value{
+ These functions are run for their side effects of creating plots and
+ do not return anything.
+}
+\author{Greg Snow, \email{538280 at gmail.com}}
+
+\seealso{ \code{tkrplot}, \code{\link{tkexamp}}, \code{\link{predict}} }
+
+\note{ The GUI currently allows you to select a factor as the
+ x-variable. If you do this it will generate some errors and you will
+ not see the plot, just choose a different variable as the x-variable
+ and the plot will return. }
+
+\examples{
+library(splines)
+
+fit.lm1 <- lm( Sepal.Width ~ ns(Petal.Width,3)*ns(Petal.Length,3)+Species,
+ data=iris)
+
+Predict.Plot(fit.lm1, pred.var = "Petal.Width", Petal.Width = 1.22,
+ Petal.Length = 4.3, Species = "versicolor",
+ plot.args = list(ylim=range(iris$Sepal.Width), col='blue'),
+ type = "response")
+Predict.Plot(fit.lm1, pred.var = "Petal.Width", Petal.Width = 1.22,
+ Petal.Length = 4.3, Species = "virginica",
+ plot.args = list(col='red'),
+ type = "response", add=TRUE)
+Predict.Plot(fit.lm1, pred.var = "Petal.Width", Petal.Width = 1.22,
+ Petal.Length = 4.4, Species = "virginica",
+ plot.args = list(col='purple'),
+ type = "response", add=TRUE)
+
+fit.glm1 <- glm( Species=='virginica' ~ Sepal.Width+Sepal.Length,
+ data=iris, family=binomial)
+
+Predict.Plot(fit.glm1, pred.var = "Sepal.Length", Sepal.Width = 1.99,
+ Sepal.Length = 6.34, plot.args = list(ylim=c(0,1), col='blue'),
+ type = "response")
+Predict.Plot(fit.glm1, pred.var = "Sepal.Length", Sepal.Width = 4.39,
+ Sepal.Length = 6.34, plot.args = list(col='red'),
+ type = "response", add=TRUE)
+
+
+
+
+if(interactive()){
+TkPredict(fit.lm1)
+
+TkPredict(fit.glm1)
+}
+
+}
+\keyword{dynamic}% at least one, from doc/KEYWORDS
+\keyword{iplot}% __ONLY ONE__ keyword per line
+\keyword{regression}
diff --git a/man/TkSpline.Rd b/man/TkSpline.Rd
new file mode 100644
index 0000000..c70dab1
--- /dev/null
+++ b/man/TkSpline.Rd
@@ -0,0 +1,67 @@
+\name{TkSpline}
+\alias{TkSpline}
+\title{Plot a set of data in a Tk window and interactively move a line to
+see predicted y-values from a spline fit corresponding to selected x-values.}
+\description{
+ This function plots a dataset in a Tk window then draws the spline fit
+ through the points. It places a line to show the predicted y from the
+ given x value. The line can be clicked on and dragged to new x-values
+ with the predicted y-values automatically updating. A table at the
+ bottem of the graph shows the values and the 3 derivatives.
+}
+\usage{
+TkSpline(x, y, method='natural', snap.to.x=FALSE, digits=4,
+ col=c('blue','#009900','red','black'),
+ xlab=deparse(substitute(x)), ylab=deparse(substitute(y)),
+ hscale=1.5, vscale=1.5, wait=TRUE,
+ ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The x-values of the data, should be sorted }
+ \item{y}{ The corresponding y-values of the data }
+ \item{method}{Spline Method, passed to \code{splinefun}}
+ \item{snap.to.x}{Logical, if TRUE then the line will only take on the
+ values of \code{x}}
+ \item{digits}{Number of digits to print, passed to \code{format}}
+ \item{col}{Colors of the prediction and other lines}
+ \item{xlab}{Label for the x-axis, passed to \code{plot}}
+ \item{ylab}{Label for the y-axis, passed to \code{plot}}
+ \item{hscale}{Horizontal scaling, passed to \code{tkrplot}}
+ \item{vscale}{Vertical scaling, passed to \code{tkrplot}}
+ \item{wait}{Should R wait for the window to close}
+ \item{\dots}{ Additional parameters passed to \code{plot}}
+}
+\details{
+ This provides an interactive way to explore predictions from a set of
+ x and y values. Internally the function \code{splinefun} is used to
+ make the predictions.
+
+ The x-value of the reference line can be changed by clicking and
+ dragging the line to a new position. The x and y values are shown in
+ the margins of the graph. Below the graph is a table with the
+ y-value and derivatives.
+}
+\value{
+ If \code{wait} is FALSE then an invisible NULL is returned, if
+ \code{wait} is TRUE then an invisible list with the x and y values and
+ derivatives is returned.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~
+%
+% ~Make other sections like Warning with \section{Warning }{....} ~
+%}
+\seealso{\code{\link{splinefun}}, \code{\link{TkApprox}} }
+\examples{
+if(interactive()) {
+ x <- 1:10
+ y <- sin(x)
+ TkSpline(x,y, xlim=c(0,11))
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{dplot }
+\keyword{dynamic }% __ONLY ONE__ keyword per line
diff --git a/man/USCrimes.Rd b/man/USCrimes.Rd
new file mode 100644
index 0000000..1a0f744
--- /dev/null
+++ b/man/USCrimes.Rd
@@ -0,0 +1,111 @@
+\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}
diff --git a/man/bct.Rd b/man/bct.Rd
new file mode 100644
index 0000000..8bc56bf
--- /dev/null
+++ b/man/bct.Rd
@@ -0,0 +1,47 @@
+\name{bct}
+\alias{bct}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Box-Cox Transforms}
+\description{
+ Computes the Box-Cox transform of the data for a given value of
+ lambda. Includes the scaling factor.
+}
+\usage{
+bct(y, lambda)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{y}{Vector of data to be transformed.}
+ \item{lambda}{Scalar exponent for transform (1 is linear, 0 is log).}
+}
+\details{
+ \code{bct} computes the Box-Cox family of transforms: y = (y\^lambda -
+ 1)/(lambda*gm\^(lambda-1)), where gm is the geometric mean of the y's.
+ returns log(y)*gm when lambda equals 0.
+}
+\value{
+ A vector of the same length as y with the corresponding transformed values.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{\code{\link{vis.boxcox}}, \code{\link{vis.boxcoxu}},
+ \code{\link[MASS]{boxcox}} in package MASS, other implementations in various
+ packages}
+\examples{
+y <- rlnorm(500, 3, 2)
+par(mfrow=c(2,2))
+qqnorm(y)
+qqnorm(bct(y,1/2))
+qqnorm(bct(y,0))
+hist(bct(y,0))
+
+
+
+}
+\keyword{manip}% at least one, from doc/KEYWORDS
+\keyword{datagen}
+\keyword{regression}
diff --git a/man/cal.Rd b/man/cal.Rd
new file mode 100644
index 0000000..513e2c2
--- /dev/null
+++ b/man/cal.Rd
@@ -0,0 +1,93 @@
+\name{cal}
+\alias{cal}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+ Plot a month or year calendar
+}
+\description{
+ Plot a calendar of the specified year or month. Monthly calendars can
+ have additional information (text/plots) added to the individual cells.
+}
+\usage{
+cal(month, year)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{month}{
+ The month for the calendar, if ommitted will do a yearly calendar,
+ can either be a number from 1 to 12 or a character string that will
+ be matched (using \code{pmatch}) against \code{month.name}.
+ }
+ \item{year}{
+ The year for the calendar. If ommitted and \code{month} is an
+ integer less than or equal to 12 then \code{month} will be used as
+ the year.
+ }
+}
+\details{
+ This function plots on the current (or default) graphics device a
+ yearly or monthly calendar. It tries to guess what you want, if both
+ \code{year} and \code{month} are ommitted then it will plot the
+ current month. If \code{month} is an integer greater than 12 and no
+ \code{year} is specified then
+ that value will be used as the year for a yearly calendar. The
+ \code{month} can be either an integer from 1 to 12 or a character
+ string that will be matched against \code{month.name} using
+ \code{pmatch}.
+
+ Each day of the monthly calendar is a plotting frame that can be
+ added to using stardard low level functions, the coordinates of the
+ plotting region (the entire box) are from 0 to 1 in both
+ dimensions. The \code{\link{updateusr}} function can be used to
+ change the coordinates. The return from the function (when creating
+ a monthly calendar) can be used to select the day.
+}
+\value{
+ Nothing is returned when a whole year calendar is created. When the
+ month calendar is created a function is returned invisibly that if
+ passed an integer corresponding to a day of the month will set the
+ graphics parameters so the corresponding day in the calendar becomes
+ the current plotting figure. See the examples below.
+}
+
+\author{Greg Snow, \email{538280 at gmail.com}}
+
+
+
+\seealso{
+ \code{\link{Sys.time}}, \code{\link{as.POSIXlt}}, \code{\link{par}}, \code{\link{updateusr}}
+}
+\examples{
+cal(2011)
+
+cal('May')
+
+setday <- cal(11, 2011)
+
+setday(3)
+text(0.5,0.5, 'Some\nCentered\nText')
+
+setday(8)
+text(1,1,'Top Right',adj=c(1,1))
+
+setday(18)
+text(0,0,'Bottom Left', adj=c(0,0) )
+
+setday(21)
+tmp.x <- runif(25)
+tmp.y <- rnorm(25, tmp.x, .1)
+mrgn.x <- 0.04*diff(range(tmp.x))
+mrgn.y <- 0.04*diff(range(tmp.y))
+updateusr( 0:1, 0:1, range(tmp.x)+c(-1,1)*mrgn.x, range(tmp.y)+c(-1,1)*mrgn.y)
+points(tmp.x, tmp.y)
+
+setday(30)
+tmp <- hist(rnorm(100), plot=FALSE)
+updateusr( 0:1, 0:1, range(tmp$breaks), range(tmp$counts*1.1,0) )
+lines(tmp)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{hplot}
+\keyword{chron}% __ONLY ONE__ keyword per line
+\keyword{ts}
diff --git a/man/ccc.Rd b/man/ccc.Rd
new file mode 100644
index 0000000..1f0be56
--- /dev/null
+++ b/man/ccc.Rd
@@ -0,0 +1,62 @@
+\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}
diff --git a/man/char2seed.Rd b/man/char2seed.Rd
new file mode 100644
index 0000000..2389ee8
--- /dev/null
+++ b/man/char2seed.Rd
@@ -0,0 +1,58 @@
+\name{char2seed}
+\alias{char2seed}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Convert a character string into a random seed }
+\description{
+ This function creates a seed for the random number generator from a
+ character string. Character strings can be based on student names so
+ that every student has a different random sample, but the teacher can
+ generate the same datasets.
+}
+\usage{
+char2seed(x, set = TRUE, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ A character string }
+ \item{set}{ Logical, should the seed be set or just returned }
+ \item{\dots}{ Additional parameters passed on to \code{set.seed} }
+}
+\details{
+ Simulations or other situations call for the need to have repeatable
+ random numbers, it is easier to remember a word or string than a
+ number, so this function converts words or character strings to an
+ integer and optionally sets the seed based on this.
+
+ Teachers can assign students to generate a random dataset using their
+ name to seed the rng, this way each student will have a different
+ dataset, but the teacher can generate the same set of data to check
+ values.
+
+ Any characters other than letters (a-zA-Z) or digits (0-9) will be
+ silently removed. This function is not case sensitive, so "ABC" and
+ "abc" will generate the same seed.
+
+ This is a many to one function, so it is possible to find different
+ words that generate the same seed, but this is unlikely by chance alone.
+}
+\value{
+ This returns an integer (but mode numeric) to use as a seed for the
+ RNG. If \code{set} is true then it is returned invisibly.
+}
+\author{ Greg Snow \email{538280 at gmail.com} }
+\seealso{ \code{\link{set.seed}} }
+\examples{
+char2seed('Snow')
+x <- rnorm(100)
+rnorm(10)
+tmp <- char2seed('Snow',set=FALSE)
+set.seed(tmp)
+y <- rnorm(100)
+
+all.equal(x,y) # should be true
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ datagen }
+
diff --git a/man/chisq.detail.Rd b/man/chisq.detail.Rd
new file mode 100644
index 0000000..4cbe0cd
--- /dev/null
+++ b/man/chisq.detail.Rd
@@ -0,0 +1,49 @@
+\name{chisq.detail}
+\alias{chisq.detail}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Print details of a chi-squared test}
+\description{
+ Prints out the details of the computations involved in a chi-squared
+ test on a table. Includes the expected values and the chi-squared
+ contribution of each cell.
+}
+\usage{
+chisq.detail(tab)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{tab}{Matrix or table to be analyzed}
+}
+\details{
+ This function prints out the input table along with the expected value
+ for each cell under the null hypothesis. It also prints out the
+ chi-squared contribution of each cell in the same pattern as the
+ table. This shows the computations involved and one rule of thumb is
+ to look for these values that are greater than 4 as a post-hoc analysis.
+}
+\value{
+
+ This function is used primarily for its side effect of printing the
+ results, but does return invisibly a list with the following components:
+
+ \item{obs}{A matrix of the observed values, same as tab.}
+ \item{expected}{A matrix of the expected values under the null hypothesis.}
+ \item{chi.table}{A matrix of the chi-squared contributions of each
+ cell.}
+ \item{chi2}{The chi-squared test statistic.}
+}
+\references{ ~put references to the literature/web site here ~ Moore, bps }
+\author{Greg Snow, \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{\code{\link{chisq.test}},\code{\link{loglin}},
+ \code{\link{xtabs}}, \code{\link{table}}, \code{\link{prop.table}},
+ \code{CrossTable} from the gmodels package.}
+\examples{
+chisq.detail(HairEyeColor[,,1])
+chisq.detail(HairEyeColor[,,2])
+}
+\keyword{htest}% at least one, from doc/KEYWORDS
+
diff --git a/man/ci.examp.Rd b/man/ci.examp.Rd
new file mode 100644
index 0000000..49611dc
--- /dev/null
+++ b/man/ci.examp.Rd
@@ -0,0 +1,80 @@
+\name{ci.examp}
+\alias{ci.examp}
+\alias{run.ci.examp}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Plot examples of Confidence Intervals }
+\description{
+ Generate \code{reps} samples from a normal distribution then compute
+ and plot confidence intervals for each sample along with information
+ about the population to demonstrate confidence intervals. Optionally
+ change the confidence level using a Tk slider.
+}
+\usage{
+ci.examp(mean.sim = 100, sd = 10, n = 25, reps = 50, conf.level = 0.95,
+ method = "z", lower.conf = (1 - conf.level)/2,
+ upper.conf = 1 - (1 - conf.level)/2)
+run.ci.examp(reps = 100, seed, method="z", n=25)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{mean.sim}{ The mean of the population. }
+ \item{sd}{ The standard deviation of the population. }
+ \item{n}{ The sample size for each sample. }
+ \item{reps}{ The number of samples/intervals to create. }
+ \item{conf.level}{ The confidence level of the intervals. }
+ \item{method}{ 'z', 't', or 'both', should the intervals be based on
+ the normal, the t, or both distributions. }
+ \item{lower.conf}{ Quantile for lower confidence bound. }
+ \item{upper.conf}{ Quantile for upper confidence bound. }
+ \item{seed}{ The seed to use for the random number generation. }
+}
+\details{
+ These functions demonstrate the concept of confidence intervals by
+ taking multiple samples from a known normal distribution and
+ calculating a confidence interval for each sample and plotting the
+ interval relative to the true mean. Intervals that contain the true
+ mean will be plotted in black and those that do not include the true
+ mean will be plotted in different colors.
+
+ The \code{method} argument determines the type of interval: 'z' will
+ use the normal distribution and the known population standard
+ deviation, 't' will use the t distribution and the sample standard
+ deviations, 'both' will compute both for each sample for easy
+ comparison (it is best to reduce \code{reps} to about 25 when using
+ 'both').
+
+ The optional arguments \code{lower.conf} and \code{upper.conf} can be
+ used to plot non-symmetric or 1 sided confidence intervals.
+
+ The function \code{run.ci.examp} also creates a Tk slider that will
+ allow you to interactively change the confidence level and replot the
+ intervals to show how the interval widths change with the confidence
+ level.
+}
+\value{
+ These functions are run solely for the side effect of plotting the
+ intervals, there is no meaningfull return value.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com} }
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{\code{\link{z.test}}, \code{\link{t.test}} }
+\examples{
+ci.examp()
+
+if(interactive()) {
+ run.ci.examp()
+}
+
+# 1 sided confidence intervals
+ci.examp(lower.conf=0, upper.conf=0.95)
+
+# non-symmetric intervals
+ci.examp(lower.conf=0.02, upper.conf=0.97)
+}
+\keyword{hplot}% at least one, from doc/KEYWORDS
+\keyword{dynamic}% __ONLY ONE__ keyword per line
+\keyword{univar}
diff --git a/man/clipplot.Rd b/man/clipplot.Rd
new file mode 100644
index 0000000..2a7d9e3
--- /dev/null
+++ b/man/clipplot.Rd
@@ -0,0 +1,72 @@
+\name{clipplot}
+\alias{clipplot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Clip plotting to a rectangular region }
+\description{
+ Clip plotting to a rectangular region that is a subset of the plotting area
+}
+\usage{
+clipplot(fun, xlim = par("usr")[1:2], ylim = par("usr")[3:4])
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{fun}{ The function or expression to do the plotting. }
+ \item{xlim}{ A vector of length 2 representing the x-limits to clip
+ plotting to, defaults to the entire width of the plotting region. }
+ \item{ylim}{ A vector of length 2 representing the y-limits to clip
+ the plot to, defaults to the entire height of the plotting region. }
+}
+\details{
+ This function resets the active region for plotting to a rectangle
+ within the plotting area and turns on clipping so that any points,
+ lines, etc. that are outside the rectange are not plotted.
+
+ A side effect of this function is a call to the \code{box()} command,
+ it is called with a fully transparent color so if your graphics device
+ honors transparency then you will probably see no effect.
+}
+\value{
+ Nothing meaningful is returned
+}
+
+\author{ Greg Snow \email{538280 at gmail.com} }
+\note{
+ This function abuses some of the intent of what par(plt=...) is
+ supposed to mean. In R2.7.0 and beyond there is a new funcntion
+ \code{clip} with the intended purpose of doing this in a more proper
+ manner (however as of my last test it is not working perfectly either,
+ so \code{clipplot} will remain undepricated for now).
+
+ It uses some hacks to make sure that the clipping region is set, but
+ it does this by plotting some tranparent boxes, therefore you should
+ not use this on devices where tranparency is not supported (or you may
+ see extra boxes).
+}
+\seealso{ \code{\link{par}}, \code{\link{lines}}, \code{clip} in R2.7.0
+ and later }
+\examples{
+x <- seq(1,100)
+y <- rnorm(100)
+plot(x,y, type='b', col='blue')
+clipplot( lines(x,y, type='b', col='red'), ylim=c(par('usr')[3],0))
+
+
+attach(iris)
+
+tmp <- c('red','green','blue')
+names(tmp) <- levels(Species)
+plot(Petal.Width,Petal.Length, col=tmp[Species])
+for(s in levels(Species)){
+ clipplot( abline(
+ lm(Petal.Length~Petal.Width, data=iris, subset=Species==s),
+ col=tmp[s]),
+ xlim=range(Petal.Width[Species==s]))
+}
+
+detach(iris)
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ aplot }
+\keyword{ dplot }% __ONLY ONE__ keyword per line
diff --git a/man/clt.examp.Rd b/man/clt.examp.Rd
new file mode 100644
index 0000000..68ba845
--- /dev/null
+++ b/man/clt.examp.Rd
@@ -0,0 +1,65 @@
+\name{clt.examp}
+\alias{clt.examp}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Plot Examples of the Central Limit Theorem}
+\description{
+ Takes samples of size \code{n} from 4 different distributions and
+ plots histograms of the means along with a normal curve with matching
+ mean and standard deviation. Creating the plots for different values
+ of \code{n} demonstrates the Central Limit Theorem.
+}
+\usage{
+clt.examp(n = 1, reps = 10000, nclass = 16, norm.param=list(mean=0,sd=1),
+ gamma.param=list(shape=1, rate=1/3), unif.param=list(min=0,max=1),
+ beta.param=list(shape1=0.35, shape2=0.25))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{n}{size of the individual samples}
+ \item{reps}{number of samples to take from each distribution}
+ \item{nclass}{number of bars in the histograms}
+ \item{norm.param}{List with parameters passed to \code{rnorm}}
+ \item{gamma.param}{List with parameters passed to \code{rgamma}}
+ \item{unif.param}{List with parameters passed to \code{runif}}
+ \item{beta.param}{List with parameters passed to \code{rbeta}}
+}
+\details{
+ The 4 distributions sampled from are a Normal with defaults mean 0 and
+ standard deviation 1, a gamma with defaults shape 1 (exponential) and
+ lambda 1/3 (mean = 3), a uniform
+ distribution from 0 to 1 (default), and a beta distribution with
+ default
+ alpha 0.35 and beta 0.25 (U shaped left skewed).
+
+ The \code{norm.param}, \code{gamma.param}, \code{unif.param}, and
+ \code{beta.param} arguments can be used to change the parameters of
+ the generating distributions.
+
+ Running the function with \code{n}=1 will show the populations. Run
+ the function again with \code{n} at higher values to show that the
+ sampling distribution of the uniform quickly becomes normal and the
+ exponential and beta distributions eventually become normal (but much
+ slower than the uniform).
+}
+\value{
+ This function is run for its side effect of creating plots. It
+ returns NULL invisibly.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{\code{\link{rnorm}}, \code{\link{rexp}}, \code{\link{runif}},
+ \code{\link{rbeta}} }
+\examples{
+clt.examp()
+clt.examp(5)
+clt.examp(30)
+clt.examp(50)
+
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+\keyword{ distribution }% __ONLY ONE__ keyword per line
+\keyword{ univar }
\ No newline at end of file
diff --git a/man/cnvrt.coords.Rd b/man/cnvrt.coords.Rd
new file mode 100644
index 0000000..16d96e4
--- /dev/null
+++ b/man/cnvrt.coords.Rd
@@ -0,0 +1,142 @@
+\name{cnvrt.coords}
+\alias{cnvrt.coords}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Convert between the 5 different coordinate sytems on a graphical device}
+\description{
+ Takes a set of coordinates in any of the 5 coordinate systems (usr,
+ plt, fig, dev, or tdev) and returns the same points in all 5
+ coordinate systems.
+}
+\usage{
+cnvrt.coords(x, y = NULL, input = c("usr", "plt", "fig", "dev","tdev"))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{Vector, Matrix, or list of x coordinates (or x and y
+ coordinates), NA's allowed. }
+ \item{y}{y coordinates (if \code{x} is a vector), NA's allowed. }
+ \item{input}{Character scalar indicating the coordinate system of the
+ input points. }
+}
+\details{
+ Every plot has 5 coordinate systems:
+
+ usr (User): the coordinate system of the data, this is shown by the
+ tick marks and axis labels.
+
+ plt (Plot): Plot area, coordinates range from 0 to 1 with 0
+ corresponding to the x and y axes and 1 corresponding to the top and
+ right of the plot area. Margins of the plot correspond to plot
+ coordinates less than 0 or greater than 1.
+
+ fig (Figure): Figure area, coordinates range from 0 to 1 with 0
+ corresponding to the bottom and left edges of the figure (including
+ margins, label areas) and 1 corresponds to the top and right edges.
+ fig and dev coordinates will be identical if there is only 1 figure
+ area on the device (layout, mfrow, or mfcol has not been used).
+
+ dev (Device): Device area, coordinates range from 0 to 1 with 0
+ corresponding to the bottom and left of the device region within the
+ outer margins and 1 is the top and right of the region withing the
+ outer margins. If the outer margins are all set to 0 then tdev and
+ dev should be identical.
+
+ tdev (Total Device): Total Device area, coordinates range from 0 to 1 with 0
+ corresponding to the bottom and left edges of the device (piece of
+ paper, window on screen) and 1 corresponds to the top and right edges.
+}
+\value{
+ A list with 5 components, each component is a list with vectors named
+ x and y. The 5 sublists are:
+ \item{usr}{The coordinates of the input points in usr (User) coordinates.}
+ \item{plt}{The coordinates of the input points in plt (Plot)
+ coordinates.}
+ \item{fig}{The coordinates of the input points in fig (Figure)
+ coordinates.}
+ \item{dev}{The coordinates of the input points in dev (Device)
+ coordinates.}
+ \item{tdev}{The coordinates of the input points in tdev (Total Device)
+ coordinates.
+ }
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com}}
+\note{ You must provide both x and y, but one of them may be \code{NA}.
+
+This function is now depricated with the new functions
+\code{grconvertX} and \code{grconvertY} in R version 2.7.0 and beyond.
+These new functions use the correct coordinate system names and have
+more coordinate systems available, you should start using them instead.
+}
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{par}} specifically 'usr','plt', and 'fig'. Also
+ 'xpd' for plotting outside of the plotting region and 'mfrow' and
+ 'mfcol' for multi figure plotting. \code{\link{subplot}},
+ \code{grconvertX} and \code{grconvertY} in R2.7.0 and later}
+\examples{
+
+old.par <- par(no.readonly=TRUE)
+
+par(mfrow=c(2,2),xpd=NA)
+
+# generate some sample data
+tmp.x <- rnorm(25, 10, 2)
+tmp.y <- rnorm(25, 50, 10)
+tmp.z <- rnorm(25, 0, 1)
+
+plot( tmp.x, tmp.y)
+
+# draw a diagonal line across the plot area
+tmp1 <- cnvrt.coords( c(0,1), c(0,1), input='plt' )
+lines(tmp1$usr, col='blue')
+
+# draw a diagonal line accross figure region
+tmp2 <- cnvrt.coords( c(0,1), c(1,0), input='fig')
+lines(tmp2$usr, col='red')
+
+# save coordinate of point 1 and y value near top of plot for future plots
+tmp.point1 <- cnvrt.coords(tmp.x[1], tmp.y[1])
+tmp.range1 <- cnvrt.coords(NA, 0.98, input='plt')
+
+# make a second plot and draw a line linking point 1 in each plot
+plot(tmp.y, tmp.z)
+
+tmp.point2 <- cnvrt.coords( tmp.point1$dev, input='dev' )
+arrows( tmp.y[1], tmp.z[1], tmp.point2$usr$x, tmp.point2$usr$y,
+ col='green')
+
+# draw another plot and add rectangle showing same range in 2 plots
+
+plot(tmp.x, tmp.z)
+tmp.range2 <- cnvrt.coords(NA, 0.02, input='plt')
+tmp.range3 <- cnvrt.coords(NA, tmp.range1$dev$y, input='dev')
+rect( 9, tmp.range2$usr$y, 11, tmp.range3$usr$y, border='yellow')
+
+# put a label just to the right of the plot and
+# near the top of the figure region.
+text( cnvrt.coords(1.05, NA, input='plt')$usr$x,
+ cnvrt.coords(NA, 0.75, input='fig')$usr$y,
+ "Label", adj=0)
+
+par(mfrow=c(1,1))
+
+## create a subplot within another plot (see also subplot)
+
+plot(1:10, 1:10)
+
+tmp <- cnvrt.coords( c( 1, 4, 6, 9), c(6, 9, 1, 4) )
+
+par(plt = c(tmp$dev$x[1:2], tmp$dev$y[1:2]), new=TRUE)
+hist(rnorm(100))
+
+par(fig = c(tmp$dev$x[3:4], tmp$dev$y[3:4]), new=TRUE)
+hist(rnorm(100))
+
+par(old.par)
+
+}
+
+\keyword{ dplot }% at least one, from doc/KEYWORDS
+\keyword{ aplot }% __ONLY ONE__ keyword per line
diff --git a/man/coin.faces.Rd b/man/coin.faces.Rd
new file mode 100644
index 0000000..f4c9978
--- /dev/null
+++ b/man/coin.faces.Rd
@@ -0,0 +1,35 @@
+\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}
diff --git a/man/col2grey.Rd b/man/col2grey.Rd
new file mode 100644
index 0000000..af7b62f
--- /dev/null
+++ b/man/col2grey.Rd
@@ -0,0 +1,40 @@
+\name{col2grey}
+\alias{col2grey}
+\alias{col2gray}
+\title{Convert colors to grey/grayscale}
+\description{
+ Convert colors to grey/grayscale so that you can see how your plot
+ will look after photocopying or printing to a non-color printer.
+}
+\usage{
+col2grey(cols)
+col2gray(cols)
+}
+\arguments{
+ \item{cols}{ Colors to convert.}
+}
+\details{
+ converts colors to greyscale using the formula grey=0.3*red +
+ 0.59*green + 0.11*blue. This allows you to see how your color plot
+ will approximately look when printed on a non-color printer or photocopied.
+}
+\value{
+ A vector of colors (greys) corresponding to the input colors.
+}
+\author{ Greg Snow \email{538280 at gmail.com} }
+\seealso{ \code{\link{grey}}, \code{\link{col2rgb}}, dichromat package }
+\examples{
+par(mfcol=c(2,2))
+tmp <- 1:3
+names(tmp) <- c('red','green','blue')
+
+barplot( tmp, col=c('red','green','blue') )
+barplot( tmp, col=col2gray( c('red','green','blue') ) )
+
+barplot( tmp, col=c('red','#008100','#3636ff') )
+barplot( tmp, col=col2grey( c('red','#008100','#3636ff') ) )
+}
+\keyword{dplot}
+\keyword{color}
+
+
diff --git a/man/correct.Rd b/man/correct.Rd
new file mode 100644
index 0000000..55c4d64
--- /dev/null
+++ b/man/correct.Rd
@@ -0,0 +1,94 @@
+\name{cor.rect.plot}
+\alias{cor.rect.plot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Plot a visualization of the correlation using colored rectangles
+}
+\description{
+ This function creates a scatterplot of the data, then adds colored
+ rectangles between the points and the mean of x and y to represent the
+ idea of the correlation coefficient.
+}
+\usage{
+cor.rect.plot(x, y, corr = TRUE, xlab = deparse(substitute(x)),
+ ylab = deparse(substitute(y)), col = c("#ff000055", "#0000ff55"),
+ ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{
+ The \code{x} value or any object that can be interpreted by \code{xy.coords}
+}
+ \item{y}{
+ The \code{y} value
+}
+ \item{corr}{
+ Should the standardized axes (right and top) show the values divided
+ by the standard deviation (TRUE, which shows correlation ideas) or not
+ (FALSE, shows covariance idea)
+}
+ \item{xlab}{
+The label for the \code{x} axis
+}
+ \item{ylab}{
+The label for the \code{y} axis
+}
+ \item{col}{
+A vector of length 2 with the colors to use for the fill of the
+rectangles, the 1st value will be used for "positive" rectangles and the 2nd value will be used for the "negative" rectangles.
+}
+ \item{\dots}{
+Possible further arguments, currently ignored
+}
+}
+\details{
+ This will create a scatterplot of the data, draw refrence lines at
+ the mean of \code{x} and the mean of \code{y}, then draw rectangles
+ from the mean point to the data points. The right and top axes will
+ show the centered (and possibly scaled if \code{corr=TRUE}) values.
+
+ The idea is that the correlation/covariance is based on summing the
+ area of the "positive" rectangles and subtracting the sum of the areas
+ of the "negative" rectangles (then dividing by n-1). If the positive
+ and negative areas are about the same then the correlation/covariance
+ is near 0, if there is more area in the positive rectangles then the
+ correlation/covariance will be positive.
+}
+\value{
+This function returns an invisible NULL, it is run for its side effects.
+}
+
+\author{Greg Snow, \email{538280 at gmail.com}}
+
+\seealso{
+ \code{\link{cor}}
+}
+\examples{
+## low correlation
+x <- rnorm(25)
+y <- rnorm(25)
+cor(x,y)
+cor.rect.plot(x,y)
+
+## Positive correlation
+x <- rnorm(25)
+y <- x + rnorm(25,3, .5)
+cor(x,y)
+cor.rect.plot(x,y)
+
+## negative correlation
+x <- rnorm(25)
+y <- rnorm(25,10,1.5) - x
+cor(x,y)
+cor.rect.plot(x,y)
+
+## zero correlation but a definite relationship
+x <- -5:5
+y <- x^2
+cor(x,y)
+cor.rect.plot(x,y)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ hplot }
+
diff --git a/man/cortest.Rd b/man/cortest.Rd
new file mode 100644
index 0000000..49b58f2
--- /dev/null
+++ b/man/cortest.Rd
@@ -0,0 +1,81 @@
+\name{SnowsCorrectlySizedButOtherwiseUselessTestOfAnything}
+\alias{SnowsCorrectlySizedButOtherwiseUselessTestOfAnything}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Snow's Correctly Sized But Otherwise Useless Test of Anything
+}
+\description{
+This is a hypothesis test designed to be correctly sized in that the
+probability of rejecting the null when it is true will be equal to your
+alpha level. Other than that it is a pretty useless test mainly
+intended for when people say something like "I just need a p-value".
+}
+\usage{
+SnowsCorrectlySizedButOtherwiseUselessTestOfAnything(x,
+ data.name = deparse(substitute(x)),
+ alternative = "You Are Lucky", ..., seed)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The data, or nothing, or something equally irrelevant}
+ \item{data.name}{ The name of the data for the output}
+ \item{alternative}{The phrase for the alternate hypothesis in the output}
+ \item{\dots}{ Additional arguments that will be silently ignored (like
+ \code{x}), future versions may mockingly ignore these instead}
+ \item{seed}{ A seed (numeric or character) used to seed the random
+ number generator. Use this or manually set the seed if you want
+ reproducible (but still meaningless) results}
+}
+\details{
+ Some of the advantages/disadvantages of this test include:
+ \itemize{
+ \item{The probability of a Type I error is alpha}
+ \item{Power can be easily computed (it is alpha)}
+ \item{Power is independent of the sample size}
+ \item{Power is independent of the hypotheses}
+ \item{This test is not affected by missing data (present data
+ either)}
+ \item{This test does not depend on any distributional or
+ independence assumptions}
+ }
+}
+\value{
+ An object of class htest with the following elements:
+
+ \item{p.value}{The p-value}
+ \item{statistic}{The test statistic (identical to the p-value)}
+ \item{data.name}{The name of the data (if any)}
+ \item{method}{The name of the test}
+ \item{alternative}{a phrase representing the alternative hypothesis}
+ \item{seed}{optionally the seed that was used}
+}
+\references{
+The author is unlikely to be willing to publish in any "journal" that
+would be willing to publish this test.
+
+fortune(264)
+}
+\author{
+Greg Snow \email{538280 at gmail.com}
+}
+\note{
+If someone has suggested that you consider this test, they most likely
+ do not intend for you to actually use the test, rather to reconsider
+ your question or the assumptions that you are making or trying to
+ avoid. This test should only be used to illustrate a point and
+ decisions (other than maybe who should pay for lunch) should never be
+ made based on the results of this test.
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{runif}}
+}
+\examples{
+ SnowsCorrectlySizedButOtherwiseUselessTestOfAnything(log(rnorm(100)))
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ htest }
+
diff --git a/man/dice.Rd b/man/dice.Rd
new file mode 100644
index 0000000..a5a0e98
--- /dev/null
+++ b/man/dice.Rd
@@ -0,0 +1,98 @@
+\name{dice}
+\alias{dice}
+\alias{plot.dice}
+\alias{panel.dice}
+\alias{prepanel.dice}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Simulate rolling dice }
+\description{
+ Simulate and optionally plot rolls of dice.
+}
+\usage{
+dice(rolls = 1, ndice = 2, sides = 6, plot.it = FALSE, load = rep(1, sides))
+\method{plot}{dice}(x, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{rolls}{ Scalar, the number of times to roll the dice. }
+ \item{ndice}{ Scalar, the number of dice to roll each time. }
+ \item{sides}{ Scalar, the number of sides per die. }
+ \item{plot.it}{ Logical, Should the results be plotted. }
+ \item{load}{ Vector of length \code{sides}, how the dice should be
+ loaded.}
+ \item{x}{ Data frame, return value from \code{dice}. }
+ \item{\dots}{ Additional arguments passed to lattice plotting function. }
+}
+\details{
+ Simulates the rolling of dice. By default it will roll 2 dice 1 time
+ and the dice will be fair. Internally the \code{sample} function is
+ used and the load option is passed to sample. \code{load} is not
+ required to sum to 1, but the elements will be divided by the sum of
+ all the values.
+}
+\value{
+ A data frame with \code{rolls} rows and \code{ndice} columns
+ representing the results from rolling the dice.
+
+ If only 1 die is rolled, then the return value will be a vector.
+
+ If \code{plot.it} is TRUE, then the return value will be invisible.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com}}
+\note{ If the plot function is used or if \code{plot.it} is TRUE, then a
+plot will be created on the current graphics device.}
+
+
+
+\seealso{ \code{\link{sample}} }
+\examples{
+
+# 10 rolls of 4 fair dice
+dice(10,4, plot.it=TRUE)
+
+# or
+
+plot(dice(10,4))
+
+# or
+
+tmp <- dice(10,4)
+plot(tmp)
+
+# a loaded die
+table(tmp <- dice(100,1,plot.it=TRUE, load=6:1 ) )
+colMeans(tmp)
+
+# Efron's dice
+ed <- list( rep( c(4,0), c(4,2) ),
+ rep(3,6), rep( c(6,2), c(2,4) ),
+ rep( c(5,1), c(3,3) ) )
+
+tmp <- dice( 10000, ndice=4 )
+ed.out <- sapply(1:4, function(i) ed[[i]][ tmp[[i]] ] )
+
+mean(ed.out[,1] > ed.out[,2])
+mean(ed.out[,2] > ed.out[,3])
+mean(ed.out[,3] > ed.out[,4])
+mean(ed.out[,4] > ed.out[,1])
+
+
+## redo De Mere's question
+
+demere1 <- dice(10000,4)
+demere2 <- dice(10000,24,sides=36)
+
+mean(apply( demere1, 1, function(x) 6 \%in\% x ))
+
+mean(apply( demere2, 1, function(x) 36 \%in\% x))
+
+plot(demere1[1:10,])
+
+## plot all possible combinations of 2 dice
+
+plot.dice( expand.grid(1:6,1:6), layout=c(6,6) )
+}
+\keyword{ distribution }% at least one, from doc/KEYWORDS
+\keyword{ hplot }% __ONLY ONE__ keyword per line
+\keyword{ datagen }
\ No newline at end of file
diff --git a/man/digits.Rd b/man/digits.Rd
new file mode 100644
index 0000000..f8a5bed
--- /dev/null
+++ b/man/digits.Rd
@@ -0,0 +1,68 @@
+\name{digits}
+\alias{digits}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+ Return the digits that make up an integer
+}
+\description{
+ Takes an integer or vector of integers and returns a vector, list, or
+ matrix of the individual digits (decimal) that make up that number.
+}
+\usage{
+digits(x, n = NULL, simplify = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{
+ An integer or vector of integers (if not integer, the fractional
+ part will be ignored)
+}
+ \item{n}{
+ The number of digits to be returned, this can be used to place 0's
+ in front of smaller numbers. If this is less than the number of
+ digits then the last \code{n} digits are returned.
+}
+ \item{simplify}{
+ Should \code{sapply} simplify the list into a matrix
+}
+}
+\details{
+ This function transforms an integer (or real ignoring the fractional
+ part) into the decimal digits that make of the decimal representation
+ of the number using modular mathematics rather than converting to
+ character, splitting the string, and converting back to numeric.
+}
+\value{
+ If \code{x} is of length 1 then a vector of the digits is returned.
+
+ If \code{x} is a vector and \code{simplify} is \code{FALSE} then a list
+ of vectors is returned, one element for each element of \code{x}.
+
+ If \code{x} is a vector and \code{simplify} is \code{TRUE} then a
+ matrix with 1 column for each element of \code{x}.
+}
+\author{
+ Greg Snow \email{538280 at gmail.com}
+}
+
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{\%\%}}, \code{\link{\%/\%}}, \code{\link{strsplit}}
+}
+\examples{
+
+digits( 12345 )
+digits( 567, n=5 )
+
+x <- c(1, 23, 456, 7890)
+
+digits(x)
+digits(x, simplify=TRUE)
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ manip }
+\keyword{ arith }% __ONLY ONE__ keyword per line
diff --git a/man/dots.Rd b/man/dots.Rd
new file mode 100644
index 0000000..bb4680f
--- /dev/null
+++ b/man/dots.Rd
@@ -0,0 +1,47 @@
+\name{dots}
+\alias{dots}
+\alias{dots2}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Create a quick dotchart (histogram)}
+\description{
+ Create a quick dotchart of 1 or 2 datasets. These dotcharts are a poor
+ man's histogram, not the trellis dotplot.
+}
+\usage{
+dots(x,...)
+dots2(x, y, colx = "green", coly = "blue", lab1 =
+deparse(substitute(x)), lab2 = deparse(substitute(y)),...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ Vector, data to be plotted (should be rounded). }
+ \item{y}{ Vector, second dataset to be plotted. }
+ \item{colx}{ Color of points for \code{x}. }
+ \item{coly}{ Color of points for \code{y}. }
+ \item{lab1}{ Label for \code{x}.}
+ \item{lab2}{ Label for \code{y}.}
+ \item{\ldots}{ Additional arguments passed to plotting functions. }
+}
+\details{
+ These functions create basic dotcharts that are quick "back of the
+ envelope" approximations to histograms. Mainly intended for demonstration.
+}
+\value{
+ No meaninful value. These functions are run for the side effect of
+ creating a plot.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com } }
+%\note{ ~~further notes~~ }
+
+
+
+\seealso{ \code{\link{dotplot}} in the lattice package, \code{\link{hist}} }
+\examples{
+
+dots( round( rnorm(50, 10,3) ) )
+dots2( round( rnorm(20, 10,3) ), round(rnorm(20,12,2)) )
+
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+
diff --git a/man/dynIdentify.Rd b/man/dynIdentify.Rd
new file mode 100644
index 0000000..c60ae15
--- /dev/null
+++ b/man/dynIdentify.Rd
@@ -0,0 +1,73 @@
+\name{dynIdentify}
+\alias{dynIdentify}
+\alias{TkIdentify}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Interacively place labels for points in a plot }
+\description{
+ These functions create a scatterplot of your points and place labels
+ for the points on them. You can then use the mouse to click and drag
+ the labels to new positions with a line stretching between the point
+ and label.
+}
+\usage{
+dynIdentify(x, y, labels = seq_along(x),
+ corners = cbind(c(-1, 0, 1, -1, 1, -1, 0, 1),
+ c(1, 1, 1, 0, 0, -1, -1, -1)), ...)
+TkIdentify(x, y, labels=seq_along(x), hscale=1.75, vscale=1.75,
+ corners = cbind( c(-1,0,1,-1,1,-1,0,1), c(1,1,1,0,0,-1,-1,-1) ),...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{x-values to plot }
+ \item{y}{y-values to plot }
+ \item{labels}{Labels for the points, defaults to a sequence of integers }
+ \item{corners}{ 2 column matrix of locations where the line can attach
+ to the label, see below}
+ \item{hscale,vscale}{Scaling passed to tkrplot}
+ \item{\dots}{Additional parameters passed to \code{plot}}
+}
+\details{
+ These functions create a scatterplot of the x and y points with the
+ labels (from the argument above) plotted on top. You can then use the
+ mouse to click and drag the labels to new locations. The Tk version
+ shows the labels being dragged, \code{dynIdentify} does not show the
+ labels being dragged, but the label will jump to the new location as
+ soon as you release the mouse button.
+
+ The \code{corners} argument is a 2 column matrix that gives the
+ allowable points at which the line from the point can attach to the
+ label (so the line does not cover thelabel). The first column
+ represents the x-coordinates and the 2nd column the y-coordinates. A
+ 1 represents the right/top of the label, A -1 is the left/bottom and a
+ 0 is the center. The default values allow attachments at the 4
+ corners and the centers of the 4 sides of the rectangle bounding the label.
+}
+\value{
+ A list of lists with the coordinates of the final positions of the
+ labels and the line ends.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow, \email{538280 at gmail.com} }
+\seealso{\code{\link{identify}} }
+\note{
+ The \code{dynIdentify} function only works on windows,
+ \code{TkIdentify} should work on any platform with tcltk.
+}
+\examples{
+if(interactive()) {
+ tmp <- TkIdentify(state.x77[,'Frost'], state.x77[,'Murder'],
+ state.abb)
+ ### now move the labels
+
+ ### recreate the graph on the current device
+ plot( state.x77[,'Frost'], state.x77[,'Murder'],
+ xlab='Frost', ylab='Frost')
+ text( tmp$labels$x, tmp$labels$y, state.abb )
+ segments( state.x77[,'Frost'], state.x77[,'Murder'],
+ tmp$lineends$x, tmp$lineends$y )
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ dynamic }
+\keyword{ aplot }% __ONLY ONE__ keyword per line
diff --git a/man/evap.Rd b/man/evap.Rd
new file mode 100644
index 0000000..b619a0c
--- /dev/null
+++ b/man/evap.Rd
@@ -0,0 +1,54 @@
+\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}
diff --git a/man/faces.Rd b/man/faces.Rd
new file mode 100644
index 0000000..00e853f
--- /dev/null
+++ b/man/faces.Rd
@@ -0,0 +1,82 @@
+\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 }
\ No newline at end of file
diff --git a/man/faces2.Rd b/man/faces2.Rd
new file mode 100644
index 0000000..7d1510c
--- /dev/null
+++ b/man/faces2.Rd
@@ -0,0 +1,94 @@
+\name{faces2}
+\alias{faces2}
+\alias{face2.plot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Chernoff Faces }
+\description{
+ Plot Chernoff Faces of the dataset, rows represent
+ subjects/observations, columns represent variables.
+}
+\usage{
+faces2(mat, which = 1:ncol(mat), labels = rownames(mat),
+ nrows = ceiling(nrow(mat)/ncols), ncols = ceiling(sqrt(nrow(mat))),
+ byrow = TRUE, scale = c("columns", "all", "center", "none"),
+ fill = c(0.5, 0.5, 1, 0.5, 0.5, 0.3, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5,
+ 0.5, 0.5, 0.5, 0.5, 1, 0.5), ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{mat}{ Matrix containing the data to plot. }
+ \item{which}{ Which columns correspond to which features (see details). }
+ \item{labels}{ Labels for the individual faces }
+ \item{nrows}{ Number of rows in the graphical layout }
+ \item{ncols}{ Number of columns in the graphical layout }
+ \item{byrow}{ Logical, should the faces be drawn rowwise or columnwise.
+ }
+ \item{scale}{ Character, how should the data be scaled. }
+ \item{fill}{ What value to use for features not assocaiated with a
+ column of data. }
+ \item{\dots}{ Additional arguments passed on to plotting functions. }
+}
+\details{
+ The features are:
+ 1 Width of center
+ 2 Top vs. Bottom width (height of split)
+ 3 Height of Face
+ 4 Width of top half of face
+ 5 Width of bottom half of face
+ 6 Length of Nose
+ 7 Height of Mouth
+ 8 Curvature of Mouth (abs < 9)
+ 9 Width of Mouth
+ 10 Height of Eyes
+ 11 Distance between Eyes (.5-.9)
+ 12 Angle of Eyes/Eyebrows
+ 13 Circle/Ellipse of Eyes
+ 14 Size of Eyes
+ 15 Position Left/Right of Eyeballs/Eyebrows
+ 16 Height of Eyebrows
+ 17 Angle of Eyebrows
+ 18 Width of Eyebrows
+
+ The face plotting routine needs the data values to be between 0 and 1
+ (inclusive). The \code{scale} option controls how scaling will be
+ done on \code{mat}: "columns" scales each column to range from 0 to
+ 1, "all" scales the entire dataset to vary from 0 to 1, "center"
+ scales each column so that the mean of the column becomes 0.5 and all
+ other values are between 0 and 1, and "none" does no scaling assuming
+ that the data has already been scaled.
+}
+\value{
+ This function is run for its side effect of plotting and does not
+ return anything.
+}
+\references{ Chernoff, H. (1973): The use of faces to represent statistiscal assoziation,
+JASA, 68, pp 361--368. }
+\author{ Original code by ; current implementation by Greg Snow \email{538280 at gmail.com} }
+\note{ If you choose to not scale the data and any data values are
+ outside of the 0 to 1 range, then strange things may happen.
+
+ This function is based on code found on the internet, the good things
+ come from there, any problems are likely due to my (Greg's) tweaking.
+}
+
+
+\seealso{\code{\link{faces}}}
+\examples{
+ faces2(matrix( runif(18*10), nrow=10), main='Random Faces')
+
+if(interactive()){
+ tke2 <- rep( list(list('slider',from=0,to=1,init=0.5,resolution=0.1)), 18)
+ names(tke2) <- c('CenterWidth','TopBottomWidth','FaceHeight','TopWidth',
+ 'BottomWidth','NoseLength','MouthHeight','MouthCurve','MouthWidth',
+ 'EyesHeight','EyesBetween','EyeAngle','EyeShape','EyeSize','EyeballPos',
+ 'EyebrowHeight','EyebrowAngle','EyebrowWidth')
+ tkfun2 <- function(...){
+ tmpmat <- rbind(Min=0,Adjust=unlist(list(...)),Max=1)
+ faces2(tmpmat, scale='none')
+ }
+
+ tkexamp( tkfun2, list(tke2), plotloc='left', hscale=2, vscale=2 )
+}
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+
diff --git a/man/fagan.Rd b/man/fagan.Rd
new file mode 100644
index 0000000..5342872
--- /dev/null
+++ b/man/fagan.Rd
@@ -0,0 +1,74 @@
+\name{fagan.plot}
+\alias{fagan.plot}
+\alias{plotFagan}
+\alias{plotFagan2}
+\alias{plotFagan.old}
+\alias{plotFagan2.old}
+\title{Create a Fagan plot to demonstrate Bayes Theorem and screening
+ tests}
+\description{
+ These functions create a plot showing the relationship between the
+ prior probability, the LR (combination of sensitivity and
+ specificity), and the posterior probability.
+}
+\usage{
+fagan.plot(probs.pre.test, LR, test.result="+")
+plotFagan(hscale=1.5, vscale=1.5, wait=FALSE)
+plotFagan2(hscale=1.5, vscale=1.5, wait=FALSE)
+plotFagan.old()
+plotFagan2.old()
+}
+\arguments{
+ \item{probs.pre.test}{ The prior probability }
+ \item{LR}{ the likelihood ratio (sensitivity/(1-specificity))}
+ \item{test.result}{either '+' or '-' indicating whether you want the
+ probability of the event or of not seeing the event}
+ \item{hscale}{Horizontal scale, passed to \code{tkrplot}}
+ \item{vscale}{Vertical scale, passed to \code{tkrplot}}
+ \item{wait}{Should the R session wait for the window to close}
+}
+\details{
+ When Bayes theorem is expressed in terms of log-odds it turns out that
+ the posterior log-odds are a linear function of the prior log-odds
+ and the log likelihood ratio. These functions plot an axis on the left
+ with the prior log-odds, an axis in the middle representing the log
+ likelihood ratio and an axis on the right representing the posterior
+ log-odds. A line is then drawn from the prior probability on the left
+ through the LR in the center and extended to the posterior probability
+ on the right. The \code{fagan.plot} creates the plot based on input
+ to the function. The \code{plotFagan} and \code{plotFagan2}
+ functions set up Tk windows with sliders representing the possible
+ inputs and show how the plot and the posterior probability changes
+ when you adjust the inputs. The \code{plotFagan} function creates
+ sliders for the prior probability and the LR, while the
+ \code{plotFagan2} function replaces the LR slider with 2 sliders for
+ the sensitivity and specificity.
+
+ More detail on the plots and the math behind them can be found at the
+ websites below.
+}
+\value{ The old functions are run for their side effects and do not return
+ a meaningful value. If \code{wait} is FALSE then NULL is returned, if
+\code{wait} is TRUE, then a list with the current values is returned.}
+\references{
+ Fagan TJ. Nomogram for Bayes theorem. N Engl J Med 1975;293(5):257-61.
+\url{http://www.cmh.edu/stats/definitions/fagan.htm}
+\url{http://ebm.bmjjournals.com/cgi/content/full/6/6/164}
+}
+
+\author{ Guazzetti Stefano and Greg Snow
+ \email{538280 at gmail.com}}
+\seealso{ \code{slider}}
+\examples{
+ fagan.plot(0.8, 2)
+
+ fagan.plot(0.8, 0.95/(1-0.90) )
+
+if(interactive()) {
+ plotFagan()
+
+ plotFagan2()
+}
+}
+\keyword{hplot}
+\keyword{dynamic}
diff --git a/man/gp.open.Rd b/man/gp.open.Rd
new file mode 100644
index 0000000..e680560
--- /dev/null
+++ b/man/gp.open.Rd
@@ -0,0 +1,85 @@
+\name{gp.open}
+\alias{gp.open}
+\alias{gp.close}
+\alias{gp.send}
+\alias{gp.plot}
+\alias{gp.splot}
+\title{Alpha version functions to send plotting commands to GnuPlot}
+\description{These functions allow you to open a connection to a gnuplot
+ process, send data and possibly other information to gnuplot for it to
+ plot, then close gnuplot and clean up temporary files and variables.
+ These functions are alpha level at best, use at your own risk.}
+\usage{
+gp.open(where='c:/progra~1/GnuPlot/bin/pgnuplot.exe')
+gp.close(pipe=gpenv$gp)
+gp.send(cmd='replot',pipe=gpenv$gp)
+gp.plot(x,y,type='p',add=FALSE, title=deparse(substitute(y)),pipe=gpenv$gp)
+gp.splot(x,y,z, add=FALSE, title=deparse(substitute(z)), pipe=gpenv$gp,
+ datafile=tempfile())
+}
+\arguments{
+ \item{where}{Path to GnuPlot Executable}
+ \item{pipe}{The pipe object connected to GnuPlot (returned from
+ \code{gp.open}), warning: changing this from the default will
+ probably break things}
+ \item{cmd}{Text string, the command to be sent verbatim to the GnuPlot
+ process}
+ \item{x}{The \code{x} coordinates to plot}
+ \item{y}{the \code{y} coordinates to plot}
+ \item{z}{the \code{z} coordinates to splot}
+ \item{type}{Either 'p' or 'l' for plotting points or lines}
+ \item{add}{Logical, should the data be added to the existing plot or
+ start a new plot}
+ \item{title}{The title or legend entry}
+ \item{datafile}{The file to store the data in for transfer to gnuplot}
+}
+\details{
+ These functions provide a basic interface to the GnuPlot program (you
+ must have GnuPlot installed (separate install)), \code{gp.open} runs
+ GnuPlot and establishes a pipe connection, \code{gp.close} sends a
+ quite command to gnuplot and cleans up temporary variables and files,
+ \code{gp.send} sends a command to the GnuPlot process verbatim, and
+ \code{gp.plot} sends data and commands to the process to create a
+ standard scatterplot or line plot.
+}
+\value{
+ \code{gp.open} returns and invisible copy of the pipe connection
+ object (to pass to other functions, but don't do this because it
+ doesn't work right yet).
+
+ The other 3 functions don't return anything meaningful. All functions
+ are run for their side effects.
+}
+\references{
+ \url{http://www.gnuplot.info/}
+}
+\author{ Greg Snow \email{538280 at gmail.com}}
+\note{
+ These functions create some temporary files and 2 temporary global
+ variables (.gp and .gp.tempfiles), running \code{gp.close} will clean
+ these up (so use it).
+
+ These functions are still alpha level.
+}
+\seealso{\code{\link{plot}} }
+\examples{
+ \dontrun{
+
+x <- 1:10
+y <- 3-2*x+x*x+rnorm(10)
+
+gp.open()
+gp.plot(x,y)
+gp.send('replot 3-2*x+x**2')
+
+tmp <- expand.grid(x=1:10, y=1:10)
+tmp <- transform(tmp, z=(x-5)*(y-3))
+gp.splot(tmp$x, tmp$y, tmp$z)
+
+gp.close()
+ }
+}
+\keyword{hplot}
+
+
+
diff --git a/man/hpd.Rd b/man/hpd.Rd
new file mode 100644
index 0000000..aeff48a
--- /dev/null
+++ b/man/hpd.Rd
@@ -0,0 +1,51 @@
+\name{hpd}
+\alias{hpd}
+\alias{emp.hpd}
+
+\title{Compute Highest Posterior Density Intervals}
+\description{
+ Compute the Highest Posterior Density Interval (HPD) from an inverse
+ density function (hpd) or a vector of realizations of the distribution
+ (emp.hpd).
+}
+
+\usage{
+hpd(posterior.icdf, conf=0.95, tol=0.00000001,...)
+
+emp.hpd(x, conf=0.95)
+}
+\arguments{
+ \item{posterior.icdf}{ Function, the inverse cdf of the posterior
+ distribution (usually a function whose name starts with 'q').}
+ \item{x}{ A vector of realizations from the posterior distribution.}
+ \item{conf}{ Scalar, the confidence level desired. }
+ \item{tol}{ Scalar, the tolerance for \code{optimize}.}
+ \item{\dots}{Additional arguments to \code{posterior.icdf}.}
+}
+\details{
+ These functions compute the highest posterior density intervals
+ (sometimes called minimum length confidence intervals) for a Bayesian
+ posterior distribution. The \code{hpd} function is used when you have
+ a function representing the inverse cdf (the common case with
+ conjugate families). The \code{emp.hpd} function is used when you
+ have realizations of the posterior (when you have results from an MCMC
+ run).
+}
+\value{
+ A vector of length 2 with the lower and upper limits of the interval.
+}
+\author{ Greg Snow \email{538280 at gmail.com}}
+\note{These functions assume that the posterior distribution is
+ unimodal, they compute only 1 interval, not the set of intervals that
+ are appropriate for multimodal distributions.}
+\seealso{\code{hdr} in the hdrcde package.}
+\examples{
+
+hpd(qbeta, shape1=50, shape2=250)
+
+tmp <- rbeta(10000, 50, 250)
+emp.hpd(tmp)
+
+}
+
+\keyword{univar}
diff --git a/man/ineq.Rd b/man/ineq.Rd
new file mode 100644
index 0000000..14cc51d
--- /dev/null
+++ b/man/ineq.Rd
@@ -0,0 +1,86 @@
+\name{\%<\%}
+\Rdversion{1.1}
+\alias{\%<\%}
+\alias{\%<=\%}
+ %- Also NEED an '\alias' for EACH other topic documented here.
+ \title{
+Less than or Less than and equal operators that can be chained together.
+}
+\description{Comparison operators that can be chained together into
+ something like 0 \%<\% x \%<\% 1 instead of 0 < x \&\& x < 1. }
+\usage{
+x \%<\% y
+x \%<=\% y
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x,y}{Values to compare
+}
+}
+\details{
+These functions/operators allow chained inequalities. To specify that
+you want the values between two values (say 0 and 1) you can use \code{0
+ \%<\% x \%<\% 1 } rather than \code{ 0 < x \&\& x < 1 }.
+}
+\value{
+%% ~Describe the value returned
+%% If it is a LIST, use
+%% \item{comp1 }{Description of 'comp1'}
+%% \item{comp2 }{Description of 'comp2'}
+%% ...
+
+A logical vector is returned that can be used for subsetting like
+\code{<}, but the original values are included as attributes to be used
+in additional comparisons.
+}
+%\references{
+%% ~put references to the literature/web site here ~
+%}
+\author{
+Greg Snow, \email{538280 at gmail.com}
+}
+\note{
+ %% ~~further notes~~
+This operator is not fully associative and has different precedence than
+\code{<} and \code{<=}, so be careful with parentheses.
+See the examples.
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+%\seealso{
+%% ~~objects to See Also as \code{\link{help}}, ~~~
+%}
+\examples{
+
+x <- -3:3
+
+ -2 \%<\% x \%<\% 2
+c( -2 \%<\% x \%<\% 2 )
+x[ -2 \%<\% x \%<\% 2 ]
+x[ -2 \%<=\% x \%<=\% 2 ]
+
+
+x <- rnorm(100)
+y <- rnorm(100)
+
+x[ -1 \%<\% x \%<\% 1 ]
+range( x[ -1 \%<\% x \%<\% 1 ] )
+
+
+cbind(x,y)[ -1 \%<\% x \%<\% y \%<\% 1, ]
+cbind(x,y)[ (-1 \%<\% x) \%<\% (y \%<\% 1), ]
+cbind(x,y)[ ((-1 \%<\% x) \%<\% y) \%<\% 1, ]
+cbind(x,y)[ -1 \%<\% (x \%<\% (y \%<\% 1)), ]
+cbind(x,y)[ -1 \%<\% (x \%<\% y) \%<\% 1, ] # oops
+
+
+3 %<% 1:10 %<% 2*3 # oops
+3 %<% 1:10 %<% (2*3) # meant this
+
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ manip }
+\keyword{ logic }% __ONLY ONE__ keyword per line
diff --git a/man/lattice.demo.Rd b/man/lattice.demo.Rd
new file mode 100644
index 0000000..3d65976
--- /dev/null
+++ b/man/lattice.demo.Rd
@@ -0,0 +1,56 @@
+\name{lattice.demo}
+\alias{lattice.demo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Interactively explore the conditioned panels in lattice plots. }
+\description{
+ Plot 1 panel from an xyplot, and optionally a 3d graph highligting the
+ shown points, then allow you to interactively set the conditioning set
+ of data to see the effects and help you better understand how xyplot works.
+}
+\usage{
+lattice.demo(x, y, z, show3d = TRUE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The x variable to plot (numeric). }
+ \item{y}{ The y variable to plot (numeric). }
+ \item{z}{ The variable to condition on (numeric). }
+ \item{show3d}{ Logical, should a 3D cloud be shown as well.}
+}
+\details{
+ This function is intended to for demonstration purposes to help
+ understand what is happening in an \code{xyplot} (lattice). When you
+ run the demo it will create a single panel from a conditioned
+ \code{xyplot} and optionally a 3D cloud with the points included in
+ the panel highlighted. The function then opens a tcl/tk dialog box
+ that allows you to choose which points are included in the panel
+ (based on the conditioning variable). You can choose the center and
+ width of the shingle displayed and the graph will update to show the
+ new selection.
+
+ The intent for this function is for a teacher to show a class how
+ lattice graphics take slices of a 3d plot and show each slice
+ seperately. Students could then work through some examples on their
+ own to better understand what functions like \code{xyplot} are doing
+ automatically.
+}
+\value{
+ No meaningful return value, this function is run for the side effects.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+
+
+\seealso{\code{xyplot} in lattice package}
+\examples{
+
+if(interactive()){
+require(stats)
+lattice.demo(quakes$long, quakes$lat, quakes$depth)
+}
+
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+\keyword{ dynamic }% __ONLY ONE__ keyword per line
diff --git a/man/ldsgrowth.Rd b/man/ldsgrowth.Rd
new file mode 100644
index 0000000..a93d947
--- /dev/null
+++ b/man/ldsgrowth.Rd
@@ -0,0 +1,40 @@
+\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}
diff --git a/man/loess.demo.Rd b/man/loess.demo.Rd
new file mode 100644
index 0000000..6a8e578
--- /dev/null
+++ b/man/loess.demo.Rd
@@ -0,0 +1,89 @@
+\name{loess.demo}
+\alias{loess.demo}
+
+\title{ Demonstrate the internals of loess curve fits }
+\description{
+ Creates a scatterplot with a loess fit, then interactively shows the
+ window and case weights used to create the curve at the selected value
+ of \code{x}.
+}
+\usage{
+loess.demo(x, y, span = 2/3, degree = 1, nearest = FALSE,
+ xlim = numeric(0), ylim = numeric(0), verbose = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The \code{x} coordinates to be plotted. }
+ \item{y}{ The \code{y} coordinates to be plotted. }
+ \item{span}{ The relative width of the window, passed on to \code{loess}. }
+ \item{degree}{ Degree of polynomial to use (0, 1, or 2), passed on to \code{loess}. }
+ \item{nearest}{ Logical, should predictions be made at the point where
+ you clicked (FALSE), or at the nearest x value of the data to where
+ you clicked (TRUE).}
+ \item{xlim}{ Limits of the Horizonal axis. }
+ \item{ylim}{ Limits of the Vertical axis. }
+ \item{verbose}{ If true then print the x coordinate being predicted. }
+}
+\details{
+ This function demonstrates the underlying calculations of loess
+ curves.
+
+ Given \code{x} and \code{y} vectors it will create a scatterplot and
+ add 2 loess fit lines (one using straight loess smooth with linear
+ interpolation and one that does a spline interpolation of the loess
+ fit).
+
+ The function then waits for the user to click on the plot. The
+ function then shows the window of points (centered at the \code{x}
+ value clicked on) used in the weighting for predicting that point and
+ shows a circle around each point in the window where the area of the
+ circle is proportional to the weight of that point in the linear fit.
+ The function also shows the linear (or quadratic) fit used to predict
+ at the selected point.
+
+ The basic steps of the loess algorithm (as demonstrated by the
+ function) is that to predict the y-value for a given x-value the
+ computer:
+
+ 1. Find all the points within a window around the x-value (the width
+ of the window is based on the parameter \code{span}).
+ 2. Weight the points in the window with points nearest the x-value
+ having the highest weight.
+ 3. Fit a weighted linear (quadratic) line to the points in the
+ window.
+ 4. Use the y-value of the fitted line (curve) at the x-value to give
+ loess prediction at that x-value.
+
+ Clicking on another point in the graph will replot with the new
+ situation.
+
+ Right click and select 'stop' to end the demonstration.
+}
+\value{
+ This function does not return anything, it is run purely for its side
+ effects.
+}
+
+\author{ Greg Snow \email{538280 at gmail.com}}
+
+
+
+
+\seealso{ \code{\link{loess}}, \code{\link{locator}} }
+\examples{
+
+if(interactive()){
+data(ethanol, package='lattice')
+attach(ethanol)
+loess.demo(E, NOx)
+# now click a few places, right click to end
+loess.demo(E, NOx, span=1.5)
+loess.demo(E, NOx, span=0.25)
+loess.demo(E, NOx, degree=0)
+loess.demo(E, NOx, degree=2)
+detach()
+}
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+\keyword{ dynamic }% __ONLY ONE__ keyword per line
+\keyword{ iplot }
\ No newline at end of file
diff --git a/man/mle.demo.Rd b/man/mle.demo.Rd
new file mode 100644
index 0000000..d90533e
--- /dev/null
+++ b/man/mle.demo.Rd
@@ -0,0 +1,65 @@
+\name{mle.demo}
+\alias{mle.demo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Demonstrate the basic concept of Maximum Likelihood Estimation }
+\description{
+ This function graphically shows log likelihoods for a set of data and
+ the normal distribution and allows you to interactively change the
+ parameter estimates to see the effect on the log likelihood.
+}
+\usage{
+mle.demo(x = rnorm(10, 10, 2), start.mean = mean(x) - start.sd,
+ start.sd = 1.2 * sqrt(var(x)))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ A vector of data (presumably from a normal distribution). }
+ \item{start.mean}{ The initial value for estimating the mean. }
+ \item{start.sd}{ The initial value for estimating the standard deviation. }
+}
+\details{
+ The function creates a plot with 3 panels: the top panel shows a
+ normal curve based on the current values of the mean and standard
+ deviation along with a vertical line for each point in \code{x} (the
+ product of the heights of these lines is the likelihood, the sum of
+ the logs of their heights is the log likelihood).
+
+ The lower 2 plots show the profiles of the mean and standard
+ deviation. The y-axis is the likelihoods of the parameters tried so
+ far, and the x-axes are the mean and standard deviation tried. The
+ point corresponding to the current parameter estimates will be solid
+ red.
+
+ A Tk slider box is also created that allows you to change the current
+ estimates of the mean and standard deviation to show the effect on the
+ log likelihood and find the maximum likelihood estimate.
+}
+\value{
+ This function is run for its side effects and returns NULL.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{fitdistr} in package MASS, \code{mle} in
+ package stats4, \code{\link{slider}} }
+\examples{
+
+if(interactive()){
+mle.demo()
+
+m <- runif(1, 50,100)
+s <- runif(1, 1, 10)
+x <- rnorm(15, m, s)
+
+mm <- mean(x)
+ss <- sqrt(var(x))
+ss2 <- sqrt(var(x)*11/12)
+mle.demo(x)
+# now find the mle from the graph and compare it to mm, ss, ss2, m, and s
+}
+}
+\keyword{ iplot }% at least one, from doc/KEYWORDS
+\keyword{ dynamic }% __ONLY ONE__ keyword per line
diff --git a/man/ms.polygram.Rd b/man/ms.polygram.Rd
new file mode 100644
index 0000000..a61fea7
--- /dev/null
+++ b/man/ms.polygram.Rd
@@ -0,0 +1,114 @@
+\name{ms.polygram}
+\alias{ms.polygram}
+\alias{ms.polygon}
+\alias{ms.filled.polygon}
+\alias{ms.male}
+\alias{ms.female}
+\alias{ms.arrows}
+\alias{ms.sunflowers}
+\alias{ms.image}
+\alias{ms.face}
+\title{Symbol functions/data to be passed as symb argument to
+ my.symbols}
+\description{
+ These functions/data matricies are examples of what can be passed as
+ the \code{symb} argument in the \code{my.symbols} function. They are
+ provided both to be used for some common symbols and as examples of
+ what can be passed as the \code{symb} argument.
+}
+\usage{
+ms.polygram(n, r=1, adj=pi/2, ...)
+ms.polygon(n, r=1, adj=pi/2, ...)
+ms.filled.polygon(n, r=1, adj=pi/2, fg=par('fg'), bg=par('fg'), ... )
+ms.male
+ms.female
+ms.arrows(angle, r=1, adj=0.5, length=0.1, ...)
+ms.sunflowers(n,r=0.3,adj=pi/2, ...)
+ms.image(img, transpose=TRUE, ...)
+ms.face(features, ...)
+}
+\arguments{
+ \item{n}{The number of sides for polygons and polygrams, the number of
+ petals(lines) for sunflowers.}
+ \item{r}{The radius of the enclosing circle for polygons and polygrams
+ (1 means that it will pretty much fill the bounding square). For
+ sunflowers this is the radius (relative to the inches square) of the
+ inner circle. For arrows this controls the length of the arrow, a
+ value of 2 means the length of the arrow will be the same as inches
+ (but it may then stick out of the box if adj != 1).}
+ \item{adj}{For polygons, polygrams, and sunflowers this is the angle
+ in radians that the first corner/point will be. The default puts a
+ corner/point straight up, this can be used to rotate the symbols. For
+ arrows, this determines the positioning of the arrow, a value of 0
+ means the arrow will start at the x,y point and point away from it,
+ 0.5 means the arrow will be centered at x,y and 1 means that the arrow
+ will end (point at) x,y.}
+ \item{fg, bg}{Colors for the filled polygons. \code{fg} is the color
+ of the line around the polygon and \code{bg} is the fill color, see
+ \code{\link{polygon}}.}
+ \item{angle}{The angle in radians that the arrow will point.}
+ \item{length}{The length of the arrow head (see
+ \code{\link{arrows}}).}
+ \item{img}{ A 3 dimensional array representing an image such as
+ produced by the png or EBImage packages.}
+ \item{transpose}{Should the image be tranposed, use TRUE for images
+ imported using package png and FALSE for images imported using
+ EBImage.}
+ \item{features}{A list of data representing the features of
+ the faces, each element represents 1 face and the values need to be
+ scaled between 0 and 1, see \code{\link{faces}} for details on which
+ elements match which features.}
+ \item{...}{additional parameters that will be passed to plotting
+ functions or be ignored.}
+}
+\details{
+ These functions/matricies can be passed as the \code{symb} argument to
+ the \code{my.symbols} function. The represent examples that can be
+ used to create your own symbols or may be used directly.
+}
+\value{
+ These functions either return a 2 column matrix of points to be passed
+ to \code{lines} or \code{NULL}.
+}
+\author{Greg Snow \email{538280 at gmail.com}}
+\seealso{\code{\link{my.symbols}}, \code{\link{polygon}},
+ \code{\link{arrows}}, \code{\link{lines}}, \code{\link{faces}}, also see
+ \code{\link{rasterImage}} for an alternative to ms.image
+}
+\examples{
+
+plot(1:10,1:10)
+my.symbols(1:10,1:10, ms.polygram, n=1:10, r=seq(0.5,1,length.out=10),
+inches=0.3)
+
+my.symbols(1:10,1:10, ms.polygon, n=1:10, add=FALSE, inches=0.3)
+
+my.symbols(1:5, 5:1, ms.filled.polygon, add=FALSE, n=3:7, fg='green',
+ bg=c('red','blue','yellow','black','white'), inches=0.3 )
+
+my.symbols( 1:10, 1:10, ms.female, inches=0.3, add=FALSE)
+my.symbols( 1:10, 10:1, ms.male, inches=0.3, add=TRUE)
+
+plot(1:10, 1:10)
+my.symbols(1:10, 1:10, ms.arrows, angle=runif(10)*2*pi, inches=0.5,
+adj=seq(0,1,length.out=10), symb.plots=TRUE)
+
+my.symbols(1:10, 1:10, ms.sunflowers, n=1:10, inches=0.3, add=FALSE)
+
+if( require(png) ) {
+ img <- readPNG(system.file("img", "Rlogo.png", package="png"))
+
+ my.symbols( runif(10), runif(10), ms.image, MoreArgs=list(img=img),
+ inches=0.5, symb.plots=TRUE, add=FALSE)
+}
+
+tmp.mtcars <- scale(mtcars, center=sapply(mtcars,min),
+ scale=sapply(mtcars,function(x) diff(range(x))) )
+tmp2.mtcars <- lapply( seq_len(nrow(tmp.mtcars)), function(i) tmp.mtcars[i,] )
+my.symbols(mtcars$wt, mtcars$mpg, ms.face, inches=0.3, features=tmp2.mtcars,
+ add=FALSE)
+
+
+}
+\keyword{dplot}
+\keyword{aplot}
\ No newline at end of file
diff --git a/man/mysymbols.Rd b/man/mysymbols.Rd
new file mode 100644
index 0000000..9ffa30a
--- /dev/null
+++ b/man/mysymbols.Rd
@@ -0,0 +1,177 @@
+\name{my.symbols}
+\alias{my.symbols}
+\title{Draw Symbols (User Defined) on a Plot}
+\description{This function draws symbols on a plot. It is similar to
+ the builtin \code{symbols} function with the difference that it plots
+ symbols defined by the user rather than a prespecified set of
+ symbols.}
+\usage{
+my.symbols(x, y=NULL, symb, inches=1, xsize, ysize,
+ add=TRUE,
+ vadj=0.5, hadj=0.5,
+ symb.plots=FALSE,
+ xlab=deparse(substitute(x)),
+ ylab=deparse(substitute(y)), main=NULL,
+ xlim=NULL, ylim=NULL, linesfun=lines,
+ ..., MoreArgs)
+}
+\arguments{
+ \item{x, y}{The \code{x} and \code{y} coordinates for the position of
+ the symbols to be plotted. These can be specified in any way which is
+ accepted by \code{xy.coords}.}
+ \item{symb}{Either a matrix, list, or function defining the symbol to
+ be plotted. If it is a matrix or list it needs to be formatted that
+ it can be passed directly to the \code{lines} function. It then
+ defines the shape of the symbol on on a range/domain of -1 to 1. If
+ this is a function it can either return a matrix or list as above
+ (points on the range/domain of -1 to 1), or it can do the plotting
+ itself.}
+ \item{inches}{The size of the square containing the symbol in inches
+ (note: unlike \code{symbols} this cannot be \code{FALSE}). This is
+ ignored if \code{xsize} or \code{ysize} is specified.}
+ \item{xsize}{The width of the bounding box(s) of the symbols in the same
+ units as the \code{x} variable. Computed from \code{ysize} or
+ \code{inches} if not specified. Can be a single value or a vector.}
+ \item{ysize}{The height of the bounding box(s) of the symbols in the
+ same units as the \code{y} variable. Computed from \code{xsize} or
+ \code{inches} if not specified. Can be a single value or a vector.}
+ \item{add}{if 'add' is 'TRUE' then the symbols are added to the
+ existing plot, otherwise a new plot is created.}
+ \item{vadj,hadj}{Numbers between 0 and 1 indicating how 'x' and 'y'
+ specify the location of the symbol. The defaults center the symbol at
+ x,y; 0 means put the bottom/left at x,y; and 1 means put
+ the top/right of the symbol at x,y.}
+ \item{symb.plots}{If \code{symb} is a function that does its own
+ plotting, set this to TRUE, otherwise it should be FALSE.}
+ \item{xlab, ylab, main, xlim, ylim}{If 'add' is 'FALSE' these are
+ passed to the \code{plot} function when setting up the plot.}
+ \item{linesfun}{The function to draw the lines if the function does not do its own drawing. The default is \code{lines} but could be replaced with \code{polygon} to draw filled polygons}
+ \item{...}{Additional arguments will be replicated to the same length
+ as \code{x} then passed to \code{symb} (if \code{symb} is a function)
+ and/or the \code{lines} function (one value per symbol drawn).}
+ \item{MoreArgs}{A list with any additional arguments to be passed to
+ the \code{symb} function (as is, without being replicated/split).}
+}
+\details{
+ The \code{symb} argument can be a 2 column matrix or a list with
+ components 'x' and 'y' that defines points on the interval [-1,1] that
+ will be connected with lines to draw the symbol. If you want a closed
+ polygon then be sure to replicate the 1st point as the last point.
+
+ If any point contains an NA then the line will not be drawn to or from
+ that point. This can be used to create a symbol with disjoint parts
+ that should not be connected.
+
+ If \code{symb} is a function then it should include a '...' argument
+ along with any arguments to define the symbol. Any unmatched
+ arguments that end up in the '...' argument will be replicated to the
+ same length as 'x' (using the \code{rep} function) then the values
+ will be passed one at a time to the \code{symb} function. If
+ \code{MoreArgs} is specified, the elements of it will also be passed
+ to \code{symb} without modification. The \code{symb} function can
+ either return a matrix or list with the points that will then be
+ passed to the \code{lines} function (see above). Or the function can
+ call the plotting functions itself (set \code{symb.plots} to TRUE).
+ High level plotting can be done (\code{plot}, \code{hist}, and other
+ functions), or low level plotting functions (\code{lines},
+ \code{points}, etc) can be used; in this case they should add things
+ to a plot with 'x' and 'y' limits of -1 to 1.
+
+ The size of the symbols can be specified by using \code{inches} in
+ which case the symbol will be set inside of squares whose sizes are
+ \code{inches} size based on the plotting device. The size can also be
+ set using \code{xsize} and/or \code{ysize} which use the same units as
+ the \code{x} and/or \code{y} variables. If only one is specified then
+ the box will be square. If both are specified and they do not match
+ the aspect ratio of the plot then the bounding box will not be square
+ and the symbol will be distorted.
+}
+\value{
+ This function is run for its side effect of plotting, it returns an
+ invisible NULL.
+}
+\author{Greg Snow \email{538280 at gmail.com}}
+\note{Since the '...' argument is passed to both \code{lines} and
+ \code{symb}, the \code{symb} function should have a '...' argument so
+ that it will ignore any additional arguments.
+
+ Arguments such as 'type' can be passed through the '...' argument if
+ you want the symbol made of something other than lines.
+
+ Plotting coordinates and sizes are based on the size of the device at
+ the time the function is called. If you resize the device after
+ plotting, all bets are off.
+
+ Currently missing values in \code{x} or \code{y} are not handled
+ well. It is best if remove all missing values first.
+}
+\seealso{\code{\link{symbols}}, \code{\link{subplot}},
+ \code{\link{mapply}}, \code{\link{ms.polygram}}, \code{\link{lines}}}
+\examples{
+
+# symb is matrix
+
+my.symbols( 1:10, runif(10), ms.male, add=FALSE, xlab='x',
+ ylab='y', inches=0.3, col=c('blue','green'), xlim=c(0,11), ylim=c(-0.1,1.1))
+my.symbols( (1:10)+0.5, runif(10), ms.female, add=TRUE, inches=0.3,
+ col=c('red','green') )
+
+# symb is function returning matrix
+
+plot(1:10, 1:10)
+my.symbols( 1:10, 1:10, ms.polygram, n=1:10, inches=0.3 )
+
+
+# symb is plotting function
+# create a variation on monthplot
+
+fit <- lm( log(co2) ~ time(co2) )
+fit.r <- resid(fit)
+
+x <- 1:12
+y <- tapply(fit.r, cycle(co2), mean)
+
+tmp.r <- split( fit.r, cycle(co2) )
+tmp.r <- lapply( tmp.r, function(x) x-mean(x) )
+
+yl <- do.call('range',tmp.r)
+
+tmpfun <- function(w,data,ylim,...){
+ tmp <- data[[w]]
+ plot(seq(along=tmp),tmp, type='l', xlab='',ylab='',
+ axes=FALSE, ylim=ylim)
+ lines(par('usr')[1:2], c(0,0), col='grey')
+}
+
+my.symbols(x,y, symb=tmpfun, inches=0.4, add=FALSE, symb.plots=TRUE,
+ xlab='Month',ylab='Adjusted CO2', xlim=c(0.5,12.5),
+ ylim=c(-0.012,0.012),
+ w=1:12, MoreArgs=list(data=tmp.r,ylim=yl) )
+
+# using xsize and ysize
+plot( 1:10, (1:10)*100, type='n', xlab='', ylab='' )
+my.symbols( 5, 500, ms.polygon, n=250, inches=1.5 )
+my.symbols( 5, 500, ms.polygon, n=250, xsize=2, col='blue' )
+my.symbols( 5, 500, ms.polygon, n=250, ysize=200, col='green' )
+my.symbols( 5, 500, ms.polygon, n=250, xsize=2, ysize=200, col='red' )
+abline( v=c(4,6), col='grey' )
+abline( h=c(400, 600), col='grey' )
+
+
+# hand crafted hexagonal grid
+
+x1 <- seq(0, by=2*sqrt(3), length.out=10)
+y1 <- seq(0, by=3, length.out=10)
+
+mypoints <- expand.grid(x=x1, y=y1)
+mypoints[,1] <- mypoints[,1] + rep( c(0,sqrt(3)), each=10, length.out=100 )
+
+plot(mypoints, asp=1, xlim=c(-2,35))
+my.symbols(mypoints, symb=ms.filled.polygon, n=6,
+ inches=par('pin')[1]/(diff(par('usr')[1:2]))*4,
+ bg=paste('gray',1:100,sep=''), fg='green' )
+
+}
+\keyword{aplot}
+\keyword{dplot}
+\keyword{hplot}
diff --git a/man/normtest.Rd b/man/normtest.Rd
new file mode 100644
index 0000000..cb1cc2b
--- /dev/null
+++ b/man/normtest.Rd
@@ -0,0 +1,76 @@
+\name{SnowsPenultimateNormalityTest}
+\alias{SnowsPenultimateNormalityTest}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+ Test the uninteresting question of whether the data represents an
+ exact normal distribution.
+}
+\description{
+ This function tests the null hypothesis that the data comes from an
+ exact normal population. This is a much less interesting/useful null
+ than what people usually want, which is to know if the data come from
+ a distribution that is similar enough to the normal to use normal
+ theory inference.
+}
+\usage{
+SnowsPenultimateNormalityTest(x)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The data }
+}
+\details{
+ The theory for this test is based on the probability of getting a
+ rational number from a truly continuous distribution defined on the
+ reals.
+
+ The main goal of this test is to quickly give a p-value for those that
+ feel it necessary to test the uninteresting and uninformative null
+ hypothesis that the data represents an exact normal, and allows the
+ user to then move on to much more important questions, like "is the
+ data close enough to the normal to use normal theory inference?".
+
+ After running this test (or better instead of running this and any
+ other test of normality) you should ask yourself what it means to test
+ for normality and why you would want to do so. Then plot the data and
+ explore the interesting/useful questions.
+}
+\value{
+%% ~Describe the value returned
+%% If it is a LIST, use
+%% \item{comp1 }{Description of 'comp1'}
+%% \item{comp2 }{Description of 'comp2'}
+%% ...
+An object of class "htest" with components:
+
+\item{p.value}{The p-value}
+\item{alternative}{a string representing the alternative hypothesis}
+\item{method}{a string describing the method}
+\item{data.name}{a string describing the name of the data}
+}
+\references{
+\code{fortune(234)}
+}
+\author{
+Greg Snow \email{538280 at gmail.com}
+}
+\note{
+Note: if you just use this function and report the p-value then the
+function has failed in its purpose. If this function helps you to think
+about your analysis and what question(s) you are really interested in,
+create meaningful plots, and focus on the more meaningful parts of
+research, then it has succeeded. See also Cochrane's Aphorism.
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{qqnorm}}, \code{\link{vis.test}}
+}
+\examples{
+SnowsPenultimateNormalityTest(rt(100,25))
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ distribution }
+\keyword{ htest }% __ONLY ONE__ keyword per line
diff --git a/man/outliers.Rd b/man/outliers.Rd
new file mode 100644
index 0000000..8442441
--- /dev/null
+++ b/man/outliers.Rd
@@ -0,0 +1,85 @@
+\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}
diff --git a/man/pairs2.Rd b/man/pairs2.Rd
new file mode 100644
index 0000000..5e94de4
--- /dev/null
+++ b/man/pairs2.Rd
@@ -0,0 +1,66 @@
+\name{pairs2}
+\alias{pairs2}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Create part of a scatterplot matrix}
+\description{
+ This function is similar to the \code{pairs} function, but instead of
+ doing all pairwise plots, it takes 2 matricies or data frames and does
+ all combinations of the first on the x-axis with the 2nd on the
+ y-axis. Used with pairs and subsets can spread a scatterplot matrix
+ accross several pages.
+}
+\usage{
+pairs2(x, y, xlabels, ylabels, panel = points, ..., row1attop = TRUE, gap = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ Matrix or data frame of variables to be used as the x-axes. }
+ \item{y}{ Matrix or data frame of variables to be used as the y-axes. }
+ \item{xlabels}{ Labels for x variables (defaults to colnames of \code{x}). }
+ \item{ylabels}{ Labels for y variables (defaults to colnames of \code{y}). }
+ \item{panel}{ Function to do the plotting (see \code{pairs}). }
+ \item{\dots}{ additional arguments passed to graphics functions}
+ \item{row1attop}{ Logical, should the 1st row be the top.}
+ \item{gap}{ Distance between plots. }
+}
+\details{
+ This functios is similar to the \code{pairs} function, but by giving
+ it 2 sets of data it only does the combinations between them. Think
+ of it as giving the upper right or lower left set of plots from
+ \code{pairs}. If a regular scatterplot matrix is too small on the
+ page/device then use \code{pairs} on subsets of the data to get the
+ diagonal blocks of a scatterplot matrix and this function to get the
+ off diagonal blocks.
+}
+\value{
+ This function is run for the side effect of the plot. It does not
+ return anything useful.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow, \email{538280 at gmail.com}}
+\note{
+ Large amounts of the code for this function were blatently
+ borrowed/stolen from the \code{pairs} function, the credit for the
+ useful parts should go to the original authors, blame for any problems
+ should go to me. This function is also released under GPL since much
+ of it comes from GPL code.
+}
+\seealso{\code{\link{pairs}}, \code{splom} in the lattice package}
+\examples{
+pairs2(iris[,1:2], iris[,3:4], col=c('red','green','blue')[iris$Species])
+
+# compare the following plot:
+pairs(state.x77, panel=panel.smooth)
+
+# to the following 4 plots
+
+pairs(state.x77[,1:4], panel=panel.smooth)
+pairs(state.x77[,5:8], panel=panel.smooth)
+pairs2( state.x77[,1:4], state.x77[,5:8], panel=panel.smooth)
+pairs2( state.x77[,5:8], state.x77[,1:4], panel=panel.smooth)
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{hplot}
+
diff --git a/man/panel.mysymbols.Rd b/man/panel.mysymbols.Rd
new file mode 100644
index 0000000..70a56db
--- /dev/null
+++ b/man/panel.mysymbols.Rd
@@ -0,0 +1,100 @@
+\name{panel.my.symbols}
+\alias{panel.my.symbols}
+\title{Draw Symbols (User Defined) on a Lattice Plot}
+\description{This function draws symbols on a lattice plot. It is similar to
+ the builtin \code{symbols} function with the difference that it plots
+ symbols defined by the user rather than a prespecified set of
+ symbols.}
+\usage{
+panel.my.symbols(x, y, symb, inches=1, polygon=FALSE,
+ ..., symb.plots=FALSE, subscripts, MoreArgs)
+}
+\arguments{
+ \item{x, y}{The \code{x} and \code{y} coordinates for the position of
+ the symbols to be plotted. These can be specified in any way which is
+ accepted by \code{xy.coords}.}
+ \item{symb}{Either a matrix, list, or function defining the symbol to
+ be plotted. If it is a matrix or list it needs to be formatted that
+ it can be passed directly to the \code{llines} function. It then
+ defines the shape of the symbol on on a range/domain of -1 to 1. If
+ this is a function it can either return a matrix or list as above
+ (points on the range/domain of -1 to 1).}
+ \item{inches}{The size of the square containing the symbol in inches
+ (note: unlike \code{symbols} this cannot be \code{FALSE}).}
+ \item{polygon}{If TRUE, use \code{lpolygon} function to plot rather than the
+ \code{llines} function.}
+ \item{symb.plots}{Currently not implemented.}
+ \item{...}{Additional arguments will be replicated to the same length
+ as \code{x} then passed to \code{symb} (if \code{symb} is a function)
+ and/or the \code{lines} function (one value per symbol drawn).}
+ \item{subscripts}{subscripts for the current panel}
+ \item{MoreArgs}{A list with any additional arguments to be passed to
+ the \code{symb} function (as is, without being replicated/split).}
+}
+\details{
+ The \code{symb} argument can be a 2 column matrix or a list with
+ components 'x' and 'y' that defines points on the interval [-1,1] that
+ will be connected with lines to draw the symbol. If you want a closed
+ polygon then be sure to replicate the 1st point as the last point or
+ use the \code{polygon} option.
+
+ If any point contains an NA then the line will not be drawn to or from
+ that point. This can be used to create a symbol with disjoint parts
+ that should not be connected.
+
+ If \code{symb} is a function then any unmatched
+ arguments that end up in the '...' argument will be replicated to the
+ same length as 'x' (using the \code{rep} function) then the values
+ will be passed one at a time to the \code{symb} function. If
+ \code{MoreArgs} is specified, the elements of it will also be passed
+ to \code{symb} without modification. The \code{symb} function can
+ either return a matrix or list with the points that will then be
+ passed to the \code{llines} function (see above).
+}
+\value{
+ This function is run for its side effect of plotting, it returns an
+ invisible NULL.
+}
+\author{Greg Snow \email{538280 at gmail.com}}
+\note{
+ Plotting coordinates and sizes are based on the size of the device at
+ the time the function is called. If you resize the device after
+ plotting, all bets are off.
+}
+\seealso{\code{\link{symbols}}, \code{\link{my.symbols}}, \code{\link{subplot}},
+ \code{\link{mapply}}, \code{\link{ms.polygram}}, \code{\link{lines}}}
+\examples{
+if(require(lattice)) {
+ tmpdf <- data.frame( x=1:10, y=1:10, g=rep( c("A","B"), each=5 ),
+ z=c(1:5,5:1) )
+
+ xyplot( y ~ x, tmpdf, panel=panel.my.symbols, symb=ms.female, inches=0.3 )
+
+ xyplot( y ~ x | g, tmpdf, panel=panel.my.symbols, symb=ms.male, inches=0.3)
+
+ xyplot( y ~ x, tmpdf, panel=panel.superpose, groups=g,
+ panel.groups= function(group.number, ...) {
+ if(group.number==1) {
+ panel.my.symbols(..., symb=ms.male)
+ } else {
+ panel.my.symbols(..., symb=ms.female)
+ } },
+ inches=0.3
+ )
+
+ xyplot( y ~ x, tmpdf, panel=panel.my.symbols, symb=ms.polygram, n=tmpdf$z,
+ inches=0.3)
+
+ xyplot( y ~ x | g, tmpdf, panel=panel.my.symbols, symb=ms.polygram,
+ n=tmpdf$z, inches=0.3)
+
+ xyplot( y ~ x, tmpdf, panel=panel.superpose, groups=g,
+ panel.groups = panel.my.symbols,
+ inches=0.3, symb=ms.polygon, n=tmpdf$z, polygon=TRUE,
+ adj=rep(c(0,pi/4),5)
+ )
+}
+}
+\keyword{aplot}
+\keyword{dplot}
+\keyword{hplot}
diff --git a/man/petals.Rd b/man/petals.Rd
new file mode 100644
index 0000000..ade51c5
--- /dev/null
+++ b/man/petals.Rd
@@ -0,0 +1,103 @@
+\name{petals}
+\alias{petals}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+ Play the Petals Around the Rose game
+}
+\description{
+This plays the lateral thinking game Petals Around the Rose. This is a
+game where 5 regular dice are rolled and the players then try to figure
+out how many petals are around the rose.
+}
+\usage{
+petals(plot = TRUE, txt = TRUE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{plot}{ Should the dice be plotted to the current/default
+ graphics device.
+}
+ \item{txt}{ Should the dice be shown in the console window using text.
+%% ~~Describe \code{txt} here~~
+}
+}
+\details{
+ At least one of the arguments \code{plot} and \code{txt} needs to be
+ true, otherwise you will be guessing blind (or testing your psychic
+ abilities).
+
+ The game is usually played with 5 physical dice, one person who knows
+ the rules (the potentate of the rose, here the computer), and one or
+ more players trying to learn the puzzle. The potentate can only give
+ the players the following 3 rules:
+
+ \enumerate{
+ \item The name of the game is "Petals Around the Rose" and the name is
+ significant.
+
+ \item The answer is always 0 or an even number.
+
+ \item The potentate can tell the answer for any roll after any guesses
+ are made.
+}
+
+The potentate (or other player) then rolls the 5 dice and any players
+are then allowed to guess. The potentate either confirms a correct
+guess or tells the correct answer, then the game continues with another
+roll. Players are not to discuss their reasoning so that each can solve
+it themselves. When a player thinks they have worked out the reasoning
+they demonstrate it by getting correct guesses, but not by discussing it
+with anyone. Generally 6 correct guesses in a row is considered
+evidence that they have figured out the rules and they are then
+considered a potentate of the rose.
+
+For this implementation the computer will simulate the role of 5 dice
+and display the results and ask for a guess of how many petals are
+around the rose. The player then enters their guess and the computer
+then either confirms that it is correct or gives the correct answer.
+
+Pressing enter without making a guess ends the game.
+
+}
+\value{
+
+ This function only returns NULL, it is run for its side effects.
+
+%% ~Describe the value returned
+%% If it is a LIST, use
+%% \item{comp1 }{Description of 'comp1'}
+%% \item{comp2 }{Description of 'comp2'}
+%% ...
+}
+\references{
+ \url{http://www.borrett.id.au/computing/petals-bg.htm}
+%% ~put references to the literature/web site here ~
+}
+\author{Greg Snow, \email{538280 at gmail.com}
+%% ~~who you are~~
+}
+\note{
+ Casual viewing of the function source code is unlikely to reveal the
+ secret (and therefore this could be used as an example of one way to
+ disguise portions of code from casual examination). More on
+ disguising source code is at \url{https://stat.ethz.ch/pipermail/r-devel/2011-October/062236.html}.
+
+ Some basic debugging can reveal the secret, but that would be cheating
+ and an admission that such a simple game has defeated you, so don't do
+ it, just keep playing until you figure it out.
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{dice}
+}
+\examples{
+if(interactive()){
+ petals()
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ misc }
+
diff --git a/man/plot.rgl.coin.Rd b/man/plot.rgl.coin.Rd
new file mode 100644
index 0000000..419b30b
--- /dev/null
+++ b/man/plot.rgl.coin.Rd
@@ -0,0 +1,106 @@
+\name{rgl.coin}
+\alias{rgl.coin}
+\alias{rgl.die}
+\alias{flip.rgl.coin}
+\alias{roll.rgl.die}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Animated die roll or coin flip }
+\description{
+ Open an rgl window, plot either a representation of a coin or a die
+ then animate the flipping/rolling.
+}
+\usage{
+rgl.coin(x, col = "black", heads = x[[1]], tails = x[[2]], ...)
+
+rgl.die(x=1:6, col.cube = "white", col.pip = "black", sides = x, ...)
+
+flip.rgl.coin(side = sample(2, 1), steps = 150)
+
+roll.rgl.die(side = sample(6, 1), steps = 250)
+}
+\arguments{
+ \item{x}{ for \code{rgl.coin} a list with information for drawing
+ the faces of the coin, defaults to \code{coin.faces}. For
+ \code{rgl.die} a vector with the number of pips to put on the
+ sides of the die (alternative way of specifying \code{sides}). }
+ \item{col}{ Color of lines on the coin faces. }
+ \item{heads}{ Design to use as "heads" side of coin. }
+ \item{tails}{ Design to use as "tails" side of coin. }
+ \item{col.cube}{ Color of the cube for the die. }
+ \item{col.pip}{ Color of the pips (spots) on the die }
+ \item{sides}{ Vector of length 6 indicating which numbers to show on
+ the die. }
+ \item{side}{ Which side of the coin (1 or 2) or die (1 through 6)
+ should end up face up. }
+ \item{steps}{ The number of steps in each part of the animation,
+ higher values will be smoother and slower, lower values will be
+ faster but more jumpy. }
+ \item{...}{ Currently any additional options are silently ignored. }
+}
+\details{
+ You must use the plot function first to create the coin or die, then
+ use the flip or roll function to start the animation. You can animate
+ multiple times for a single use of the plotting function.
+
+ You can manually rotate the image as well, see the \code{rgl} package
+ for details.
+
+ The defaults plot a regular coin and die, but arguments are available
+ to create special casses (2 headed coin, die with 2 6's and no 1,
+ ...).
+
+ The data list \code{coin.faces} contains information on designs for
+ the faces of the coins in case you want to choose a different design.
+
+ The default rolling and flipping options ranomly choose which side
+ will be face up following a uniform distribution. You can specify the
+ side yourself, or use the \code{sample} function to do a biased random
+ flip/roll.
+}
+\value{
+ Which side ended up face up (1 or 2 for coin, 1 through 6 for die).
+ This is the internal numbering and does not match a change in the
+ \code{sides} argument.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com}}
+\note{ The current algorithm for animating the die roll shows all the
+ sides, but I am not satisfied with it. Please suggest improvements. }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{dice}}, \code{\link{plot.dice}},
+ \code{\link{coin.faces}}, \code{\link{sample}} }
+\examples{
+if(interactive()){
+rgl.coin()
+flip.rgl.coin()
+flip.rgl.coin(1)
+flip.rgl.coin(2)
+
+rgl.clear()
+
+# two-headed coin
+rgl.coin(tails=coin.faces$qh)
+
+rgl.clear()
+
+# letters instead of pictures
+rgl.coin(heads=coin.faces$H, tails=coin.faces$T)
+
+# biased flip
+flip.rgl.coin( sample(2,1, prob=c(0.65, 0.35) ) )
+
+rgl.clear()
+
+rgl.die()
+roll.rgl.die()
+roll.rgl.die(6)
+
+# biased roll
+roll.rgl.die( sample(6,1, prob=c(1,2,3,3,2,1) ) )
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ datagen }% __ONLY ONE__ keyword per line
+\keyword{distribution}
\ No newline at end of file
diff --git a/man/plot2script.Rd b/man/plot2script.Rd
new file mode 100644
index 0000000..98ed758
--- /dev/null
+++ b/man/plot2script.Rd
@@ -0,0 +1,70 @@
+\name{plot2script}
+\alias{plot2script}
+\title{Create a script from the current plot}
+\description{This function attempts to create a script that will
+ recreate the current plot (in the graphics window). You can then edit
+ any parts of the script that you want changed and rerun to get the
+ modified plot.}
+\usage{
+plot2script(file='clipboard')
+}
+\arguments{
+ \item{file}{The filename (the clipboard by default) for the script to
+ create or append to.}
+}
+\details{
+ This function works with the graphics window and mainly traditional
+ graphics (it may work with lattice or other graphics, but has not
+ really been tested with those).
+
+ This function creates a script file (or puts it on the clipboard so
+ that you can past into a script window or text editor) that will
+ recreate the current graph in the current graph window. The script
+ consists of very low level functions (calls to \code{plot.window} and
+ \code{axis} rather than letting \code{plot} handle all this).
+
+ If you want the higher level functions that were actually used, then
+ use the \code{history} or \code{savehistory} commands (this will
+ probably be the better method for most cases).
+
+ Some of the low level plotting functions use different arguments to
+ the internal version than the user callable version (\code{box} for
+ example), the arguments to these functions may need to be editted
+ before the full script will run correctly.
+
+ The lengths of command lines between the creation of the script and
+ what can be run in R do not always match, you may need to manually
+ wrap long lines in the script before it will run properly.
+}
+\value{
+ This function is run for its side effects and does not return anything
+ meaningful.
+}
+\author{Greg Snow \email{538280 at gmail.com}}
+\note{ For any serious projects it is best to put your code into a
+ script to begin with and edit the original script rather than using
+ this function.
+
+ This function depends on the \code{recordPlot} function which can
+ change in any version. Therefore this function should not be
+ considered stable.
+}
+\seealso{\code{\link{history}}, \code{\link{savehistory}},
+ \code{\link{recordPlot}}, \code{\link{source}} }
+\examples{
+if(interactive()){
+
+# create a plot
+plot(runif(10),rnorm(10))
+lines( seq(0,1,length=10), rnorm(10,1,3) )
+
+# create the script
+plot2script()
+
+# now paste the script into a script window or text processor.
+# edit the ranges in plot.window() and change some colors or
+# other options. Then run the script.
+ }
+}
+\keyword{iplot}
+\keyword{dplot}
\ No newline at end of file
diff --git a/man/power.examp.Rd b/man/power.examp.Rd
new file mode 100644
index 0000000..18dad8e
--- /dev/null
+++ b/man/power.examp.Rd
@@ -0,0 +1,81 @@
+\name{power.examp}
+\alias{power.examp}
+\alias{run.power.examp}
+\alias{run.power.examp.old}
+\alias{power.refresh}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Graphically illustrate the concept of power. }
+\description{
+ Create graphs of a normal test statistic under the null and
+ alternative hypotheses to graphically show the idea of power.
+}
+\usage{
+power.examp(n = 1, stdev = 1, diff = 1, alpha = 0.05, xmin = -2, xmax = 4)
+run.power.examp(hscale=1.5, vscale=1.5, wait=FALSE)
+run.power.examp.old()
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{n}{ The sample size for the test statistic. }
+ \item{stdev}{ The standard deviation of the population. }
+ \item{diff}{ The true difference in means (alternate hypothesis). }
+ \item{alpha}{ The type I error rate to use for the test. }
+ \item{xmin}{ The minimum x value to show on the graph. }
+ \item{xmax}{ The maximum x value to show on the graph. }
+ \item{hscale}{Controls width of plot, passed to \code{tkrplot}.}
+ \item{vscale}{Controls height of plot, passed to \code{tkrplot}.}
+ \item{wait}{Should R wait for the window to close.}
+}
+\details{
+ This function will draw 2 graphs representing an upper-tailed test of
+ hypothesis.
+
+ The upper panel represents the test statistic under the
+ null hypothesis that the true mean (or mean difference) is 0. It then
+ also shows the upper tail area equal to \code{alpha} and the rejection
+ region for the test statistic.
+
+ The lower panel shows the normal distribution for the test statistic
+ under the alternative hypothesis where the true mean (or mean
+ difference) is \code{diff}. Using the rejection region from the upper
+ panel it shades the upper tail area that corresponds to the power of
+ the test.
+
+ Both curves are affected by the specified \code{stdev} and sample size
+ \code{n}.
+
+ The function \code{run.power.examp} will in addition create a Tk
+ slider box that will allow you to interactively change the values of
+ \code{stdev}, \code{diff}, \code{alpha}, and \code{n} to dynamically
+ see the effects of the change on the graphs and on the power of the
+ test.
+
+ This can be used to demonstrate the concept of power, show the effect
+ of sample size on power, show the inverse relationship between the
+ type I and type II error rates, and show how power is dependent on the
+ true mean (or difference) and the population standard deviation.
+}
+\value{
+ \code{power.examp} invisibly returns the power computed.
+
+ \code{run.power.examp} returns a list with the parameter settings and
+ the power if \code{wait} is TRUE.
+
+ \code{run.power.examp.old} does not return anything meaningful.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com} }
+%\note{ ~~further notes~~ }
+
+ %~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{power.t.test}} }
+\examples{
+power.examp()
+power.examp(n=25)
+power.examp(alpha=0.1)
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+\keyword{ dynamic }% __ONLY ONE__ keyword per line
+\keyword{ univar }
+\keyword{ htest }
diff --git a/man/put.points.demo.Rd b/man/put.points.demo.Rd
new file mode 100644
index 0000000..8154bc5
--- /dev/null
+++ b/man/put.points.demo.Rd
@@ -0,0 +1,63 @@
+\name{put.points.demo}
+\alias{put.points.demo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Demonstrate Correlation and Regression by placing and moving
+ data points }
+\description{
+ Place data points on a graph to demonstrate concepts related to
+ correlation and regression.
+}
+\usage{
+put.points.demo(x = NULL, y = NULL, lsline = TRUE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ x-coordinates for initial points. }
+ \item{y}{ y-coordinates for initial points. }
+ \item{lsline}{ Logical, should the ls regresion line be included. }
+}
+\details{
+ The plot area is divided into 2 sections, the left section shows a
+ scatterplot of your points, the right panel controls what happens when
+ you click in the left panel.
+
+ The top of the right panel has an "end" button that you click on to
+ end the demonstration.
+
+ The middle right panel toggles the least squares line and information.
+
+ The bottom right panel has radio buttons that determine what clicking
+ in the left panel will do, the options are to add a point, delete a
+ point, or move a point.
+
+ To move a point click on the point you want to move, it will become
+ solid, then click in the place you want it to move to.
+
+ When deleting or moving points, the closest point to where you click
+ will be deleted or moved, even if you click in an empty area.
+
+ Whenever you add, delete, or move a point the correlation, r\^2, and
+ regression line will be updated. You can start with a set of points
+ then demonstrate what happens to the correlation and regression line
+ when outliers are added or important points are moved or deleted.
+}
+\value{
+ This function does not return anything.
+}
+\author{ Greg Snow \email{538280 at gmail.com} }
+
+\seealso{ \code{\link{plot}}, \code{\link{cor}} }
+\examples{
+
+if(interactive()){
+put.points.demo()
+
+x <- rnorm(25, 5, 1)
+y <- x + rnorm(25)
+put.points.demo(x,y)
+}
+
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ iplot }% __ONLY ONE__ keyword per line
+\keyword{regression}
\ No newline at end of file
diff --git a/man/rgl.Map.Rd b/man/rgl.Map.Rd
new file mode 100644
index 0000000..9ece964
--- /dev/null
+++ b/man/rgl.Map.Rd
@@ -0,0 +1,47 @@
+\name{rgl.Map}
+\alias{rgl.Map}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Plot a map in an rgl window }
+\description{
+ Plots a map (from a Map object from package maptools) on a unit sphere
+ in an rgl window that can then be interactively rotated.
+}
+\usage{
+rgl.Map(Map, which, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{Map}{ A \code{Map} object }
+ \item{which}{ Vector indicating the subset of polygons to plot. }
+ \item{\dots}{ Additional arguments passed on to \code{rgl.lines}. }
+}
+\details{
+ This assumes that the map is cordinates in degrees and plots the map
+ on a unit sphere in an rgl window making a globe. You can then rotate
+ the globe by clicking and dragging in the window.
+}
+\value{
+ There is no return value, this function is run for its side effect.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com}}
+\note{ This function is still beta level software (some extra lines show
+up). This needs to be updated to use the new spatial objects, you can
+use it as an idea, but probably won't work directly.}
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{\code{rgl} in package rgl, \code{plot.Map} in
+ package maptools }
+\examples{
+if(interactive()){
+# assumes that the time zone shape files have been downloaded
+# from: http://openmap.bbn.com/data/shape/timezone/
+
+tz <- maptools:::read.shape('WRLDTZA')
+rgl.Map(tz)
+rgl.spheres(0,0,0,.999, col='darkblue')
+}
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+\keyword{ dynamic }% __ONLY ONE__ keyword per line
diff --git a/man/roc.demo.Rd b/man/roc.demo.Rd
new file mode 100644
index 0000000..380f4a2
--- /dev/null
+++ b/man/roc.demo.Rd
@@ -0,0 +1,57 @@
+\name{roc.demo}
+\alias{roc.demo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Demonstrate ROC curves by interactively building one }
+\description{
+ This demonstration allows you to interactively build a Receiver
+ Operator Curve to better understand what goes into creating them.
+}
+\usage{
+roc.demo(x = rnorm(25, 10, 1), y = rnorm(25, 11, 1.5))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ Data values for group 1 (controls). }
+ \item{y}{ Data values for group 2 (cases). }
+}
+\details{
+ Density plots for the 2 groups will be created in the lower panel of
+ the plot (colored red (group 1) and blue (group 2)) along with rug
+ plots of the actual datapoints. There is also a
+ green vertical line that represents a decision rule cutoff, any points
+ higher than the cutoff are predicted to be in group 2 and points less
+ than the cuttoff are predicted to be in group 1. The sensitivity and
+ specificity for the current cuttoff value are printed below the plot.
+
+ A Tk slider box is also created that allows you to move the cuttoff
+ value and update the plots. As the cutoff value changes, the
+ different combinations of sensitivity and specificity are added to the
+ ROC curve in the top panel (the point corresponding to the current
+ cuttoff value is highlighted in red). A line is also drawn from the
+ point representing sensitivity and specificity both equal to 1 to the
+ point closest to it.
+}
+\value{
+ No meaninful value is returned, this function is run solely for the
+ side effects.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{slider}}, \code{ROC} function in package
+ Epi, \code{auROC} in package limma, package ROC }
+\examples{
+
+if(interactive()){
+roc.demo()
+with(CO2,
+ roc.demo(uptake[Type=='Mississippi'],
+ uptake[Type=='Quebec'] )
+)
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ classif }% __ONLY ONE__ keyword per line
diff --git a/man/rotate.cloud.Rd b/man/rotate.cloud.Rd
new file mode 100644
index 0000000..cd20a73
--- /dev/null
+++ b/man/rotate.cloud.Rd
@@ -0,0 +1,64 @@
+\name{rotate.cloud}
+\alias{rotate.cloud}
+\alias{rotate.persp}
+\alias{rotate.wireframe}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Interactively rotate 3D plots }
+\description{
+ Interactively rotate common 3d plots: cloud, persp, and wireframe.
+}
+\usage{
+rotate.cloud(x, ...)
+rotate.persp(x, y, z)
+rotate.wireframe(x, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ \code{x}, see \code{persp}, or formula/matrix to pass to
+ cloud or wireframe }
+ \item{y}{ \code{y}, see \code{persp} }
+ \item{z}{ \code{z}, see \code{persp} }
+ \item{\dots}{ additional arguments passed on to \code{cloud} or \code{persp}}
+}
+\details{
+ Use these functions just like \code{cloud}, \code{persp}, and
+ \code{wireframe}. In addition to the default plot a Tk slider window
+ will be created that will allow you to rotate the plot.
+
+ The rotations parameters are passed the \code{screen} argument of
+ \code{cloud} and \code{wireframe} and the \code{theta}, \code{phi},
+ \code{r}, \code{d}, \code{ltheta}, \code{lphi}, and \code{shade}
+ arguments of \code{persp}.
+
+ For \code{cloud} and \code{wireframe} plots the order of the \code{x},
+ \code{y}, and \code{z} argumets can be rearanged, just type the
+ appropriate letters in the boxes on the left, then press the "refresh"
+ button (changing the order changes the plot for these 2 plots).
+}
+\value{
+ These functions are run for the side effects of the plots and Tk
+ windows, nothing meaninful is returned.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{cloud} it the lattice package,
+ \code{\link{persp}}, \code{wireframe} in the lattice package }
+\examples{
+
+if(interactive()){
+rotate.cloud(Sepal.Length ~ Petal.Length*Petal.Width, data=iris)
+
+rotate.wireframe(volcano)
+
+z <- 2 * volcano # Exaggerate the relief
+x <- 10 * (1:nrow(z)) # 10 meter spacing (S to N)
+y <- 10 * (1:ncol(z)) # 10 meter spacing (E to W)
+rotate.persp(x,y,z)
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ hplot }% __ONLY ONE__ keyword per line
diff --git a/man/run.cor.examp.Rd b/man/run.cor.examp.Rd
new file mode 100644
index 0000000..1288fb6
--- /dev/null
+++ b/man/run.cor.examp.Rd
@@ -0,0 +1,65 @@
+\name{run.cor.examp}
+\alias{run.cor.examp}
+\alias{run.cor2.examp}
+\alias{run.old.cor.examp}
+\alias{run.old.cor2.examp}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Interactively demonstrate correlations }
+\description{
+ Make a scatterplot and a Tk slider window that allows you to
+ interactively set the correlation and/or R\^2.
+}
+\usage{
+run.cor.examp(n=100, seed, vscale=1.5, hscale=1.5, wait=FALSE)
+run.cor2.examp(n=100, seed, vscale=1.5, hscale=1.5, wait=FALSE)
+run.old.cor.examp(n = 100, seed)
+run.old.cor2.examp(n = 100, seed)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{n}{ Number of points to plot. }
+ \item{seed}{ What seed to use. }
+ \item{vscale}{ Vertical scale passed to tkrplot. }
+ \item{hscale}{ Horizontal scale passed to tkrplot. }
+ \item{wait}{ Should R wait for the tk window to close. }
+}
+\details{
+ The function \code{run.cor.examp} draws a scatterplot and allows you
+ to set the correlation using a Tk slider window.
+
+ The function \code{run.cor2.examp} does the same, but has a slider for
+ R\^2 as well as the correlation, when either slider is moved the other
+ one will update to match.
+
+ The 2 "old" versions use the default graphics device with a seperate
+ window with the sliders, the versions without "old" in the name
+ include the plot and sliders together in a single tk window.
+
+ The size of the plot can be changed by changing the values in the
+ hscale and vscale boxes and clicking on the "Refresh" button.
+}
+\value{
+ If \code{wait} is TRUE, then the return value is a list with the x and
+ y values of the final plot.
+
+ If \code{wait} is FALSE (and in the "old" versions) an invisible NULL
+ is returned.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com} }
+\note{ If \code{wait} is TRUE then R will wait until you click on the
+ "Exit" button before you can use your R session again. If \code{wait}
+ is FALSE then the tk window will appear, but R will regain control so
+ that you can continue to use R as well as interact with the
+ demonstration window.}
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{cor}}, \code{\link{tkexamp}} }
+\examples{
+if(interactive()) {
+ run.cor2.examp()
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+
diff --git a/man/run.hist.demo.Rd b/man/run.hist.demo.Rd
new file mode 100644
index 0000000..97317a8
--- /dev/null
+++ b/man/run.hist.demo.Rd
@@ -0,0 +1,36 @@
+\name{run.hist.demo}
+\alias{run.hist.demo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Create a histogram and interactively change the number of bars. }
+\description{
+ Create a histogram then use a Tk slider window to change the number of
+ bars, the minimum, and the maximum.
+}
+\usage{
+run.hist.demo(x)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ Data to plot. }
+}
+\details{
+ Draws a histogram and creates a Tk slider window that allows you to
+ explore how changing the parameters affects the appearance of the plot.
+}
+\value{
+ No meaninful value is returned.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com} }
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{hist}}, \code{\link{slider}} }
+\examples{
+if(interactive()){
+run.hist.demo( rnorm(250, 100, 5) )
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ hplot }% __ONLY ONE__ keyword per line
diff --git a/man/shadowtext.Rd b/man/shadowtext.Rd
new file mode 100644
index 0000000..c9b8b9b
--- /dev/null
+++ b/man/shadowtext.Rd
@@ -0,0 +1,65 @@
+\name{shadowtext}
+\Rdversion{1.1}
+\alias{shadowtext}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Add text to a plot with a contrasting background.}
+\description{
+ This is similar to the text function, but it also puts a background
+ shadow (outline) behind the text to make it stand out from the
+ background better.
+}
+\usage{
+shadowtext(x, y = NULL, labels, col = "white", bg = "black",
+ theta = seq(pi/4, 2 * pi, length.out = 8), r = 0.1, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{x-coordinates for the text}
+ \item{y}{y-coordinates for the text}
+ \item{labels}{The text labels to plot}
+ \item{col}{Color of the text}
+ \item{bg}{Color of the background shadow}
+ \item{theta}{Angles for plotting the background}
+ \item{r}{Thickness of the shadow relative to plotting size}
+ \item{\dots}{Additional arguments passed on to \code{text}}
+}
+\details{
+ When adding text to a plot it is possible that the color of the text
+ may make it difficult to see relative to its background. If the text
+ spans different backgrounds then it may not be possible to find a
+ single color to give proper contrast.
+
+ This function creates a contrasting shadow for the text by first
+ plotting several copies of the text at angles \code{theta} and
+ distance \code{r} in the background color, then plotting the text on
+ top.
+
+ This gives a shadowing or outlining effect to the text making it
+ easier to read on any background.
+}
+\value{
+ This function is run for its side effects, returns NULL.
+}
+%\references{
+%% ~put references to the literature/web site here ~
+%}
+\author{Greg Snow, \email{538280 at gmail.com}}
+%\note{
+%% ~~further notes~~
+%}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+ \code{\link{text}}
+}
+\examples{
+ plot(1:10, 1:10, bg='aliceblue')
+ rect(3,3,5,8, col='navy')
+ text(5,6, 'Test 1', col='lightsteelblue')
+ shadowtext(5,4, 'Test 2', col='lightsteelblue')
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ aplot }
+
diff --git a/man/sigma.test.Rd b/man/sigma.test.Rd
new file mode 100644
index 0000000..4e393e1
--- /dev/null
+++ b/man/sigma.test.Rd
@@ -0,0 +1,47 @@
+\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 at 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
+
diff --git a/man/simfun.Rd b/man/simfun.Rd
new file mode 100644
index 0000000..a77de0f
--- /dev/null
+++ b/man/simfun.Rd
@@ -0,0 +1,243 @@
+\name{simfun}
+\alias{simfun}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+ Create a function to simulate data
+}
+\description{
+This function is used to create a new function that will simulate data.
+This could be used by a teacher to create homework or test conditions
+that the students would then simulate data from (each student could have
+their own unique data set) or this function could be used in simulations
+for power or other values of interest.
+}
+\usage{
+simfun(expr, drop, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{expr}{
+ This is an expression, usually just one or more statements, that will
+ generate the simulated data.
+}
+ \item{drop}{
+A character vector of names of objects/columns that will be dropped from
+the return value. These are usually intermediate objects or parameter
+values that you don't want carried into the final returned object.
+}
+ \item{\dots}{
+Additional named items that will be in the environment when \code{expr}
+is evaluated.
+}
+}
+\details{
+ This function creates another function to simulate data. You supply
+ the general ideas of the simulation to this function and the resulting
+ function can then be used to create simulated datasets. The resulting
+ function can then be given to students for them to simulate datasets,
+ or used localy as part of larger simulations.
+
+ The environment where the expression is evaluated will have all the
+ columns or elements of the \code{data} argument available as well as
+ the \code{data} argument itself. Any variables/parameters passed
+ through \code{...} in the original function will also be available.
+ You then supply the code based on those variables to create the
+ simulated data. The names of any columns or parameters submitted as
+ part of \code{data} will need to match the code exactly (provide
+ specific directions to the users on what columns need to be named).
+ Rember that indexing using factors indexes based on the underlying
+ integers not the character representation. See the examples for
+ details.
+
+ The resulting function can be saved and loaded/attached in different R
+ sessions (it is important to use \code{save} rather than something
+ like \code{dput} so that the environment of the function is
+ preserved).
+
+ The function includes an optional seed that will be used with the
+ \code{\link{char2seed}} function (if the seed is a character) so that
+ each student could use a unique but identifiable seed (such as their
+ name or something based on their name) so that each student will use a
+ different dataset, but the instructor will be able to generate the
+ exact same dataset to check answers.
+
+ The "True" parameters are hidden in the environment of the function so
+ the student will not see the "true" values by simply printing the
+ function. However an intermediate level R programmer/user would be
+ able to extract the simulation parameters (but the correct homework or
+ test answer will not be the simulation parameters).
+}
+\value{
+The return value is a function that will generate simulated datasets.
+ The function will have 2 arguments, \code{data} and \code{seed}. The
+ \code{data} argument can be either a data frame of the predictor
+ variables (study design) or a list of simulation parameters. The
+ \code{seed} argument will be passed on to \code{\link{set.seed}} if it
+ is numeric and \code{\link{char2seed}} if it is a character.
+
+The return value of this function is a dataframe with the simulated data
+and any explanitory variables passed to the function.
+
+See the examples for how to use the result function.
+}
+\author{Greg Snow, \email{538280 at gmail.com}}
+\note{
+ This function was not designed for speed, if you are doing long
+ simulations then hand crafting the simulation function will probably
+ run quicker than one created using this function.
+
+ Like the prediction functions the data frame passed in as the data
+ argument will need to have exact names of the columns to match with
+ the code (including capitolization).
+
+ This function is different from the \code{\link{simulate}} functions
+ in that it allows for different sample sizes, user specified
+ parameters, and different predictor variables.
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{set.seed}}, \code{\link{char2seed}}, \code{\link{within}}, \code{\link{simulate}}, \code{\link{save}}, \code{\link{load}}, \code{\link{attach}}
+}
+\examples{
+# Create a function to simulate heights for a given dataset
+
+simheight <- simfun( {h <- c(64,69); height<-h[sex]+ rnorm(10,0,3)}, drop='h' )
+
+my.df <- data.frame(sex=rep(c('Male','Female'),each=5))
+simdat <- simheight(my.df)
+t.test(height~sex, data=simdat)
+
+# a more general version, and have the expression predefined
+# (note that this assumes that the levels are Female, Male in that order)
+
+myexpr <- quote({
+ n <- length(sex)
+ h <- c(64,69)
+ height <- h[sex] + rnorm(n,0,3)
+})
+
+simheight <- simfun(eval(myexpr), drop=c('n','h'))
+my.df <- data.frame(sex=sample(rep(c('Male','Female'),c(5,10))))
+(simdat <- simheight(my.df))
+
+# similar to above, but use named parameter vector and index by names
+
+myexpr <- quote({
+ n <- length(sex)
+ height <- h[ as.character(sex)] + rnorm(n,0,sig)
+})
+
+simheight <- simfun(eval(myexpr), drop=c('n','h','sig'),
+ h=c(Male=69,Female=64), sig=3)
+my.df <- data.frame( sex=sample(c('Male','Female'),100, replace=TRUE))
+(simdat <- simheight(my.df, seed='example'))
+
+# Create a function to simulate Sex and Height for a given sample size
+# (actually it will generate n males and n females for a total of 2*n samples)
+# then use it in a set of simulations
+simheight <- simfun( {sex <- factor(rep(c('Male','Female'),each=n))
+ height <- h[sex] + rnorm(2*n,0,s)
+ }, drop=c('h','n'), h=c(64,69), s=3)
+(simdat <- simheight(list(n=10)))
+
+out5 <- replicate(1000, t.test(height~sex, data=simheight(list(n= 5)))$p.value)
+out15 <- replicate(1000, t.test(height~sex, data=simheight(list(n=15)))$p.value)
+
+mean(out5 <= 0.05)
+mean(out15 <= 0.05)
+
+# use a fixed population
+
+simstate <- simfun({
+ tmp <- state.df[as.character(State),]
+ Population <- tmp[['Population']]
+ Income <- tmp[['Income']]
+ Illiteracy <- tmp[['Illiteracy']]
+}, state.df=as.data.frame(state.x77), drop=c('tmp','state.df'))
+simstate(data.frame(State=sample(state.name,10)))
+
+# Use simulation, but override setting the seed
+
+simheight <- simfun({
+ set.seed(1234)
+ h <- c(64,69)
+ sex <- factor(rep(c('Female','Male'),each=50))
+ height <- round(rnorm(100, rep(h,each=50),3),1)
+ sex <- sex[ID]
+ height <- height[ID]
+}, drop='h')
+(newdat <- simheight(list(ID=c(1:5,51:55))))
+(newdat2<- simheight(list(ID=1:10)))
+
+# Using a fitted object
+
+fit <- lm(Fertility ~ . , data=swiss)
+simfert <- simfun({
+ Fertility <- predict(fit, newdata=data)
+ Fertility <- Fertility + rnorm(length(Fertility),0,summary(fit)$sigma)
+}, drop=c('fit'), fit=fit)
+
+tmpdat <- as.data.frame(lapply(swiss[,-1],
+ function(x) round(runif(100, min(x), max(x)))))
+names(tmpdat) <- names(swiss)[-1]
+fertdat <- simfert(tmpdat)
+head(fertdat)
+rbind(coef(fit), coef(lm(Fertility~., data=fertdat)))
+
+# simulate a nested mixed effects model
+simheight <- simfun({
+ n.city <- length(unique(city))
+ n.state <- length(unique(state))
+ n <- length(city)
+ height <- h[sex] + rnorm(n.state,0,sig.state)[state] +
+ rnorm(n.city,0,sig.city)[city] + rnorm(n,0,sig.e)
+}, sig.state=1, sig.city=0.5, sig.e=3, h=c(64,69),
+ drop=c('sig.state','sig.city','sig.e','h','n.city','n.state','n'))
+
+tmpdat <- data.frame(state=gl(5,20), city=gl(10,10),
+ sex=gl(2,5,length=100, labels=c('F','M')))
+heightdat <- simheight(tmpdat)
+
+# similar to above, but include cost information, this assumes that
+# each new state costs $100, each new city is $10, and each subject is $1
+# this shows 2 possible methods
+
+simheight <- simfun({
+ n.city <- length(unique(city))
+ n.state <- length(unique(state))
+ n <- length(city)
+ height <- h[sex] + rnorm(n.state,0,sig.state)[state] +
+ rnorm(n.city,0,sig.city)[city] + rnorm(n,0,sig.e)
+ cost <- 100 * (!duplicated(state)) + 10*(!duplicated(city)) + 1
+ cat('The total cost for this design is $', 100*n.state+10*n.city+1*n,
+ '\n', sep='')
+}, sig.state=1, sig.city=0.5, sig.e=3, h=c(64,69),
+ drop=c('sig.state','sig.city','sig.e','h','n.city','n.state','n'))
+
+tmpdat <- data.frame(state=gl(5,20), city=gl(10,10),
+ sex=gl(2,5,length=100, labels=c('F','M')))
+heightdat <- simheight(tmpdat)
+sum(heightdat$cost)
+
+
+# another mixed model method
+
+simheight <- simfun({
+ state <- gl(n.state, n/n.state)
+ city <- gl(n.city*n.state, n/n.city/n.state)
+ sex <- gl(2, n.city, length=n, labels=c('F','M') )
+ height <- h[sex] + rnorm(n.state,0,sig.state)[state] +
+ rnorm(n.city*n.state,0,sig.city)[city] + rnorm(n,0,sig.e)
+}, drop=c('n.state','n.city','n','sig.city','sig.state','sig.e','h'))
+
+heightdat <- simheight( list(
+ n.state=5, n.city=2, n=100, sig.state=10, sig.city=3, sig.e=1, h=c(64,69)
+))
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ datagen }
+\keyword{ design }
diff --git a/man/slider.Rd b/man/slider.Rd
new file mode 100644
index 0000000..b663be9
--- /dev/null
+++ b/man/slider.Rd
@@ -0,0 +1,191 @@
+\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*(65<zz)*(zz<73)
+ cz<-10+col(zz)[zz>0];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
+
diff --git a/man/sliderv.Rd b/man/sliderv.Rd
new file mode 100644
index 0000000..2e66cb0
--- /dev/null
+++ b/man/sliderv.Rd
@@ -0,0 +1,65 @@
+\name{sliderv}
+\alias{sliderv}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Create a Tk slider window }
+\description{
+ Create a Tk slider window with the sliders positioned vertically
+ instead of horizontally.
+}
+\usage{
+sliderv(refresh.code, names, minima, maxima, resolutions, starts,
+ title = "control", no = 0, set.no.value = 0)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{refresh.code}{ Function to be called when sliders are moved. }
+ \item{names}{ Labels for the sliders. }
+ \item{minima}{ Vector of minimum values for the sliders. }
+ \item{maxima}{ Vector of maximum values for the sliders. }
+ \item{resolutions}{ Vector of resolutions for the sliders. }
+ \item{starts}{ Vector of starting values for the sliders. }
+ \item{title}{ Title to put at the top of the Tk box. }
+ \item{no}{ The number of the slider whose value you want. }
+ \item{set.no.value}{ Vector of length 2 with the number of slider to
+ set and the new value. }
+}
+\details{
+ This is a variation on the \code{slider} function with vertical sliders
+ arranged in a row rather than horizontal sliders arranged in a column.
+
+ This is based on an early version of \code{slider} and therefore does
+ not have as many bells and whistles (but sometimes fits the screen better).
+}
+\value{
+ Returns the value of a given slider when used as: \code{slider(no=i)}.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com} }
+\note{
+ You can move the slider in 3 different ways: You can left click
+ and drag the slider itself, you can left click in the trough to either
+ side of the slider and the slider will move 1 unit in the direction
+ you clicked, or you can right click in the trough and the slider will
+ jump to the location you clicked at.
+
+ This function may not stay in this package (consider it
+ semi-depricated). See the \code{\link{tkexamp}} function for another
+ approach to do the same thing.
+}
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{tkexamp}}, \code{\link{slider}} }
+\examples{
+if(interactive()){
+face.refresh <- function(...){
+ vals <- sapply(1:15, function(x) slider(no=x))
+ faces( rbind(0, vals, 1), scale=F)
+}
+
+sliderv( face.refresh, as.character(1:15), rep(0,15), rep(1,15),
+ rep(0.05, 15), rep(0.5,15), title='Face Demo')
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ iplot}
diff --git a/man/spread.labs.Rd b/man/spread.labs.Rd
new file mode 100644
index 0000000..a0ab6e8
--- /dev/null
+++ b/man/spread.labs.Rd
@@ -0,0 +1,80 @@
+\name{spread.labs}
+\alias{spread.labs}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Spread out close points for labeling in plots }
+\description{
+This function takes as set of coordinates and spreads out the close
+values so that they can be used in labeling plots without overlapping.
+}
+\usage{
+spread.labs(x, mindiff, maxiter = 1000, stepsize = 1/10, min = -Inf, max = Inf)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The coordinate values (x or y, not both) to spread out. }
+ \item{mindiff}{ The minimum distance between return values }
+ \item{maxiter}{ The maximum number of iterations }
+ \item{stepsize}{ How far to move values in each iteration }
+ \item{min}{ Minimum bound for returned values }
+ \item{max}{ Maximum bound for returned values }
+}
+\details{
+ Sometimes the desired locations for labels in plots results in the
+ labels overlapping. This function takes the coordinate values (x or
+ y, not both) and finds those points that are less than \code{mindiff}
+ (usually a function of \code{strheight} or \code{strwidth}) apart and
+ increases the space between them (by \code{stepsize} *
+ \code{mindiff}). This may or may not be enough and moving some points
+ away from their nearest neighbor may move them too close to another
+ neighbor, so the process is iterated until either \code{maxiter} steps
+ have been tried, or all the values are at least \code{mindiff} apart.
+
+ The \code{min} and \code{max} arguments prevent the values from going
+ outside that range (they should be specified such that the original
+ values are all inside the range).
+
+ The values do not need to be presorted.
+}
+\value{
+ A vector of coordinates (order corresponding to the original \code{x})
+ that can be used as a replacement for \code{x} in placing labels.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow, \email{538280 at gmail.com} }
+%\note{ ~~further notes~~
+%
+% ~Make other sections like Warning with \section{Warning }{....} ~
+%}
+\seealso{ \code{\link{text}}, the \code{spread.labels} function in the
+ \code{plotrix} package. }
+\examples{
+# overlapping labels
+plot(as.integer(state.region), state.x77[,1], ylab='Population',
+ xlab='Region',xlim=c(1,4.75), xaxt='n')
+axis(1, at=1:4, lab=levels(state.region) )
+
+text( as.integer(state.region)+.5, state.x77[,1], state.abb )
+segments( as.integer(state.region)+0.025, state.x77[,1],
+ as.integer(state.region)+.375, state.x77[,1] )
+
+# now lets redo the plot without overlap
+
+tmp.y <- state.x77[,1]
+for(i in levels(state.region) ) {
+ tmp <- state.region == i
+ tmp.y[ tmp ] <- spread.labs( tmp.y[ tmp ], 1.2*strheight('A'),
+ maxiter=1000, min=0 )
+}
+
+plot(as.integer(state.region), state.x77[,1], ylab='Population',
+ xlab='Region', xlim=c(1,4.75), xaxt='n')
+axis(1, at=1:4, lab=levels(state.region) )
+
+text( as.integer(state.region)+0.5, tmp.y, state.abb )
+segments( as.integer(state.region)+0.025, state.x77[,1],
+ as.integer(state.region)+0.375, tmp.y )
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ dplot }
+
diff --git a/man/squishplot.Rd b/man/squishplot.Rd
new file mode 100644
index 0000000..d2bbb63
--- /dev/null
+++ b/man/squishplot.Rd
@@ -0,0 +1,70 @@
+\name{squishplot}
+\alias{squishplot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Squish the plotting area to a specified aspect ratio }
+\description{
+ Adjusts the plotting area to a specific aspect ratio. This is
+ different from using the \code{asp} argument in that it puts the extra
+ space in the margins rather than inside the plotting region.
+}
+\usage{
+squishplot(xlim, ylim, asp = 1, newplot=TRUE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{xlim}{ The x limits of the plot, or the entire x vector.}
+ \item{ylim}{ The y limits of the plot, or the entire y vector.}
+ \item{asp}{ The y/x aspect ratio.}
+ \item{newplot}{ Should plot.new() be called before making the
+ calculations.}
+}
+\details{
+ This function sets the plot area of the current graph device so that
+ the following plot command will plot with the specified aspect ratio.
+
+ This is different from using the \code{asp} argument to
+ \code{plot.default} in where the created white space goes (see the
+ example). Using \code{plot.default} will place the whitespace within
+ the plotting region and can result in the axes and annotations being
+ quite far from the actual data. This command sets up the plotting
+ region so that the extra whitespace is in the margin areas and moves
+ the axes and annotations close to the data.
+
+ Any other desired parameter settings or resizing of the graphics
+ device should be set before calling
+ \code{squishplot}, especially settings dealing with multiple figures
+ or margin areas.
+
+ After plotting, the parameters need to be reset or later plots may
+ come out wrong.
+}
+\value{
+ Invisible list containing the '\code{plt}' values from \code{par} that
+ were in place before the call to \code{squishplot} that can be used to
+ reset the graphical parameters after plotting is finished.
+}
+\author{ Greg Snow \email{538280 at gmail.com} }
+\note{
+ Remember to set other graphical parameters, then call
+ \code{squishplot}, then call the plotting function(s), then reset the
+ parameters.
+}
+\seealso{ \code{\link{plot.default}}, \code{\link{plot.window}},
+ \code{\link{par}} }
+\examples{
+x <- rnorm(25, 10, 2 )
+y <- 5 + 1.5*x + rnorm(25,0,2)
+
+par(mfrow=c(1,3))
+plot(x,y)
+
+op <- squishplot(x,y,1)
+plot(x,y)
+par(op)
+
+plot(x,y, asp=1)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ dplot }
+
diff --git a/man/steps.Rd b/man/steps.Rd
new file mode 100644
index 0000000..4901aa2
--- /dev/null
+++ b/man/steps.Rd
@@ -0,0 +1,126 @@
+\name{steps}
+\alias{steps}
+\docType{data}
+\title{
+Steps data
+}
+\description{
+This is the export from a pedometer worn for nearly about 11 months by
+the package author.
+}
+\usage{data(steps)}
+\format{
+ A data frame with 331 observations on the following 79 variables.
+ \describe{
+ \item{\code{Date}}{The Date for the given data}
+ \item{\code{Total.Steps}}{Total Steps recorded for the day}
+ \item{\code{Aerobic.Steps}}{Total Aerobic Steps recorded for the day (see below)}
+ \item{\code{Aerobic.Walking.Time}}{Time spent in aerobic walking for
+ the day}
+ \item{\code{Calories}}{Estimated calories burned for the day}
+ \item{\code{Distance}}{Estimated distance walked for the day in miles}
+ \item{\code{Fat.Burned}}{Estimated grams of fat burned by walking}
+ \item{\code{Steps.12AM}}{Steps recorded between Midnight and 1 am}
+ \item{\code{Steps.1AM}}{Steps recorded between 1 am and 2 am}
+ \item{\code{Steps.2AM}}{Steps recorded between 2 am and 3 am}
+ \item{\code{Steps.3AM}}{Steps recorded between 3 am and 4 am}
+ \item{\code{Steps.4AM}}{Steps recorded between 4 am and 5 am}
+ \item{\code{Steps.5AM}}{Steps recorded between 5 am and 6 am}
+ \item{\code{Steps.6AM}}{Steps recorded between 6 am and 7 am}
+ \item{\code{Steps.7AM}}{Steps recorded between 7 am and 8 am}
+ \item{\code{Steps.8AM}}{Steps recorded between 8 am and 9 am}
+ \item{\code{Steps.9AM}}{Steps recorded between 9 am and 10 am}
+ \item{\code{Steps.10AM}}{Steps recorded between 10 am and 11 am}
+ \item{\code{Steps.11AM}}{Steps recorded between 11 am and Noon}
+ \item{\code{Steps.12PM}}{Steps recorded between Noon and 1 pm}
+ \item{\code{Steps.1PM}}{Steps recorded between 1 pm and 2 pm}
+ \item{\code{Steps.2PM}}{Steps recorded between 2 pm and 3 pm}
+ \item{\code{Steps.3PM}}{Steps recorded between 3 pm and 4 pm}
+ \item{\code{Steps.4PM}}{Steps recorded between 4 pm and 5 pm}
+ \item{\code{Steps.5PM}}{Steps recorded between 5 pm and 6 pm}
+ \item{\code{Steps.6PM}}{Steps recorded between 6 pm and 7 pm}
+ \item{\code{Steps.7PM}}{Steps recorded between 7 pm and 8 pm}
+ \item{\code{Steps.8PM}}{Steps recorded between 8 pm and 9 pm}
+ \item{\code{Steps.9PM}}{Steps recorded between 9 pm and 10 pm}
+ \item{\code{Steps.10PM}}{Steps recorded between 10 pm and 11 pm}
+ \item{\code{Steps.11PM}}{Steps recorded between 11 pm and Midnight}
+ \item{\code{Aerobic.Steps.12AM}}{Aerobic steps recorded between
+ Midnight and 1 am}
+ \item{\code{Aerobic.Steps.1AM}}{Aerobic steps recorded between 1 am
+ and 2 am}
+ \item{\code{Aerobic.Steps.2AM}}{Aerobic steps recorded between 2 am
+ and 3 am}
+ \item{\code{Aerobic.Steps.3AM}}{Aerobic steps recorded between 3 am
+ and 4 am}
+ \item{\code{Aerobic.Steps.4AM}}{Aerobic steps recorded between 4 am
+ and 5 am}
+ \item{\code{Aerobic.Steps.5AM}}{Aerobic steps recorded between 5 am
+ and 6 am}
+ \item{\code{Aerobic.Steps.6AM}}{Aerobic steps recorded between 6 am
+ and 7 am}
+ \item{\code{Aerobic.Steps.7AM}}{Aerobic steps recorded between 7 am
+ and 8 am}
+ \item{\code{Aerobic.Steps.8AM}}{Aerobic steps recorded between 8 am
+ and 9 am}
+ \item{\code{Aerobic.Steps.9AM}}{Aerobic steps recorded between 9 am
+ and 10 am}
+ \item{\code{Aerobic.Steps.10AM}}{Aerobic steps recorded between 10
+ am and 11 am}
+ \item{\code{Aerobic.Steps.11AM}}{Aerobic steps recorded between 11
+ am and Noon}
+ \item{\code{Aerobic.Steps.12PM}}{Aerobic steps recorded between Noon
+ and 1 pm}
+ \item{\code{Aerobic.Steps.1PM}}{Aerobic steps recorded between 1 pm
+ and 2 pm}
+ \item{\code{Aerobic.Steps.2PM}}{Aerobic steps recorded between 2 pm
+ and 3 pm}
+ \item{\code{Aerobic.Steps.3PM}}{Aerobic steps recorded between 3 pm
+ and 4 pm}
+ \item{\code{Aerobic.Steps.4PM}}{Aerobic steps recorded between 4 pm
+ and 5 pm}
+ \item{\code{Aerobic.Steps.5PM}}{Aerobic steps recorded between 5 pm
+ and 6 pm}
+ \item{\code{Aerobic.Steps.6PM}}{Aerobic steps recorded between 6 pm
+ and 7 pm}
+ \item{\code{Aerobic.Steps.7PM}}{Aerobic steps recorded between 7 pm
+ and 8 pm}
+ \item{\code{Aerobic.Steps.8PM}}{Aerobic steps recorded between 8 pm
+ and 9 pm}
+ \item{\code{Aerobic.Steps.9PM}}{Aerobic steps recorded between 9 pm
+ and 10 pm}
+ \item{\code{Aerobic.Steps.10PM}}{Aerobic steps recorded between 10
+ pm and 11 pm}
+ \item{\code{Aerobic.Steps.11PM}}{Aerobic steps recorded between 11
+ pm and Midnight}
+ \item{\code{Used.12AM}}{Any movement detected between Midnight and 1 am}
+ \item{\code{Used.1AM}}{Any movement detected between 1 am and 2 am}
+ \item{\code{Used.2AM}}{Any movement detected between 2 am and 3 am}
+ \item{\code{Used.3AM}}{Any movement detected between 3 am and 4 am}
+ \item{\code{Used.4AM}}{Any movement detected between 4 am and 5 am}
+ \item{\code{Used.5AM}}{Any movement detected between 5 am and 6 am}
+ \item{\code{Used.6AM}}{Any movement detected between 6 am and 7 am}
+ \item{\code{Used.7AM}}{Any movement detected between 7 am and 8 am}
+ \item{\code{Used.8AM}}{Any movement detected between 8 am and 9 am}
+ \item{\code{Used.9AM}}{Any movement detected between 9 am and 10 am}
+ \item{\code{Used.10AM}}{Any movement detected between 10 am and 11 am}
+ \item{\code{Used.11AM}}{Any movement detected between 11 am and Noon}
+ \item{\code{Used.12PM}}{Any movement detected between Noon and 1 pm}
+ \item{\code{Used.1PM}}{Any movement detected between 1 pm and 2 pm}
+ \item{\code{Used.2PM}}{Any movement detected between 2 pm and 3 pm}
+ \item{\code{Used.3PM}}{Any movement detected between 3 pm and 4 pm}
+ \item{\code{Used.4PM}}{Any movement detected between 4 pm and 5 pm}
+ \item{\code{Used.5PM}}{Any movement detected between 5 pm and 6 pm}
+ \item{\code{Used.6PM}}{Any movement detected between 6 pm and 7 pm}
+ \item{\code{Used.7PM}}{Any movement detected between 7 pm and 8 pm}
+ \item{\code{Used.8PM}}{Any movement detected between 8 pm and 9 pm}
+ \item{\code{Used.9PM}}{Any movement detected between 9 pm and 10 pm}
+ \item{\code{Used.10PM}}{Any movement detected between 10 pm and 11 pm}
+ \item{\code{Used.11PM}}{Any movement detected between 11 pm and Midnight}
+ }
+}
+
+\examples{
+data(steps)
+## maybe str(steps) ; plot(steps) ...
+}
+\keyword{datasets}
diff --git a/man/stork.Rd b/man/stork.Rd
new file mode 100644
index 0000000..9638f8d
--- /dev/null
+++ b/man/stork.Rd
@@ -0,0 +1,43 @@
+\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}
diff --git a/man/subplot.Rd b/man/subplot.Rd
new file mode 100644
index 0000000..caa57da
--- /dev/null
+++ b/man/subplot.Rd
@@ -0,0 +1,155 @@
+\name{subplot}
+\alias{subplot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Embed a new plot within an existing plot}
+\description{
+ Subplot will embed a new plot within an existing plot at the
+ coordinates specified (in user units of the existing plot).
+}
+\usage{
+subplot(fun, x, y, size=c(1,1), vadj=0.5, hadj=0.5,
+ inset=c(0,0), type=c('plt','fig'), pars=NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{fun}{an expression defining the new plot to be embedded.}
+ \item{x}{\code{x}-coordinate(s) of the new plot (in user coordinates
+ of the existing plot), or a character string.}
+ \item{y}{\code{y}-coordinate(s) of the new plot, \code{x} and \code{y}
+ can be specified in any of the ways understood by \code{xy.coords}.}
+ \item{size}{The size of the embedded plot in inches if \code{x} and
+ \code{y} have length 1.}
+ \item{vadj}{vertical adjustment of the plot when \code{y} is a scalar,
+ the default is to center vertically, 0 means place the bottom of the
+ plot at \code{y}, 1 places the top of the plot at \code{y}.}
+ \item{hadj}{horizontal adjustment of the plot when \code{x} is a
+ scalar, the default is to center horizontally, 0 means place the
+ left edge of the plot at \code{x}, and 1 means place the right edge
+ of the plot at \code{x}.}
+ \item{inset}{1 or 2 numbers representing the proportion of the plot to
+ inset the subplot from edges when x is a character string. The first
+ element is the horizontal inset, the second is the vertical inset.}
+ \item{type}{Character string, if 'plt' then the plotting region is
+ defined by \code{x}, \code{y}, and \code{size} with axes,
+ etc. outside that box; if 'fig' then all annotations are also inside
+ the box.}
+ \item{pars}{a list of parameters to be passed to \code{par} before
+ running \code{fun}.}
+}
+\details{
+ The coordinates \code{x} and \code{y} can be scalars or vectors of
+ length 2. If vectors of length 2 then they determine the opposite
+ corners of the rectangle for the embedded plot (and the parameters
+ \code{size}, \code{vadj}, and \code{hadj} are all ignored).
+
+ If \code{x} and \code{y} are given as scalars then the plot position
+ relative to the point and the size of the plot will be determined by
+ the arguments \code{size}, \code{vadj}, and \code{hadj}. The default
+ is to center a 1 inch by 1 inch plot at \code{x,y}. Setting
+ \code{vadj} and \code{hadj} to \code{(0,0)} will position the lower
+ left corner of the plot at \code{(x,y)}.
+
+ If \code{x} is a character string, then it will be parsed for the
+ strings "left", "right", "top", and "bottom" and x and y will be set
+ appropriately (anything not specified will be set at the center in
+ that dimension) using also the \code{inset} argument. This allows the
+ position of the subplot to be specified as 'topleft' or 'bottom', etc.
+ The \code{inset} argument is in proportion of the plot units, so 0.1
+ means inset 10\% of the width/height of the plotting distance. If
+ \code{hadj}/\code{vadj} are not specified, they will be set appropriately.
+
+ The rectangle defined by \code{x}, \code{y}, \code{size}, \code{vadj},
+ and \code{hadj} will be used as the plotting area of the new plot.
+ Any tick marks, axis labels, main and sub titles will be outside of
+ this rectangle if \code{type} is 'plt'. If type is 'fig' then the
+ annotations will be inside the box.
+
+ Any graphical parameter settings that you would like to be in place
+ before \code{fun} is evaluated can be specified in the \code{pars}
+ argument (warning: specifying layout parameters here (\code{plt},
+ \code{mfrow}, etc.) may cause unexpected results).
+
+ After the function completes the graphical parameters will have been
+ reset to what they were before calling the function (so you can
+ continue to augment the original plot).
+}
+\value{
+ An invisible list with the graphical parameters that were in effect
+ when the subplot was created. Passing this list to \code{par} will
+ enable you to augment the embedded plot.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Greg Snow \email{538280 at gmail.com}}
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{\code{\link{grconvertX}}, \code{\link{par}},
+ \code{\link{symbols}}, \code{\link{my.symbols}}, \code{\link{ms.image}}}
+\examples{
+# make an original plot
+plot( 11:20, sample(51:60) )
+
+# add some histograms
+
+subplot( hist(rnorm(100)), 15, 55)
+subplot( hist(runif(100),main='',xlab='',ylab=''), 11, 51, hadj=0, vadj=0)
+subplot( hist(rexp(100, 1/3)), 20, 60, hadj=1, vadj=1, size=c(0.5,2) )
+subplot( hist(rt(100,3)), c(12,16), c(57,59), pars=list(lwd=3,ask=FALSE) )
+
+### some of the following examples work fine in an interactive session,
+### but loading the packages required does not work well in testing.
+
+# augment a map
+if( interactive() && require(maptools) ){
+ plot(state.vbm,fg=NULL)
+ tmp <- cbind( state.vbm$center_x, state.vbm$center_y )
+ for( i in 1:50 ){
+ tmp2 <- as.matrix(USArrests[i,c(1,4)])
+ tmp3 <- max(USArrests[,c(1,4)])
+ subplot( barplot(tmp2, ylim=c(0,tmp3),names=c('',''),yaxt='n'),
+ x=tmp[i,1], y=tmp[i,2], size=c(.1,.1))
+ }
+}
+
+tmp <- rnorm(25)
+qqnorm(tmp)
+qqline(tmp)
+tmp2 <- subplot( hist(tmp,xlab='',ylab='',main=''),
+ grconvertX(0.1,from='npc'), grconvertY(0.9,from='npc'),
+ vadj=1, hadj=0 )
+abline(v=0, col='red') # wrong way to add a reference line to histogram
+
+# right way to add a reference line to histogram
+op <- par(no.readonly=TRUE)
+par(tmp2)
+abline(v=0, col='green')
+par(op)
+
+
+# scatter-plot using images
+if(interactive() && require(png)) {
+
+ image.png <- function(x,...) {
+ cols <- rgb( x[,,1], x[,,2], x[,,3], x[,,4] )
+ z <- 1:length(cols)
+ dim(z) <- dim(x[,,1])
+ z <- t(z)
+ z <- z[ ,rev(seq_len(ncol(z))) ]
+ image(z, col=cols, axes=FALSE, ...)
+ }
+
+ logo <- readPNG(system.file("img", "Rlogo.png", package="png"))
+
+ x <- runif(10)
+ y <- runif(10)
+ plot(x,y, type='n')
+ for(i in 1:10) {
+ subplot(image.png(logo), x[i], y[i], size=c(0.3,0.3))
+ }
+}
+
+}
+\keyword{aplot}% at least one, from doc/KEYWORDS
+\keyword{dplot}
+
diff --git a/man/tkBrush.Rd b/man/tkBrush.Rd
new file mode 100644
index 0000000..61bd1f3
--- /dev/null
+++ b/man/tkBrush.Rd
@@ -0,0 +1,115 @@
+\name{tkBrush}
+\alias{tkBrush}
+\title{Change the Color and Styles of points interactively}
+\description{Creates a Tk window with a scatterplot matrix, then allows
+ you to "brush" the points to change their color and/or style.}
+\usage{
+tkBrush(mat,hscale=1.75,vscale=1.75,wait=TRUE,...)
+}
+\arguments{
+ \item{mat}{A matrix of the data to plot, columns are variables, rows
+ are observations, same as \code{pairs}}
+ \item{hscale}{Passed to \code{tkrplot}}
+ \item{vscale}{Passed to \code{tkrplot}}
+ \item{wait}{Should the function wait for you to finish, see below}
+ \item{...}{Additional arguments passed to the panel functions}
+}
+\details{
+ This function creates a Tk window with a pairs plot of \code{mat},
+ then allows you to interactively move a rectangle (the brush) over the
+ points to change their color and plotting character.
+
+ The arrow keys can be used to change the size and shape of the brush.
+ The left arrow makes the rectangle wider, the right makes it
+ narrower. The up arrow key makes it taller, the right makes it
+ shorter.
+
+ When the mouse button is not pressed the points inside the brush will
+ change while in the brush, but return to their previous state when the
+ brush moves off them. If the mouse button is pressed then the points
+ inside the brush will be changed and the change will remain until a
+ different set of conditions is brushed on them.
+
+ The style of the brushed points is determined by the values of the 2
+ entry boxes on the right side of the plot. You can specify the
+ plotting character in the \code{pch} box, this can be anything that
+ you would regularly pass to the \code{pch} argument of \code{points},
+ e.g. an integer or single character. You can specify the color of the
+ brushed points using the \code{color} entry box, specify the name of
+ any color recognized by R (see \code{colors}), if this box does not
+ contain a legal color name then black will be used.
+
+ If \code{wait} is FALSE then the Tk window will exist independently of
+ R and you can continue to do other things in the R window, in this
+ case the function returns NULL. If \code{wait} is TRUE then R waits
+ for you to close the Tk window (using the quit button) then returns a
+ list with the colors and plotting characters resulting from your
+ brushing, this information can be used to recreate the plot using
+ \code{pairs} on a new graphics device (for printing or saving).
+
+}
+\value{
+ Either NULL (if Wait=FALSE) or a list with components \code{col} and
+ \code{pch} corresponding to the state of the points.
+}
+\author{ Greg Snow \email{538280 at gmail.com}}
+\seealso{\code{\link{pairs}},\code{colors},\code{\link{points}},
+ the \code{iplots} package}
+\examples{
+if(interactive()){
+
+# Iris dataset
+
+out1 <- tkBrush(iris)
+
+# Now brush the points
+
+pairs(iris, col=out1$col, pch=out1$pch)
+
+# or
+
+colhist <- function(x,...){
+ tmp <- hist(x,plot=F)
+ br <- tmp$breaks
+ w <- as.numeric(cut(x,br,include.lowest=TRUE))
+ sy <- unlist(lapply(tmp$counts,function(x)seq(length=x)))
+ my <- max(sy)
+ sy <- sy/my
+ my <- 1/my
+ sy <- sy[order(order(x))]
+ tmp.usr <- par('usr'); on.exit(par(usr=tmp.usr))
+ par(usr=c(tmp.usr[1:2],0,1.5))
+ rect(br[w], sy-my, br[w+1], sy,
+ col=out1$col, # note out1$col is hardcoded here.
+ border=NA)
+ rect(br[-length(br)], 0, br[-1], tmp$counts*my)
+}
+pairs(iris, col=out1$col, pch=out1$pch, diag.panel=colhist)
+
+
+# some spheres
+
+s1 <- matrix(nrow=0,ncol=3)
+
+while( nrow(s1) < 1000 ){
+ tmp <- rnorm(3)
+ if( sum(tmp^2) <= 1 ){
+ s1 <- rbind(s1,tmp)
+ }
+}
+
+s2 <- matrix(rnorm(3000), ncol=3)
+s2 <- s2/apply(s2,1,function(x) sqrt(sum(x^2)))
+
+tkBrush(s1, wait=FALSE)
+tkBrush(s2, wait=FALSE)
+
+# now paint values where var 2 is close to 0 in both plots
+# and compare the var 1 and var 3 relationship
+
+}
+}
+
+\keyword{ hplot }
+\keyword{ iplot }
+\keyword{ dynamic }
\ No newline at end of file
diff --git a/man/tkexamp.Rd b/man/tkexamp.Rd
new file mode 100644
index 0000000..7bbb845
--- /dev/null
+++ b/man/tkexamp.Rd
@@ -0,0 +1,269 @@
+\name{tkexamp}
+\alias{tkexamp}
+%- Also NEED an '\alias' for EACH other topic documented here.
+%- cp slider2.Rd /home/wiwi/pwolf/work/work.rtrevive/install.dir/rwined/man/slider.Rd
+\title{Create Tk dialog boxes with controls to show examples of changing
+parameters on a graph.}
+\description{
+ This utility will create a Tk window with a graph and controls to
+ change the parameters of the plotting function interactively.
+}
+\usage{
+ tkexamp(FUN, param.list, vscale=1.5, hscale=1.5, wait=FALSE,
+plotloc='top', an.play=TRUE, print=FALSE, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{FUN}{A function call to create the example plot}
+ \item{param.list}{A list of lists with information on the parameters
+ to control and the controls to use. See Details Below}
+ \item{vscale}{Vertical size of plot, passed to \code{tkrplot}}
+ \item{hscale}{Horizontal size of plot, passed to \code{tkrplot}}
+ \item{wait}{Should R wait for the demo to end}
+ \item{plotloc}{Character with "top", "left", or "right" indicating
+ where the plot should be placed relative to the controls}
+ \item{an.play}{Should the scheduling in tcltk2 package be used for animations}
+ \item{print}{Automatically print the result (useful for ggplot2/lattice)}
+ \item{...}{Extra arguments, currently ignored}
+}
+\details{
+ This is a helper function to create interactive demonstrations of the
+ effect of various function arguments on the resulting graph.
+
+ The \code{FUN} argument should be a function call to create the basic
+ plot (if run stand alone this should create the starting plot). The
+ arguments to be changed should not be included.
+
+ The \code{param.list} is a nested list of lists that defines which
+ controls to use for which function arguments. Additional levels of
+ nested lists creates groups of controls (see examples below) and if
+ the list is named in the enclosing list, that name will be used to
+ label the group.
+
+ The
+ lowest level of lists control a single function argument with the
+ control to be used. The name of the list in the enclosing list is the
+ name of the function argument to be used, e.g. \code{"pch=list(...)"}
+ will create a control for the \code{pch} parameter.
+
+ The first element of the innermost list is a character string
+ specifying which control to use (from the list below), the rest of the
+ elements must be named and specify parameters of the controls. For
+ details on all possible parameters see the tcltk documentation. Any
+ parameter can be set using this list, for example most controls have a
+ \code{width} parameter that can be set with code like \code{width=5}.
+ Most controls also have an \code{init} argument that specifies the
+ initial value that the control will be set to (most have a default in
+ case you don't specify the value).
+
+ The following are the possible controls you can specify as the first
+ element of the list along with the most common parameters to specify:
+
+ "numentry", an entry box where a number can be typed in, this will be
+ passed to \code{FUN} wrapped in \code{as.numeric()}.
+
+ "entry", an entry box where a character string can be typed in (this
+ will be passed to \code{FUN} as a character string, not converted).
+
+ "slider", a slider (or scale) that can be dragged left and right to
+ choose the different values. The common parameters to specify are
+ "from" (the lowest value), "to" (the largest value), and "resolution"
+ (the increment size when sliding).
+
+ "vslider", just like slider except that the slider is dragged up and
+ down rather than left and right.
+
+ "spinbox", an entry widget for a number with small arrows on the right
+ side that can be used to increment/decrement the value, or you can
+ type in a value. The common parameters to set are "from" (smallest
+ value), "to" (largest value), and "increment" (how much to change the
+ value by when clicking on the arrows). You can also set "values"
+ which is a vector of values that can be used. This will be passed to
+ \code{FUN} as a number.
+
+ "checkbox", a box that can be checked, passed to \code{FUN} as a
+ logical (TRUE if checked, FALSE if not checked). To set the intial
+ value as TRUE (the default is FALSE) use \code{init='T'}.
+
+ "combobox", an entry widget with an arrow on the right side that will
+ bring up a list of values to choose from. This value is passed to
+ \code{FUN} as a character string. The important parameter to set is
+ "values" which is a vector of character strings to choose between.
+ This option will only work with tcl version 8.5 or later and will
+ probably produce an error in earlier versions.
+
+ "radiobuttons", a set of choices with check boxes next to each, when
+ one is selected the previous selection is cleared. The important
+ parameter to set is "values" wich is a vector of character strings to
+ choose between.
+
+ "animate", is a combination of a slider and a button. If the tcltk2
+ package is avaliable and \code{an.play=TRUE} then the button will say
+ "Play" and pressing the button will automatically increment the slider
+ (and update the graph) until it reaches the maximum value. Otherwise
+ the button will say "Inc" and you must click and hold on the button to
+ run the animation (this might be prefered in that you can stop the
+ animation). Either way you can set the delay option (all other
+ options match with the slider option) and move the slider when the
+ interaction is not happening. The animation starts at the current
+ value on the slider and goes to the maximum value. You should only
+ have at most one animation control (multiple will confuse each other),
+ this includes not having multiple windows operating at the same time
+ with animation controls.
+
+ Each nesting of lists will also change how the controls are placed
+ (top to bottom vs. left to right).
+
+
+ The Tk window will also have a default set of controls at the bottom.
+ These include entry widgets for \code{vscale} and \code{hscale} for
+ changing the size of the graph (initially set by arguments to
+ \code{tkexamp}). A "Refresh" button that will refresh the graph with
+ the new parameter values (some controls like sliders will
+ automatically refresh, but others like entries will not refresh on
+ their own and you will need to click on this button to see the
+ updates). A "Print Call" button that when clicked will print a text
+ string to the R terminal that represents the function call with the
+ current argument settings (copying and pasting this to the command
+ line should recreate the current plot on the current plotting
+ device). And an "Exit" button that will end the demo and close the window.
+}
+\value{
+ If \code{wait} is FALSE then it returns an invisible NULL, if
+ \code{wait} is TRUE then it returns a list with the argument values
+ when the window was closed.
+}
+\author{Greg Snow, \email{538280 at gmail.com}}
+
+\note{You can move the sliders in 3 different ways: You can left click
+ and drag the slider itself, you can left click in the trough to either
+ side of the slider and the slider will move 1 unit in the direction
+ you clicked, or you can right click in the trough and the slider will
+ jump to the location you clicked at.
+ }
+
+\seealso{ \code{tkrplot}, the fgui package, the playwith package, and
+ the rpanel package }
+
+\examples{
+if(interactive()) {
+
+x <- sort( runif(25,1,10) )
+y <- rnorm(25, x)
+
+# some common plotting parameters
+
+tke.test1 <- list(Parameters=list(
+ pch=list('spinbox',init=1,from=0,to=255,width=5),
+ cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1),
+ type=list('combobox',init='b',
+ values=c('p','l','b','o','c','h','s','S','n'),
+ width=5),
+ lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5),
+ lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5)
+ ))
+
+tkexamp( plot(x,y), tke.test1, plotloc='top' )
+
+# different controls for the parameters
+
+tke.test2 <- list(Parameters=list(
+ pch=list('spinbox',init=1,values=c(0:25,32:255),width=5),
+ cex=list('slider',init=1.5,from=0.1,to=5,resolution=0.1),
+ type=list('radiobuttons',init='b',
+ values=c('p','l','b','o','c','h','s','S','n'),
+ width=5),
+ lwd=list('spinbox',init=1,from=0,to=5,increment=1,width=5),
+ lty=list('spinbox',init=1,from=0,to=6,increment=1,width=5),
+ xpd=list('checkbox')
+ ))
+
+tkexamp( plot(x,y), tke.test2, plotloc='left')
+
+tmp <- tkexamp( plot(x,y), list(tke.test2), plotloc='right', wait=TRUE )
+
+# now recreate the plot
+tmp$x <- x
+tmp$xlab <- 'x'
+tmp$y <- y
+tmp$ylab <- 'y'
+do.call('plot', tmp)
+
+# a non plotting example
+
+tke.test3 <- list(
+ sens=list('slider', init=0.95, from=0.9, to=1, resolution=0.005),
+ spec=list('slider', init=0.9, from=0.8, to=1, resolution=0.005),
+ prev=list('slider', init=0.01, from=0.0001, to=0.1, resolution=0.0001),
+ step=list('spinbox', init=1, from=1, to=11, width=5),
+ n=list('numentry',init=100000, width=7)
+)
+
+options(scipen=1)
+tkexamp( SensSpec.demo(), tke.test3 )
+# now increment step and watch the console
+
+# Above example but converting it to plot
+
+tempfun <- function(sens,spec,prev,step,n) {
+ if(missing(sens) || missing(n)) return(invisible(NULL))
+ tmp <- capture.output( SensSpec.demo(sens=sens,spec=spec,
+ prev=prev, n=n, step=step) )
+ par(cex=2.25)
+ plot.new()
+ tmp2 <- strheight(tmp)
+ text(0, 1-cumsum(tmp2*1.5), tmp, family='mono', adj=0)
+ title('Sensitivity and Specificity Example')
+}
+
+tkexamp( tempfun(), tke.test3, hscale=4, vscale=2 )
+
+# an example using trellis graphics
+
+tke.test4 <- list(
+ alpha=list('slider', from=0,to=1,init=1,
+ resolution=0.05),
+ cex=list('spinbox',init=.8,from=.1,to=3,increment=.1,width=5),
+ col=list('entry',init='#0080ff'),
+ pch=list('spinbox',init=1, from=0,to=255,
+ increment=1,width=5),
+ fill=list('entry',init='transparent')
+)
+
+tempfun <- function(x,y,alpha,cex,col,pch,fill) {
+ if(missing(alpha) || missing(cex)) {return()}
+ trellis.par.set(plot.symbol=list(alpha=alpha, cex=cex, col=col,
+ font=1,pch=pch,fill=fill))
+ print(xyplot( y~x ))
+}
+
+require(lattice)
+
+tkexamp( tempfun(x,y), list(tke.test4), plotloc='left')
+
+
+# Two example using ggplot2
+
+if( require(ggplot2) ) {
+
+## 1
+ tkexamp( qplot(cty,data=mpg, geom='histogram'),
+ list(binwidth=list('slider',from=1,to=25)),
+ print=TRUE)
+
+## 2
+ tmpfun <- function(bw=2){
+ print(ggplot(mpg, aes(cty)) +
+ geom_histogram(binwidth = bw))
+ }
+
+ tkexamp( tmpfun, list(bw=list('slider',from=1, to=5)))
+
+
+}
+
+}
+}
+\keyword{dynamic}% at least one, from doc/KEYWORDS
+\keyword{iplot}% __ONLY ONE__ keyword per line
+
diff --git a/man/tree.demo.Rd b/man/tree.demo.Rd
new file mode 100644
index 0000000..2c232b7
--- /dev/null
+++ b/man/tree.demo.Rd
@@ -0,0 +1,53 @@
+\name{tree.demo}
+\alias{tree.demo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Interactively demonstrate regression trees }
+\description{
+ Interactively recursively partition a dataset to demonstrate
+ regression trees.
+}
+\usage{
+tree.demo(x, y)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ The predictor variable. }
+ \item{y}{ The response variable. }
+}
+\details{
+ This function first creates a scatterplot of \code{x} and \code{y} and
+ shows the residual sum of squares from fitting a horizontal line to
+ the y-values.
+
+ Clicking anywhere on the graph will show an updated graph where the
+ data is partitioned into 2 groups based on the x-value where you
+ clicked with a horizontal line fit to each group (including showing
+ the updated residual sum of squares). Clicking again will move the
+ partitioning value based on the new click.
+
+ When you have found a good partitioning (reduces the RSS), right click
+ and choose 'stop' and that partition will become fixed. Now you can
+ click to do a second set of partions (breaking the data into 3
+ groups).
+
+ To finish the demo, right click and choose 'stop', then right click
+ again and choose 'stop' again.
+}
+\value{
+ A vector with the x-values of the cut points that you selected (sorted).
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com} }
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ The rpart and tree packages }
+\examples{
+if(interactive()){
+data('ethanol', package='lattice')
+print(with(ethanol, tree.demo(E,NOx)))
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ models }% __ONLY ONE__ keyword per line
diff --git a/man/triplot.Rd b/man/triplot.Rd
new file mode 100644
index 0000000..5e3a519
--- /dev/null
+++ b/man/triplot.Rd
@@ -0,0 +1,75 @@
+\name{triplot}
+\alias{triplot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Create or add to a Trilinear Plot }
+\description{
+ Create (or add to) a trilinear plot of 3 proportions that sum to 1.
+}
+\usage{
+triplot(x, y = NULL, z = NULL, labels = dimnames(x)[[2]],
+ txt = dimnames(x)[[1]], legend = NULL, legend.split = NULL,
+ inner = TRUE, inner.col = c("lightblue", "pink"), inner.lty = c(2, 3),
+ add = FALSE, main = "", ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ Vector or matrix of up to 3 columns. }
+ \item{y}{ Vector (if \code{x} is a vector). }
+ \item{z}{ Vector (if \code{x} is a vector). }
+ \item{labels}{ Labels for the 3 components (printed at corners). }
+ \item{txt}{ Vector of text strings to be plotted instead of points. }
+ \item{legend}{ Labels for the data points }
+ \item{legend.split}{ What proportion of the labels will go on the left. }
+ \item{inner}{ Logical, should the inner reference lines be plotted. }
+ \item{inner.col}{ Colors for the 2 inner triangles. }
+ \item{inner.lty}{ Line types for the 2 inner triangles. }
+ \item{add}{ Add points to existing plot (TRUE), or create a new plot (FALSE). }
+ \item{main}{ Main title for the plot. }
+ \item{\dots}{ Additional arguments passed on to \code{points} or \code{text}. }
+}
+\details{
+ Trilinear plots are useful for visualizing membership in 3 groups by
+ plotting sets of 3 proportions that sum to 1 within each set.
+
+ The data can be passed to the function as a matrix with either 2 or 3
+ columns, or as seperate vectors to \code{x}, \code{y}, and optionaly
+ \code{z}. If 2 columns are passed in, then they must be between 0 and
+ 1 and the 3rd column will be created by subtracting both from 1. If 3
+ columns of data are given to the function then each will be divided by
+ the sum of the 3 columns (they don't need to sum to 1 before being
+ passed in).
+}
+\value{
+ An invisible matrix with 2 columns and the same number of rows as \code{x}
+ corresponding to the points plotted (after transforming to 2
+ dimensions).
+
+ The return matrix can be passed to \code{identify} for labeling of
+ individual points.
+
+ Using \code{type='n'} and \code{add=FALSE} will return the transformed
+ points without doing any plotting.
+}
+\references{ Allen, Terry. Using and Interpreting the Trilinear Plot.
+ Chance. 15 (Summer 2002). }
+\author{ Greg Snow \email{538280 at gmail.com} }
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{triangle.plot} in package ade4,
+ \code{ternaryplot} in package vcd, \code{tri} in package cwhtool,
+ \code{soil.texture} and \code{triax.plot} in package plotrix. }
+\examples{
+triplot(USArrests[c(1,4,2)])
+tmp <- triplot(USArrests[c(1,4,2)],txt=NULL)
+if(interactive()){ identify(tmp, lab=rownames(USArrests) ) }
+
+tmp <- rbind( HairEyeColor[,,'Male'], HairEyeColor[,,'Female'])
+tmp[,3] <- tmp[,3] + tmp[,4]
+tmp <- tmp[,1:3]
+triplot(tmp, legend=rep(c('Male','Femal'),each=4),
+ col=rep(c('black','brown','red','yellow'),2))
+}
+\keyword{ hplot }% at least one, from doc/KEYWORDS
+\keyword{ aplot }% __ONLY ONE__ keyword per line
diff --git a/man/updateusr.Rd b/man/updateusr.Rd
new file mode 100644
index 0000000..a46672e
--- /dev/null
+++ b/man/updateusr.Rd
@@ -0,0 +1,71 @@
+\name{updateusr}
+\alias{updateusr}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Updates the 'usr' coordinates in the current plot. }
+\description{
+ For a traditional graphics plot this function will update the 'usr'
+ coordinates by transforming a pair of points from the current usr
+ coordinates to those specified.
+}
+\usage{
+updateusr(x1, y1 = NULL, x2, y2 = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x1}{ The x-coords of 2 points in the current 'usr' coordianates,
+ or anything that can be passed to \code{xy.coords}.}
+ \item{y1}{ The y-coords of 2 points in the current 'usr' coordinates,
+ or an object representing the points in the new 'usr' coordinates. }
+ \item{x2}{ The x-coords for the 2 points in the new coordinates. }
+ \item{y2}{ The y-coords for the 2 points in the new coordinates. }
+}
+\details{
+ Sometimes graphs (in the traditional graphing scheme) end up with usr
+ coordinates different from expected for adding to the plot (for
+ example \code{barplot} does not center the bars at integers). This
+ function will take 2 points in the current 'usr' coordinates and the
+ desired 'usr' coordinates of the 2 points and transform the user
+ coordinates to make this happen. The updating only shifts and scales
+ the coordinates, it does not do any rotation or warping transforms.
+
+ If \code{x1} and \code{y1} are lists or matricies and \code{x2} and
+ \code{y2} are not specified, then \code{x1} is taken to be the
+ coordinates in the current system and \code{y1} is the coordinates in
+ the new system.
+
+ Currently you need to give the function exactly 2 points in each
+ system. The 2 points cannot have the same x values or y values in
+ either system.
+}
+\value{
+ An invisible list with the previous 'usr' coordinates from \code{par}.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow, \email{538280 at gmail.com} }
+\note{
+ Currently you need to give coordinates for exactly 2 points without
+ missing values. Future versions of the function will allow missing
+ values or multiple points.
+}
+\seealso{\code{\link{par}} }
+\examples{
+tmp <- barplot(1:4)
+updateusr(tmp[1:2], 0:1, 1:2, 0:1)
+lines(1:4, c(1,3,2,2), lwd=3, type='b',col='red')
+
+# update the y-axis to put a reference distribution line in the bottom
+# quarter
+
+tmp <- rnorm(100)
+hist(tmp)
+tmp2 <- par('usr')
+xx <- seq(min(tmp), max(tmp), length.out=250)
+yy <- dnorm(xx, mean(tmp), sd(tmp))
+updateusr( tmp2[1:2], tmp2[3:4], tmp2[1:2], c(0, max(yy)*4) )
+lines(xx,yy)
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ dplot }
+\keyword{ aplot }% __ONLY ONE__ keyword per line
diff --git a/man/vis.binom.Rd b/man/vis.binom.Rd
new file mode 100644
index 0000000..880b392
--- /dev/null
+++ b/man/vis.binom.Rd
@@ -0,0 +1,55 @@
+\name{vis.binom}
+\alias{vis.binom}
+\alias{vis.gamma}
+\alias{vis.normal}
+\alias{vis.t}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Plot various distributions then interactivly adjust the parameters. }
+\description{
+ Plot a curve of a distribution, then using a Tk slider window adjust
+ the parameters and see how the distribution changes. Optionally also
+ plots reference distributions.
+}
+\usage{
+vis.binom()
+vis.gamma()
+vis.normal()
+vis.t()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ These functions plot a distribution, then create a Tk slider box that
+ allows you to adjust the parameters of the distribution to see how the
+ curve changes.
+
+ Check boxes are available in some cases to also show reference
+ distributions (normal and poisson for the binomial, exponential and
+ chi-squared for gamma, and normal for t). The exponential and
+ chi-squared distributions are those with the same mean as the plotted
+ gamma.
+
+ If you change the plotting
+ ranges then you need to click on the 'refresh' button to update the plot.
+}
+\value{
+ These functions are run for their side effects and do not return
+ anything meaningful.
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com} }
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{dnorm}}, \code{\link{dgamma}}, etc. }
+\examples{
+if(interactive()){
+vis.binom()
+vis.normal()
+vis.gamma()
+vis.t()
+}
+}
+\keyword{ distribution }% at least one, from doc/KEYWORDS
+\keyword{ hplot }% __ONLY ONE__ keyword per line
+\keyword{ dynamic }
\ No newline at end of file
diff --git a/man/vis.boxcox.Rd b/man/vis.boxcox.Rd
new file mode 100644
index 0000000..f1b28bd
--- /dev/null
+++ b/man/vis.boxcox.Rd
@@ -0,0 +1,70 @@
+\name{vis.boxcox}
+\alias{vis.boxcox}
+\alias{vis.boxcox.old}
+\alias{vis.boxcoxu}
+\alias{vis.boxcoxu.old}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Interactively visualize Box-Cox transformations }
+\description{
+ Explore the Box-Cox family of distributions by plotting data
+ transformed and untransformed and interactively choose values for lambda.
+}
+\usage{
+vis.boxcox(lambda = sample(c(-1,-0.5,0,1/3,1/2,1,2), 1),
+ hscale=1.5, vscale=1.5, wait=FALSE)
+
+vis.boxcoxu(lambda = sample( c(-1,-0.5,0,1/3,1/2,1,2), 1),
+ y, xlab=deparse(substitute(y)),
+ hscale=1.5, vscale=1.5, wait=FALSE)
+
+vis.boxcox.old(lambda = sample(c(-1, -0.5, 0, 1/3, 1/2, 1, 2), 1))
+
+vis.boxcoxu.old(lambda = sample(c(-1, -0.5, 0, 1/3, 1/2, 1, 2), 1))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lambda}{ The true value of lambda to use. }
+ \item{y}{ Optional data to use in the transform. }
+ \item{xlab}{ Label for x-axis.}
+ \item{hscale}{ The horizontal scale, passed to \code{tkrplot}. }
+ \item{vscale}{ The vertical scale, passed to \code{tkrplot}. }
+ \item{wait}{ Should R wait for the demo window to close. }
+}
+\details{
+ These functions will generate a sample of data and plot the
+ untrasformed data (left panels) and the transformed data (right
+ panels). Initially the value of \code{lambda} is 1 and the 2 sets of
+ plots will be identical.
+
+ You then adjust the transformation parameter \code{lambda} to see how
+ the right panels change.
+
+ The function \code{vis.boxcox} shows the effect of transforming the
+ y-variable in a simple linear regression.
+
+ The function \code{vis.boxcoxu} shows a single variable compared to
+ the normal distribution.
+}
+\value{
+ The old versions have no useful return value. If \code{wait} is FALSE
+ then they will return an invisible NULL, if \code{wait} is TRUE then
+ the return value will be a list with the final value of \code{lamda},
+ the original data, and the transformed y (at the final \code{lamda} value).
+}
+\references{ GEP Box; DR Cox. An Analysis of Transformations. Journal
+ of the Royal Statitical Society. Series B, Vol. 26, No. 2 (1964) 211-252 }
+\author{ Greg Snow \email{538280 at gmail.com} }
+%\note{ ~~further notes~~ }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{bct}}, \code{boxcox} in package MASS }
+\examples{
+if(interactive()) {
+vis.boxcoxu()
+vis.boxcox()
+}
+}
+\keyword{ dynamic }% at least one, from doc/KEYWORDS
+\keyword{ univar }% __ONLY ONE__ keyword per line
+\keyword{ regression }
\ No newline at end of file
diff --git a/man/vis.test.Rd b/man/vis.test.Rd
new file mode 100644
index 0000000..7c83b6a
--- /dev/null
+++ b/man/vis.test.Rd
@@ -0,0 +1,186 @@
+\name{vis.test}
+\Rdversion{1.1}
+\alias{vis.test}
+\alias{vt.qqnorm}
+\alias{vt.normhist}
+\alias{vt.scatterpermute}
+\alias{vt.tspermute}
+\alias{vt.residpermute}
+\alias{vt.residsim}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Do a Visual test of a null hypothesis by choosing the graph that does
+not belong.
+}
+\description{
+These functions help in creating a set of plots based on the real data
+and some modification that makes the null hypothesis true. The user
+then tries to choose which graph represents the real data.
+}
+\usage{
+vis.test(..., FUN, nrow=3, ncol=3, npage=3, data.name = "", alternative)
+vt.qqnorm(x, orig=TRUE)
+vt.normhist(x, ..., orig=TRUE)
+vt.scatterpermute(x, y, ..., orig=TRUE)
+vt.tspermute(x, type='l', ..., orig=TRUE)
+vt.residpermute(model, ..., orig=TRUE)
+vt.residsim(model, ..., orig=TRUE)
+}
+
+\arguments{
+ \item{\dots}{ data and arguments to be passed on to \code{FUN} or to
+ plotting functions, see details below}
+ \item{FUN}{ The function to create the plots on the original or null
+ hypothesis data}
+ \item{nrow}{ The number of rows of graphs per page }
+ \item{ncol}{ The number of columns of graphs per page }
+ \item{npage}{ The number of pages to use in the testing }
+ \item{data.name}{Optional character string for the name of the data in
+ the output}
+ \item{alternative}{Optional character string for the alternative
+ hypothesis in the output}
+ \item{orig}{ Logical, should the original data be plotted, or data
+ based on the null hypothesis }
+ \item{x}{data or x-coordinates of the data}
+ \item{y}{y-coordinates of the data}
+ \item{type}{type of plot, passed on to plot function (use 'p' for
+ points)}
+ \item{model}{An \code{lm} object, or any model object for which
+ \code{fitted} and \code{resid} return vectors}
+}
+\details{
+ The \code{vis.test} function will create a \code{nrow} by \code{ncol}
+ grid of plots, one
+ of which is based on the real (original) data and the others which
+ are based on a null hypothesis simulation (a statistical "lineup").
+ The real plot is placed at
+ random within the set. The user then clicks on their best guess
+ of which plot is the real one (the most different from the others).
+ If the null hypothesis is true for the real data, then this will be a
+ guess with a 1/(\code{nrow}*\code{ncol}) probability of success. This
+ process is then
+ repeated for a total of \code{npage} times. A p-value is then
+ constructed based on the
+ number of correct guesses and the null hypothesis that
+ there is a 1/(\code{nrow}*\code{ncol}) chance of guessing correct each
+ time (this will work
+ best if the person doing the choosing has not already seen
+ plots/summaries of the data).
+
+ If the plotting function (\code{FUN}) is not passed as a named
+ argument, then the first argument (in the \dots) that is a function
+ will be used. If no functions are passed then the function will stop
+ with an error.
+
+ The plotting function (\code{FUN}) can be an existing function or a
+ user supplied function. The function must have an argument named
+ "orig" which indicates whether to plot the original data or the null
+ hypothesis data. A new seed will be set before each call to
+ \code{FUN} except when \code{orig} is \code{TRUE}. Inside the
+ function if \code{orig} is \code{TRUE} then the function should plot
+ the original data. When \code{orig} is \code{FALSE} then the function
+ should do some form of simulation based on the data with the null
+ hypothesis true and plot the simulated data (making sure to give no
+ signs that it is different from the original plot).
+
+ The return object includes a list with the seeds set before each of
+ the plots (\code{NA} for the original data plot) and a vector of the
+ plots selected by the user. This information can be used to recreate
+ the simulated plots by setting the seed then calling \code{FUN}.
+
+
+ The \code{vt.qqnorm} function tests the null hypothesis that a vector
+ of data comes from a normal distribution (or at least pretty close) by
+ creating a \code{qqnorm} plot of the original data, or the same plot
+ of random data from a normal distribution with the same mean and
+ standard deviation as the original data.
+
+ The \code{vt.normhist} function tests the null hypothesis that a
+ vector of data comes from a normal distribution (or at least pretty
+ close) by plotting a histogram with a reference line representing a
+ normal distribution of either the original data or a set of random
+ data from a normal distribution with the same mean and standard
+ deviation as the original.
+
+ The \code{vt.scatterpermute} function tests the null hypothesis of "no
+ relationship" between 2 vectors of data. When \code{orig} is \code{TRUE} the
+ function creates a scatterplot of the 2 variables, when \code{orig} is
+ \code{FALSE} the function first permutes the y variable randomly
+ (making no relationship) then creates a scatter plot with the original
+ x and permuted y variables.
+
+ The \code{vt.tspermute} function creates a time series type plot of a
+ single vector against its index. When \code{orig} is false, the
+ vector is permuted before plotting.
+
+ The \code{vt.residpermute} function takes a regression object (class
+ lm, or any model type object for which \code{fitted} and \code{resid}
+ return vectors) and does a residual plot of the fitted values on the x
+ axis and residuals on the y axis. The loess smooth curve
+ (\code{scatter.smooth} is the plotting function) and a reference line
+ at 0 are included. When \code{orig} is \code{FALSE} the residuals are
+ randomly permuted before being plotted.
+
+ The \code{vt.residsim} function takes a regression object (class lm,
+ or any model type object for which \code{fitted} and \code{resid}
+ return vectors) and does a residual plot of the fitted values on the x
+ axis and residuals on the y axis. The loess smooth curve
+ (\code{scatter.smooth} is the plotting function) and a reference line
+ at 0 are included. When \code{orig} is \code{FALSE} the residuals are
+ simulate from a normal distribution with mean 0 and standard deviation
+ the same as the residuals.
+
+}
+\value{
+ The \code{vis.test} function returns an object of class \code{htest}
+ with the following components:
+ \item{method}{The string "Visual Test"}
+ \item{data.name}{The name of the data passed to the function}
+ \item{statistic}{The number of correct "guesses"}
+ \item{p.value}{The p-value based on the number of correct "guesses"}
+ \item{nrow}{The number of rows per page}
+ \item{ncol}{The number of columns per page}
+ \item{npage}{The number of pages}
+ \item{seeds}{A list with 3 vectors containing the seeds set before
+ calling \code{FUN}, the correct plot has an \code{NA}}
+ \item{selected}{A vector of length \code{npage} indicating the number of the
+ figure picked in each of the \code{npage} tries}
+
+ The other functions are run for their side effects and do not return
+ anything meaningful.
+}
+\references{
+Buja, A., Cook, D. Hofmann, H., Lawrence, M. Lee, E.-K., Swayne, D.F and
+ Wickham, H. (2009) Statistical Inference for exploratory data analysis
+ and model diagnostics Phil. Trans. R. Soc. A 2009 367, 4361-4383 doi:
+ 10.1098/rsta.2009.0120
+}
+\author{Greg Snow \email{538280 at gmail.com}}
+
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+\section{Warning}{The p-value is based on the assumption that under the
+ null hypothesis there is a 1/(\code{nrow}*\code{ncol}) chance of
+ picking the correct plot
+ and that the \code{npage} choices are independent of each other. This
+ may not be
+ true if the user is familiar with the data or remembers details of the
+ plot between picks.}
+
+\seealso{\code{\link{set.seed}} }
+\examples{
+
+if(interactive()) {
+ x <- rexp(25, 1/3)
+ vis.test(x, vt.qqnorm)
+
+ x <- rnorm(100, 50, 3)
+ vis.test(x, vt.normhist)
+}
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ hplot }
+\keyword{ datagen }% __ONLY ONE__ keyword per line
+\keyword{ htest }
\ No newline at end of file
diff --git a/man/z.test.Rd b/man/z.test.Rd
new file mode 100644
index 0000000..20f3b6c
--- /dev/null
+++ b/man/z.test.Rd
@@ -0,0 +1,54 @@
+\name{z.test}
+\alias{z.test}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Z test for known population standard deviation }
+\description{
+ Compute the test of hypothesis and compute confidence interval on the
+ mean of a population when the standard deviation of the population is known.
+}
+\usage{
+z.test(x, mu = 0, stdev, alternative = c("two.sided", "less", "greater"),
+ sd = stdev, n=length(x), conf.level = 0.95, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ Vector of data values or the mean of the data. }
+ \item{mu}{ Hypothesized mean of the population. }
+ \item{stdev}{ Known standard deviation of the population. }
+ \item{alternative}{ Direction of the alternative hypothesis. }
+ \item{sd}{ Alternative to \code{stdev} }
+ \item{n}{ The sample size if \code{x} is the sample mean. }
+ \item{conf.level}{ Confidence level for the interval computation. }
+ \item{\dots}{ Additional arguments are silently ignored. }
+}
+\details{
+ Many introductory statistical texts introduce inference by using the Z
+ test and Z based confidence intervals based on knowing the population
+ standard deviation. Most statistical packages do not include
+ functions to do Z tests since the T test is usually more appropriate
+ for real world situations. This function is meant to be used during
+ that short period of learning when the student is learning about
+ inference using Z procedures, but has not learned the T based
+ procedures yet. Once the student has learned about the T
+ distribution the \code{t.test} function should be used instead of this
+ one (but the syntax is very similar, so this function should be an
+ appropriate introductory step to learning \code{t.test}).
+}
+\value{
+ An object of class \code{htest} containing the results
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{ Greg Snow \email{538280 at gmail.com} }
+\note{ This function should be used for learning only, real data should
+ generally use \code{t.test}. }
+
+% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{ \code{\link{t.test}}, \code{\link{print.htest}} }
+\examples{
+x <- rnorm(25, 100, 5)
+z.test(x, 99, 5)
+
+}
+\keyword{ htest }% at least one, from doc/KEYWORDS
+
diff --git a/man/zoomplot.Rd b/man/zoomplot.Rd
new file mode 100644
index 0000000..7acc4a3
--- /dev/null
+++ b/man/zoomplot.Rd
@@ -0,0 +1,71 @@
+\name{zoomplot}
+\alias{oldzoomplot}
+\alias{zoomplot}
+\title{Zoom or unzoom an existing plot in the plot window}
+\description{This function allows you to change the x and y ranges of
+ the plot that is currently in the plot window. This has the effect of
+ zooming into a section of the plot, or zooming out (unzooming) to show
+ a larger region than is currently shown.}
+\usage{
+zoomplot(xlim, ylim=NULL )
+oldzoomplot(xlim, ylim=NULL )
+}
+\arguments{
+ \item{xlim, ylim}{The new x and y limits of the plot. These can be
+ passed in in any form understood by \code{xy.coords}. The range of
+ xlim and ylim are actually used so you can pass in more than 2 points.}
+}
+\details{
+ This function recreates the current plot in the graphics window but
+ with different xlim, ylim arguments. This gives the effect of zooming
+ or unzooming the plot.
+
+ This only works with traditional graphics (not lattice/trellis).
+
+ This function is a quick hack that should only be used for quick
+ exploring of data. For any serious work you should create a script
+ with the plotting commands and adjust the xlim and ylim parameters to
+ give the plot that you want.
+
+ Only the x and y ranges are changed, the size of the plotting
+ characters and text will stay the same.
+
+ The \code{oldzoomplot} function is the version that worked for 2.15
+ and earlier, \code{zoomplot} should be used for R 3.0.
+}
+\value{
+ This function is run for its side effects and does not return anything
+ meaningful.
+}
+\author{Greg Snow \email{538280 at gmail.com}}
+\note{ For any serious projects it is best to put your code into a
+ script to begin with and edit the original script rather than using
+ this function.
+
+ This function works with the standard \code{plot} function and some
+ others, but may not work for more complicated plots.
+
+ This function depends on the \code{recordPlot} function which can
+ change in any version. Therefore this function should not be
+ considered stable.
+}
+\seealso{\code{\link{plot.default}}, \code{\link{par}},
+ \code{\link{matplot}}, \code{\link{plot2script}},
+ \code{\link{source}}}
+\examples{
+if(interactive()){
+
+with(iris, plot(Sepal.Length, Petal.Width,
+ col=c('red','green','blue')[Species]))
+text( 6.5, 1.5, 'test' )
+zoomplot( locator(2) ) # now click on 2 points in the plot to zoom in
+
+plot( 1:10, rnorm(10) )
+tmp <- rnorm(10,1,3)
+lines( (1:10) + 0.5, tmp, col='red' )
+zoomplot( c(0,11), range(tmp) )
+}
+}
+\keyword{dplot}
+\keyword{iplot}
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-teachingdemos.git
More information about the debian-science-commits
mailing list