[R-gui] tkEditMatrix()
Philippe Grosjean
phgrosjean at sciviews.org
Tue Sep 20 19:58:51 CEST 2005
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: Philippe.Grosjean at umh.ac.be
) ) ) ) )
( ( ( ( ( web: http://www.umh.ac.be/~econum
) ) ) ) ) http://www.sciviews.org
( ( ( ( (
..............................................................
jhallman at frb.gov 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 at stat.math.ethz.ch
> https://stat.ethz.ch/mailman/listinfo/r-sig-gui
>
>
More information about the R-SIG-GUI
mailing list