[R] R demos

[Peter Wolf]

Federico Calboli wrote:

>Hi All,
>
>I am currently preparing some form of slideshow introducing R and its
>capabilities for some colleagues. The thing will be about 30 mins, and
>I'd like to have some "pretty pictures" and some "amazing facts" (I'm
>trying to sell, obviously :)).
>
>Can I ask if it's possible to easily retrieve a gross figure of the
>number of functions in R considering the "base" install and all the
>libraries available?
>
>Apart from graphics and lattice, are there any more packages producing
>eye catching graphics (possibly with a survival analysis/epidemiological
>bend)?
>
>Cheers,
>
>Federico Calboli
>
>  
>
In the package relax you find the function slider().
The help page of slider shows a nice application: R.veil.in.the.wind()
Here are the definitions of slider and R.veil.in.the.wind:

# definition of slider
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)
{
    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")
    }
    invisible(nt)
}
# definition of R.veil.in.the.wind
 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)  )
     }


# now let's  test it!

R.veil.in.the.wind()