[R-gui] tkEditMatrix()

[jhallman@frb.gov]

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)
}