Nothing
.add.frame <- function(Tab,type,frame.name,argument.names="",arguments="",initial.values=c(),title="",border=FALSE,entry.width="2",argument.values=c(),argument.types=c(),from=c(),to=c(),by=c(),length=c(),select.multiple=FALSE,button.name="",button.function="",button.data="",arg.frames=c(),button.otherarg="",button.object="",button.width="12",button.data.transf="matrix",save=TRUE,show.save=TRUE,show=TRUE ,new.frames=new.frames){
# Entry Fields
if(type=="entryfields"){
new <- list(type=type,frame.name=frame.name,argument.names=argument.names,arguments=arguments,initial.values=initial.values,title=title,border=border,entry.width=entry.width,argument.types=argument.types)
new.frames[[Tab]][[length(new.frames[[Tab]])+1]] <- new
new.frames <- .order.button.frames(new.frames,Tab)
return(new.frames)
}
# Radio buttons
if(type=="radiobuttons"){
new <- list(type=type,frame.name=frame.name,argument.names=argument.names,arguments=arguments,initial.values=initial.values,title=title,border=border,argument.values=argument.values,argument.types=argument.types)
new.frames[[Tab]][[length(new.frames[[Tab]])+1]] <- new
new.frames <- .order.button.frames(new.frames,Tab) # Make sure the manual button frames are the last ones in the list .
return(new.frames)
}
# Check Boxes
if(type=="checkboxes"){
new <- list(type=type,frame.name=frame.name,argument.names=argument.names,arguments=arguments,initial.values=initial.values,title=title,border=border)
new.frames[[Tab]][[length(new.frames[[Tab]])+1]] <- new
new.frames <- .order.button.frames(new.frames,Tab)
return(new.frames)
}
# Slider Values
if(type=="valuesliders"){
new <- list(type=type,title=title,border=border,frame.name=frame.name,argument.names=argument.names,arguments=arguments,initial.values=initial.values,from=from,to=to,by=by,length=length)
new.frames[[Tab]][[length(new.frames[[Tab]])+1]] <- new
new.frames <- .order.button.frames(new.frames,Tab)
return(new.frames)
}
# Spin Boxes
if(type=="spinboxes"){
new <- list(type=type,frame.name=frame.name,argument.names=argument.names,arguments=arguments,initial.values=initial.values,from=from,to=to,by=by,entry.width=entry.width,title=title,border=border)
new.frames[[Tab]][[length(new.frames[[Tab]])+1]] <- new
new.frames <- .order.button.frames(new.frames,Tab)
return(new.frames)
}
# List Boxes
if(type=="listbox"){
new <- list(type=type,frame.name=frame.name,argument.names=argument.names,arguments=arguments,argument.values=argument.values,argument.types=argument.types,initial.values=initial.values,length=length,select.multiple=select.multiple,title=title,border=border)
new.frames[[Tab]][[length(new.frames[[Tab]])+1]] <- new
new.frames <- .order.button.frames(new.frames,Tab)
return(new.frames)
}
# Manual Buttons
if(type=="buttons"){
new <- list(frame.name=frame.name,type=type,button.name=button.name,button.function=button.function,button.data=button.data,button.otherarg=button.otherarg,arg.frames=arg.frames,button.object=button.object,title="",border=FALSE,save=save,show=show,show.save=show.save,button.width=button.width,button.data.transf=button.data.transf)
new.frames[[Tab]][[length(new.frames[[Tab]])+1]] <- new
new.frames <- .order.button.frames(new.frames,Tab)
return(new.frames)
}
}
.order.button.frames <- function(new.frames,Tab){
boolean <- sapply(new.frames[[Tab]],FUN=function(x){x$type=="buttons"})
new.frames[[Tab]] <- new.frames[[Tab]][order(boolean)]
return(new.frames)
}
#.as.var <- function(x){ return(eval.parent( as.name(x) ,n=1))}
.find.frame <- function(x,frame.name){
temp.names <- (lapply(x,FUN=function(d){return(d$frame.name)}))
find.boolean <- temp.names==frame.name
if(sum(find.boolean)==1){
return(which(find.boolean))
}
else if(sum(find.boolean)>1){
stop(paste("'",frame.name,"' is used for multiple frames!",sep=""),call.=FALSE)
}
else{
stop(paste("'",frame.name,"' is not recognised as a framename. Check your 'grid.config' matrix.",sep=""),call.=FALSE)
}
}
.eval.command <- function(x){return(eval.parent(parse(text=x),n=1))}
.combine.rows <- function(Tab,rows,title,border,grid.rows,grid.config){
all.grid.rows <- grid.rows
all.grid.config <- grid.config
eval(parse(text=paste("grid.rows <- all.grid.rows[[",Tab,"]]",sep="")))
eval(parse(text=paste("grid.config <- all.grid.config[[",Tab,"]]",sep="")))
# The names of the frames involved in this combined row are extracted. This information is needed in the template function.
name.frames <- as.vector(grid.config[rows,])
name.frames <- name.frames[!is.na(name.frames)]
new <- list(rows=rows,title=title,border=border,name.frames=name.frames)
grid.rows[[length(grid.rows)+1]] <- new
# In order to keep the grid.rows object correct. Sort the list, based on the rows inside an element:
# This will ensure making a correct grid, even if the rows were combined like first 3 & 4, then 1 & 2
grid.rows <- grid.rows[order( unlist(lapply(grid.rows,FUN=function(x){return(min(x$rows))})) )]
eval(parse(text=paste("all.grid.rows[[",Tab,"]] <- grid.rows",sep="")))
return(all.grid.rows)
}
.make.correct.frame <- function(title,border,window){
if(title!="" & border==TRUE){
return(ttklabelframe(window,text=gettextRcmdr(title)))
}
else{
if(border==TRUE){relief<-"groove"} else {relief <- "flat"}
return(tkframe(window,relief=relief,borderwidth=2))
}
}
.initialize.new.frames <- function(ntabs){
new.frames <- list()
for(i in 1:ntabs){
new.frames[[i]] <- list()
}
return(new.frames)
}
.initialize.grid.config <- function(ntabs){
grid.config <- list()
for(i in 1:ntabs){
grid.config[[i]] <- list()
}
return(grid.config)
}
.initialize.grid.rows <- function(ntabs){
grid.rows <- list()
for(i in 1:ntabs){
grid.rows[[i]] <- list()
}
return(grid.rows)
}
.grid.matrix <- function(Tab,data,grid.config=grid.config,...){
temp <- matrix(data=data,...)
grid.config[[Tab]] <- temp
return(grid.config)
}
.build.command.argument <- function(current.frame,command){
if(current.frame$type=="entryfields"){
number.entries <- length(current.frame$arguments)
arguments <- current.frame$arguments
for(j in 1:number.entries){
if(current.frame$argument.types[j]=="num"){
add.command <- if(tclvalue(current.frame$entry.vars[[j]])==""){""} else {paste(",",arguments[j],"=",tclvalue(current.frame$entry.vars[[j]]),sep="")}
}
if(current.frame$argument.types[j]=="char"){
add.command <- if(tclvalue(current.frame$entry.vars[[j]])==""){""} else {paste(",",arguments[j],"='",tclvalue(current.frame$entry.vars[[j]]),"'",sep="")}
}
command <- paste(command,add.command,sep="")
}
return(command)
}
if(current.frame$type=="radiobuttons"){
temp <- (tclvalue(current.frame$radioVar))
if(grepl("BUTTONSTART",temp,fixed=TRUE)){
temp <- gsub("BUTTONSTART","",temp,fixed=TRUE)
}
if(current.frame$argument.types=="char"){
add.command <- paste( ",",current.frame$arguments,"='",temp,"'",sep="" )
}
if(current.frame$argument.types=="num"){
add.command <- paste( ",",current.frame$arguments,"=",temp,sep="" )
}
command <- paste(command,add.command,sep="")
return(command)
}
if(current.frame$type=="checkboxes"){
number.checks <- length(current.frame$arguments)
arguments <- current.frame$arguments
for(j in 1:number.checks){
# temp.command <- paste("temp.var <- as.character(tclvalue(",arguments[[j]],"Variable))" ,sep="")
# .eval.command(temp.command)
temp.var <- as.character(tclvalue(current.frame$checkVar[[j]]))
if(temp.var=="1"){check.var <- TRUE} else {check.var <- FALSE}
add.command <- paste(",",arguments[j],"=",check.var,sep="")
command <- paste(command,add.command,sep="")
}
return(command)
}
if(current.frame$type=="valuesliders"){
number.sliders <- length(current.frame$arguments)
arguments <- current.frame$arguments
for(j in 1:number.sliders){
add.command <- paste(",",arguments[j],"=",tclvalue(current.frame$slider.vars[[j]]),sep="")
command <- paste(command,add.command,sep="")
}
return(command)
}
if(current.frame$type=="spinboxes"){
number.spins <- length(current.frame$arguments)
arguments <- current.frame$arguments
for(j in 1:number.spins){
add.command <- paste(",",arguments[j],"=",tclvalue(current.frame$spin.vars[[j]]),sep="")
command <- paste(command,add.command,sep="")
}
return(command)
}
if(current.frame$type=="listbox"){
sel <- as.integer(tkcurselection(current.frame$listBox))+1
command <- paste0(command,",",current.frame$arguments,"=")
if(current.frame$select.multiple==TRUE){
add.command <- paste0("c(")
if(current.frame$argument.types=="char"){chartype <- TRUE}else{chartype <- FALSE}
for(i.sel in sel){
if(chartype){
add.command <- paste0(add.command,"'",current.frame$argument.values[i.sel],"'")
}
else{
add.command <- paste0(add.command,current.frame$argument.values[i.sel])
}
if(!(i.sel==sel[length(sel)])){add.command <- paste0(add.command,",")}
}
add.command <- paste0(add.command,")")
}
else{
if(current.frame$argument.types=="char"){
add.command <- paste0("'",current.frame$argument.values[sel],"'")
}
else{
add.command <- paste0(current.frame$argument.values[sel])
}
}
command <- paste0(command,add.command)
}
}
.transform.vector2text <- function(x){
if(length(x)==0){return("c()")}
out <- "c("
for(i.arg in 1:length(x)){
out <- paste(out,"'",x[i.arg],"'",sep="")
if(i.arg!=length(x)){out <- paste(out,",",sep="")}
}
out <- paste(out,")",sep="")
return(out)
}
.build.button.function <- function(function.command,arg.names,button_result,new.frames,save,Tab){
for(i.frame in arg.names){
boolean <- sapply(new.frames[[Tab]],FUN=function(x){x$frame.name==i.frame})
temp.index <- which(boolean==TRUE)
if(sum(boolean) ==0){stop(paste("'",i.frame,"' is not defined in 'new.frames' object",sep=""))}
if(sum(boolean)>1){stop(paste("'",i.frame,"' is defined multiple times in 'new.frames' object",sep=""))}
if(sum(boolean)==1){
current.arg.frame <- new.frames[[Tab]][[temp.index]]
function.command <- .build.command.argument(current.arg.frame,function.command)
}
}
function.command <- paste(function.command,")" ,sep="")
function.command <- gsub("\\(,","\\(",function.command) # Fixing the case when no data or otherarg is used (function(,x=1))
if(save==TRUE){function.command <- paste(button_result," <- ",function.command,sep="")}
return(function.command)
}
.give.doublequote <- function(x){return(paste("\"",x,"\"",sep=""))}
.Setwd <- function (x=TRUE)
{
wd <- tclvalue(tkchooseDirectory(initialdir = getwd(), parent = CommanderWindow()))
if (wd != "")
doItAndPrint(paste("setwd(\"", wd, "\")", sep = ""))
}
.rcmdr.warning <- function(x){
warning.command <- paste("warning('",x,"',call.=FALSE)",sep="")
justDoIt(warning.command)
}
SaveGUI <- function(object.names,init.name="result"){
#object.names = vector of names of the objects which should be saved
init.name <- paste0(init.name,".RData")
filenameLoc <- tclvalue(tkgetSaveFile(initialfile=init.name,filetypes="{{RData Files} {.RData .rda}} {{All files} *}"))
save.command <- paste0("save(list=",deparse(object.names),",file='",filenameLoc,"')")
doItAndPrint(save.command)
}
LoadGUI <- function(){
fileNameLoc <- tclvalue(tkgetOpenFile(filetypes="{{RData Files} {.RData .rda}} {{All files} *}"))
load.command <- paste0("load('",fileNameLoc,"')")
doItAndPrint(load.command)
}
.updateEnvirObject <- function(name,ENVIR){
if(is.null(.GetEnvREST("GUI_envir"))){
GUI_envir <- list()
.AssignEnvREST("GUI_envir",GUI_envir)
}
GUI_envir <- .GetEnvREST("GUI_envir")
if(name %in% names(GUI_envir)){
index.env <- which(name==names(GUI_envir))
temp.env <- GUI_envir[[index.env]]
rm(list=ls(temp.env),envir=temp.env)
}
else{
index.env <- length(GUI_envir)+1
}
GUI_envir[[index.env]] <- ENVIR
names(GUI_envir)[index.env] <- name
.AssignEnvREST("GUI_envir",GUI_envir)
}
.EnvREST <- new.env()
.GetEnvREST <- function(x){
if(!exists(x,envir=.EnvREST,inherits=FALSE)){
return(NULL)
}
else{
return(get(x=x,envir=.EnvREST,inherits=FALSE))
}
}
.AssignEnvREST <- function(x,value){
assign(x=x,value=value,envir=.EnvREST)
}
GetWindowsENVIR <- function(){
return(.GetEnvREST("GUI_envir"))
}
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.