slider: slider / button control widgets

Description

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)

Arguments

sl.functions

set of functions or function connected to the slider(s)

sl.names

labels of the sliders

sl.mins

minimum values of the sliders' ranges

sl.maxs

maximum values of the sliders' ranges

sl.deltas

change of step per click

sl.defaults

default values for the sliders

but.functions

function or list of functions that are assigned to the button(s)

but.names

labels of the buttons

slider(no=i) requests slider i

set.no.value

slider(set.no.value=c(i,val)) sets slider i to value val

obj.name

slider(obj.name=name) requests the value of variable name from environment slider.env

obj.value

slider(obj.name=name,obj.value=value) assigns value to variable name in environment slider.env

reset.function

function that comprises the commands of the reset.button

title

title of the control window

Value

Using slider in definition mode slider returns the value of new created the top level widget. slider(no=i) returns the actual value of slider i. slider(obj.name=name) returns the value of variable name in environment slider.env.

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 slider.env. Slider function management takes place in the environment slider.env. If 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: sl.functions, sl.names, sl.minima, sl.maxima,sl.deltas, and sl.defaults. The first argument, 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 sl.functions[[2]] (or in case of one function for all sliders the function sl.functions) is called.}

Definition{... of buttons: Buttons are defined by a vector of labels but.names and a list of functions: but.functions. If button i is pressed the function stored in but.functions[[i]] is called.}

Requesting{... a slider: slider(no=1) returns the actual value of slider 1, slider(no=2) returns the value of slider 2, etc. You are allowed to include expressions of the type slider(no=i) in functions describing the effect of sliders or buttons.}

Setting{... a slider: slider(set.no.value=c(2,333)) sets slider 2 to value 333. 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 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 p and another one to control q, but they should satisfy: 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 slider.env. Use slider(obj.name="p.save",obj.value=1-slider(no=2)) to assign value 1-slider(no=2) to the variable p.save . slider(obj.name=p.save) returns the value of variable p.save.}

Examples

Run this code

# example 1, sliders only
## 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
## 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
## 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
## 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()


## 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)
}