R : Copyright 2005, The R Foundation for Statistical Computing
Version 2.1.1  (2005-06-20), ISBN 3-900051-07-0

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for a HTML browser interface to help.
Type 'q()' to quit R.

> ### * <HEADER>
> ###
> attach(NULL, name = "CheckExEnv")
> assign(".CheckExEnv", as.environment(2), pos = length(search())) # base
> ## add some hooks to label plot pages for base and grid graphics
> setHook("plot.new", ".newplot.hook")
> setHook("persp", ".newplot.hook")
> setHook("grid.newpage", ".gridplot.hook")
> 
> assign("cleanEx",
+        function(env = .GlobalEnv) {
+ 	   rm(list = ls(envir = env, all.names = TRUE), envir = env)
+            RNGkind("default", "default")
+ 	   set.seed(1)
+    	   options(warn = 1)
+ 	   delayedAssign("T", stop("T used instead of TRUE"),
+ 		  assign.env = .CheckExEnv)
+ 	   delayedAssign("F", stop("F used instead of FALSE"),
+ 		  assign.env = .CheckExEnv)
+ 	   sch <- search()
+ 	   newitems <- sch[! sch %in% .oldSearch]
+ 	   for(item in rev(newitems))
+                eval(substitute(detach(item), list(item=item)))
+ 	   missitems <- .oldSearch[! .oldSearch %in% sch]
+ 	   if(length(missitems))
+ 	       warning("items ", paste(missitems, collapse=", "),
+ 		       " have been removed from the search path")
+        },
+        env = .CheckExEnv)
> assign("..nameEx", "__{must remake R-ex/*.R}__", env = .CheckExEnv) # for now
> assign("ptime", proc.time(), env = .CheckExEnv)
> grDevices::postscript("TeachingDemos-Examples.ps")
> assign("par.postscript", graphics::par(no.readonly = TRUE), env = .CheckExEnv)
> options(contrasts = c(unordered = "contr.treatment", ordered = "contr.poly"))
> options(warn = 1)    
> library('TeachingDemos')
Loading required package: tcltk
Loading Tcl/Tk interface ... done
Loading required package: lattice
> 
> assign(".oldSearch", search(), env = .CheckExEnv)
> assign(".oldNS", loadedNamespaces(), env = .CheckExEnv)
> cleanEx(); ..nameEx <- "bct"
> 
> ### * bct
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: bct
> ### Title: Box-Cox Transforms
> ### Aliases: bct
> ### Keywords: manip datagen regression
> 
> ### ** 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))
> 
> ## The function is currently defined as
> 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)
+   }
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)
}
> 
> 
> 
> graphics::par(get("par.postscript", env = .CheckExEnv))
> cleanEx(); ..nameEx <- "chisq.detail"
> 
> ### * chisq.detail
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: chisq.detail
> ### Title: Print details of a chi-squared test
> ### Aliases: chisq.detail
> ### Keywords: htest
> 
> ### ** Examples
> 
> chisq.detail(HairEyeColor[,,1])


observed
expected

      Brown   Blue Hazel Green Total
Black 32     11    10     3       56
      17.61  21.42  9.97  7.00      
                                    
Brown 38     50    25    15      128
      40.24  48.97 22.79 16.00      
                                    
Red   10     10     7     7       34
      10.69  13.01  6.05  4.25      
                                    
Blond  3     30     5     8       46
      14.46  17.60  8.19  5.75      
                                    
Total 83    101    47    33      264


Cell Contributions
      Brown    Blue   Hazel   Green        
Black 11.77 +  5.07 +  0.00 +  2.29 +      
Brown  0.12 +  0.02 +  0.21 +  0.06 +      
Red    0.04 +  0.70 +  0.15 +  1.78 +      
Blond  9.08 +  8.74 +  1.24 +  0.88 = 42.16

df = 9  P-value = 0 

> chisq.detail(HairEyeColor[,,2])


observed
expected

       Brown   Blue Hazel Green Total
Black  36      9     5     2       52
       21.72  18.07  7.29  4.91      
                                     
Brown  81     34    29    14      158
       65.99  54.91 22.16 14.93      
                                     
Red    16      7     7     7       37
       15.45  12.86  5.19  3.50      
                                     
Blond   4     64     5     8       81
       33.83  28.15 11.36  7.66      
                                     
Total 137    114    46    31      328


Cell Contributions
      Brown    Blue   Hazel   Green        
Black  9.39 +  4.55 +  0.72 +  1.73 +      
Brown  3.41 +  7.97 +  2.11 +  0.06 +      
Red    0.02 +  2.67 +  0.63 +  3.51 +      
Blond 26.31 + 45.65 +  3.56 +  0.02 = 112.3

df = 9  P-value = 0 

> 
> 
> 
> cleanEx(); ..nameEx <- "ci.examp"
> 
> ### * ci.examp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: ci.examp
> ### Title: Plot examples of Confidence Intervals
> ### Aliases: ci.examp run.ci.examp
> ### Keywords: hplot dynamic univar
> 
> ### ** Examples
> 
> ci.examp()
> ## Not run: 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)
> 
> 
> 
> cleanEx(); ..nameEx <- "clt.examp"
> 
> ### * clt.examp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: clt.examp
> ### Title: Plot Examples of the Central Limit Theorem
> ### Aliases: clt.examp
> ### Keywords: hplot distribution univar
> 
> ### ** Examples
> 
> clt.examp()
> clt.examp(5)
> clt.examp(30)
> clt.examp(50)
> 
> 
> 
> 
> cleanEx(); ..nameEx <- "cnvrt.coords"
> 
> ### * cnvrt.coords
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: cnvrt.coords
> ### Title: Convert between the 4 different coordinate sytems on a graphical
> ###   device
> ### Aliases: cnvrt.coords
> ### Keywords: dplot aplot
> 
> ### ** 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
> 
> 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)
> 
> 
> 
> ## The function is currently defined as
> function(x,y=NULL,input=c('usr','plt','fig','dev')) {
+ 
+   input <- match.arg(input)
+   xy <- xy.coords(x,y)
+   
+   cusr <- par('usr')
+   cplt <- par('plt')
+   cfig <- par('fig')
+   
+   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]
+ 
+     return( list( usr=usr, plt=plt, fig=fig, dev=dev ) )
+   }
+ 
+   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]
+ 
+     return( list( usr=usr, plt=plt, fig=fig, dev=dev ) )
+   }
+ 
+   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]
+     
+     return( list( usr=usr, plt=plt, fig=fig, dev=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]
+ 
+   return( list( usr=usr, plt=plt, fig=fig, dev=dev ) )
+ 
+   }
function (x, y = NULL, input = c("usr", "plt", "fig", "dev")) 
{
    input <- match.arg(input)
    xy <- xy.coords(x, y)
    cusr <- par("usr")
    cplt <- par("plt")
    cfig <- par("fig")
    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]
        return(list(usr = usr, plt = plt, fig = fig, dev = dev))
    }
    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]
        return(list(usr = usr, plt = plt, fig = fig, dev = dev))
    }
    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]
        return(list(usr = usr, plt = plt, fig = fig, dev = 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]
    return(list(usr = usr, plt = plt, fig = fig, dev = dev))
}
> 
> 
> 
> graphics::par(get("par.postscript", env = .CheckExEnv))
> cleanEx(); ..nameEx <- "coin.faces"
> 
> ### * coin.faces
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: coin.faces
> ### Title: Designs for coin faces for use with plot.rgl.coin
> ### Aliases: coin.faces
> ### Keywords: datasets
> 
> ### ** Examples
> 
> ## Not run: 
> ##D plot.rgl.coin(heads=coin.faces$H, tails=coin.faces$T)
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "dice"
> 
> ### * dice
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: dice
> ### Title: Simulate rolling dice
> ### Aliases: dice plot.dice panel.dice prepanel.dice
> ### Keywords: distribution hplot datagen
> 
> ### ** 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 ) )

 1  2  3  4  5  6 
27 28 16 12 11  6 
> mean(tmp)
Red 
2.7 
> 
> ## redo De Mere's question
> 
> demere1 <- dice(10000,4)
> demere2 <- dice(10000,24,sides=36)
> 
> mean(apply( demere1, 1, function(x) 6 %in% x ))
[1] 0.5188
> 
> mean(apply( demere2, 1, function(x) 36 %in% x))
[1] 0.4913
> 
> plot(demere1[1:10,])
> 
> ## plot all possible combinations of 2 dice
> 
> plot.dice( expand.grid(1:6,1:6), layout=c(6,6) )
> 
> 
> 
> cleanEx(); ..nameEx <- "dots"
> 
> ### * dots
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: dots
> ### Title: Create a quick dotchart (histogram)
> ### Aliases: dots dots2
> ### Keywords: hplot
> 
> ### ** Examples
> 
> 
> dots2( round( rnorm(20, 10,3) ), round(rnorm(20,12,2)) )
Warning: parameter "ticks" could not be set in high-level plot() function
> dots2( round( rnorm(20, 10,3) ), round(rnorm(20,12,2)) )
Warning: parameter "ticks" could not be set in high-level plot() function
> 
> 
> 
> 
> cleanEx(); ..nameEx <- "faces"
> 
> ### * faces
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: faces
> ### Title: Chernoff Faces
> ### Aliases: faces
> ### Keywords: hplot
> 
> ### ** Examples
> 
> ##---- Should be DIRECTLY executable !! ----
> ##-- ==>  Define data, use random,
> ##--    or do  help(data=index)  for the standard data sets.
> 
> 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")
> 
> ## The function is currently defined as
> function(xy=rbind(1:3,5:3,3:5,5:7),which.row,fill=FALSE,nrow,ncol,
+                 scale=TRUE,byrow=FALSE,main,labels){
+ 
+ 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))
+   }
+ 
+ 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
+   
+ 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
+   
+ 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))
+          
+   
+ for(ind in 1:n){
+   
+ factors<-xy[ind,] 
+ face <- face.orig
+   
+ 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]
+   
+ 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])
+   
+ 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]
+   
+ 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])
+      
+   
+ 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])
+   
+ 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})
+   
+ 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,]))
+ )
+ 
+ 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)
+   }
+   }
+ 
+ if(!missing(main)){
+   par(opar);par(mfrow=c(1,1))
+   mtext(main, 3, 3, TRUE, 0.5)
+   title(main)
+   }
+   }
function (xy = rbind(1:3, 5:3, 3:5, 5:7), which.row, fill = FALSE, 
    nrow, ncol, scale = TRUE, byrow = FALSE, main, labels) 
{
    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))
    }
    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
    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)), 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)), hair = rbind(hair1 = c(72, 
        12), hair2 = c(64, 50), c(36, 74), c(0, 79)))
    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
    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(0.7, 4))
    on.exit(par(opar))
    for (ind in 1:n) {
        factors <- xy[ind, ]
        face <- face.orig
        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]
        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])
        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]
        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])
        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])
        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
        })
        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, 
                ])))
        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)
        }
    }
    if (!missing(main)) {
        par(opar)
        par(mfrow = c(1, 1))
        mtext(main, 3, 3, TRUE, 0.5)
        title(main)
    }
}
> 
> 
> 
> graphics::par(get("par.postscript", env = .CheckExEnv))
> cleanEx(); ..nameEx <- "faces2"
> 
> ### * faces2
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: faces2
> ### Title: Chernoff Faces
> ### Aliases: faces2 face2.plot
> ### Keywords: hplot
> 
> ### ** Examples
> 
>   faces2(matrix( runif(18*10), nrow=10), main='Random Faces')
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
Warning: parameter "main" could not be set in high-level plot() function
> 
> 
> 
> cleanEx(); ..nameEx <- "hpd"
> 
> ### * hpd
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: hpd
> ### Title: Compute Highest Posterior Density Intervals
> ### Aliases: hpd emp.hpd
> ### Keywords: univar
> 
> ### ** Examples
> 
> 
> hpd(qbeta, shape1=50, shape2=250)
[1] 0.1253598 0.2092238
> 
> tmp <- rbeta(10000, 50, 250)
> emp.hpd(tmp)
[1] 0.1258773 0.2101818
> 
> 
> 
> 
> cleanEx(); ..nameEx <- "identify.Map"
> 
> ### * identify.Map
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: identify.Map
> ### Title: Identify polygons within a plotted map from the maptools
> ###   packages.
> ### Aliases: identify.Map identify.polylist
> ### Keywords: aplot iplot
> 
> ### ** Examples
> 
> ## Not run: 
> ##D library(maptools)
> ##D plot(state.vbm)
> ##D identify(state.vbm) # now click on the map a few times.
> ##D 
> ##D plot(state.vbm)
> ##D identify(state.vbm, state.abb, n=5)
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "lattice.demo"
> 
> ### * lattice.demo
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: lattice.demo
> ### Title: Interactively explore the conditioned panels in lattice plots.
> ### Aliases: lattice.demo
> ### Keywords: hplot dynamic
> 
> ### ** Examples
> 
> 
> ## Not run: 
> ##D require(stats)
> ##D lattice.demo(quakes$long, quakes$lat, quakes$depth)
> ## End(Not run)
> 
> 
> 
> 
> cleanEx(); ..nameEx <- "loess.demo"
> 
> ### * loess.demo
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: loess.demo
> ### Title: Demonstrate the internals of loess curve fits
> ### Aliases: loess.demo
> ### Keywords: hplot dynamic iplot
> 
> ### ** Examples
> 
> 
> ## Not run: 
> ##D data(ethanol, package='lattice')
> ##D attach(ethanol)
> ##D loess.demo(E, NOx)
> ##D # now click a few places, right click to end
> ##D loess.demo(E, NOx, span=1.5)
> ##D loess.demo(E, NOx, span=0.25)
> ##D loess.demo(E, NOx, degree=0)
> ##D loess.demo(E, NOx, degree=2)
> ##D detach()
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "mle.demo"
> 
> ### * mle.demo
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: mle.demo
> ### Title: Demonstrate the basic concept of Maximum Likelihood Estimation
> ### Aliases: mle.demo
> ### Keywords: iplot dynamic
> 
> ### ** Examples
> 
> 
> ## Not run: 
> ##D mle.demo()
> ##D 
> ##D m <- runif(1, 50,100)
> ##D s <- runif(1, 1, 10)
> ##D x <- rnorm(15, m, s)
> ##D 
> ##D mm <- mean(x)
> ##D ss <- sqrt(var(x))
> ##D ss2 <- sqrt(var(x)*11/12)
> ##D mle.demo(x)
> ##D # now find the mle from the graph and compare it to mm, ss, ss2, m, and s
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "plot.rgl.coin"
> 
> ### * plot.rgl.coin
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: plot.rgl.coin
> ### Title: Animated die roll or coin flip
> ### Aliases: plot.rgl.coin plot.rgl.die flip.rgl.coin roll.rgl.die
> ### Keywords: dynamic datagen distribution
> 
> ### ** Examples
> 
> ## Not run: 
> ##D plot.rgl.coin()
> ##D flip.rgl.coin()
> ##D flip.rgl.coin(1)
> ##D flip.rgl.coin(2)
> ##D 
> ##D rgl.clear()
> ##D 
> ##D # two-headed coin
> ##D plot.rgl.coin(tails=coin.faces$qh)
> ##D 
> ##D rgl.clear()
> ##D 
> ##D # letters instead of pictures
> ##D plot.rgl.coin(heads=coin.faces$H, tails=coin.faces$T)
> ##D 
> ##D # biased flip
> ##D flip.rgl.coin( sample(2,1, prob=c(0.65, 0.35) )
> ##D 
> ##D rgl.clear()
> ##D 
> ##D plot.rgl.die()
> ##D roll.rgl.die()
> ##D roll.rgl.die(6)
> ##D 
> ##D # biased roll
> ##D roll.rgl.die( sample(6,1, prob=c(1,2,3,3,2,1) ) )
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "power.examp"
> 
> ### * power.examp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: power.examp
> ### Title: Graphically illustrate the concept of power.
> ### Aliases: power.examp run.power.examp power.refresh
> ### Keywords: hplot dynamic univar htest
> 
> ### ** Examples
> 
> power.examp()
> power.examp(n=25)
> power.examp(alpha=0.1)
> 
> 
> 
> cleanEx(); ..nameEx <- "project.Map"
> 
> ### * project.Map
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: project.Map
> ### Title: Apply projections to Map objects (from maptools package)
> ### Aliases: project.Map
> ### Keywords: manip spatial
> 
> ### ** Examples
> 
> ## Not run: 
> ##D 
> ##D library(mapproj)
> ##D # assumes that the time zone shape files have been downloaded
> ##D # from: http://openmap.bbn.com/data/shape/timezone/
> ##D 
> ##D tz <- read.shape('WRLDTZA')
> ##D plot(project.Map(tz,'bonne',param=45))
> ##D plot(project.Map(tz,'albers',param=c(30,40)))
> ##D plot(project.Map(tz,'gnomonic',orient=c(0,-100,0)))
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "put.points.demo"
> 
> ### * put.points.demo
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: put.points.demo
> ### Title: Demonstrate Correlation and Regression by placing and moving
> ###   data points
> ### Aliases: put.points.demo
> ### Keywords: dynamic iplot regression
> 
> ### ** Examples
> 
> 
> ## Not run: 
> ##D put.points.demo()
> ##D 
> ##D x <- rnorm(25, 5, 1)
> ##D y <- x + rnorm(25)
> ##D put.points.demo(x,y)
> ## End(Not run)
> 
> 
> 
> 
> cleanEx(); ..nameEx <- "recenter.Map"
> 
> ### * recenter.Map
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: recenter.Map
> ### Title: Recenter a Map object from the maptools package.
> ### Aliases: recenter.Map
> ### Keywords: manip spatial
> 
> ### ** Examples
> 
> ## Not run: 
> ##D ## this assumes that the time zone shape files have been downloaded
> ##D ## from: http://openmap.bbn.com/data/shape/timezone/
> ##D ## and the US states map (st99_d00) files have been downloaded from
> ##D ## http://www.census.gov/geo/www/maps/
> ##D 
> ##D us <- read.shape('st99_d00')
> ##D tz <- read.shape('WRLDTZA')
> ##D plot(us)
> ##D plot(recenter.Map(us,-100))
> ##D plot(recenter.Map(tz,-165))
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "rgl.Map"
> 
> ### * rgl.Map
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: rgl.Map
> ### Title: Plot a map in an rgl window
> ### Aliases: rgl.Map
> ### Keywords: hplot dynamic
> 
> ### ** Examples
> 
> ## Not run: 
> ##D # assumes that the time zone shape files have been downloaded
> ##D # from: http://openmap.bbn.com/data/shape/timezone/
> ##D 
> ##D tz <- read.shape('WRLDTZA')
> ##D rgl.Map(tz)
> ##D rgl.spheres(0,0,0,.999, col='darkblue')
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "roc.demo"
> 
> ### * roc.demo
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: roc.demo
> ### Title: Demonstrate ROC curves by interactively building one
> ### Aliases: roc.demo
> ### Keywords: dynamic classif
> 
> ### ** Examples
> 
> 
> ## Not run: 
> ##D roc.demo()
> ##D with(CO2,
> ##D   roc.demo(uptake[Type=='Mississippi'],
> ##D            uptake[Type=='Quebec']       )
> ##D )
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "rotate.cloud"
> 
> ### * rotate.cloud
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: rotate.cloud
> ### Title: Interactively rotate 3D plots
> ### Aliases: rotate.cloud rotate.persp rotate.wireframe
> ### Keywords: dynamic hplot
> 
> ### ** Examples
> 
> 
> ## Not run: 
> ##D rotate.cloud(Sepal.Length ~ Petal.Length*Petal.Width, data=iris)
> ##D 
> ##D rotate.wireframe(volcano)
> ##D 
> ##D z <- 2 * volcano        # Exaggerate the relief
> ##D x <- 10 * (1:nrow(z))   # 10 meter spacing (S to N)
> ##D y <- 10 * (1:ncol(z))   # 10 meter spacing (E to W)
> ##D rotate.persp(x,y,z)
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "run.cor.examp"
> 
> ### * run.cor.examp
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: run.cor.examp
> ### Title: Interactively demonstrate correlations
> ### Aliases: run.cor.examp run.cor2.examp
> ### Keywords: dynamic
> 
> ### ** Examples
> 
> ## Not run: 
> ##D run.cor.examp()
> ##D run.cor2.examp()
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "run.hist.demo"
> 
> ### * run.hist.demo
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: run.hist.demo
> ### Title: Create a histogram and interactively change the number of bars.
> ### Aliases: run.hist.demo
> ### Keywords: dynamic hplot
> 
> ### ** Examples
> 
> ## Not run: 
> ##D run.hist.demo( rnorm(250, 100, 5) )
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "slider"
> 
> ### * slider
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: slider
> ### Title: slider / button control widgets
> ### Aliases: slider
> ### Keywords: dynamic iplot
> 
> ### ** Examples
> 
> 
> # example 1, sliders only
> ## Not run: 
> ##D ## This example cannot be run by examples() but should work in an interactive R session
> ##D plot.sample.norm<-function(){
> ##D  refresh.code<-function(...){
> ##D    mu<-slider(no=1); sd<-slider(no=1); n<-slider(no=3)
> ##D    x<-rnorm(n,mu,sd)
> ##D    plot(x)
> ##D  }
> ##D  slider(refresh.code,sl.names=c("value of mu","value of sd","n number of observations"),
> ##D        sl.mins=c(-10,.01,5),sl.maxs=c(+10,50,100),sl.deltas=c(.01,.01,1),sl.defaults=c(0,1,20))
> ##D }
> ##D plot.sample.norm()
> ## End(Not run)
> 
> # example 2, sliders and buttons
> ## Not run: 
> ##D ## This example cannot be run by examples() but should work in an interactive R session
> ##D plot.sample.norm.2<-function(){
> ##D  refresh.code<-function(...){
> ##D    mu<-slider(no=1); sd<-slider(no=2); n<-slider(no=3)
> ##D    type=  slider(obj.name="type")
> ##D    x<-rnorm(n,mu,sd)
> ##D    plot(seq(x),x,ylim=c(-20,20),type=type)
> ##D  }
> ##D  slider(refresh.code,sl.names=c("value of mu","value of sd","n number of observations"),
> ##D        sl.mins=c(-10,.01,5),sl.maxs=c(10,10,100),sl.deltas=c(.01,.01,1),sl.defaults=c(0,1,20),
> ##D        but.functions=list(
> ##D               function(...){slider(obj.name="type",obj.value="l");refresh.code()},
> ##D               function(...){slider(obj.name="type",obj.value="p");refresh.code()},
> ##D               function(...){slider(obj.name="type",obj.value="b");refresh.code()}
> ##D        ),
> ##D        but.names=c("lines","points","both"))
> ##D   slider(obj.name="type",obj.value="l")
> ##D }
> ##D plot.sample.norm.2()
> ## End(Not run)
> 
> # example 3, dependent sliders
> ## Not run: 
> ##D ## This example cannot be run by examples() but should work in an interactive R session
> ##D print.of.p.and.q<-function(){
> ##D  refresh.code<-function(...){
> ##D    p.old<-slider(obj.name="p.old")
> ##D    p<-slider(no=1); if(abs(p-p.old)>0.001) {slider(set.no.value=c(2,1-p))}
> ##D    q<-slider(no=2); if(abs(q-(1-p))>0.001) {slider(set.no.value=c(1,1-q))}
> ##D    slider(obj.name="p.old",obj.value=p)
> ##D    cat("p=",p,"q=",1-p,"\n")
> ##D  }
> ##D  slider(refresh.code,sl.names=c("value of p","value of q"),
> ##D        sl.mins=c(0,0),sl.maxs=c(1,1),sl.deltas=c(.01,.01),sl.defaults=c(.2,.8))
> ##D  slider(obj.name="p.old",obj.value=slider(no=1))
> ##D }
> ##D print.of.p.and.q()
> ## End(Not run)
> 
> # example 4, rotating a surface
> ## Not run: 
> ##D ## This example cannot be run by examples() but should work in an interactive R session
> ##D R.veil.in.the.wind<-function(){
> ##D   # Mark Hempelmann / Peter Wolf
> ##D   par(bg="blue4", col="white", col.main="white", 
> ##D       col.sub="white", font.sub=2, fg="white") # set colors and fonts
> ##D   samp  <- function(N,D) N*(1/4+D)/(1/4+D*N) 
> ##D   z<-outer(seq(1, 800, by=10), seq(.0025, 0.2, .0025)^2/1.96^2, samp) # create 3d matrix
> ##D   h<-100 
> ##D   z[10:70,20:25]<-z[10:70,20:25]+h; z[65:70,26:45]<-z[65:70,26:45]+h
> ##D   z[64:45,43:48]<-z[64:45,43:48]+h; z[44:39,26:45]<-z[44:39,26:45]+h
> ##D   x<-26:59; y<-11:38; zz<-outer(x,y,"+"); zz<-zz*(65<zz)*(zz<73)
> ##D   cz<-10+col(zz)[zz>0];rz<-25+row(zz)[zz>0]; z[cbind(cz,rz)]<-z[cbind(cz,rz)]+h
> ##D   refresh.code<-function(...){
> ##D     theta<-slider(no=1); phi<-slider(no=2)
> ##D     persp(x=seq(1,800,by=10),y=seq(.0025,0.2,.0025),z=z,theta=theta,phi=phi, 
> ##D           scale=T, shade=.9, box=F, ltheta = 45, 
> ##D           lphi = 45, col="aquamarine", border="NA",ticktype="detailed")   
> ##D   }
> ##D   slider(refresh.code, c("theta", "phi"), c(0, 0),c(360, 360),c(.2, .2),c(85, 270)  )
> ##D }
> ##D R.veil.in.the.wind()
> ## End(Not run)
> 
> ## The function is currently defined as
> 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){
+   # slider, version2, pw 040107
+   if(!missing(no)) return(as.numeric(tclvalue(get(paste("slider",no,sep=""),env=slider.env))))
+   if(!missing(set.no.value)){ try(eval(parse(text=paste("tclvalue(slider",set.no.value[1],")<-",
+                             set.no.value[2],sep="")),env=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,env=slider.env) else
+       obj.value<-get(obj.name,env=slider.env)
+     return(obj.value)
+   }
+   if(missing(title)) title<-"slider control widget"
+   require(tcltk); nt<-tktoplevel(); tkwm.title(nt,title); tkwm.geometry(nt,"+0+0")
+   if(missing(sl.names)) sl.names<-NULL
+   if(missing(sl.functions)) sl.functions<-function(...){}
+   for(i in seq(sl.names)){
+     eval(parse(text=paste("assign('slider",i,"',tclVar(sl.defaults[i]),env=slider.env)",sep="")))
+     tkpack(fr<-tkframe(nt));  lab<-tklabel(fr, text=sl.names[i], width="25")
+     sc<-tkscale(fr,from=sl.mins[i],to=sl.maxs[i],showvalue=T,resolution=sl.deltas[i],orient="horiz")
+     tkpack(lab,sc,side="right"); assign("sc",sc,env=slider.env)
+     eval(parse(text=paste("tkconfigure(sc,variable=slider",i,")",sep="")),env=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,env=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="")),env=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)
+ }
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) 
{
    if (!missing(no)) 
        return(as.numeric(tclvalue(get(paste("slider", no, sep = ""), 
            env = slider.env))))
    if (!missing(set.no.value)) {
        try(eval(parse(text = paste("tclvalue(slider", set.no.value[1], 
            ")<-", set.no.value[2], sep = "")), env = 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, env = slider.env)
        else obj.value <- get(obj.name, env = slider.env)
        return(obj.value)
    }
    if (missing(title)) 
        title <- "slider control widget"
    require(tcltk)
    nt <- tktoplevel()
    tkwm.title(nt, title)
    tkwm.geometry(nt, "+0+0")
    if (missing(sl.names)) 
        sl.names <- NULL
    if (missing(sl.functions)) 
        sl.functions <- function(...) {
        }
    for (i in seq(sl.names)) {
        eval(parse(text = paste("assign('slider", i, "',tclVar(sl.defaults[i]),env=slider.env)", 
            sep = "")))
        tkpack(fr <- tkframe(nt))
        lab <- tklabel(fr, text = sl.names[i], width = "25")
        sc <- tkscale(fr, from = sl.mins[i], to = sl.maxs[i], 
            showvalue = T, resolution = sl.deltas[i], orient = "horiz")
        tkpack(lab, sc, side = "right")
        assign("sc", sc, env = slider.env)
        eval(parse(text = paste("tkconfigure(sc,variable=slider", 
            i, ")", sep = "")), env = 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, env = 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 = "")), env = 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)
}
> 
> 
> 
> cleanEx(); ..nameEx <- "sliderv"
> 
> ### * sliderv
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: sliderv
> ### Title: Create a Tk slider window
> ### Aliases: sliderv
> ### Keywords: dynamic iplot
> 
> ### ** Examples
> 
> ## Not run: 
> ##D face.refresh <- function(...){
> ##D         vals <- sapply(1:15, function(x) slider(no=x))
> ##D         faces( rbind(0, vals, 1), scale=F)
> ##D }
> ##D 
> ##D sliderv( face.refresh, as.character(1:15), rep(0,15), rep(1,15), 
> ##D         rep(0.05, 15), rep(0.5,15), title='Face Demo')
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "state.vbm"
> 
> ### * state.vbm
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: state.vbm
> ### Title: Map object for the US State Visibility Based Map
> ### Aliases: state.vbm
> ### Keywords: datasets
> 
> ### ** Examples
> 
> library(maptools)
Loading required package: foreign
> data('state.vbm',package='TeachingDemos')
> plot(state.vbm)
> plot(state.vbm,auxvar=state.x77[,'Income'])
> 
> 
> 
> cleanEx(); ..nameEx <- "strip.shingle"
> 
> ### * strip.shingle
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: strip.shingle
> ### Title: strip function for trellis plots
> ### Aliases: strip.shingle
> ### Keywords: aplot hplot dplot
> 
> ### ** Examples
> 
> library(lattice)
> Depth <- equal.count(quakes$depth, number=8, overlap=.1)
> xyplot(lat ~ long | Depth, data = quakes, strip=strip.shingle)
> 
> 
> 
> cleanEx(); ..nameEx <- "tree.demo"
> 
> ### * tree.demo
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: tree.demo
> ### Title: Interactively demonstrate regression trees
> ### Aliases: tree.demo
> ### Keywords: dynamic models
> 
> ### ** Examples
> 
> ## Not run: 
> ##D data('ethanol', package='lattice')
> ##D print(with(ethanol, tree.demo(E,NOx)))
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "triplot"
> 
> ### * triplot
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: triplot
> ### Title: Create or add to a Trilinear Plot
> ### Aliases: triplot
> ### Keywords: hplot aplot
> 
> ### ** Examples
> 
> triplot(USArrests[c(1,4,2)])
> tmp <- triplot(USArrests[c(1,4,2)],txt=NULL)
> ## Not run:  identify(tmp, lab=rownames(USArrestes) ) 
> 
> 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))
> 
> 
> 
> cleanEx(); ..nameEx <- "vis.binom"
> 
> ### * vis.binom
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: vis.binom
> ### Title: Plot various distributions then interactivly adjust the
> ###   parameters.
> ### Aliases: vis.binom vis.gamma vis.normal vis.t
> ### Keywords: distribution hplot dynamic
> 
> ### ** Examples
> 
> ## Not run: 
> ##D vis.binom()
> ##D vis.normal()
> ##D vis.gamma()
> ##D vis.t()
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "vis.boxcox"
> 
> ### * vis.boxcox
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: vis.boxcox
> ### Title: Interactively visualize Box-Cox transformations
> ### Aliases: vis.boxcox vis.boxcoxu
> ### Keywords: dynamic univar regression
> 
> ### ** Examples
> 
> ## Not run: 
> ##D vis.boxcoxu()
> ##D vis.boxcox()
> ## End(Not run)
> 
> 
> 
> cleanEx(); ..nameEx <- "z.test"
> 
> ### * z.test
> 
> flush(stderr()); flush(stdout())
> 
> ### Name: z.test
> ### Title: Z test for known population standard deviation
> ### Aliases: z.test
> ### Keywords: htest
> 
> ### ** Examples
> 
> x <- rnorm(25, 100, 5)
> z.test(x, 99, 5)

	One Sample z-test

data:  x 
z = 1.8433, n = 25, Std. Dev. = 5, Std. Dev. of the sample mean = 1,
p-value = 0.06528
alternative hypothesis: true mean is not equal to 99 
95 percent confidence interval:
  98.88336 102.80329 
sample estimates:
mean of x 
 100.8433 

> 
> 
> 
> 
> ### * <FOOTER>
> ###
> cat("Time elapsed: ", proc.time() - get("ptime", env = .CheckExEnv),"\n")
Time elapsed:  18.2 0.66 19 0 0 
> grDevices::dev.off()
null device 
          1 
> ###
> ### Local variables: ***
> ### mode: outline-minor ***
> ### outline-regexp: "\\(> \\)?### [*]+" ***
> ### End: ***
> quit('no')