Nothing
# Some Rcmdr dialogs for the TeachingDemos package
# last modified: 2015-12-08 by J. Fox
# Note: the following function (with contributions from Richard Heiberger and Milan Bouchet-Valat)
# can be included in any Rcmdr plug-in package to cause the package to load
# the Rcmdr if it is not already loaded
.onAttach <- function(libname, pkgname){
if (!interactive()) return()
putRcmdr("slider.env", new.env())
Rcmdr <- options()$Rcmdr
plugins <- Rcmdr$plugins
if (!pkgname %in% plugins) {
Rcmdr$plugins <- c(plugins, pkgname)
options(Rcmdr=Rcmdr)
if("package:Rcmdr" %in% search()) {
if(!getRcmdr("autoRestart")) {
closeCommander(ask=FALSE, ask.save=TRUE)
Commander()
}
}
else {
Commander()
}
}
}
simulateConfidenceIntervals <- function(){
defaults <- list(muVar="100", sigmaVar="15", nVar="25", repsVar="50", confLevelVar=".95", sigmaKnownVar="1")
dialog.values <- getDialog("simulateConfidenceIntervals", defaults)
initializeDialog(title=gettextRcmdr("Confidence Intervals for the Mean"))
muVar <- tclVar(dialog.values$muVar)
muEntry <- tkentry(top, width="6", textvariable=muVar)
sigmaVar <- tclVar(dialog.values$sigmaVar)
sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar)
nVar <- tclVar(dialog.values$nVar)
nEntry <- tkentry(top, width="6", textvariable=nVar)
repsVar <- tclVar(dialog.values$repsVar)
repsEntry <- tkentry(top, width="6", textvariable=repsVar)
confLevelVar <- tclVar(dialog.values$confLevelVar)
confLevelEntry <- tkentry(top, width="6", textvariable=confLevelVar)
sigmaKnownVar <- tclVar(dialog.values$sigmaKnownVar)
sigmaKnownBox <- tkcheckbutton(top, variable=sigmaKnownVar)
onOK <- function(){
closeDialog()
mu <- as.numeric(tclvalue(muVar))
if (is.na(mu)){
errorCondition(recall=simulateConfidenceIntervals, message="Population mean must be a number.")
return()
}
sigma <- as.numeric(tclvalue(sigmaVar))
if (is.na(sigma) || sigma <= 0){
errorCondition(recall=simulateConfidenceIntervals,
message="Population standard deviation must be a positive number.")
return()
}
n <- round(as.numeric(tclvalue(nVar)))
if (is.na(n) || n <= 0){
errorCondition(recall=simulateConfidenceIntervals, message="Sample size must be a positive integer.")
return()
}
reps <- round(as.numeric(tclvalue(repsVar)))
if (is.na(reps) || reps <= 0){
errorCondition(recall=simulateConfidenceIntervals, message="Number of samples must be a positive integer.")
return()
}
confLevel <- as.numeric(tclvalue(confLevelVar))
if (is.na(confLevel) || confLevel <= 0 || confLevel >= 1){
errorCondition(recall=simulateConfidenceIntervals, message="Confidence level must be between 0 and 1.")
return()
}
sigmaKnown <- as.numeric(tclvalue(sigmaKnownVar))
putDialog("simulateConfidenceIntervals", lapply(list(muVar=mu, sigmaVar=sigma, nVar=n, repsVar=reps,
confLevelVar=confLevel, sigmaKnownVar=sigmaKnown), as.character))
command <- paste("ci.examp(mean.sim = ", mu, ", sd = ", sigma, ", n = ", n, ", reps = ", reps,
", conf.level = ", confLevel, ", method = ", if (sigmaKnown) '"z"' else '"t"', ")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="ci.examp", reset="simulateConfidenceIntervals", apply="simulateConfidenceIntervals")
tkgrid(tklabel(top, text="Population mean"), muEntry, sticky="e")
tkgrid(tklabel(top, text="Population standard deviation"), sigmaEntry, sticky="e")
tkgrid(tklabel(top, text="Sample size"), nEntry, sticky="e")
tkgrid(tklabel(top, text="Number of samples"), repsEntry, sticky="e")
tkgrid(tklabel(top, text="Confidence level"), confLevelEntry, sticky="e")
tkgrid(tklabel(top, text="Population standard deviation known"), sigmaKnownBox, sticky="e")
tkgrid(buttonsFrame, sticky="w", columnspan=2)
tkgrid.configure(muEntry, sticky="w")
tkgrid.configure(sigmaEntry, sticky="w")
tkgrid.configure(nEntry, sticky="w")
tkgrid.configure(repsEntry, sticky="w")
tkgrid.configure(confLevelEntry, sticky="w")
tkgrid.configure(sigmaKnownBox, sticky="w")
dialogSuffix(rows=7, columns=2, focus=muEntry)
}
centralLimitTheorem <- function(){
Library("TeachingDemos")
initializeDialog(title=gettextRcmdr("Central Limit Theorem"))
defaults <- list(nVar="1", repsVar=10000, nclassVar="16")
dialog.values <- getDialog("centralLimitTheorem", defaults)
nVar <- tclVar(dialog.values$nVar)
nEntry <- tkentry(top, width="6", textvariable=nVar)
repsVar <- tclVar(dialog.values$repsVar)
repsEntry <- tkentry(top, width="6", textvariable=repsVar)
nclassVar <- tclVar(dialog.values$nclassVar)
nclassEntry <- tkentry(top, width="6", textvariable=nclassVar)
onOK <- function(){
closeDialog()
n <- round(as.numeric(tclvalue(nVar)))
if (is.na(n) || n <= 0){
errorCondition(recall=simulateConfidenceIntervals, message="Sample size must be a positive integer.")
return()
}
reps <- round(as.numeric(tclvalue(repsVar)))
if (is.na(reps) || reps <= 0){
errorCondition(recall=simulateConfidenceIntervals, message="Number of samples must be a positive integer.")
return()
}
nclass <- round(as.numeric(tclvalue(nclassVar)))
if (is.na(nclass) || reps <= 0){
errorCondition(recall=simulateConfidenceIntervals, message="Number of samples must be a positive integer.")
return()
}
putDialog("centralLimitTheorem", lapply(list(nVar=n, repsVar=reps, nclassVar=nclass), as.character))
command <- paste("clt.examp(n = ", n, ", reps = ", reps, ", nclass =", nclass, ")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="clt.examp", reset="centralLimitTheorem", apply="centralLimitTheorem")
tkgrid(tklabel(top, text="Sample size"), nEntry, sticky="e")
tkgrid(tklabel(top, text="Number of samples"), repsEntry, sticky="e")
tkgrid(tklabel(top, text="Approximate number of bins for histograms"), nclassEntry, sticky="e")
tkgrid(buttonsFrame, sticky="w", columnspan=2)
tkgrid.configure(nEntry, sticky="w")
tkgrid.configure(repsEntry, sticky="w")
tkgrid.configure(nclassEntry, sticky="w")
dialogSuffix(rows=4, columns=2, focus=nEntry)
}
flipCoin <- function(){
rgl::rgl.open()
TeachingDemos::rgl.coin()
TeachingDemos::flip.rgl.coin()
}
rollDie <- function(){
rgl::rgl.open()
TeachingDemos::rgl.die()
TeachingDemos::roll.rgl.die()
}
powerExample <- function(){
TeachingDemos::power.examp()
TeachingDemos::run.power.examp()
}
correlationExample <- function(){
TeachingDemos::run.cor.examp()
}
linearRegressionExample <- function(){
put.points.demo()
}
visBinom <- function(){
TeachingDemos::vis.binom()
}
visNormal <- function(){
TeachingDemos::vis.normal()
}
vist <- function(){
TeachingDemos::vis.t()
}
visGamma <- function(){
TeachingDemos::vis.gamma()
}
run.cor.examp <- function (n = 100, seed)
# slightly modified by J. Fox from the TeachingDemos package
{
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)
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()
}
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
{
if (!missing(no))
return(as.numeric(tclvalue(get(paste("slider", no, sep = ""),
envir = getRcmdr("slider.env")))))
if (!missing(set.no.value)) {
try(eval(parse(text = paste("tclvalue(slider", set.no.value[1],
")<-", set.no.value[2], sep = "")), envir = getRcmdr("slider.env")))
return(set.no.value[2])
}
if (!missing(obj.name)) {
if (!missing(obj.value))
assign(obj.name, obj.value, envir = getRcmdr("slider.env"))
else obj.value <- get(obj.name, envir = getRcmdr("slider.env"))
return(obj.value)
}
if (missing(title))
title <- "slider control widget"
nt <- tktoplevel()
tkwm.title(nt, title)
tkwm.geometry(nt, "+0+0")
if (missing(sl.names))
sl.names <- NULL
if (missing(sl.functions))
sl.functions <- function(...) {
}
for (i in seq(sl.names)) {
eval(parse(text = paste("assign('slider", i, "',tclVar(sl.defaults[i]), envir=getRcmdr('slider.env'))",
sep = "")))
tkpack(fr <- tkframe(nt))
lab <- tklabel(fr, text = sl.names[i], width = "25")
sc <- tkscale(fr, from = sl.mins[i], to = sl.maxs[i],
showvalue = TRUE, resolution = sl.deltas[i], orient = "horiz")
tkpack(lab, sc, side = "right")
assign("sc", sc, envir = getRcmdr("slider.env"))
eval(parse(text = paste("tkconfigure(sc,variable=slider",
i, ")", sep = "")), envir = getRcmdr("slider.env"))
sl.fun <- if (length(sl.functions) > 1)
sl.functions[[i]]
else sl.functions
if (!is.function(sl.fun))
sl.fun <- eval(parse(text = paste("function(...){",
sl.fun, "}")))
tkconfigure(sc, command = sl.fun)
}
assign("slider.values.old", sl.defaults, envir = getRcmdr("slider.env"))
tkpack(f.but <- tkframe(nt), fill = "x")
tkpack(tkbutton(f.but, text = "Exit", command = function() tkdestroy(nt)),
side = "right")
if (!missing(reset.function)){
reset.function <- function(...) print("relax")
if (!is.function(reset.function))
reset.function <- eval(parse(text = paste("function(...){",
reset.function, "}")))
tkpack(tkbutton(f.but, text = "Reset", command = function() {
for (i in seq(sl.names)) eval(parse(text = paste("tclvalue(slider",
i, ")<-", sl.defaults[i], sep = "")), envir = getRcmdr("slider.env"))
reset.function()
}), side = "right")
}
if (missing(but.names))
but.names <- NULL
for (i in seq(but.names)) {
but.fun <- if (length(but.functions) > 1)
but.functions[[i]]
else but.functions
if (!is.function(but.fun))
but.fun <- eval(parse(text = paste("function(...){",
but.fun, "}")))
tkpack(tkbutton(f.but, text = but.names[i], command = but.fun),
side = "left")
cat("button", i, "eingerichtet")
}
invisible(nt)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.