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. > ### *
> ### > 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("relax-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('relax') Loading required package: tcltk Loading Tcl/Tk interface ... done > > assign(".oldSearch", search(), env = .CheckExEnv) > assign(".oldNS", loadedNamespaces(), env = .CheckExEnv) > cleanEx(); ..nameEx <- "relax" > > ### * relax > > flush(stderr()); flush(stdout()) > > ### Name: relax > ### Title: R editor: relax > ### Aliases: relax > ### Keywords: documentation > > ### ** Examples > > > ## The function is currently defined as > function (workname.sys = "out.rev", no.plots = FALSE, cmds = "", but.Wizardry = TRUE){ + # nearly 5000 lines of R / Tcl/Tk code + } function (workname.sys = "out.rev", no.plots = FALSE, cmds = "", but.Wizardry = TRUE) { } > > > > 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 ##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 <- "tangleR" > > ### * tangleR > > flush(stderr()); flush(stdout()) > > ### Name: tangleR > ### Title: function to tangle a file > ### Aliases: tangleR > ### Keywords: file programming > > ### ** Examples > > ## Not run: > ##D ## This example cannot be run by examples() but should be work in an interactive R session > ##D tangleR("testfile.rev") > ## End(Not run) > "tangleR(\"testfile.rev\")" [1] "tangleR(\"testfile.rev\")" > ## The function is currently defined as > function(in.file,out.file,expand.roots=NULL,expand.root.start=TRUE){ + # german documentation of the code: + # look for file webR.pdf, P. Wolf 050204 + ... + } function (in.file, out.file, expand.roots = NULL, expand.root.start = TRUE) { ... } > > > > cleanEx(); ..nameEx <- "weaveR" > > ### * weaveR > > flush(stderr()); flush(stdout()) > > ### Name: weaveR > ### Title: function to weave a file > ### Aliases: weaveR > ### Keywords: file documentation programming > > ### ** Examples > > ## Not run: > ##D ## This example cannot be run by examples() but should be work in an interactive R session > ##D weaveR("testfile.rev","testfile.tex") > ##D weaveR("testfile.rev") > ## End(Not run) > ## The function is currently defined as > weaveR<-function(in.file,out.file){ + # german documentation of the code: + # look for file webR.pdf, P. Wolf 050204 + ... + } > > > > ### *