Nothing
################################
#
# misc user dialog functions
#
################################
################################
# Function to choose the number of axes
################################
"chooseaxes" <- function(eig, rank1)
{
tf <- tktoplevel()
tkwm.title(tf,"Number of axes")
done <- tclVar(0)
nfvar <- tclVar()
nf <- 0
"getnf" <- function()
{
if (tclvalue(nfvar) != "") {
nf <<- parse(text=tclvalue(nfvar))[[1]]
} else nf <<- 2
tkdestroy(tf)
return(nf)
}
plotEig(eig[1:rank1], col.plot="grey", paxes.draw=TRUE, paxes.x.draw=FALSE)
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
nf.entry <- tkentry(frame1, textvariable=nfvar)
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function() getnf())
tkgrid(tklabel(frame1,text="Select the number of axes : "), nf.entry)
tkgrid(submit.but)
tkpack(frame1, fill = "x")
#tkconfigure(nf.entry, state="disabled")
tkbind(tf, "<Destroy>", function() tclvalue(done) <- 2)
tkbind(tf, "<KeyPress-Return>", function() getnf())
tkfocus(nf.entry)
tkwait.variable(done)
if(tclvalue(done) == "2") return(nf)
tkdestroy(tf)
}
################################
# Function to choose the dataframe : builds a listbox containing the dataframes
# that are in the global environment and allows the user to choose one
################################
"choosedf" <- function(df.entry, dfnr.label, dfnc.label)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose dataframe")
done <- tclVar(0)
vnr <- NULL
vnc <- NULL
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dataframe
# or a list. If it is a data frame, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.data.frame(xobj)) {
tkinsert(tlb, "end", x1)
cbind(nrow(xobj),ncol(xobj))
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.data.frame(sobj)) {
tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
fn2 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.data.frame(sobj)) {
cbind(nrow(sobj), ncol(sobj))
}
}
res <- sapply(names(xobj), fn2)
return(res)
}
}
}
v <- unlist(lapply(obj, flb))
if (length(v) > 0) {
vnr <- v[seq(from=1,to=length(v),by=2)]
vnc <- v[seq(from=2,to=length(v),by=2)]
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dataframe text entry
#
tkdelete(df.entry, 0, "end")
tkinsert(df.entry, "end", choix)
#
# Put the row and column numbers of the dataframe in the corresponding labels
#
tkconfigure(dfnr.label, text=as.character(vnr[numi]))
tkconfigure(dfnc.label, text=as.character(vnc[numi]))
tkdestroy(tf)
}
################################
# Function to choose the spatial object (contour or area) : builds a listbox containing the contours
# that are in the global environment and allows the user to choose one
################################
"choosesp" <- function(sp.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose sp")
done <- tclVar(0)
vnr <- NULL
vnc <- NULL
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...) tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function() tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function() tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dataframe
# or a list. If it is a data frame, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.data.frame(xobj) && ((ncol(xobj) == 3) | (ncol(xobj) == 4))) {
tkinsert(tlb, "end", x1)
cbind(nrow(xobj),ncol(xobj))
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.data.frame(sobj) && ((ncol(sobj) == 3) | (ncol(sobj) == 4))) {
tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
fn2 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.data.frame(sobj) && ((ncol(sobj) == 3) | (ncol(sobj) == 4))) {
cbind(nrow(sobj), ncol(sobj))
}
}
res <- sapply(names(xobj), fn2)
return(res)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dataframe text entry
#
tkdelete(sp.entry, 0, "end")
tkinsert(sp.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose the pixmap : builds a listbox containing the pixmaps
# that are in the global environment and allows the user to choose one
################################
"choosepm" <- function(pm.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose pixmap")
done <- tclVar(0)
vnr <- NULL
vnc <- NULL
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dataframe
# or a list. If it is a data frame, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (class(xobj) == "pixmapIndexed") {
tkinsert(tlb, "end", x1)
cbind(nrow(xobj),ncol(xobj))
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (class(xobj) == "pixmapIndexed") {
tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
fn2 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (class(xobj) == "pixmapIndexed") {
cbind(nrow(sobj), ncol(sobj))
}
}
res <- sapply(names(xobj), fn2)
return(res)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dataframe text entry
#
tkdelete(pm.entry, 0, "end")
tkinsert(pm.entry, "end", choix)
#
# Put the row and column numbers of the dataframe in the corresponding labels
#
#tkconfigure(dfnr.label, text=as.character(vnr[numi]))
#tkconfigure(dfnc.label, text=as.character(vnc[numi]))
tkdestroy(tf)
}
################################
# Function to choose a distance matrix : builds a listbox containing the dist mat
# that are in the global environment and allows the user to choose one
################################
"choosedist" <- function(df.entry, dfnr.label, dfnc.label)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose distance matrix")
done <- tclVar(0)
vnr <- NULL
vnc <- NULL
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dist mat
# or a list. If it is a dist mat, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (inherits(xobj, "dist")) {
tkinsert(tlb, "end", x1)
cbind(attributes(xobj)$Size,attributes(xobj)$Size)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (inherits(sobj, "dist")) {
tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
fn2 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (inherits(sobj, "dist")) {
cbind(attributes(sobj)$Size,attributes(sobj)$Size)
}
}
res <- sapply(names(xobj), fn2)
return(res)
}
}
}
v <- unlist(lapply(obj, flb))
vnr <- v[seq(from=1,to=length(v),by=2)]
vnc <- v[seq(from=2,to=length(v),by=2)]
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dist mat text entry
#
tkdelete(df.entry, 0, "end")
tkinsert(df.entry, "end", choix)
#
# Put the row and column numbers of the dist mat in the corresponding labels
#
tkconfigure(dfnr.label, text=as.character(vnr[numi]))
tkconfigure(dfnc.label, text=as.character(vnc[numi]))
tkdestroy(tf)
}
################################
# Function to choose a neighbouring : builds a listbox containing the neighbouring
# that are in the global environment and allows the user to choose one
################################
"chooseneig" <- function(neig.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose neighbouring")
done <- tclVar(0)
vnr <- NULL
vnc <- NULL
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a neighbouring
# or a list. If it is a dist mat, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (inherits(xobj, "neig")) {
tkinsert(tlb, "end", x1)
cbind(attributes(xobj)$Size,attributes(xobj)$Size)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (inherits(sobj, "neig")) {
tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
fn2 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (inherits(sobj, "neig")) {
cbind(attributes(sobj)$Size,attributes(sobj)$Size)
}
}
res <- sapply(names(xobj), fn2)
return(res)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the neig text entry
#
tkdelete(neig.entry, 0, "end")
tkinsert(neig.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose a vector of numerics : builds a listbox containing the numeric vectors
# that are in the global environment and allows the user to choose one
################################
"chooseval" <- function(tt, dfnr.label, rw.entry, urwvar)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose values")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
nbr <- tclvalue(tkcget(dfnr.label, "-text"))
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a vector
# or a list. If it is a dist mat, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.vector(xobj) && identical(class(xobj), "numeric")) {
if (length(xobj) == nbr) tkinsert(tlb, "end", x1)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.vector(sobj) && identical(class(sobj), "numeric")) {
if (length(sobj) == nbr) tkinsert(tlb, "end", sobjn)
} else if (is.data.frame(sobj)) {
if (nrow(sobj) == nbr)
tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(rw.entry, 0, "end")
tkinsert(rw.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose a vector of labels : builds a listbox containing the label vectors
# that are in the global environment and allows the user to choose one
################################
"chooselab" <- function(tt, dfnr.label, rw.entry, urwvar)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose labels")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
nbr <- tclvalue(tkcget(dfnr.label, "-text"))
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a vector
# or a list. If it is a dist mat, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.vector(xobj) && identical(class(xobj), "character")) {
if (length(xobj) == nbr) tkinsert(tlb, "end", x1)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.vector(sobj) && identical(class(sobj), "character")) {
if (length(sobj) == nbr) tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(rw.entry, 0, "end")
tkinsert(rw.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose row weights
################################
"chooserw" <- function(tt, dfnr.label, rw.entry, urwvar)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose row weights")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
nbr <- tclvalue(tkcget(dfnr.label, "-text"))
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a vector
# or a list. If it is a dist mat, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.vector(xobj) && identical(class(xobj), "numeric")) {
if (length(xobj) == nbr) tkinsert(tlb, "end", x1)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.vector(sobj) && identical(class(sobj), "numeric")) {
if (length(sobj) == nbr) tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(rw.entry, 0, "end")
tkinsert(rw.entry, "end", choix)
tclvalue(urwvar)<-"0"
urwvar <- tclVar(0)
rwl.cbut <- tkcheckbutton(tt,text="Uniform row weights", variable=urwvar)
tkdestroy(tf)
}
################################
# Function to choose column weights
################################
"choosecw" <- function(tt, dfnc.label, cw.entry, ucwvar)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose column weights")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
nbc <- tclvalue(tkcget(dfnc.label, "-text"))
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a vector
# or a list. If it is a dist mat, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.vector(xobj) && identical(class(xobj), "numeric")) {
if (length(xobj) == nbc) tkinsert(tlb, "end", x1)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.vector(sobj) && identical(class(sobj), "numeric")) {
if (length(sobj) == nbc) tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(cw.entry, 0, "end")
tkinsert(cw.entry, "end", choix)
tclvalue(ucwvar)<-"0"
tkcheckbutton(tt,text="Uniform row weights", variable=ucwvar)
tkdestroy(tf)
}
################################
# Function to choose a data set in the ade4 package
################################
"choosepackage" <- function(show, history)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose ade4 data set")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
lade4 <- data(package="ade4", envir=env_ade4tkgui)
for (i in seq(1, length(lade4$result)/4)) {
dsname <- lade4$result[i,3]
tkinsert(tlb, "end", dsname)
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tlb, "<Button-3>", function() if (tclvalue(tkcurselection(tlb)) != "") print(help(tclvalue(tkget(tlb, tclvalue(tkcurselection(tlb)))))))
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
data(list=choix, envir=env_ade4tkgui)
if (show) {
pr1 <- substr(options("prompt")$prompt, 1,2)
cat("data(", choix, ")\n", pr1, sep="")
}
if (history)
rewriteHistory(paste("data(", choix, ")", sep=""))
tkdestroy(tf)
q <- tkmessageBox(icon="info", title="Data set loaded", type="ok", message=paste("The \"",choix,"\" data set has been successfully loaded.", sep=""))
}
################################
# Function to choose a text file
################################
"readtable" <- function(show, history)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose a text file")
done <- tclVar(0)
typesvar <- tclVar()
tabnamevar <- tclVar("")
filenamevar <- tclVar("clipboard")
fictrt <- tclVar()
varnames <- tclVar(1)
sepVar <- tclVar(1)
otherSepVar <- tclVar("")
decSepVar <- tclVar(1)
colClassVar <- tclVar(4)
"choosefile" <- function()
{
tclvalue(typesvar)="{{Text files} {.txt}}"
fictrt <- tkgetOpenFile(filetypes=tclvalue(typesvar))
fpath <- tclvalue(fictrt)
tkdelete(file.entry, 0, "end")
tkinsert(file.entry, "end", fpath)
}
"choosefic" <- function(show, history)
{
if (tclvalue(tabnamevar) != "") {
tabname <- parse(text=tclvalue(tabnamevar))[[1]]
} else tabname <- "untitled"
if (tclvalue(filenamevar) != "") {
filename <- tclvalue(filenamevar)
} else return()
varn <- as.logical(tclObj(varnames))
sep <- tclvalue(sepVar)
if (sep == 1) sepch <- ""
if (sep == 2) sepch <- ","
if (sep == 3) sepch <- ";"
if (sep == 4) {
if (tclvalue(otherSepVar) != "") {
otherSep <- tclvalue(otherSepVar)
} else otherSep <- ""
sepch <- otherSep
}
decSep <- tclvalue(decSepVar)
if (decSep == 1) decsepch <- "."
if (decSep == 2) decsepch <- ","
colClass <- tclvalue(colClassVar)
if (colClass == 1) colClass <- "numeric"
if (colClass == 2) colClass <- "character"
if (colClass == 3) colClass <- "factor"
if (colClass == 4) colClass <- "auto"
if (colClass == "auto") {
rdcom <- paste(tabname," <<- read.table(file='", filename, "', header=",varn,
", sep='",sepch,"', dec='",decsepch,"')", sep="")
} else {
rdcom <- paste(tabname," <<- read.table(file='", filename, "', header=",varn,
", sep='",sepch,"', dec='",decsepch,"', colClasses='",colClass,"')", sep="")
}
if (show) {
pr1 <- substr(options("prompt")$prompt, 1,2)
cat(rdcom, "\n", pr1, sep="")
}
if (history) rewriteHistory(rdcom)
eval(parse(text=rdcom))
tkdestroy(tf)
eval(parse(text=paste("edit(", tabname, ")", sep="")))
}
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
labh <- tklabel(frame1, bitmap="questhead")
tkbind(labh, "<Button-1>", function() print(help("read.table")))
tkgrid(tklabel(frame1,text="Read text file", font="Times 18", foreground="red"), labh, columnspan=2)
tkpack(frame1, fill = "x")
frame2 <- tkframe(tf, relief="groove", borderwidth=2)
tab.entry <- tkentry(frame2, textvariable=tabnamevar)
file.entry <- tkentry(frame2, textvariable=filenamevar)
choosefile.but <- tkbutton(frame2, text="Set", command=function() choosefile())
tkgrid(tklabel(frame2,text="Text file to read : "), file.entry, choosefile.but)
tkgrid(tklabel(frame2,text="Dataframe to receive the data : "), tab.entry)
varnames.cbut <- tkcheckbutton(frame2,text="Variables names on the first row of data file", variable=varnames)
tkgrid(varnames.cbut, columnspan=2, sticky="w")
sepFrame <- tkframe(frame2, relief="groove", borderwidth=2)
sep.entry <- tkentry(sepFrame, textvariable=otherSepVar, width=10)
tkgrid(tklabel(sepFrame, text="Field separator:", foreground="blue"))
tkgrid(tkradiobutton(sepFrame, text="Default", value=1, variable=sepVar), sticky="w")
tkgrid(tkradiobutton(sepFrame, text="Commas", value=2, variable=sepVar), sticky="w")
tkgrid(tkradiobutton(sepFrame, text="Semicolon", value=3, variable=sepVar), sticky="w")
tkgrid(tkradiobutton(sepFrame, text="Other", value=4, variable=sepVar), sep.entry, sticky="w")
decSepFrame <- tkframe(frame2, relief="groove", borderwidth=2)
tkgrid(tklabel(decSepFrame, text="Decimal separator:", foreground="blue"))
tkgrid(tkradiobutton(decSepFrame, text="Period [.]", value=1, variable=decSepVar), sticky="w")
tkgrid(tkradiobutton(decSepFrame, text="Comma [,]", value=2, variable=decSepVar), sticky="w")
colClassFrame <- tkframe(frame2, relief="groove", borderwidth=2)
tkgrid(tklabel(colClassFrame, text="Column types:", foreground="blue"))
tkgrid(tkradiobutton(colClassFrame, text="Default", value=4, variable=colClassVar), sticky="w")
tkgrid(tkradiobutton(colClassFrame, text="Numeric", value=1, variable=colClassVar), sticky="w")
tkgrid(tkradiobutton(colClassFrame, text="Character", value=2, variable=colClassVar), sticky="w")
tkgrid(tkradiobutton(colClassFrame, text="Factor", value=3, variable=colClassVar), sticky="w")
tkgrid(sepFrame, decSepFrame, colClassFrame, sticky="n")
tkpack(frame2, fill = "x")
ok.but <- tkbutton(tf, text="Submit", command=function() choosefic(show, history))
cancel.but <- tkbutton(tf, text="Dismiss", command=function() tkdestroy(tf))
tkpack(cancel.but, ok.but, side="left", fill="x", expand=1)
tkbind(tf, "<Destroy>", function() tclvalue(done) <- 2)
tkbind(tf, "<KeyPress-Return>", function() choosefic(show, history))
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done) == "2")
return(0)
tkdestroy(tf)
}
################################
# Function to display a text file
################################
"displaytable" <- function(tabname)
{
tt <- tktoplevel()
tkwm.title(tt, "Dataframe display")
txt <- tktext(tt, bg="white", font="courier")
scr <- tkscrollbar(tt, repeatinterval=5, command=function(...)tkyview(txt,...))
## Safest to make sure scr exists before setting yscrollcommand
tkconfigure(txt, yscrollcommand=function(...)tkset(scr,...))
tkpack(txt, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
sink(conn <- file("Rlisting001.tmp", open="w"))
cheval <- paste(tabname,"[1:min(20,nrow(", tabname, ")), 1:min(5,ncol(", tabname, "))]", sep="")
cat("First rows and columns of dataframe:\n")
print(eval(parse(text=cheval)))
sink()
close(conn)
chn <- tclopen(file.path("Rlisting001.tmp"))
tkinsert(txt, "end", tclread(chn))
tclclose(chn)
system("rm Rlisting001.tmp")
tkconfigure(txt, state="disabled")
tkmark.set(txt,"insert","0.0")
tkfocus(txt)
}
################################
# dialog box to display a dudi
################################
"dudisp" <- function(show, history)
{
tf <- tktoplevel()
tkwm.title(tf,"Dudi display")
"calldisp" <- function(show, history)
{
dialog.dudi.display(show, history, tclvalue(dudivar))
if (show) {
pr1 <- substr(options("prompt")$prompt, 1,2)
cat(paste("dialog.dudi.display(", show, ",", history, ",eval(expression(", dQuote(tclvalue(dudivar)), ")))", sep=""), "\n", pr1, sep="")
}
if (history)
rewriteHistory(paste("dialog.dudi.display(", show, ",", history, ",eval(expression(", dQuote(tclvalue(dudivar)), ")))", sep=""))
tkdestroy(tf)
}
done <- tclVar(0)
dudivar <- tclVar()
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
labh <- tklabel(frame1, bitmap="questhead")
tkbind(labh, "<Button-1>", function() print(help("dudi")))
tkgrid(tklabel(frame1,text="Dudi display", font="Times 18", foreground="red"), labh, columnspan=2)
tkpack(frame1, fill = "x")
frame2 <- tkframe(tf, relief="groove", borderwidth=2)
dudi.entry <- tkentry(frame2, textvariable=dudivar)
choosedudi.but <- tkbutton(frame2, text="Set", command=function() choosedudi(dudi.entry))
tkgrid(tklabel(frame2,text="dudi name : "), dudi.entry, choosedudi.but)
tkpack(frame2, fill = "x")
cancel.but <- tkbutton(tf, text="Dismiss", command=function() tkdestroy(tf))
dispdudi.but <- tkbutton(tf, text="Submit", command=function() calldisp(show, history))
tkpack(cancel.but, dispdudi.but, expand=1, fill="x", side="left")
tkbind(tf, "<Destroy>", function() tclvalue(done) <- 2)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkbind(tf, "<KeyPress-Return>", function() calldisp(show, history))
tkwait.variable(done)
if(tclvalue(done) == "2") return(0)
tkdestroy(tf)
}
################################
# Function to choose the dudi
################################
"choosedudi" <- function(dudi.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose dudi")
done <- tclVar(0)
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dudi
# or a list. If it is a dudi, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.dudi(xobj) || class(xobj)=="discrimin" || class(xobj)=="dpcoa") {
tkinsert(tlb, "end", x1)
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dataframe text entry
#
tkdelete(dudi.entry, 0, "end")
tkinsert(dudi.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose the dudi
################################
"choosedudirc" <- function(dudi.entry, dfnr.label, dfnc.label)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose dudi")
done <- tclVar(0)
vnr <- NULL
vnc <- NULL
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dudi
# or a list. If it is a dudi, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.dudi(xobj)) {
tkinsert(tlb, "end", x1)
nr <- eval(parse(text=paste("nrow(",x1,"$tab",")",sep="")))
nc <- eval(parse(text=paste("ncol(",x1,"$tab",")",sep="")))
return(cbind(nr, nc))
}
}
v <- unlist(lapply(obj, flb))
if (length(v) > 0) {
vnr <- v[seq(from=1,to=length(v),by=2)]
vnc <- v[seq(from=2,to=length(v),by=2)]
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dataframe text entry
#
tkdelete(dudi.entry, 0, "end")
tkinsert(dudi.entry, "end", choix)
#
# Put the row and column numbers of the dataframe in the corresponding labels
#
tkconfigure(dfnr.label, text=as.character(vnr[numi]))
tkconfigure(dfnc.label, text=as.character(vnc[numi]))
tkdestroy(tf)
}
################################
# Function to choose the dudi
################################
"chooseduditest" <- function(dudi.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose dudi")
done <- tclVar(0)
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dudi
# or a list. If it is a dudi, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (class(xobj)=="between" || class(xobj)=="discrimin" || class(xobj)=="coinertia" || class(xobj)=="cca" || class(xobj)=="pcaiv" || class(xobj)=="pcaivortho") {
tkinsert(tlb, "end", x1)
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dataframe text entry
#
tkdelete(dudi.entry, 0, "end")
tkinsert(dudi.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose the graph
################################
"choosegraph" <- function(graph.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose graph")
done <- tclVar(0)
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
#
# cmdlist contains the list of graphs that were drawn by the user.
#
cmdlist1 <- get("cmdlist", envir=env_ade4tkgui)
if (length(cmdlist1) > 1) {
for (i in 2:length(cmdlist1)) {
if (is.call(cmdlist1[[i]])) {
dcall <- cmdlist1[[i]]
narg <- length(names(dcall))
paramlst <- encodeString(dcall)[2:narg]
arglst <- names(dcall)[2:narg]
call1 <- paste(encodeString(dcall)[1],"(", paste(arglst, paramlst, sep=" = ",collapse=", "), ")", sep="")
tkinsert(tlb, "end", call1)
} else {
tkinsert(tlb, "end", as.character(cmdlist1[[i]]))
}
}
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# Put the name of the object in the dataframe text entry
#
tkdelete(graph.entry, 0, "end")
tkinsert(graph.entry, "end", numi)
tkdestroy(tf)
}
################################
# Function to choose a factor (s.class version)
################################
"choosefac" <- function(fac.entry, dfnr.label)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose factor")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
nbr <- tclvalue(tkcget(dfnr.label, "-text"))
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a vector
# or a list. If it is a dist mat, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.factor(xobj)) {
if (length(xobj) == nbr) tkinsert(tlb, "end", x1)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$", x, sep="")
options(show.error.messages = FALSE)
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
options(show.error.messages = TRUE)
if (is.factor(sobj)) {
if (length(sobj) == nbr) tkinsert(tlb, "end", sobjn)
} else if (is.list(sobj)) {
if (length(names(sobj)) != 0) {
fn2 <- function(x) {
ssobjn <- paste(sobjn,"$", x, sep="")
options(show.error.messages = FALSE)
ssobj <- try(eval(parse(text=ssobjn)), silent=TRUE)
options(show.error.messages = TRUE)
if (is.factor(ssobj)) {
if (length(ssobj) == nbr) tkinsert(tlb, "end", ssobjn)
}
}
sapply(names(sobj), fn2)
}
}
}
sapply(names(xobj), fn1)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(fac.entry, 0, "end")
tkinsert(fac.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose a factor (between version)
################################
"choosefac2" <- function(fac.entry, dudi.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose factor")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
dudiname <- ""
dudi <- tclvalue(tkcget(dudi.entry, "-text"))
if (tclvalue(dudi) != "") dudiname <- parse(text=tclvalue(dudi))[[1]]
if (dudiname != "") {
nbr <- eval(parse(text=paste("nrow(",dudiname,"$tab)",sep="")))
} else nbr <- 0
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.factor(xobj)) {
if (length(xobj) == nbr) tkinsert(tlb, "end", x1)
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$", x, sep="")
options(show.error.messages = FALSE)
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
options(show.error.messages = TRUE)
if (is.factor(sobj)) {
if (length(sobj) == nbr) tkinsert(tlb, "end", sobjn)
} else if (is.list(sobj)) {
if (length(names(sobj)) != 0) {
fn2 <- function(x) {
ssobjn <- paste(sobjn,"$", x, sep="")
options(show.error.messages = FALSE)
ssobj <- try(eval(parse(text=ssobjn)), silent=TRUE)
options(show.error.messages = TRUE)
if (is.factor(ssobj)) {
if (length(ssobj) == nbr) tkinsert(tlb, "end", ssobjn)
}
}
sapply(names(sobj), fn2)
}
}
}
sapply(names(xobj), fn1)
}
}
}
v <- unlist(lapply(obj, flb))
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(fac.entry, 0, "end")
tkinsert(fac.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose a vector of color names
################################
"choosecol" <- function(col.entry, facvar)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose a vector of color names")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
nlev <- length(levels(eval(parse(text=tclvalue(facvar)))))
for (i in 1:length(obj)) {
nomobj <- obj[[i]]
xobj <- get(nomobj, envir=globalenv())
if (is.vector(xobj) && is.character(xobj)) {
if (length(xobj) == nlev) tkinsert(tlb, "end", nomobj)
}
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(col.entry, 0, "end")
tkinsert(col.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose a vector of weights
################################
"choosewt" <- function(wt.entry, dfnr.label)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose a vector of weights")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
for (i in 1:length(obj)) {
nomobj <- obj[[i]]
xobj <- get(nomobj, envir=globalenv())
if (is.vector(xobj) && is.numeric(xobj)) {
nbr <- tclvalue(tkcget(dfnr.label, "-text"))
if (length(xobj) == nbr) tkinsert(tlb, "end", nomobj)
}
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(wt.entry, 0, "end")
tkinsert(wt.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to choose hull levels
################################
"choosechull" <- function(chull.entry)
{
tf <- tktoplevel()
tkwm.title(tf,"Choose a vector hull levels")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
for (i in 1:length(obj)) {
nomobj <- obj[[i]]
xobj <- get(nomobj, envir=globalenv())
if (is.vector(xobj) && is.numeric(xobj)) {
tkinsert(tlb, "end", nomobj)
}
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
numc <- tclvalue(tkcurselection(tlb))
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
tkdelete(chull.entry, 0, "end")
tkinsert(chull.entry, "end", choix)
tkdestroy(tf)
}
################################
# Function to save a graphic in a file
################################
"outgraph" <- function()
{
#
# Main dialog window with title and frames
#
tf <- tktoplevel()
tkwm.title(tf,"Save graphic")
#
# Frames
#
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
frame2 <- tkframe(tf, relief="groove", borderwidth=2)
frame3 <- tkframe(tf, relief="groove", borderwidth=2)
devframe <- tkframe(frame2, relief="groove", borderwidth=2)
#
# Tcl/Tk variables
#
done <- tclVar(0)
formatvar <- tclVar(1)
widthvar <- tclVar(6)
heightvar <- tclVar(6)
#
# Save function
#
"savefic" <- function(formatvar, widthvar, heightvar)
{
outform <- tclvalue(formatvar)
width <- as.numeric(tclvalue(widthvar))
height <- as.numeric(tclvalue(heightvar))
odev <- dev.cur()
if (outform == 1) { # postcript
filename <- tclvalue(tkgetSaveFile(initialfile="Rplots.ps", defaultextension=".ps",
title="Save graph...", filetypes="{PostScript {.ps .eps}} {{All Files} {*.*}}"))
if (filename != "") {
postscript(file=filename, width=width, height=height)
}
} else if (outform == 2) { # pdf
filename <- tclvalue(tkgetSaveFile(initialfile="Rplots.pdf", defaultextension=".pdf",
title="Save graph...", filetypes="{PDF {.pdf}} {{All Files} {*.*}}"))
if (filename != "") {
pdf(file=filename, width=width, height=height)
}
} else if (outform == 3) { # pictex
filename <- tclvalue(tkgetSaveFile(initialfile="Rplots.tex", defaultextension=".tex",
title="Save graph...", filetypes="{PicTeX {.tex}} {{All Files} {*.*}}"))
if (filename != "") {
pictex(file=filename, width=width, height=height)
}
} else if (outform == 4) { # xfig
filename <- tclvalue(tkgetSaveFile(initialfile="Rplots.fig", defaultextension=".fig",
title="Save graph...", filetypes="{XFig {.fig}} {{All Files} {*.*}}"))
if (filename != "") {
xfig(file=filename, width=width, height=height)
}
} else if (outform == 5) { # png
filename <- tclvalue(tkgetSaveFile(initialfile="Rplots.png", defaultextension=".png",
title="Save graph...", filetypes="{PNG {.png}} {{All Files} {*.*}}"))
if (filename != "") {
png(filename=filename, width=width, height=height)
}
} else if (outform == 6) { # jpeg
filename <- tclvalue(tkgetSaveFile(initialfile="Rplots.jpeg", defaultextension=".jpeg",
title="Save graph...", filetypes="{JPEG {.jpeg .jpg}} {{All Files} {*.*}}"))
if (filename != "") {
jpeg(filename=filename, width=width, height=height)
}
}
ndev <- dev.cur()
dev.set(odev)
dev.copy(which=ndev)
dev.off()
tkdestroy(tf)
}
#
# Frames setup
#
tkgrid(tklabel(tf,text="Save current graphic", font="Times 18"), columnspan=2)
tkgrid(tklabel(frame2,text="Output format : "), sticky="n")
tkgrid(tkradiobutton(frame2, text="postscript", value=1, variable=formatvar), sticky="w")
tkgrid(tkradiobutton(frame2, text="pdf", value=2, variable=formatvar), sticky="w")
tkgrid(tkradiobutton(frame2, text="pictex", value=3, variable=formatvar), sticky="w")
tkgrid(tkradiobutton(frame2, text="xfig", value=4, variable=formatvar), sticky="w")
tkgrid(tkradiobutton(frame2, text="png", value=5, variable=formatvar), sticky="w")
tkgrid(tkradiobutton(frame2, text="jpeg", value=6, variable=formatvar), sticky="w")
tkgrid(frame2, rowspan=2, sticky="n")
tkgrid(tklabel(frame3,text="Output size : "))
width.entry <- tkentry(frame3, textvariable=widthvar, width=10)
height.entry <- tkentry(frame3, textvariable=heightvar, width=10)
tkgrid(tklabel(frame3,text="Width : "), width.entry)
tkgrid(tklabel(frame3,text="Height : "), height.entry)
tkgrid(frame3, column=1, row=1, sticky="n")
save.but <- tkbutton(frame1, text="Save", command=function() savefic(formatvar, widthvar, heightvar))
cancel.but <- tkbutton(frame1, text="Dismiss", command=function() tkdestroy(tf))
tkgrid(save.but, cancel.but)
tkgrid(frame1, column=1, row=2, sticky="n")
tkbind(tf, "<Destroy>", function() tclvalue(done) <- 2)
tkbind(tf, "<KeyPress-Return>", function() savefic(formatvar, widthvar, heightvar))
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done) == "2")
return(0)
tkdestroy(tf)
}
################################
# Function to create a new graphic window
################################
"newGr" <- function()
{
if(.Platform$OS.type == "unix") {
if (capabilities("aqua")) {
# quartz()
dev.new()
} else if (capabilities("X11")) {
# x11()
dev.new()
}
} else {
# windows()
dev.new()
}
assign("winlist", get("winlist", envir=env_ade4tkgui)+1, envir=env_ade4tkgui)
}
################################
# Function to reset the list of graphics
################################
"resetgraph" <- function()
{
if (exists("cmdlist")) rm("cmdlist", envir=env_ade4tkgui)
assign("cmdlist", "cmdlist", envir=env_ade4tkgui)
}
################################
# Function to choose the graphic Window
################################
"selectGr" <- function()
{
tf <- tktoplevel()
tkwm.title(tf,"Choose window")
done <- tclVar(0)
tkpack(tklabel(tf,text="Activate a graphic window", font="Times 18"))
numi <- 1
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
#
# dev.list contains the list of graphic windows.
#
devlist <- dev.list()
if (!is.null(devlist)) {
for (i in 1:length(devlist)) {
tkinsert(tlb, "end", paste("Device",devlist[i]))
if (devlist[i] == dev.cur()) {
tkitemconfigure(tlb, i-1, foreground="red", selectforeground="red")
}
}
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
#
# sets the chosen device as active
#
dev.set(devlist[numi])
tkdestroy(tf)
}
################################
# Function to ask for save before quit
################################
"askQuit" <- function()
{
q <- tkmessageBox(message="Do you want to save before quitting?",icon="question",type="yesnocancel",default="yes")
if (tclvalue(q) != "cancel") q(tclvalue(q))
}
################################
# Function to edit a dataframe
################################
"editdf" <- function()
{
tf <- tktoplevel()
tkwm.title(tf,"Choose dataframe")
done <- tclVar(0)
tlb <- tklistbox(tf)
scr <- tkscrollbar(tf, repeatinterval=5, command=function(...)tkyview(tlb,...))
tkconfigure(tlb, yscrollcommand=function(...)tkset(scr,...))
frame1 <- tkframe(tf, relief="groove", borderwidth=2)
cancel.but <- tkbutton(frame1, text="Dismiss", command=function()tkdestroy(tf))
submit.but <- tkbutton(frame1, text="Choose", default="active", command=function()tclvalue(done)<-1)
tkpack(cancel.but, submit.but, side="left")
tkpack(frame1, side="bottom")
tkpack(tlb, side="left", fill="both", expand=TRUE)
tkpack(scr, side="right", fill="y")
obj <- ls(globalenv())
#
# For all objects in the global environment, check to see if it is a dataframe
# or a list. If it is a data frame, insert it in the listbox, and if it is a list,
# check its elements.
#
flb <- function(x1) {
xobj <- get(x1, envir=globalenv())
if (is.data.frame(xobj)) {
tkinsert(tlb, "end", x1)
cbind(nrow(xobj),ncol(xobj))
} else if (is.list(xobj)) {
if (length(names(xobj)) != 0) {
fn1 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.data.frame(sobj)) {
tkinsert(tlb, "end", sobjn)
}
}
sapply(names(xobj), fn1)
fn2 <- function(x) {
sobjn <- paste(x1,"$",x,sep="")
sobj <- try(eval(parse(text=sobjn)), silent=TRUE)
if (is.data.frame(sobj)) {
cbind(nrow(sobj), ncol(sobj))
}
}
res <- sapply(names(xobj), fn2)
return(res)
}
}
}
v <- unlist(lapply(obj, flb))
if (length(v) > 0) {
vnr <- v[seq(from=1,to=length(v),by=2)]
vnc <- v[seq(from=2,to=length(v),by=2)]
}
tkbind(tlb, "<Double-ButtonPress-1>", function() tclvalue(done)<-1)
tkbind(tf, "<Destroy>", function() tclvalue(done)<-2)
tkbind(tf, "<KeyPress-Return>", function() tclvalue(done)<-1)
tkbind(tf, "<KeyPress-Escape>", function() tkdestroy(tf))
tkwait.variable(done)
if(tclvalue(done)=="2") return(0)
#
# Get the number of the element choosed by the user
#
numc <- tclvalue(tkcurselection(tlb))
numi <- as.integer(numc)+1
if(numc == "") {
tkdestroy(tf)
return(0)
}
choix <- tclvalue(tkget(tlb, numc))
eval(parse(text=paste(choix, " <<- edit(", choix, ")", sep="")))
tkdestroy(tf)
}
################################
# Function to modify the history (thanks to Thomas Lumley :)
# http://finzi.psych.upenn.edu/R/Rhelp02a/archive/41067.html
# [R] can one evaluate an expression in a comment? (or insert resultsinto history?) from Thomas Lumley on 2004-11-08
################################
"rewriteHistory" <- function(command)
{
file1 <- tempfile("Rrawhist")
on.exit(unlink(file1))
savehistory(file1)
conn<-file(file1,open="a")
writeLines(command, con=conn)
close(conn)
loadhistory(file1)
}
################################
# Functions to test if one or two values are empty and to return a default value
# Two useful functions for programming optimization
################################
".test1value" <- function(val, default) {
if(val!="")
return(parse(text=val)[[1]])
else
return(default)
}
".test2values" <- function(val1, val2, default) {
if((val1!="") & (val2!=""))
return(c(eval(parse(text=val1)), eval(parse(text=val2))))
else
return(default)
}
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.