R/tk2edit.R

In tcltk2: Tcl/Tk Additions

# TODO: Rework all this!!!

#dim.tclArray <- function (ta)
#{
#  nms <- grep(",", names(ta), value = TRUE)
#  if (length(nms) == 0) return(c(0, 0))
#  c(max(as.numeric(gsub(",.*", "", nms))),
#      max(as.numeric(gsub(".*,", "", nms)))) + 1
#}


#' Edit a matrix or data frame in spreadsheet-like editor
#'
#' A tkTable widget is used to display and edit a matrix or data frame. One
#' can edit entries, add or delete rows and columns, ...
#'
#' @param x A matrix or data frame to edit.
#' @param title The title of the editor window.
#' @param header Do we display a header?
#' @param maxHeight The maximum height of the editor window.
#' @param maxWidth The maximum width of the editor window.
#' @param fontsize The size of the font to use in the editor window.
#' @param ... Further arguments to pass to the function.
#'
#' @return The function is used for its side-effet, that is, to modify a matrix or data
#' frame in a spreadsheet-like editor.
#' @note You need the tkTable widget to use this function.
#' @export
#' @author Jeffrey J. Hallman
#' @seealso [tclSetValue()]
#'
#' @examples
#' \dontrun{
#' # These cannot be run by examples() but should be OK when pasted
#' # into an interactive R session with the tcltk package loaded
#' data(iris)
#' tk2edit(iris)
#' }
tk2edit <- function(x, title = "Matrix Editor", header = NULL,
maxHeight = 600, maxWidth = 800, fontsize = 9, ...) {
  if (!is.tk())
    stop("Package Tk is required but not loaded")
  if (!inherits(tclRequire("Tktable", warn = FALSE), "tclObj"))
    stop("Tcl package 'Tktable' must be installed first")
  .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 = TRUE)
    for (i in 2:nrow(cm))
      for (j in 1:ncol(cm))
        ta[[i - 1, j - 1]] <- as.tclObj(cm[i, j], drop = TRUE)
  }

  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 = TRUE)
    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 = FALSE]

  # Ignore bad 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)
  outMat
}