Philippe,
I wrote this matrix editor that uses Tktable and sent it to James Wettenhall,
suggesting that he might want to add it to his tcltk examples web page. James
replied that he was no longer maintaining those pages, but that you had
volunteered to take them over. James also suggested I send it to the
R-SIG-GUI list, so I'm doing that as well.
The code is public domain, so feel free to do anything you like with it.
Jeff Hallman
dim.tclArray <- function(ta){
nms <- grep(",", names(ta), value = T)
if(length(nms) == 0) return(c(0,0))
c(max(as.numeric(gsub(",.*", "", nms))),
max(as.numeric(gsub(".*,", "", nms)))) + 1
}
tkEditMatrix <- function(x, title="Matrix Editor",
header = NULL,
maxHeight = 600, maxWidth = 800,
fontsize = 17,
...){
tclRequire("Tktable")
.Tcl(paste("option add *Table.font {courier", fontsize, "bold}"))
old <- options(scipen = 7)
on.exit(options(old))
makeCharMat <- function(x){
## make sure it's a character matrix
mat <- matrix(unlist(x), nrow = nrow(as.matrix(x)))
dm <- dim(mat)
## check for row and column names
hasRownames <- length(rn <- rownames(x)) > 0
hasColnames <- length(cn <- colnames(x)) > 0
## fake row and column names if they aren't there
if(!hasRownames) rn <- paste("[", 1:nrow(x), ",]", sep = "")
if(!hasColnames) cn <- paste("[,", 1:ncol(x), "]", sep = "")
## format the columns
mat[] <- apply(unclass(mat), 2, format, justify = "right")
mat <- rbind(cn, mat)
mat <- cbind(c("", rn), mat)
mat
}
fillTclArrayFromCharMat <- function(ta, cm){
## cm[,1] contains column names, while cm[1,] has rownames
## cm[1,1] is ignored
for(j in 2:ncol(cm)) ta[[0, j-1]] <- as.tclObj(cm[1, j], drop = T)
for(i in 2:nrow(cm))
for(j in 1:ncol(cm))
ta[[i-1, j-1]] <- as.tclObj(cm[i, j], drop = T)
}
tA <- tclArray()
cmat <- makeCharMat(x)
fillTclArrayFromCharMat(tA, cmat)
tt <- tktoplevel()
tkwm.title(tt,title)
colwidths <- apply(cmat, 2, function(x) max(nchar(x)) + 1 )
nTableCols <- ncol(cmat)
if((moreWidth <- 60 - sum(colwidths)) > 0){
addEach <- moreWidth %/% length(colwidths)
if(addEach < 5) colwidths <- colwidths + addEach + 1
else nTableCols <- nTableCols + ceiling(moreWidth/10)
}
tktable <- tkwidget(tt, "table",
variable = tA,
rows = nrow(cmat), cols = nTableCols,
titlerows = 1, titlecols = 1, selecttitle = 1,
anchor = "e", multiline = 0,
selectmode = "extended",
rowseparator = dQuote("\n"),
colseparator = dQuote("\t"),
background = "white",
maxheight = maxHeight, maxwidth = maxWidth,
xscrollcommand = function(...) tkset(xscr,...),
yscrollcommand = function(...) tkset(yscr,...))
xscr <-tkscrollbar(tt, orient = "horizontal",
command = function(...)tkxview(tktable,...))
yscr <- tkscrollbar(tt, command = function(...)tkyview(tktable,...))
## set column widths
for(i in 1:ncol(cmat)) tcl(tktable, "width", i-1, colwidths[i])
## rebind the Backspace key, which somehow gets messed up
string <- "bind Table <BackSpace> {
set ::tk::table::Priv(junk) [%W icursor]
if {[string compare {} $::tk::table::Priv(junk)] &&
$::tk::table::Priv(junk)} {
%W delete active [expr {$::tk::table::Priv(junk)-1}]
}}"
.Tcl(string)
## internal functions for buttons
activeRow <- function() as.numeric(tkindex(tktable, "active", "row"))
activeCol <- function() as.numeric(tkindex(tktable, "active", "col"))
undoEdits <- function(){
ta <- tclArray()
fillTclArrayFromCharMat(ta, cmat)
assign("tA", ta, inherits = T)
tkconfigure(tktable, variable = tA)
}
finish <- function() tkdestroy(tt)
cancel <- function(){
undoEdits()
tkdestroy(tt)
}
insertRow <- function(){
row <- activeRow()
col <- activeCol()
tkinsert(tktable, "rows", row, 1)
newCell <- paste(row + 1, col, sep = ",")
tkactivate(tktable, newCell)
tksee(tktable, newCell)
}
insertCol <- function(){
row <- activeRow()
col <- activeCol()
tkinsert(tktable, "cols", col, 1)
newCell <- paste(row, col + 1, sep = ",")
tkactivate(tktable, newCell)
tksee(tktable, newCell)
}
deleteRow <- function(){
if((row <- activeRow()) != 0)
tkdelete(tktable, "rows", row, 1)
}
deleteCol <- function(){
if((col <- activeCol()) != 0)
tkdelete(tktable, "cols", col, 1)
}
copyRow <- function(){
src <- activeRow()
if(src != 0){
insertRow()
dst <- activeRow()
for(j in 0:(ncol(tA)-1)) tA[[dst,j]] <- tA[[src, j]]
}
}
copyCol <- function(){
src <- activeCol()
if(src != 0){
insertCol()
dst <- activeCol()
for(i in 0:(nrow(tA)-1)) tA[[i,dst]] <- tA[[i,src]]
}
}
finishButton <- tkbutton(tt, text = "Finish", command = finish)
cancelButton <- tkbutton(tt, text = "Cancel", command = cancel)
undoEditsButton <- tkbutton(tt, text = "Undo Edits", command = undoEdits)
insertRowButton <- tkbutton(tt, text = "Insert Row", command = insertRow)
copyRowButton <- tkbutton(tt, text = "Copy Row", command = copyRow)
deleteRowButton <- tkbutton(tt, text = "Delete Row", command = deleteRow)
insertColButton <- tkbutton(tt, text = "Insert Col", command = insertCol)
copyColButton <- tkbutton(tt, text = "Copy Col", command = copyCol)
deleteColButton <- tkbutton(tt, text = "Delete Col", command = deleteCol)
## Layout
if(length(header) > 0){
for(label in header)
tkgrid(tklabel(tt, text = label), columnspan = 7, sticky = "nw")
}
tkgrid(tktable, yscr, columnspan = 8)
tkgrid.configure(tktable, sticky = "news")
tkgrid.configure(yscr, sticky = "nsw")
tkgrid(xscr, sticky = "new", columnspan = 8)
tkgrid(insertRowButton, copyRowButton, deleteRowButton, sticky = "news")
tkgrid(insertColButton, copyColButton, deleteColButton,
"x", cancelButton, undoEditsButton, finishButton, sticky = "news")
tkgrid.columnconfigure(tt, 3, weight = 1)
tkgrid.rowconfigure(tt, length(header), weight = 1)
tkactivate(tktable, "0,0")
tktag.configure(tktable, "active", background = "lightyellow2")
tktag.configure(tktable, "title", state = "normal")
tkgrab.set(tt)
tkfocus(tt)
tkwait.window(tt)
outMat <- matrix("", nrow = nrow(tA), ncol = ncol(tA))
for(i in 1:nrow(outMat))
for(j in 1:ncol(outMat)){
val <- tA[[i-1,j-1]]
if(is.null(val)) val <- ""
else val <- tclvalue(val)
outMat[i,j] <- val
}
## recover row and column names
rn <- outMat[,1][-1]
cn <- outMat[1,][-1]
outMat <- outMat[-1, -1, drop = F]
## ignore badd and/or NA row and column names
badRownames <- c(grep("\\[.*\\]", rn), (1:length(rn))[is.na(rn)])
if(length(badRownames) != length(rn)){
rn[badRownames] <- ""
rownames(outMat) <- rn
}
badColnames <- c(grep("\\[.*\\]", cn), (1:length(cn))[is.na(cn)])
if(length(badColnames) != length(cn)){
cn[badColnames] <- ""
colnames(outMat) <- cn
}
mode(outMat) <- mode(x)
Sys.sleep(0.1)
return(outMat)
}
_______________________________________________
R-SIG-GUI mailing list
R-SIG-GUI@stat.math.ethz.ch
https://stat.ethz.ch/mailman/listinfo/r-sig-gui
