[R] [tcltk] tktable: bindings doesn't triggers the ValidationCommand and Command

[Cleber N.Borges]

Dears,

I'm trying to create an Data Editor like Rgui.exe's FIX (windows)...

The code is below.

The problem is that I can not get the binds to trigger the validation
commands and the main table command

Control-C, Control-V, and Control-X work only in the visual without my R
data being changed.

Any help, tip or example is welcome and I thank you in advance for your
attention.

Thank you very much


Cleber

################### R 3.4  Tcl  8.6


library( tcltk )
tclRequire("Tktable")

ncol <- 6
nrow <- 6

x <- matrix( rnorm( nrow*ncol ), nrow, ncol )

rownames(x) <- paste0( "Sam ", 1:nrow )
colnames(x) <- paste0( "Var ", 1:ncol )

###############################################################

showdigits <- 6

tablecmd <- function(r,c,S){
r <- as.integer( r )
c <- as.integer( c )
showNA <- is.na( x[ r,c ] )
if( r == 0 && c > 0 ) return( tcl("expr", '{', colnames(x)[c], '}' ) )
if( c == 0 && r > 0 ) return( tcl("expr", '{', rownames(x)[r], '}' ) )
if( r >  0 && c > 0 &&  showNA ) return( tcl("expr", "{}" ) )
if( r >  0 && c > 0 && !showNA ) return( tcl("expr", round( x[r,c],
digits=showdigits ) ) )# signif
if( r == 0 && c == 0 ) return( tcl("expr", "{}" ) )
}

tablevcmd <- function( S,s,r,c ){
# s : current value # S : potential new value
if( grepl("\n", S ) ){
     tcl('::tk::table::MoveCell', .Tk.ID( tableData ), 1, 0 )
     return( tcl( 'expr', 0 ) )
     }
r <- as.integer( r )
c <- as.integer( c )
if( r == 0 && c > 0 ) {
     colnames(x)[c] <<- S
     return( tcl( 'expr', 1 ) )
     }
if( c == 0 && r > 0 ) {
     rownames(x)[r] <<- S
     return( tcl( 'expr', 1 ) )
     }
if( grepl(" ", S ) ){
     tcl('::tk::table::MoveCell', .Tk.ID( tableData ), 1, 0 )
     return( tcl( 'expr', 0 ) )
     }
if( S == "" ) {
     x[r,c] <<- NA
     return( tcl( 'expr', 1 ) )
     }
if( S != s ){
     x[r,c] <<- as.numeric( S )
     return( tcl( 'expr', 1 ) )
     }
}

# make the GUI
top <- tktoplevel()
tcl( 'wm', 'title',     top, 'DataFix' )

fmTableData <- ttkframe( top, borderwidth=2 )
tcl( 'pack', fmTableData, fill="both", expand=TRUE, padx=15, pady=15  )

fxscroll <- function(...){ tcl( scrX, 'set', ... ) }
fyscroll <- function(...){ tcl( scrY, 'set', ... ) }

tableData <- tkwidget( fmTableData, 'table', rows=nrow+1, cols=ncol+1,
height=-1, width=-1,
ellipsis='............', insertofftime=0, flashmode=TRUE, flashtime=1,
anchor='e',
resizeborders='col', wrap=FALSE, font='{Courier} 10', padx=5, pady=2,#
ipadx=3, ipady=1,
rowstretchmode='unset', colstretchmode='unset', multiline=FALSE, cache=TRUE,
background="white", selectmode="extended", selecttitle=TRUE,
relief='groove',
borderwidth=c(0,1,0,1), drawmode='compatible', colwidth=12,
highlightcolor="gray", highlightbackground="white", highlightthickness=1,
xscrollcommand=fxscroll, yscrollcommand=fyscroll, rowseparator='\n',
colseparator='\t',
validate=TRUE, vcmd=tablevcmd, usecommand=TRUE, command=tablecmd )

scrX <- ttkscrollbar( fmTableData, orient="horizont",
command=function(...) tcl( tableData,'xview',...) )
scrY <- ttkscrollbar( fmTableData, orient="vertical",
command=function(...) tcl( tableData,'yview',...) )
#### empacotando os scrollbars
tcl( "pack", scrY, side = "right",  fill = "y", expand = FALSE, pady =
c(0,18) )
tcl( "pack", scrX, side = "bottom", fill = "x", expand = FALSE )

tcl( tableData, "tag", "celltag", "ZeroZero", "0,0" )
tcl( tableData, "tag", "rowtag",  "rowtitle", "0" )
tcl( tableData, "tag", "coltag",  "coltitle", "0" )

tcl( tableData, "tag", "configure", "ZeroZero", bg='SystemButtonFace',
fg='SystemButtonFace', state='disabled' )

tcl( tableData, "tag", "configure", "rowtitle", bg='lightgray',
relief='groove', anchor='center')#, borderwidth=c(1,1,1,1) )
tcl( tableData, "tag", "configure", "coltitle", bg='lightgray',
relief='groove', anchor='w')#, borderwidth=c(1,1,1,1) )

tcl( tableData, "tag", "configure", "active", fg='green', bg='gray90',
relief='solid', borderwidth=c(1,1,1,1) )
tcl( tableData, "width", "0", "15" )

tcl( 'pack', tableData, side='left', anchor='n', fill="both", expand=TRUE )

#################################################################
# stay here to serve as an example
#################################################################
# bind Table <Up> {::tk::table::MoveCell %W -1  0}
tcl( 'bind', .Tk.ID( tableData ), '<F1>', paste('::tk::table::MoveCell',
.Tk.ID( tableData ), 1, 0 )  )
# bind Table <$cut>    {tk_tableCut %W}
tcl( 'bind', .Tk.ID( tableData ), '<F2>', paste('tk_tableCut', .Tk.ID(
tableData ) ) )












---
Este email foi escaneado pelo Avast antivírus.
https://www.avast.com/antivirus

	[[alternative HTML version deleted]]