Thank you. I'll integrate this to the tcl/tk web page... and also, if you like in the tcltk2 package in preparation (see http://www.sciviews.org/SciViews-R). Best,
Philippe Grosjean ..............................................<°}))><........ ) ) ) ) ) ( ( ( ( ( Prof. Philippe Grosjean ) ) ) ) ) ( ( ( ( ( Numerical Ecology of Aquatic Systems ) ) ) ) ) Mons-Hainaut University, Pentagone (3D08) ( ( ( ( ( Academie Universitaire Wallonie-Bruxelles ) ) ) ) ) 8, av du Champ de Mars, 7000 Mons, Belgium ( ( ( ( ( ) ) ) ) ) phone: + 32.65.37.34.97, fax: + 32.65.37.30.54 ( ( ( ( ( email: [EMAIL PROTECTED] ) ) ) ) ) ( ( ( ( ( web: http://www.umh.ac.be/~econum ) ) ) ) ) http://www.sciviews.org ( ( ( ( ( .............................................................. [EMAIL PROTECTED] wrote: > 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 > > _______________________________________________ R-SIG-GUI mailing list R-SIG-GUI@stat.math.ethz.ch https://stat.ethz.ch/mailman/listinfo/r-sig-gui
