Nothing
# 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
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.