R/gWidgets2-filter.R

Defines functions is_notalnum is_punct is_digit is_alpha is_alnum debug_data.frame dffilter_reload dffilter

## edit a really large data set *after* it has been filtered

dffilter <- function(data_set, display=TRUE, maximize=TRUE, editable=FALSE, 
                     data_set_name=NULL, sel.col=NULL, sel.row=NULL, esc=FALSE, 
                     def.col=50, details=TRUE, details.on.tab.sel=TRUE, 
                     confirm.big.df=TRUE, 
                     initial.vars=data.frame(data_set_nms[1], "preset", "preset", 
                        stringsAsFactors=FALSE), filter.on.tab.sel=TRUE, 
                     hide=FALSE
                     , crosstab=TRUE, crosstab.on.tab.sel=TRUE, 
                     free.mem=1
                     ){
    require(gWidgets2RGtk2)
    require(gWidgets2) ## on github not CRAN. (require(devtools); install_github("gWidgets2", "jverzani")
    options(guiToolkit="RGtk2")
    require(RGtk2)
    ##FIXME !!proper CRAN packaging
    ##FIXME !!put package require() in appropriate handlers
    ##free.mem: 2 - periodic, 1 - on.close, 0 - never
    if(details) require(Hmisc)
    

    DF <- NULL                      # global gdf instance
    rows <- NULL                    # global rows index
    rows.disp <- NULL               # global rows index (subset currently displayed)
    rows.descr_old <- list()               # global rows index (subset previously displayed)
    idxs <- NULL                    # global set of indices that are being edited
    cnms <- NULL                    # global column names
    cnms.disp <- NULL               # global column names (subset currently displayed)
    cnms.descr_old <- list()               # global column names (subset currently displayed)
    len_idxs <- NULL                # global set of indices that are being edited (length)
    len_cnms <- NULL                # global column names (length)
    data_set_dim <- NULL            # global df dim
    c_names <- NULL                 # global column names widget
    old_selection <- NULL           # global old selection storage
    radio.inst <- NULL
    radio.sel <- NULL
    DF_deb <- NULL
    details.out <- list()
    new.disp <- TRUE
    new.descr <- TRUE
    new.ctab <- TRUE
    rows.df.deb <- NULL               # global rows index (subset currently displayed)
    filter.types <- c("single"="RadioItem", "multiple"="ChoiceItem", 
        "range"="RangeItem", "preset"="PresetItem")
    h_disp_lab <- NULL
    hidden.panel <- hide
    b_disp_font <- list(weight = "normal")
    tb_ctab <- NULL
    ctab.dropped <- c()
    ctab.sel <- list()
    DF_ctab <- NULL
    has_b_melt_var <- FALSE
    b_melt_var.ctab <- NULL
    ctab.vars.init <- list()
    rows.ctab_old <- list()               # global rows index (subset previously displayed)
    cnms.ctab_old <- list()               # global column names (subset currently displayed)
    tb_ctab.tmp.sel <- NULL
    new.descr.sync <- TRUE
    new.ctab.sync <- TRUE
    l_lyt_ctab <- list()
    f_lyt_ctab <- list()
    g_variable2...fixed <- NULL     ## global instance of special 'variable' obj in ctab
    free.mem.nr <- 0
    
    ##if there is no Details tab, we always want to display subset
    if(!details) filter.on.tab.sel <- FALSE
    free.mem <- free.mem[1]
    
     #print(data_set_name)
     #print(class(sel.row))
     #print(length(sel.row))
     #for(i in sel.row) print(class(i)[1])
    #for(i in 1:length(sel.row)) print(svalue(sel.row[[i]]))
    
    ## ensure we have a data frame of 1x2 dimensions
    stopifnot(is.data.frame(data_set))
    if(is.null(data_set_name)) data_set_name <- deparse(substitute(data_set))
    if(!is.character(data_set_name)) data_set_name <- as.character(data_set_name)
    data_set_nms <- names(data_set)
    data_set_dim_orig <- dim(data_set)
    stopifnot(all(data_set_dim_orig >= c(1,2)))
    ##if pdata.frame, don't use droplevels()
    is_pdata.frame <- isTRUE(class(data_set)[1] == "pdata.frame")

    ##deal with duplicate names 
    ##inform user after window becomes visible
    dupl.names <- any(duplicated(data_set_nms))
    na.names <- any(is.na(data_set_nms))
    if(dupl.names || na.names){
        data_set_nms <- make.names(data_set_nms, unique = TRUE)
        names(data_set) <- data_set_nms
    }
        
    w <- gwindow(paste(data_set_name, " (", data_set_dim_orig[1], ' x ', 
                       data_set_dim_orig[2], ')', sep=''), visible=FALSE, 
                 handler=function(h,...){
                     #return(data_set)
                 })
    
    h_free.mem <- function(h,...) {
        if(free.mem %in% 1:2){
            ##FIXME block user closing window
            a <- gwindow("", visible = FALSE, width=50, height=30, parent=w)
            a$widget$setDecorated(FALSE)
            gw <- ggroup(cont=a)
            glabel(" ", cont=gw)
            
            ##BUG ui drawing is sometimes unreliable and time-dependent
            ##add spinner
            gspin <- gtkSpinner()
            gspin$start()
            Sys.sleep(0.02)
            add(gw, gspin)
            
            glabel("Freeing up memory... ", cont=gw)
            Sys.sleep(0.02)
            visible(a) <- TRUE
            
            ##free mem
            Sys.sleep(0.02)
            gc(FALSE)
            dispose(a)
        }
        FALSE
    }
    addHandlerUnrealize(w, handler=h_free.mem)
    
    ##set WM icon (gtk-only)
    w_img <- gdkPixbufNewFromFile("gtk-logo-rgb.gif")
    getToolkitWidget(w)$setIcon(w_img$retval)
                 
    ##maximize window on load
    if(maximize) getToolkitWidget(w)$maximize()
    
    #pg <- gpanedgroup(cont=ntbk, horizontal=TRUE, label=" Filter")
    pg <- gpanedgroup(cont=w, horizontal=TRUE)
    #pg <- ggroup(cont=w, horizontal=TRUE)
    f_side0 <- gvbox(cont=pg, use.scrollwindow=FALSE, 
                     resize=FALSE, shrink=FALSE)  ##1st side of paned grp
    
    ## have a hide/show button
    f_side0g <- ggroup(cont=f_side0)
    f_side0g1 <- ggroup(cont=f_side0g)
    b_hide <- gbutton("Hide", cont=f_side0g1)
    h_hide <- function(h, ...){
        val <- svalue(h$obj)
        if(val == "Hide") {
            delete(f_side0, f_side1)
            add(f_side0g, f_side0g2)
            delete(f_side0g, f_side0g1)
            svalue(pg) <- as.integer(size(b_show)[1])
            hidden.panel <<- TRUE
        } else {
            add(f_side0, f_side1, expand=T)
            #print(sapply(f_side0$children, function(u) size(u)))
            add(f_side0g, f_side0g1)
            delete(f_side0g, f_side0g2)
            ##FIXME this slowly enlargens panel size after multiple clicks
            svalue(pg) <- as.integer(size(c_names)[1] + 9)
            hidden.panel <<- FALSE
        }
        #blockHandlers(h$obj)
        #unblockHandler(h$obj)
    }
    addHandlerClicked(b_hide, h_hide)
    b_hide$set_icon("go-back")
    tooltip(b_hide) <- "Hide panel"

    ## have a reload button
    ##FIXME !!restore the sel of row filters
    #addSpring(f_side0g)
    b_reload <- gbutton("Reload", cont=f_side0g1)
    h_reload <- function(h, ...) {
        #print(data_set_name)
        #print(class(row_filter))
        #for(i in sel.row) print(class(i)[1])
        #for(i in 1:length(sel.row)) print(svalue(sel.row[[i]]))
        
        h_free.mem()
        dispose(w)
        dffilter_reload(data_set=get(data_set_name), display=display, maximize=maximize, 
                        editable=editable, data_set_name=data_set_name, 
                        sel.col=old_selection, sel.row=row_filter, 
                        hide=hidden.panel)
    }
    addHandlerClicked(b_reload, h_reload)
    b_reload$set_icon("refresh")
    tooltip(b_reload) <- "Reload data frame"
    
    ##vertically aligned buttons for when panel is hidden
    f_side0g2 <- ggroup(horizontal = FALSE, cont=f_side0g)
    b_show <- gbutton("", cont=f_side0g2)
    addHandlerClicked(b_show, h_hide)
    b_show$set_icon("go-forward")
    tooltip(b_show) <- "Show panel"
    #add(f_side0g2, b_reload)
    b_reload2 <- gbutton("", cont=f_side0g2)
    addHandlerClicked(b_reload2, h_reload)
    b_reload2$set_icon("refresh")
    tooltip(b_reload2) <- "Reload data frame"
    delete(f_side0g, f_side0g2)  ##init the vertical buttons


    #f_side1 <- gvbox(cont=f_side0, use.scrollwindow=TRUE, expand=TRUE)
    f_side1 <- gpanedgroup(FALSE, cont=f_side0, expand=TRUE)
    
    ##FIXME mv this to appropriate location in code
    ############################
    ##Filter *tab*
    #df_side <- gvbox(cont=pg, expand=TRUE)
    ntbk <- gnotebook(3, cont=pg)  ##2nd side of paned grp
    df_side <- gvbox(cont=ntbk, expand=TRUE, label=" Filter")
    ntbk$add_tab_icon(1, "find")
    ntbk$add_tab_tooltip(1, "Display data frame")
    
    df_box <- ggroup(cont=df_side, expand=TRUE) ## holds DF instance
    glabel("Select columns to be displayed \nand define appropriate row filters,\nthen click the 'Display selection' button. \nIf you make changes to your data, you \ncan merge them into the original dataset.", cont=df_box)
    
    btn_gp <- ggroup(cont=df_side)
    if(editable) {
        do_btn <- gbutton("Merge changes...", cont=btn_gp)
        do_btn$set_icon("ok")
        enabled(do_btn) <- FALSE
    }
    addSpring(btn_gp)
    close_btn <- gbutton("Close", cont=btn_gp, handler=function(h,...){
        h_free.mem()
        dispose(w)
    })
    #gsb_df <- gstatusbar('', cont=df_side)  ##uncomment to enable gtkSpinner() functionality
    gsb_dfl <- gstatusbar('', cont=df_side)
    ##set statusbar for spinner
    #gsb_dff <- gsb_df$block[[1]]

    #gsb_dff$remove(gsb_dff[[1]])                        #remove old
    #gsb_dfg <- ggroup()
    #gsb_dff$add(gsb_dfg$block)                          # add a group

    #gsb_dfl <- glabel("")
    #add(gsb_dfg, gsb_dfl)
    #addSpring(gsb_dfg)
    #gsb_dfsp <- gtkSpinner()
    
    ##inital spin
    #add(gsb_dfg, gsb_dfsp)
    #gsb_dfsp$start()
    #gsb_dfsp$stop()
    #gsb_dfg$widget$remove(gsb_dfsp)
    
    ## set up filters.
    ## Select columns
    c_gp <- gframe("<b> Select columns: </b>", markup=TRUE, cont=f_side1, 
                   horizontal=FALSE)

    ##fancy search for selecting columns
    ##prepare the search input box & handler
     vb <- gvbox(container=c_gp)
     search_type <-  list(ignore.case=TRUE, perl=FALSE, fixed=FALSE)  ##init global instance
       gp <- ggroup(cont=vb)
       ed <- gedit("", initial.msg="Filter column names by...", expand=TRUE, container=gp)
       tooltip(ed) <- "Select columns by searching for a (partial) variable name (e.g. 'vari'). If the search string contains a ':' or a ',' (e.g. '1:3, 5, 10'), we attempt to parse it as e.g. c(1:3, 5, 10) and use it as an index to select columns."
       ed$set_icon("ed-search", "start")
       ed$set_icon("ed-remove", "end")
       ed$set_icon_handler(function(h,...) {
         svalue(ed) <- ""
         focus(ed) <- TRUE
       }, where="end")
       ed$widget$setIconActivatable("primary", FALSE)
       
       search_handler <- function(h,..., do_old=TRUE){
         ## we keep track of old selection here
         ## that updates only when user changes selection, not when filter does
         cur_sel <- old_selection
         blockHandlers(c_names)
         on.exit(unblockHandlers(c_names))
         val <- svalue(ed)
         #print(val)

         if(val == ""){
           c_names[] <<- data_set_nms
           ed$widget$modifyBase(GtkStateType["normal"], NULL)
           ed$widget$modifyText(GtkStateType["normal"], NULL) 
           #break.point("f", F)
         } else if(any(grepl(":", val), grepl(",", val))){
               val.parse <- paste("c(", val, ")", sep="")
               val.numeric <- try(eval(parse(text=val.parse)), TRUE)
               #print(val.numeric)
               if(class(val.numeric) == "try-error"){
                   new_vals <- NULL
               } else {
                   ##drop values outside range of column index
                   val.numeric <- val.numeric[ val.numeric >= 1 ]
                   val.numeric <- val.numeric[ val.numeric <= length(data_set_nms) ]
                   #print(sort(unique(val.numeric)))
                   new_vals <- data_set_nms[sort(unique(val.numeric))]
               }
               if(length(new_vals)){
                   c_names[] <<- new_vals
                   ed$widget$modifyBase(GtkStateType["normal"], NULL)
                   ed$widget$modifyText(GtkStateType["normal"], NULL) 
               } else {
                   c_names[] <<- character(0) 
                   ed$widget$modifyBase(GtkStateType["normal"], "#FF6666")
                   ed$widget$modifyText(GtkStateType["normal"], "white") 
                   tooltip(c_names) <- c_names_tip()
                   return()
               }
         } else {
           l <- c(list(pattern=val, x=data_set_nms), search_type)
           new_vals <- data_set_nms[do.call(grepl, l)]
           if (length(new_vals)) {
             c_names[] <<- new_vals
             ed$widget$modifyBase(GtkStateType["normal"], NULL)
             ed$widget$modifyText(GtkStateType["normal"], NULL) 
           } else {
             c_names[] <<- character(0) 
             ed$widget$modifyBase(GtkStateType["normal"], "#FF6666")
             ed$widget$modifyText(GtkStateType["normal"], "white") 
             tooltip(c_names) <- c_names_tip()
             return()
           }
         }
         svalue(c_names) <<- cur_sel
         tooltip(c_names) <- c_names_tip()
       }

       b <- gbutton("", cont=gp)
       tooltip(b) <- "Search options"
       b$set_icon("properties")

       cbs <- list(gcheckbox("Ignore case", checked=TRUE, handler=function(h,...) {
                             search_type[["ignore.case"]] <<- svalue(h$obj)
                             search_handler(do_old=FALSE)
                             }),
                   gcheckbox("Regex", checked=TRUE, handler=function(h,...) {
                     search_type[["fixed"]] <<- !svalue(h$obj)
                     search_handler(do_old=FALSE)                                                     
                   }),
                   gcheckbox("Perl compatible", checked=FALSE, handler=function(h,...) {
                     search_type[["perl"]] <<- svalue(h$obj)
                     search_handler(do_old=FALSE)                                                     
                   })
       )
       
       addPopupMenu(b, gmenu(cbs, popup=TRUE))

       addHandlerKeystroke(ed, search_handler)
       addHandlerChanged(ed, search_handler)


    c_names <- gcheckboxgroup(data_set_nms, checked=TRUE, cont=c_gp, 
                              use.table=TRUE, expand=TRUE, fill=TRUE, 
                              handler = function(h,...){
                                  tooltip(c_names) <- c_names_tip()
                              })
    c_names_tip <- function(){
        paste(#"Visible:", length(c_names), "/", length(data_set_nms),
              "Selected:", length(svalue(c_names)), "/", length(c_names))
    }
    tooltip(c_names) <- c_names_tip()
    
    ##FIXME sel.col logic is broken
    ##if sel.col is supplied (e.g. for reload) check structure to see if all 
    ##selected variables are still present in reloaded data frame
    if(def.col!=0){
        svalue(c_names, index=TRUE) <- 1:min(def.col, data_set_dim_orig[2])
    }
    if(!is.null(sel.col)){
        ##message to inform user when selection couldn't be restored after window is visible
        if(all(sel.col %in% data_set_nms)) svalue(c_names) <- sel.col
        tooltip(c_names) <- c_names_tip()
    }

    ##continue fancy search functionality
    ##initialize old_selection which will be the output value of c_names
    old_selection <- svalue(c_names)
    #svalue(c_names, index=TRUE) <<- TRUE

                              
    s_gp <- ggroup(cont=c_gp, horizontal=TRUE)
    
    ## Invert selection, select all and select none are all useful in different cases
    b_invert <- gbutton("", cont=ggroup(cont=s_gp), handler = function(h,...) {
        svalue(c_names, index=TRUE) <<- setdiff(1:data_set_dim_orig[2], 
                                               svalue(c_names, index=TRUE))
        #len_cnms_update()
        #h_disp()
    })
    tooltip(b_invert) <- 'Invert selection'
    b_invert$set_icon("jump-to")
 
    b_selall <- gbutton("Select all", cont=ggroup(cont=s_gp), handler = function(h,...) {
        #svalue(c_names, index=TRUE) <- 1:length(data_set_nms)
        svalue(c_names, index=TRUE) <<- TRUE
        #c_names$invoke_change_handler()
        #len_cnms_update()
        #h_disp()
    })
    tooltip(b_selall) <- 'Select all'
    b_selall$set_icon("select-all")

    b_clear <- gbutton("Clear", cont=ggroup(cont=s_gp), handler = function(h,...) {
        #svalue(c_names, index=TRUE) <- integer()
        svalue(c_names, index=TRUE) <<- FALSE
        #len_cnms_update()
        #h_disp()
    })
    tooltip(b_clear) <- 'Select none'
    
    
    ###############################
    ## Filter rows by logical
    if(!is.null(sel.row)){
       #sel.row[[1]]$make_ui(visible=TRUE)
        #print(length(sel.row$l))
        #print(sel.row$l[[1]]$name)
        #print(sel.row$l[[1]]$type)
        #print(class(sel.row$l[[1]])[1])
        filter.type <- c()
        filter.var <- c()
        for(i in sel.row$l){ 
            filter.type <- c(filter.type , class(i)[1])
            filter.var <- c(filter.var , i$name)
        }
        for(i in 1:length(filter.type)) names(filter.type)[i] <- names(
            filter.types)[filter.types == filter.type[i]]
        initial.vars <- data.frame(vars=filter.var, names=filter.var, 
            filter=names(filter.type), stringsAsFactors=FALSE)
        initial.vars[ initial.vars$filter=="preset", "vars"] <- data_set_nms[1]
        #print(initial.vars)
       ##FIXME this should work, but ends up in an error
       #sel.row$l[[1]]$initialize_item()
       #sel.row[[1]]$initialize_item()
       #row_filter <- sel.row
       #row_filter$l[[1]]$initialize_item()
    }
    f_side1bis <- gvbox(cont=f_side1, use.scrollwindow=TRUE, expand=TRUE)
    r_gp <- gframe("<b>Filter rows:</b>", markup=TRUE, cont=f_side1bis, horizontal=FALSE)
    row_filter <- gfilter(data_set, initial.vars=initial.vars, 
                          cont=r_gp, expand=TRUE, head.def=500)


    ## centralized handler helper fun to update size of row/col selection
    len_idxs_update <- function(h, ...) {
        rows <<- svalue(row_filter)
        ##FIXME sometimes this catch is buggy
        ##catch if row_filter outputs all FALSE or empty selection
        if(!any(rows)){
            idxs <<- integer()
            len_idxs <<- 0L
        } else {
            idxs <<- which(rows)                  # move to global variable
            len_idxs <<- length(idxs)                  # move to global variable
        }
        data_set_dim <<- c(len_idxs, len_cnms)
    }
    len_cnms_update <- function(h, ...) {
        cnms <<- old_selection
        len_cnms <<- length(cnms)                  # move to global variable
        data_set_dim <<- c(len_idxs, len_cnms)
    }

    ## centralized handler helper fun to update size in 'display' button
    h_disp <- function(h, ...){
        #rows <<- svalue(row_filter)
        #idxs <<- which(rows)                  # move to global variable
        #len_idxs <<- length(idxs)                  # move to global variable
        #cnms <<- svalue(c_names)
        #cnms <<- old_selection
        #len_cnms <<- length(cnms)                  # move to global variable
        
        ## detect size of data frame to be displayed
        if(any(data_set_dim < c(1,2))){
            enabled(b_disp) <- FALSE
        } else enabled(b_disp) <- TRUE
        
        blockHandlers(b_disp)
        ## dynamically update 'display' button label given current selection
        h_disp_lab <<- paste(' selection (', data_set_dim[1], 
                                          ' x ', data_set_dim[2], ')', sep='')
        svalue(b_disp, append=T) <- paste(if(svalue(ntbk)==1) 'Display' else 
            if(svalue(ntbk)==2) 'Describe' else 
                if(svalue(ntbk)==3) 'Define', h_disp_lab, sep='')
        b_disp$set_icon("execute")
        b_disp_font <<- list(weight = "bold")
        font(b_disp) <- b_disp_font
        unblockHandlers(b_disp)
        
        ## autoupdate when option checked and button enabled
        if( svalue(cb_autoupdate) & enabled(b_disp) ) b_disp$invoke_change_handler()
    }
    # addHandlerChanged(c_names, h_disp)
    # addHandlerChanged(b_selall, h_disp)
    # addHandlerChanged(b_invert, h_disp)
    # addHandlerChanged(b_clear, h_disp)

    ##pick-up changes to row selection
     addHandlerChanged(row_filter, function(h,...) {
        ##update display button
        len_idxs_update()
        h_disp()
     })
    
    ##pick-up changes to col selection
    ##handler for fancy search functionality
    ##needs to be after h_disp() is defined
     addHandlerChanged(c_names, function(h,...) {
       ### XXX selection
       ## have to be careful, as items may be narrowed
       visible_items = c_names[]
       new <- svalue(h$obj)
       old <- intersect(visible_items, old_selection)

       
       added <- setdiff(new, old)
       removed <- setdiff(old, new)

       ## This is sort of tricky, not sure it is correct
       if(length(added) > 0) {
         old_selection <<- unique(c(old_selection, added))
       }
       if(length(removed) > 0) {
         old_selection <<- setdiff(old_selection, removed)
       }
       old_selection <<- data_set_nms[data_set_nms %in% old_selection]
       
       ##update display button
       len_cnms_update()
       h_disp()
     })
    
    ##init dummy handler funs to avoid "not found" error
    h_details <- function() invisible(NULL)
    h_details.ins <- function() invisible(NULL)
    
    ##handler to execute on click of 'display' button
    hb_disp <- function(h,...) {
        #rows <- svalue(row_filter)
        #cnms <<- svalue(c_names)
        #cnms <<- old_selection
        #idxs <<- which(rows)                  # move to global variable
        
        ##store rows/cnms currently being displayed for use in describe()
        rows.disp <<- rows
        cnms.disp <<- cnms
        
        ##FIXME need to make this message tab specific
        ##check if loading a huge data frame and warn user
        if(all( (sum(rows) * length(cnms)) >= 500000, confirm.big.df)){
            bd_huge <- gconfirm('You are about to load a large data frame, 
which may take a long time to display (in 
some cases up to several minutes). 
                   
Do you want to proceed?', title="Warning", icon="warning")
            if(!bd_huge) return()
        }
        
        ##gtkSpinner() functionality
        #add(gsb_dfg, gsb_dfsp)
        #gsb_dfsp$start()
        
        ##by default Display data frame only when the tab is selected
        if(any(!filter.on.tab.sel, svalue(ntbk)==1)){
            h_filter()
            ##signal new display event via button
            #new.disp <<- TRUE
            new.descr <<- TRUE
            new.ctab <<- TRUE
        }
        
        ## custom message when displaying full database.
        if(all(data_set_dim == data_set_dim_orig)){
            svalue(gsb_dfl) <- paste("Displaying the full data set.", sep='')
        } else {
            svalue(gsb_dfl) <- paste('Displaying a ', data_set_dim[1], ' x ', 
                                   data_set_dim[2], " subset.", sep='')
        }
        #gsb_dfsp$stop()
        #gsb_dfg$widget$remove(gsb_dfsp)
        b_disp_font <<- list(weight = "normal")
        font(b_disp) <- b_disp_font
        
        ##update details tab
        ##FIXME ??speed-up: mv this to handler on tab selection
        if(details){
            #print(svalue(ntbk))
            if(any(!details.on.tab.sel, svalue(ntbk)==2)){
                h_details()
                h_details.ins()
                ##signal new describe event via button
                #new.descr <<- TRUE
                new.disp <<- TRUE
                new.ctab <<- TRUE
            }
        }
        
        if(crosstab){
            if(any(!crosstab.on.tab.sel, svalue(ntbk)==3)){
                h_ctab_vars()
                h_ctab_vars.ins(drop.vars=TRUE)
                #h_ctab_clear()

                ##signal new ctab event via button
                #new.ctab <<- TRUE
                new.disp <<- TRUE
                new.descr <<- TRUE
            }
        }

        #print("end-of-button handler")
        #print(paste("new.disp:", new.disp))
        #print(paste("new.descr:", new.descr))
        #print(paste("new.ctab:", new.ctab))
    }
    
    
    h_filter <- function(h, ...){
        ##periodically free up memory
        if(free.mem == 2){
            free.mem.nr <<- free.mem.nr + 1
            if(free.mem.nr == 5){
                h_free.mem()
                free.mem.nr <<- 0
            }
        }
        
        ## now add a data frame
        delete(df_box, df_box[1])             # remove child
        
        ## disable editing if so requested
        if(!editable){
            DF <<- gdf(data_set[rows, cnms], cont=df_box, expand=TRUE, 
                       freeze_attributes=TRUE)
            sapply(1:data_set_dim[2], function(j) editable(DF, j) <- FALSE)

            ## if(editable), disallow row/col c-menu when not all columns/rows are displayed (freeze_attributes=TRUE)
        } else if( all(data_set_dim == data_set_dim_orig) ){
            ## display full data set
            DF <<- gdf(data_set[rows, cnms], cont=df_box, expand=TRUE)
        } else if( all(data_set_dim != data_set_dim_orig) ){
            ## display subset (fewer rows/columns)
            DF <<- gdf(data_set[rows, cnms], cont=df_box, expand=TRUE, 
                       freeze_attributes=TRUE)
        } else if( all(data_set_dim[1] != data_set_dim_orig[1], 
                       data_set_dim[2] == data_set_dim_orig[2])) {
            ## display subset (fewer rows / all columns)
            DF <<- gdf(data_set[rows, cnms], cont=df_box, expand=TRUE, 
                       freeze_attributes="column")
        } else if( all(data_set_dim[1] == data_set_dim_orig[1], 
                       data_set_dim[2] != data_set_dim_orig[2])) {
            ## display subset (all rows / fewer columns)
            DF <<- gdf(data_set[rows, cnms], cont=df_box, expand=TRUE, 
                       freeze_attributes="row")
        }
        DF$set_selectmode("multiple")
        
        ##FIXME move this outside handler? 
        ## use "edited" dirty flag
        addHandlerChanged(DF, handler=function(h,...){
            if(!grepl('*', svalue(w), fixed=T)){
                enabled(do_btn) <- TRUE
                svalue(w) <- paste( svalue(w), '*', sep='')
            }
        })
        if(grepl('*', svalue(w), fixed=T)){
            enabled(do_btn) <- FALSE
            svalue(w) <- paste( substr(svalue(w), 1, (nchar(svalue(w))-1)), sep='')
        }
        
        ##signal that no new display is necessary
        #new.descr <<- FALSE
        #new.ctab <<- FALSE
        new.disp <<- FALSE
        #print("display event")
        #print(paste("new.disp:", new.disp))
        #print(paste("new.descr:", new.descr))
        #print(paste("new.ctab:", new.ctab))
    }
    
    b_disp <- gbutton(paste("Display selection (", data_set_dim_orig[1], ' x ', 
                            data_set_dim_orig[2], ')', sep=''), expand=TRUE, 
                      cont=ggroup(cont=f_side1bis), handler=hb_disp)
    enabled(b_disp) <- TRUE
    b_disp$set_icon("execute")
    #font(b_disp) <- list(weight = "bold")
    
    ## allow to automatically update the viewed subset
    cb_autoupdate <- gcheckbox('Update automatically', cont=ggroup(cont=f_side1bis))
    tooltip(cb_autoupdate) <- "If checked refresh the displayed dataset \nas soon as the column or row selections change."
    
    ##FIXME full editing support for some other time
    ##??editable checkbox (freeze_attributes=TRUE)
    #         cb_do_btn <- gcheckbox('Allow editing', checked=FALSE, cont=ggroup(cont=f_side1), 
    #                                handler=function(h,...){
    #                                    if((grepl('*', svalue(w), fixed=T) & 
    #                                            svalue(cb_do_btn))){
    #                                        enabled(do_btn) <- TRUE
    #                                    }
    #         })
    #         tooltip(obj=cb_do_btn) <- "If checked allow editing of displayed subsets \nin a spreadsheet-like environment."
    
    ##init display button label
    len_idxs_update()
    len_cnms_update()
    #print(data_set_dim)
    h_disp()  ##update display button size given 'preset' filter

    ##activate auto-display of preset filter
    #if(display) hb_disp()
    if(display) b_disp$invoke_change_handler()
    
    ## What to do when you do ...
    if(editable){
        addHandlerClicked(do_btn, function(h,...) {
            ## change me to your liking
            if(gconfirm('Merge changes into the original data frame?', 'Confirm merge...', 
                        icon='question')) {
                ##!!graciously reintegrate when row/col deletion/insertion or NA vals present
                data_set[idxs, cnms] <<- DF[]
                assign(data_set_name, data_set, .GlobalEnv)
                enabled(do_btn) <- FALSE
                svalue(w) <- paste( substr(svalue(w), 1, (nchar(svalue(w))-1)), sep='')
                galert("The original data frame has been modified.", parent=w)
            } else {
                #galert("Modifications cancelled.", parent=w)
            }
        }) 
    }
    #print(size(pg))
    #print(size(c_names))
    #print(size(s_gp))
    #print(sapply(f_side0g$children, function(u) size(u)))
    
    
    ############################
    ##Details tab
    ##FIXME !!details=F is completely broken (as it will affect crosstab too)
    if(details){
    dgg <- ggroup(cont=ntbk, horizontal=TRUE, label=" Details")
    ntbk$add_tab_icon(2, "info")
    ntbk$add_tab_tooltip(2, "Describe data frame")
    
    #svalue(ntbk) <- 1
    dntbk <- gnotebook(2, cont=dgg, expand=TRUE, fill=TRUE)


    #####
    ##Describe sub-tab
    ##FIXME !!add numSummary tab (RcmdrMisc)
    dlgg <- ggroup(cont=dntbk, horizontal=FALSE, label="Describe", expand=TRUE, 
                   use.scrollwindow = TRUE)
    #tooltip(dlgg) <- "Describe the data set that is currently displayed"
    ##radio buttons
    dlgg1 <- ggroup(cont=dlgg, expand=FALSE)
    details_choices <- c("full"="Full data set", "col"="Column selection", 
                        "sel"="Displayed subset", "row"="Row selection")
    r_descr <- gradio(details_choices, 2, horizontal=TRUE, cont=dlgg1
                      #, label="Describe data set"
                      )
    tooltip(dlgg1) <- "Describe the full data set, a column selection (all rows), the currently displayed subset, a row selection (all columns)"
    
    ##handler to update/init describe() output
    h_descr <- function(h,...) {
        radio.sel <<- svalue(r_descr, index=TRUE)
        radio.inst <<- "r_descr"
        r_sync()
    }
    addHandlerChanged(r_descr, h_descr)
    t_descr <- gtext(cont=dlgg, font.attr=list(family="monospace"), 
                     #width=500, height=1000, 
                     expand=TRUE)
    editable(t_descr) <- FALSE

    #####
    ##Summary sub-tab
    dsgg <- ggroup(cont=dntbk, horizontal=FALSE, label="Summary", expand=TRUE, 
                   use.scrollwindow = TRUE)
    #tooltip(dsgg) <- "Describe the data set that is currently displayed"
    ##radio buttons
    dsgg1 <- ggroup(cont=dsgg, expand=FALSE)
    r_summ <- gradio(details_choices, 2, horizontal=TRUE, cont=dsgg1)
    tooltip(dsgg1) <- "Summarise the full data set, a column selection (all rows), the currently displayed subset, a row selection (all columns)"
    
    ##handler to update/init summary() output
    h_summ <- function(h,...) {
        radio.sel <<- svalue(r_summ, index=TRUE)
        radio.inst <<- "r_summ"
        r_sync()
    }
    addHandlerChanged(r_summ, h_summ)
    t_summ <- gtext(cont=dsgg, font.attr=list(family="monospace"), 
                     #width=500, height=1000, 
                     expand=TRUE)
    editable(t_summ) <- FALSE

    #####
    ##Labels sub-tab
    dlabgg <- ggroup(cont=dntbk, horizontal=FALSE, label="Labels", expand=TRUE, 
                   use.scrollwindow = TRUE)
    dlabgg2 <- ggroup(cont=dlabgg, expand=FALSE)
    r_lab <- gradio(details_choices, 2, horizontal=TRUE, cont=dlabgg2)
    tooltip(dlabgg2) <- "Display labels for the full data set, a column selection (all rows), the currently displayed subset, a row selection (all columns)"
    
    ##hideable label
    dlabgg3 <- gexpandgroup("Data frame:", cont=dlabgg, horizontal=FALSE, 
        expand=F, fill=T)
    tooltip(dlabgg3) <- "Label stored in `label(data, self=TRUE)`"
    t_lab.df <- gtext(cont=dlabgg3, font.attr=list(family="monospace"), 
                     width=300, height=25*6, 
                     expand=T, fill=T)
    editable(t_lab.df) <- FALSE
    
    ##helper fun to list label in a dataframe
    list_lab <- function(data=data_set){
        lab <- label(data, self=TRUE)
        if(lab=="") return(NULL)
        cat(lab)
    }

    #lab.out <- list_lab()
    #lab.out.ins <- if(!is.null(lab.out)) capture.output(cat(lab.out)) else 
    #    capture.output(lab.out)
    #lab.out.ins <- capture.output(list_lab())
    #insert(t_lab.df, lab.out.ins, font.attr=list(family="monospace"))
    #if(is.null(lab.out.ins)) visible(dlabgg3) <- FALSE
    #if(all(lab.out.ins=="NULL", 
    #    label(data_set, self=TRUE)!="NULL")) visible(dlabgg3) <- FALSE

    ##handler to update/init label() output
    h_lab <- function(h,...){
        radio.sel <<- svalue(r_lab, index=TRUE)
        radio.inst <<- "h_lab"
        r_sync()
    }
    addHandlerChanged(r_lab, h_lab)

    dlabgg4 <- gexpandgroup("Variables:", cont=dlabgg, horizontal=FALSE, 
        expand=T, fill=T)
    tooltip(dlabgg4) <- "Labels stored in `label(data)`"
    t_lab.var <- gtext(cont=dlabgg4, font.attr=list(family="monospace"), 
                     #width=500, height=1000, 
                     expand=TRUE)
    editable(t_lab.var) <- FALSE
    

    #####
    ##Levels sub-tab
    dlevgg <- ggroup(cont=dntbk, horizontal=FALSE, label="Levels", expand=TRUE, 
                   use.scrollwindow = TRUE)
    dlevgg2 <- ggroup(cont=dlevgg, expand=FALSE)
    r_lev <- gradio(details_choices, 2, horizontal=TRUE, cont=dlevgg2
                      #, label="Describe data set"
    )
    tooltip(dlevgg2) <- "Display levels of factors for the full data set, a column selection (all rows), the currently displayed subset, a row selection (all columns)"
    
    ##helper fun to list levels in a dataframe
    list_levs <- function(data=data_set, vars=NULL){
        if(is.null(vars)) vars <- names(data)
        lev_logi <- sapply(data, class)=="factor"
        if(is_pdata.frame){
            lev_logi <- lev_logi | sapply(data, inherits, "factor")
        }
        lev_nms <- vars[lev_logi]
        if(length(lev_nms)==0) return(NULL)
        levs <- lapply(lev_nms, function(x) levels(data[ , x]))
        names(levs) <- lev_nms
        return(levs)
    }

    ##handler to update/init describe() output
    h_lev <- function(h,...) {
        radio.sel <<- svalue(r_lev, index=TRUE)
        radio.inst <<- "r_lev"
        r_sync()
    }
    addHandlerChanged(r_lev, h_lev)
    t_lev <- gtext(cont=dlevgg, font.attr=list(family="monospace"), 
                     #width=500, height=1000, 
                     expand=TRUE)
    editable(t_lev) <- FALSE
    
    #####
    ##Variables sub-tab
    dvargg <- ggroup(cont=dntbk, horizontal=FALSE, label="Variables", expand=TRUE, 
                   use.scrollwindow = TRUE)
    dvargg2 <- ggroup(cont=dvargg, expand=FALSE)
    r_var <- gradio(details_choices, 2, horizontal=TRUE, cont=dvargg2
                      #, label="Describe data set"
    )
    tooltip(dvargg2) <- "Display variable names for the full data set, a column selection (all rows), the currently displayed subset, a row selection (all columns)"
    
    ##handler to update/init describe() output
    h_var <- function(h,...) {
        radio.sel <<- svalue(r_var, index=TRUE)
        radio.inst <<- "r_var"
        r_sync()
    }
    addHandlerChanged(r_var, h_var)
    t_var <- gtext(cont=dvargg, font.attr=list(family="monospace"), 
                     #width=500, height=1000, 
                     expand=TRUE)
    editable(t_var) <- FALSE
    
    #####
    ##Debugging sub-tab
    ddebgg <- ggroup(cont=dntbk, horizontal=FALSE, label="Debugging", expand=TRUE
                    #, use.scrollwindow = TRUE
                   )
    #ddebgg <- gvbox(cont = dntbk, expand=TRUE)
    #tooltip(dsgg) <- "Describe the data set that is currently displayed"
    ##radio buttons
    ddebgg1 <- ggroup(cont=ddebgg, expand=FALSE)
    r_deb <- gradio(details_choices, 2, horizontal=TRUE, cont=ddebgg1
                      #, label="Describe data set"
                      )
    tooltip(ddebgg1) <- "Display debugging info for the full data set, a column selection (all rows), the currently displayed subset, a row selection (all columns)"
    
    cb_deb <- gcheckbox("Extended debugging details", checked=FALSE, cont=ddebgg)
    tooltip(cb_deb) <- "Check to see additional debugging information"

    ##handler to update/init describe() output
    h_deb <- function(h,...) {
        radio.sel <<- svalue(r_deb, index=TRUE)
        radio.inst <<- "r_deb"
        r_sync()
    }
    addHandlerChanged(r_deb, h_deb)
    df_deb_box <- ggroup(cont=ddebgg, expand=TRUE) ## holds DF_deb instance
    ## create a place-holder that can later be deleted
    DF_deb <- glabel("", cont=df_deb_box, expand=TRUE)
    
    ##hide extended debugging details when requested
    h_cb_deb <- function(h, ...){
        #print(svalue(cb_deb))
        #print(rows.df.deb)
        #if(svalue(cb_deb)) print(rep(TRUE, rows.df.deb)) else
        #    print(1:rows.df.deb %in% 1:8)
        if(svalue(cb_deb)) visible(DF_deb) <<- rep(TRUE, rows.df.deb) else
            ##FIXME need to generalize this
            visible(DF_deb) <<- 1:rows.df.deb %in% 1:8
    }
    addHandlerChanged(cb_deb, h_cb_deb)


    ##focus Describe sub-tab
    svalue(dntbk) <- 1

    ##handler to keep Details radios in sync
    r_sync <- function(h, ...){
        ##details
        if(radio.inst!="r_descr") svalue(r_descr, index=TRUE) <- radio.sel
        if(radio.inst!="r_summ") svalue(r_summ, index=TRUE) <- radio.sel
        if(radio.inst!="r_lab") svalue(r_lab, index=TRUE) <- radio.sel
        if(radio.inst!="r_lev") svalue(r_lev, index=TRUE) <- radio.sel
        if(radio.inst!="r_var") svalue(r_var, index=TRUE) <- radio.sel
        if(radio.inst!="r_deb") svalue(r_deb, index=TRUE) <- radio.sel
        ##crosstab
        if(radio.inst!="r_ctab") svalue(r_ctab, index=TRUE) <- radio.sel
    }
    
    f_details <- function(x=data_set, nm=data_set_name, nms=data_set_nms){
        out <- list()
        out[["descr"]] <- try(describe(x, descript=nm))
        if(!is_pdata.frame) out[["summ"]] <- capture.output(summary(x)) else
            out[["summ"]] <- "NULL"
        out[["lab.df"]] <- capture.output(list_lab()) ##use only data_set
        ##FIXME need to check if this works after subset
        out[["lab.var"]] <- capture.output(label(x))
        out[["lev"]] <- capture.output(list_levs(x, NULL))
        out[["var"]] <- capture.output(dput(names(x)))
        out[["deb"]] <- debug_data.frame(x, full.names = nms)
        return(out)
    }
    
    ##use one handler to rule them all (since subsetting is the bitch)
    h_details <- function(h, choice=radio.sel, ...) {
        choice <- names(details_choices)[choice]
        #print(choice)
        if(choice=='full'){
            ##avoid re-computing if output already exists
            if(is.null(details.out[[choice]])) details.out[[choice]] <<- f_details()
        } else if(choice=='col'){
            ##compute if output does NOT exist
            if(is.null(details.out[[choice]])){
                if(!is_pdata.frame){
                    details.out[[choice]] <<- f_details(droplevels(data_set[ , cnms.disp]))
                } else {
                    details.out[[choice]] <<- f_details(data_set[ , cnms.disp])
                }
            ##avoid re-computing if output already exists & selection same
            } else if(!isTRUE(all.equal(cnms.disp, cnms.descr_old[[choice]]))){
                if(!is_pdata.frame){
                    details.out[[choice]] <<- f_details(droplevels(data_set[ , cnms.disp]))
                } else {
                    details.out[[choice]] <<- f_details(data_set[ , cnms.disp])
                }
            }
            ##store selection of displayed details
            cnms.descr_old[[choice]] <<- cnms.disp
        } else if(choice=='sel'){
            if(is.null(details.out[[choice]])){
                ##FIXME if possible use DF[] conditionally
                #details.out[[choice]] <<- f_details(droplevels(DF[]))
                if(!is_pdata.frame){
                    details.out[[choice]] <<- f_details(droplevels(data_set[rows.disp, cnms.disp]))
                } else {
                    details.out[[choice]] <<- f_details(data_set[rows.disp, cnms.disp])
                }
            } else if(any(!isTRUE(all.equal(cnms.disp, cnms.descr_old[[choice]])), 
                !isTRUE(all.equal(rows.disp, rows.descr_old[[choice]])))){
                #details.out[[choice]] <<- f_details(droplevels(DF[]))
                if(!is_pdata.frame){
                    details.out[[choice]] <<- f_details(droplevels(data_set[rows.disp, cnms.disp]))
                } else {
                    details.out[[choice]] <<- f_details(data_set[rows.disp, cnms.disp])
                }
            }
            cnms.descr_old[[choice]] <<- cnms.disp
            rows.descr_old[[choice]] <<- rows.disp
        } else if(choice=='row'){
            if(is.null(details.out[[choice]])){
                if(!is_pdata.frame){
                    details.out[[choice]] <<- f_details(droplevels(data_set[rows.disp, ]))
                } else {
                    details.out[[choice]] <<- f_details(data_set[rows.disp, ])
                }
            } else if(!isTRUE(all.equal(rows.disp, rows.descr_old[[choice]]))){
                if(!is_pdata.frame){
                    details.out[[choice]] <<- f_details(droplevels(data_set[rows.disp, ]))
                } else {
                    details.out[[choice]] <<- f_details(data_set[rows.disp, ])
                }
            }
            rows.descr_old[[choice]] <<- rows.disp
        }
        
        ##signal that no new describe is necessary
        #new.disp <<- FALSE
        #new.ctab <<- FALSE
        new.descr <<- FALSE
        #print("describe event")
        #print(paste("new.disp:", new.disp))
        #print(paste("new.descr:", new.descr))
        #print(paste("new.ctab:", new.ctab))

        ##signal that no new describe after sync is necessary
        new.descr.sync <<- FALSE
        #print(paste("new.descr.sync:", new.descr.sync))
        #print(paste("new.ctab.sync:", new.ctab.sync))
    }

    h_details.ins <- function(h, choice=radio.sel, ins=details.out, ...){
        choice <- names(details_choices)[choice]
        svalue(t_descr) <- ""
        insert(t_descr, capture.output(ins[[choice]][["descr"]]), 
            font.attr=list(family="monospace"))
        svalue(t_summ) <- ""
        insert(t_summ, ins[[choice]][["summ"]], font.attr=list(family="monospace"))
        ##FIXME speed-up: check if you can do this only when reloading df
        svalue(t_lab.df) <- ""
        insert(t_lab.df, ins[[choice]][["lab.df"]], font.attr=list(family="monospace"))
        #if(all(ins[[choice]][["lab.df"]]=="NULL", 
        #    label(data_set, self=TRUE)!="NULL")) visible(dlabgg3) <- FALSE
        svalue(t_lab.var) <- ""
        insert(t_lab.var, ins[[choice]][["lab.var"]], font.attr=list(family="monospace"))
        svalue(t_lev) <- ""
        insert(t_lev, ins[[choice]][["lev"]], font.attr=list(family="monospace"))
        svalue(t_var) <- ""
        insert(t_var, ins[[choice]][["var"]], font.attr=list(family="monospace"))
        delete(df_deb_box, df_deb_box[1])             # remove child
        DF_deb <<- gdf(ins[[choice]][["deb"]], cont=df_deb_box, expand=TRUE, 
                      freeze_attributes=TRUE)
        if(is.null(rows.df.deb)) rows.df.deb <<- nrow(DF_deb)
        h_cb_deb()
        sapply(1:data_set_dim[2], function(j) editable(DF_deb, j) <- FALSE)
        DF_deb$set_selectmode("multiple")
    }
    
    ##handle change of radio choice in Details tab
    addHandlerChanged(r_descr, function(h, ...){
        if(details.on.tab.sel){
        ##by default update Details only when the tab is selected
            if(svalue(ntbk)==2){
                h_details()
                h_details.ins()
                new.ctab.sync <<- TRUE
                #print("describe sync event")
                #print(paste("new.descr.sync:", new.descr.sync))
                #print(paste("new.ctab.sync:", new.ctab.sync))
            }
        }
    })
    
    
    ############################
    ##Pivot table tab (cross tabulation)
    if(crosstab){
        require(reshape2)
        require(formula.tools)
    cgg <- ggroup(cont=ntbk, horizontal=TRUE, label=" Pivot Table")
    ntbk$add_tab_icon(3, "jump-to")
    ntbk$add_tab_tooltip(3, "Explore data frame using pivot tables (cross tabulations)")
    
    cntbk <- gnotebook(2, cont=cgg, expand=TRUE, fill=TRUE)


    #####
    ##Reshape sub-tab
    clgg <- ggroup(cont=cntbk, horizontal=FALSE, label="Reshape", expand=TRUE, 
                   use.scrollwindow = TRUE)
    #tooltip(clgg) <- "Describe the data set that is currently displayed"
    ##radio buttons
    clgg1 <- ggroup(cont=clgg, expand=FALSE)
    r_ctab <- gradio(details_choices, 2, horizontal=TRUE, cont=clgg1)
    tooltip(clgg1) <- "Generate pivot tables from the full data set, a column selection (all rows), the currently displayed subset, a row selection (all columns)"
    
    ##FIXME !!on radio sync, gracefully redo ctab
    h_rshp <- function(h,...){
        radio.sel <<- svalue(r_ctab, index=TRUE)
        radio.inst <<- "r_ctab"
        r_sync()
    }
    addHandlerChanged(r_ctab, h_rshp)

    clgg2 <- ggroup(cont=clgg)
    cb_ctab <- gcheckbox("Pivot table layout", checked=TRUE, cont=clgg2)
    tooltip(cb_ctab) <- "Uncheck to hide the pivot table layout editor"
    
    h_ctab_hide <- function(h, ...){
        hide_layout.ctab <- !(svalue(cb_ctab))
        if(hide_layout.ctab){
            delete(gg_tb_ctab0, gg_tb_ctab1)
            delete(gg_ctab1, gg_ctab2)
            svalue(pg_ctab) <- 0
            enabled(b_ctab_clear) <- FALSE
        } else {
            add(gg_tb_ctab0, gg_tb_ctab1, expand=T)
            add(gg_ctab1, gg_ctab2)
            svalue(pg_ctab) <- as.integer(size(tb_ctab)[1] + 0)
            enabled(b_ctab_clear) <- TRUE
        }
    }
    addHandlerChanged(cb_ctab, h_ctab_hide)
    
    h_ctab_clear <- function(h, all.fields=TRUE, field.nr=NULL, ...){
        #print(ctab.sel)
        #print(all.fields)
        #print(field.nr)

        ##reset all fields or one field in particular
        idx <- if(all.fields) 1:3 else field.nr
        stopifnot(!is.null(idx))
        #print(idx)
        lapply(idx, function(x){
              ##REQ !!how to speedy delete all children of container
              lapply(lyt_ctab[1,x]$children, function(y) delete(lyt_ctab[1,x], y))
        })
        
        ##reinit global instances
        if(all.fields){
            ##reset all fields
            ctab.dropped <<- c()
            ctab.sel <<- list()
            ##reinit search box
            svalue(ed_search_ctab) <- ""
            ##update gtable variables
            h_ctab_vars.ins()
        } else {
            ##reset one field in particular
            stopifnot(!is.null(field.nr), length(field.nr)==1)
            x <- field.nr
            #print(x)
            ctab.sel_tmp <- ctab.sel[[as.character(x)]]
            ctab.dropped <<- ctab.dropped[!(ctab.dropped %in% ctab.sel_tmp)]
            ctab.sel[[as.character(x)]] <<- character(0)
            #ctab.sel[[as.character(x)]] <<- sapply(lyt_ctab[1,x]$children, 
            #       function(y) svalue(y$children[[1]]))
            #tb_ctab[] <- old_selection[!(old_selection %in% ctab.dropped)]
            ##update gtable variables
            ##active search
            h_ctab_vars.ins(drop.vars=TRUE, tmp.sel=tb_ctab.tmp.sel)
        }

        if(length(ctab.sel[["3"]])!=0){
            h_ctab_reshape()
        } else {
            ##rm displayed ctab
            delete(g_df_ctab_box, g_df_ctab_box[1])             # remove child
            DF_ctab <<- glabel("", cont=g_df_ctab_box, expand=TRUE)
        }
        
        ##take care of Values field
        if(any(all.fields, field.nr == 3)){
            b_melt_var.ctab <<- NULL
            has_b_melt_var <<- FALSE
            ##delete special 'variable` button
            ##FIXME if(field.nr == 3), do NOT rm  g_variable2...fixed
            ##FIXME some related (R:21444): Gtk-CRITICAL **: 
            ##'IA__gtk_container_remove: assertion 'GTK_IS_TOOLBAR (container) || widget->parent == GTK_WIDGET (container)' failed
            #g_dnd_name <- paste("g_", "variable", 2, "...fixed", sep="")
            #try(delete(lyt_ctab[1,2], get(g_dnd_name)), silent=F)
            try(delete(lyt_ctab[1,2], g_variable2...fixed), silent=T)
            g_variable2...fixed <<- NULL
        }
    }
    b_ctab_clear <- gbutton("Clear", cont=clgg2, handler=function(h, ...){ 
                            h_ctab_clear(all.fields=TRUE)
                            })
    tooltip(b_ctab_clear) <- "Clear pivot table and its layout"
    
    pg_ctab <- gpanedgroup(cont=clgg, expand=T, fill=T)
    #svalue(pg_ctab) <- 0.20

    ##FIXME on sync need to check if col sel is incompatible with already added vars
    gg_tb_ctab0 <- gvbox(cont=pg_ctab, expand=T)
    gg_tb_ctab1 <- ggroup(cont=gg_tb_ctab0, expand=T)
    gg_tb_ctab1bis <- gvbox(cont=gg_tb_ctab1, expand=T)

    ##fancy search for selecting ctab variables
    ##prepare the search input box & handler
     vb_search_ctab <- gvbox(container=gg_tb_ctab1bis)
     search_type_ctab <-  list(ignore.case=TRUE, perl=FALSE, fixed=FALSE)  ##init global instance
     gp_search_ctab <- ggroup(cont=vb_search_ctab)
       
       ed_search_ctab <- gedit("", initial.msg="Filter variables by...", expand=TRUE, 
                    container=gp_search_ctab)
       ed_search_ctab$set_icon("ed-search", "start")
       ed_search_ctab$set_icon("ed-remove", "end")
       ed_search_ctab$set_icon_handler(function(h,...) {
         svalue(ed_search_ctab) <- ""
         focus(ed_search_ctab) <- TRUE
       }, where="end")
       ed_search_ctab$widget$setIconActivatable("primary", FALSE)
       
       search_handler_ctab <- function(h,..., do_old=TRUE, 
            choice=radio.sel, ins=ctab.vars.init, dropped.vars=ctab.dropped){
         choice <- names(details_choices)[choice]
         ## we keep track of old selection here
         ## that updates only when user changes selection, not when filter does
         #cur_sel <- old_selection_search_ctab
         blockHandlers(tb_ctab)
         on.exit(unblockHandlers(tb_ctab))
         val <- svalue(ed_search_ctab)

         if(val == "") {
           ##revert to default `gtable` behavior
           tb_ctab.tmp.sel <<- NULL
           h_ctab_vars.ins(drop.vars=TRUE)
           ed_search_ctab$widget$modifyBase(GtkStateType["normal"], NULL)
           ed_search_ctab$widget$modifyText(GtkStateType["normal"], NULL) 
         } else {
           l <- c(list(pattern=val, x=cnms.disp), search_type_ctab)
           #avail_vals <- h_ctab_vars.ins(drop.vars=TRUE, ret=TRUE)
           ##initially do for all vars in gtable..
           avail_vals <- h_ctab_vars.ins(ret=TRUE)
           new_vals <- avail_vals[do.call(grepl, l)]
           #new_vals <- new_vals[!is.na(new_vals)]
           #print(avail_vals)
           #print(new_vals)
           if (length(new_vals)) {
             tb_ctab.tmp.sel <<- new_vals
             h_ctab_vars.ins(drop.vars=TRUE, tmp.sel=tb_ctab.tmp.sel)
             #tb_ctab[] <<- new_vals
             #tb_ctab[] <<- na.omit(new_vals)
             ed_search_ctab$widget$modifyBase(GtkStateType["normal"], NULL)
             ed_search_ctab$widget$modifyText(GtkStateType["normal"], NULL) 
           } else {
             tb_ctab.tmp.sel <<- character(0)
             h_ctab_vars.ins(null.sel=TRUE)
             ed_search_ctab$widget$modifyBase(GtkStateType["normal"], "#FF6666")
             ed_search_ctab$widget$modifyText(GtkStateType["normal"], "white") 
             return()
           }
         }
         #svalue(tb_ctab) <<- cur_sel
       }

       b_search_ctab <- gbutton("", cont=gp_search_ctab)
       tooltip(b_search_ctab) <- "Search options"
       b_search_ctab$set_icon("properties")
       cbs_search_ctab <- list(gcheckbox("Ignore case", checked=TRUE, handler=function(h,...) {
                             search_type_ctab[["ignore.case"]] <<- svalue(h$obj)
                             search_handler_ctab(do_old=FALSE)
                             }),
                   gcheckbox("Regex", checked=TRUE, handler=function(h,...) {
                     search_type_ctab[["fixed"]] <<- !svalue(h$obj)
                     search_handler_ctab(do_old=FALSE)                                                     
                   }),
                   gcheckbox("Perl compatible", checked=FALSE, handler=function(h,...) {
                     search_type_ctab[["perl"]] <<- svalue(h$obj)
                     search_handler_ctab(do_old=FALSE)                                                     
                   })
                   )
       
       addPopupMenu(b_search_ctab, gmenu(cbs_search_ctab, popup=TRUE))

       addHandlerKeystroke(ed_search_ctab, search_handler_ctab)
       addHandlerChanged(ed_search_ctab, search_handler_ctab)


    ##REQ programmatically resize gtable/gdf?
    ##REQ disable c-menu rename column
    ##REQ label variables by factor/char & numeric
    tb_ctab <- gtable(cnms.disp, cont=gg_tb_ctab1bis)
    names(tb_ctab) <- "Variables"
    ##REQ tb_ctab$set_selectmode("multiple")
    #tb_ctab$set_selectmode("multiple")
    #size(tbl) <- c(100, 300)

    ##continue fancy search functionality
    ##initialize old_selection which will be the output value of tb_ctab
    ##!!may rm this as not  used
    #old_selection_search_ctab <- svalue(tb_ctab)


    gg_ctab0 <- gvbox(cont=pg_ctab)
    gg_ctab1 <- ggroup(cont=gg_ctab0)
    gg_ctab2 <- ggroup(cont=gg_ctab1)

    ##FIXME !!implement multiple DnD
    addDropSource(tb_ctab, handler=function(h,...){
        svalue(tb_ctab)
    })
    
    ##FIXME rename handler if don't save copy of subset, and rm all unnecessary checks??
    h_ctab_vars <- function(h, choice=radio.sel, ...) {
        choice <- names(details_choices)[choice]
        #print(choice)
        
        ##FIXME !!on 'define sel' button, when sel is different..
        ##..check what vars are already in fields and drop them with a msg:
        #tb_ctab[] <- old_selection[!(old_selection %in% ctab.dropped)]
        ##FIXME can this check be put below? 
        if(!isTRUE(all.equal(cnms.disp, cnms.ctab_old[[choice]]))){
            h_ctab_clear(all.fields=TRUE)
        } else {
            ##FIXME check if this can be avoided
            svalue(ed_search_ctab) <- ""
        }
        
        if(choice=='full'){
            ##avoid re-computing if output already exists
            if(is.null(ctab.vars.init[[choice]])) ctab.vars.init[[choice]] <<- data_set_nms
        } else if(choice=='col'){
            ##compute if output does NOT exist
            if(is.null(ctab.vars.init[[choice]])){
                ctab.vars.init[[choice]] <<- cnms.disp
                #ctab.vars.init[[choice]] <<- f_details(droplevels(data_set[ , cnms.disp]))
            ##avoid re-computing if output already exists & selection same
            } else if(!isTRUE(all.equal(cnms.disp, cnms.ctab_old[[choice]]))){
                ctab.vars.init[[choice]] <<- cnms.disp
                #ctab.vars.init[[choice]] <<- f_details(droplevels(data_set[ , cnms.disp]))
            }
            ##store selection of displayed details
            cnms.ctab_old[[choice]] <<- cnms.disp
        } else if(choice=='sel'){
            if(is.null(ctab.vars.init[[choice]])){
                ##FIXME if possible use DF[] conditionally
                ctab.vars.init[[choice]] <<- cnms.disp
                #ctab.vars.init[[choice]] <<- f_details(droplevels(DF[]))
                #ctab.vars.init[[choice]] <<- f_details(droplevels(data_set[rows.disp, cnms.disp]))
            } else if(any(!isTRUE(all.equal(cnms.disp, cnms.ctab_old[[choice]])), 
                !isTRUE(all.equal(rows.disp, rows.ctab_old[[choice]])))){
                ctab.vars.init[[choice]] <<- cnms.disp
                #ctab.vars.init[[choice]] <<- f_details(droplevels(DF[]))
                #ctab.vars.init[[choice]] <<- f_details(droplevels(data_set[rows.disp, cnms.disp]))
            }
            cnms.ctab_old[[choice]] <<- cnms.disp
            rows.ctab_old[[choice]] <<- rows.disp
        } else if(choice=='row'){
            if(is.null(ctab.vars.init[[choice]])){
                ctab.vars.init[[choice]] <<- data_set_nms
                #ctab.vars.init[[choice]] <<- f_details(droplevels(data_set[rows.disp, ]))
            } else if(!isTRUE(all.equal(rows.disp, rows.ctab_old[[choice]]))){
                ctab.vars.init[[choice]] <<- data_set_nms
                #ctab.vars.init[[choice]] <<- f_details(droplevels(data_set[rows.disp, ]))
            }
            rows.ctab_old[[choice]] <<- rows.disp
        }
        
        {
            lyt_val <- 3
            lyt_has_child <- try(is.null(lyt_ctab[1,lyt_val]$children[[1]]), silent=T)
            if(!(class(lyt_has_child)=="try-error"))
                h_ctab_reshape()
        }
        
        ##signal that no new ctab is necessary
        #new.disp <<- FALSE
        #new.descr <<- FALSE
        new.ctab <<- FALSE
        #print("ctab event")
        #print(paste("new.disp:", new.disp))
        #print(paste("new.descr:", new.descr))
        #print(paste("new.ctab:", new.ctab))

        ##signal that no new ctab after sync is necessary
        new.ctab.sync <<- FALSE
        #print(paste("new.descr.sync:", new.descr.sync))
        #print(paste("new.ctab.sync:", new.ctab.sync))
    }
    
    ##handler to update variables in gtable instance
    h_ctab_vars.ins <- function(h, choice=radio.sel, ins=ctab.vars.init, 
        drop.vars=FALSE, dropped.vars=ctab.dropped, ret=FALSE, 
        null.sel=FALSE, tmp.sel=NULL, ...){
        #print("go-h_ctab_vars.ins")
        #print(ctab.vars.init)
        #restore.point('f', F)
        
        ##displayed sel should be NULL
        if(null.sel){
            tb_ctab[] <<- data.frame("Variables"=character(0))
            return()
        }

        ##displayed sel is !NULL
        choice <- names(details_choices)[choice]
        selection <- ins[[choice]]
        if(!is.null(tmp.sel)) selection <- tmp.sel
        #if(!is.null(tmp.sel)){
        #    tb_ctab[] <<- data.frame("Variables"=
        #        tmp.sel[!(tmp.sel %in% dropped.vars)])
        #    return()
        #}
        if(!drop.vars){
            out <- selection
            if(ret) return(out) else 
                tb_ctab[] <<- data.frame("Variables"=out)
        } else {
            out <- selection[!(selection %in% dropped.vars)]
            if(ret) return(out) else 
                tb_ctab[] <<- data.frame("Variables"=out)
        }
    }
    
    lyt_ctab <- glayout(homogeneous=F, cont=gg_ctab2, expand=TRUE, fill=T)
    ##FIXME ??add clear button and DnD area to gframe (render 'clear field' more visible UI)
    ##FIXME disable c-menu clear when not needed
    field.nms <- c("Row Fields", "Column Fields", "Values")
    for(i in 1:3){
        lyt_ctab[1,i, expand=TRUE, fill=T] <- 
                f_lyt_ctab[[i]] <- gframe("", horizontal=FALSE,
                              container=lyt_ctab, expand=TRUE, fill=T)
        ##have gframe with custom label (and context menu)
        l_lyt_ctab[[i]] <- glabel(field.nms[i])
        tooltip(l_lyt_ctab[[i]]) <- paste(
            "Right-click on", field.nms[i], "to clear field variables")
        #print(i)
        #print(field.nms[i])
        h_ctab_clear.force <- function(i){
            force(i)
            #print(i)
            function(h, ...){
                h_ctab_clear(all.fields=FALSE, field.nr=i)
            }
        }
        addRightclickPopupMenu(l_lyt_ctab[[i]], 
        #addPopupMenu(l_lyt_ctab[[i]], 
            list(a=gaction("Clear field", icon="clear", 
                    handler=h_ctab_clear.force(i)
                        #function(h, ...){
                        #    h_ctab_clear(all.fields=FALSE, field.nr=i)
                        #}
                        )))
        f_lyt_ctab[[i]]$block$setLabelWidget(l_lyt_ctab[[i]]$block)         # the voodoo
        l_lyt_ctab[[i]]$widget$setSelectable(FALSE)           # may not be needed
    }
    #lyt_ctab[1,2, expand=TRUE, fill=T] <- gframe("Column Fields", horizontal=FALSE,
    #                      container=lyt_ctab, expand=TRUE, fill=T)
    #lyt_ctab[1,3, expand=TRUE, fill=T] <- gframe("Values", horizontal=FALSE,
    #                      container=lyt_ctab, expand=TRUE, fill=T)
    lyt_ctab[1,4, expand=TRUE, fill=T] <- gframe("Options", horizontal=FALSE,
                      container=lyt_ctab, expand=TRUE, fill=T)
    g_cmb.fun_ctab <- ggroup(cont=lyt_ctab[1,4])
    ##FIXME !!add margins cb
    cmb.fun_ctab <- gcombobox(c("length", "length2", "mean", "median", "sd", "var", "sum"), editable=TRUE, 
              use_completion=TRUE, cont=g_cmb.fun_ctab)
    #size(cmb.fun_ctab) <- c(140,25)
    cmb.fun.args_ctab <- gcombobox(c("", "na.rm=TRUE"), selected=1, editable=TRUE, 
              use_completion=TRUE, cont=g_cmb.fun_ctab)
    
    g_df_ctab_box <- ggroup(cont=gg_ctab0, expand=T)
    DF_ctab <- glabel("", cont=g_df_ctab_box, expand=TRUE)
    
    h_ctab_reshape <- function(h, choice=radio.sel, ...){
        ##FIXME !!strange issue with varname_varname when:
        ##'    adding two value vars
        ##'    adding grp on col field
        ##'    rm grp in col field
        ##'    rm 1 value var
        ##'    Error in eval(expr, envir, enclos) : object 'variable' not found
        ##FIXME !!error when row selection is zero
        ##Error in dim(ordered) <- ns : 
		##  dims [product 1] do not match the length of object [0]
		##Error in names(details_choices)[choice] : 
		##  invalid subscript type 'externalptr'
        #print(ctab.sel[["1"]])
        #print(ctab.sel[["2"]])
        choice <- names(details_choices)[choice]
        ##use melt if two or more Value vars
        use.melt <- length(ctab.sel[["3"]]) >= 2
        form.ctab <- formula(paste(
            if(any(is.null(ctab.sel[["1"]]), length(ctab.sel[["1"]])==0)) "." else 
                paste(unlist(ctab.sel[["1"]]), collapse=" + "), 
            if(any(is.null(ctab.sel[["2"]]), length(ctab.sel[["2"]])==0)) 
                ifelse(!use.melt, ".", "variable") else 
                    paste(c(unlist(ctab.sel[["2"]]), if(use.melt) "variable"), collapse=" + "), 
            sep=" ~ "))
        if(use.melt){
            form.vars.ctab <- all.vars(form.ctab)
            form.vars.ctab <- form.vars.ctab[!(form.vars.ctab %in% ".")]
            form.vars.ctab <- form.vars.ctab[!grepl("variable", form.vars.ctab, fixed=T)]
            m.data_set <- melt(
                            if(choice=='full') data_set else 
                            if(choice=='col') data_set[ , cnms.disp] else 
                            if(choice=='sel') data_set[rows.disp , cnms.disp] else 
                            if(choice=='row') data_set[rows.disp , ], 
                id.vars=form.vars.ctab, 
                measure.vars=unlist(ctab.sel[["3"]]))
            #form.ctab <- update(form.ctab, ~ . + variable)
        }
        #print(form.ctab)
        #print(svalue(cmb.fun_ctab))
        fun.args_ctab <- as.list(parse(text=paste0("f(", svalue(cmb.fun.args_ctab) , ")"))[[1]])[-1]
        #print(fun.args_ctab)
        ##assume df is already molten (in long-format)
        ##FIXME use try to catch incorrect arguments
        df.ctab <- do.call(dcast, 
                         c(list(if(use.melt) m.data_set else {
                         ##FIXME ??speed-up: mv this into h_ctab_vars and have copy of subset (doc consider memory usage, though)
                            if(choice=='full') data_set else 
                            if(choice=='col') data_set[ , cnms.disp] else 
                            if(choice=='sel') data_set[rows.disp , cnms.disp] else 
                            if(choice=='row') data_set[rows.disp , ]
                         }, 
                         form.ctab, fun.aggregate=get(svalue(cmb.fun_ctab))), 
                         fun.args_ctab, 
                         list(value.var=if(!use.melt) unlist(ctab.sel[["3"]]) else "value")))
        ##FIXME fix this wehn melt involved
        if(!use.melt){
            cat(paste("dcast(", data_set_name, ", ", form.ctab, ", fun.aggregate=", 
                    svalue(cmb.fun_ctab), ", ", if(length(fun.args_ctab)!=0) paste(
                        svalue(cmb.fun.args_ctab), ", ", sep=""),
                    "value.var='", unlist(ctab.sel[["3"]]), "')", sep=""), "\n\n")
        }
        ##update GUI
        if(use.melt){
            ##FIXME check that no clash with "variable" var in data_set_nms
            ##FIXME make it possible to move buttons between row/col fields
            #b_dnd <- "variable"
            #x <- 2
            #g_dnd_name <- paste("g_", b_dnd, x, "...fixed", sep="")
            if(!has_b_melt_var){
                #print(g_dnd_name)
                #g_variable2...fixed <<- ggroup(cont=lyt_ctab[1,x])
                g_variable2...fixed <<- ggroup(cont=lyt_ctab[1,2])
                #assign(g_dnd_name, ggroup(cont=lyt_ctab[1,x]))
                #b_melt_var.ctab <<- gbutton(b_dnd, cont=get(g_dnd_name), expand=F, fill=F, 
                b_melt_var.ctab <<- gbutton("variable", cont=g_variable2...fixed, expand=F, fill=F, 
                    handler=function(h, ...){
                    #delete(lyt_ctab[1,x], get(g_dnd_name))
                    delete(lyt_ctab[1,2], g_variable2...fixed)
                    g_variable2...fixed <<- NULL
                    #ctab.dropped <<- ctab.dropped[!(ctab.dropped %in% b_dnd)]
                    #tb_ctab[] <- old_selection[!(old_selection %in% ctab.dropped)]
                    #ctab.sel_tmp <- ctab.sel[[as.character(x)]]
                    #ctab.sel[[as.character(x)]] <<- ctab.sel_tmp[!(ctab.sel_tmp %in% b_dnd)]
                    #delete(g_df_ctab_box, g_df_ctab_box[1])             # remove child
                    #DF_ctab <<- glabel("", cont=g_df_ctab_box, expand=TRUE)
                    #lyt_has_child <- try(is.null(lyt_ctab[1,lyt_val]$children[[1]]), silent=T)
                    ##FIXME there is an error here
                    #if(names(lyt_ctab[1,x]) != "Values"){
                    #	if(class(lyt_has_child)=="try-error") return()
                    })
                blockHandlers(b_melt_var.ctab)
                font(b_melt_var.ctab) <- list(color = "darkblue")
				has_b_melt_var <<- TRUE
            }
        }
        ##insert resulting cross tab in the gui
        delete(g_df_ctab_box, g_df_ctab_box[1])             # remove child
        DF_ctab <<- gdf(df.ctab, cont=g_df_ctab_box, expand=TRUE, 
                       freeze_attributes=TRUE)
        sapply(1:ncol(DF_ctab), function(j) editable(DF_ctab, j) <- FALSE) 
		DF_ctab$set_selectmode("multiple")
    }
    
    ##FIXME Error in get(svalue(cmb.fun_ctab)) : object 'ma' not found
    ##FIXME !!be more selective when activate h_ctab_reshape: put check inside fun
    ##(e.g. it activates even if no Value var)
	#    Error in if (!(value.var %in% names(data))) { : 
	#  argument is of length zero
    addHandlerChanged(cmb.fun_ctab, function(h, ...){
		#svalue(cmb.fun.args_ctab) <- ""
		h_ctab_reshape()
	})
	##FIXME need to think of a way to request confirmatoin from user when finished inputting args
    addHandlerChanged(cmb.fun.args_ctab, h_ctab_reshape)
    
    ##handle change of radio choice in Crosstab tab
    addHandlerChanged(r_ctab, function(h, ...){
        if(crosstab.on.tab.sel){
        ##by default update Crosstab only when the tab is selected
            if(svalue(ntbk)==3){
                h_ctab_vars()
                h_ctab_vars.ins(drop.vars=TRUE)
                #h_ctab_clear()
                new.descr.sync <<- TRUE
                #print("ctab sync event")
                #print(paste("new.descr.sync:", new.descr.sync))
                #print(paste("new.ctab.sync:", new.ctab.sync))
            }
        }
    })


    ##FIXME ??allow duplication of vars from one target to another (using ctrl+DnD)
    ##FIXME allow reverse DnD, to allow rm of buttons from target area
    ##FIXME ??add rm button in front (or have buttons with close buttons)
    ##REQ can gdf() handle arrays (acast)
    lapply(1:3, function(x){
        addDropTarget(lyt_ctab[1,x], handler=function(h,...) {
            lyt_val <- 3
            b_dnd <- h$dropdata
            field.nm <- svalue(l_lyt_ctab[[x]])
            #print(b_dnd)
            #print(field.nm)
            ##REQ how to disable DnD notification when button is already present
            ##refuse spurious drops
            ##FIXME !!radio sync: respect radio sel on drop: old_selection | data_set_nms
            ##'use a r_sync.sel global var
            if(!(b_dnd %in% old_selection)) return()
            #print(length(lyt_ctab[1,x]$children))
            ctab.sel[[as.character(x)]] <<- sapply(lyt_ctab[1,x]$children, 
                               function(y) svalue(y$children[[1]]))
            #print(unlist(ctab.sel))
            if(any(unlist(ctab.sel) %in% b_dnd)) return()
            #gbutton(h$dropdata, cont=lyt_ctab[1,x])
            #break.point()
            lyt_has_child <- try(is.null(lyt_ctab[1,lyt_val]$children[[1]]), silent=T)
            lyt_has_child_2nd <- try(is.null(lyt_ctab[1,lyt_val]$children[[2]]), silent=T)
            ##FIXME add message to inform users of failed DnD, or tooltip
            if(field.nm == "Values"){
                ##if only 1 Value exists, rm fixed 'variable' button
                if(class(lyt_has_child)!="try-error"){
            if(F){
                    lyt_val_tmp <- svalue(lyt_ctab[1,x]$children[[1]]$children[[1]])
                    #print(lyt_val_tmp)
                    ctab.dropped <<- ctab.dropped[!(ctab.dropped %in% lyt_val_tmp)]
                    tb_ctab[] <- old_selection[!(old_selection %in% ctab.dropped)]
                    ctab.sel_tmp <- ctab.sel[[as.character(x)]]
                    ctab.sel[[as.character(x)]] <<- ctab.sel_tmp[!(ctab.sel_tmp %in% 
                        lyt_val_tmp)]
                    #ctab.sel[[as.character(x)]] <<- list()
                    #print(ctab.sel[["3"]])
                    delete(lyt_ctab[1,x], lyt_ctab[1,x]$children[[1]])
            }
                }
            }
            g_dnd_name <- paste("g_", b_dnd, x, sep="")
            assign(g_dnd_name, ggroup(cont=lyt_ctab[1,x]))
            gbutton(b_dnd, cont=get(g_dnd_name), expand=F, fill=F, 
				handler=function(h, ...){
				#print("asdf")
                #print(x)
                #print(ctab.sel[["1"]])
                #print(ctab.sel[["2"]])
                delete(lyt_ctab[1,x], get(g_dnd_name))
				ctab.dropped <<- ctab.dropped[!(ctab.dropped %in% b_dnd)]
				#tb_ctab[] <- old_selection[!(old_selection %in% ctab.dropped)]
                #restore.point('f', F)
                ##take into account if there is an active search
                if(is.null(tb_ctab.tmp.sel)){
                    h_ctab_vars.ins(drop.vars=TRUE)
                } else {
                    ##active search
                    h_ctab_vars.ins(drop.vars=TRUE, tmp.sel=tb_ctab.tmp.sel)
                }
				ctab.sel_tmp <- ctab.sel[[as.character(x)]]
				ctab.sel[[as.character(x)]] <<- ctab.sel_tmp[!(ctab.sel_tmp %in% b_dnd)]
				delete(g_df_ctab_box, g_df_ctab_box[1])             # remove child
				DF_ctab <<- glabel("", cont=g_df_ctab_box, expand=TRUE)
				lyt_has_child <- try(is.null(lyt_ctab[1,lyt_val]$children[[1]]), silent=T)
				if(class(lyt_has_child)=="try-error") return()
                ##FIXME !!some error still lurking with many changes to layout: click 1st Value button and then 'var' doesn't get rmed
                ##Error in eval(expr, envir, enclos) : object 'variable' not found
                if(field.nm == "Values"){
                    if(all(class(lyt_has_child_2nd)=="try-error", has_b_melt_var)){
                        #print('go')
                        #restore.point('f', F)
                        #lyt_ctab[1,2]$children[[1]]
                        #for(i in 1:2)
                        #    try(delete(lyt_ctab[1,i], 
                        #               get(paste("g_", "variable", 2, "...fixed", sep=""))))
                        unblockHandlers(b_melt_var.ctab)
                        b_melt_var.ctab$invoke_change_handler()
                        b_melt_var.ctab <<- NULL
                        has_b_melt_var <<- FALSE
                    }
                }
                #print("go2")
				#print(ctab.sel[["1"]])
				#print(ctab.sel[["2"]])
                #break.point()
				h_ctab_reshape()
            })
#             b_dnd_name <- paste("b_", b_dnd, sep="")
#             assign(b_dnd_name, gbutton(b_dnd, cont=get(g_dnd_name), expand=F, fill=F))
#             addHandlerRightclick(get(b_dnd_name), handler=function(h, ...){
# 				print("asdf")
# 				delete(lyt_ctab[1,x], h$parent)
#             })
            #gg_val <- ggroup(cont=lyt_ctab[1,x])
            #gbutton(h$dropdata, cont=gg_val)
            #addSpring(gg_val)
            ctab.dropped <<- c(ctab.dropped, b_dnd)
            #tb_ctab[] <- old_selection[!(old_selection %in% ctab.dropped)]
            #print("here")
            #restore.point('f', F)
            ##take into account if there is an active search
            if(is.null(tb_ctab.tmp.sel)){
                h_ctab_vars.ins(drop.vars=TRUE)
            } else {
                ##active search
                h_ctab_vars.ins(drop.vars=TRUE, tmp.sel=tb_ctab.tmp.sel)
            }
            ctab.sel[[as.character(x)]] <<- c(ctab.sel[[as.character(x)]], b_dnd)
            #print(ctab.sel)
            ##do not initiate cross-tab if no value.var selected
            if(field.nm != "Values"){
                if(class(lyt_has_child)=="try-error") return()
            }
            h_ctab_reshape()
        })
    })
    
    }
    
    ##init Details tab on start-up
    ##default to column selection or subset selection ??
    radio.sel <- 3
    radio.inst <- ""
    r_sync()
    ##by default update Details only when the tab is selected
    if(!details.on.tab.sel){
        h_details()
        h_details.ins()
    }
    ##by default update Crosstab only when the tab is selected
    if(!crosstab.on.tab.sel){
        h_ctab_vars()
        h_ctab_vars.ins()
    }

    ##focus Filter tab
    svalue(ntbk) <- 1
    ##FIXME thoroughly test !details.on.tab.sel
    if(details.on.tab.sel){
        ##by default update Details only when the tab is selected
        ##and if there is a newly displayed data frame
        addHandlerChanged(ntbk, function(h, ...){
                if(h$page.no==2){
                    if(any(new.descr, new.descr.sync)){
                        h_details()
                        h_details.ins()
                    }
                    blockHandlers(b_disp)
                    svalue(b_disp, append=T) <- paste('Describe', h_disp_lab, sep='')
                    b_disp$set_icon("execute")
                    font(b_disp) <- b_disp_font
                    unblockHandlers(b_disp)
                    #print("switch-to-tab-2 event")
                    #print(paste("new.disp:", new.disp))
                    #print(paste("new.descr:", new.descr))
                    #print(paste("new.ctab:", new.ctab))
                }
            })
    }
	}
    if(filter.on.tab.sel){
        ##by default update Filter only when the tab is selected
        ##and if there is a newly displayed data frame
        addHandlerChanged(ntbk, function(h, ...){
                if(h$page.no==1){
                    if(new.disp){
                        h_filter()
                    }
                    blockHandlers(b_disp)
                    svalue(b_disp, append=T) <- paste('Display', h_disp_lab, sep='')
                    b_disp$set_icon("execute")
                    font(b_disp) <- b_disp_font
                    unblockHandlers(b_disp)
                    #print("switch-to-tab-1 event")
                    #print(paste("new.disp:", new.disp))
                    #print(paste("new.descr:", new.descr))
                    #print(paste("new.ctab:", new.ctab))
                }
            })
    }

    if(crosstab.on.tab.sel){
        ##by default update Crosstab only when the tab is selected
        ##and if there is a newly displayed data frame
        addHandlerChanged(ntbk, function(h, ...){
                if(h$page.no==3){
                    if(any(new.ctab, new.ctab.sync)){
                        h_ctab_vars()
                        h_ctab_vars.ins(drop.vars=TRUE)
                        #h_ctab_clear()
                    }
                    blockHandlers(b_disp)
                    svalue(b_disp, append=T) <- paste('Define', h_disp_lab, sep='')
                    b_disp$set_icon("execute")
                    font(b_disp) <- b_disp_font
                    unblockHandlers(b_disp)
                    #print("switch-to-tab-3 event")
                    #print(paste("new.disp:", new.disp))
                    #print(paste("new.descr:", new.descr))
                    #print(paste("new.ctab:", new.ctab))
                }
            })
    }


    ##update button label given tab selection
    ##FIXME something doesn't work as expected
#     addHandlerChanged(ntbk, function(h, ...){
#         svalue(b_disp, append=T) <- paste(if(h$page.no==1) 'Display' else 
#             if(h$page.no==2) 'Describe', h_disp_lab, sep='')
#         b_disp$set_icon("execute")
#     })

    ##set GUI window parameters
    ##set sizes
    size(w) <- c(750, 600)
    
    ##FIXME if mv visible call down, then pg doesn't resize correctly
    visible(w) <- TRUE
    svalue(pg) <- as.integer(size(b_disp)[1] + 20)
    #svalue(pg) <- 0.42
    #svalue(pg) <- 250L
    ## use 5 lines as hight of selection box (less claustrophobic)
    size(c_names)[2] <- 5*25
    svalue(f_side1) <- 0.33
    ##FIXME it works here, but not above
    svalue(pg_ctab) <- 0.15
    #size(gg_ctab2) <- c(1000, 300)
    ##REQ setting one dim makes the other stuck (prove with DnD)
    #size(lyt_ctab)[2] <- 100
    #size(lyt_ctab[1,1])[1] <- c(250)
    #size(lyt_ctab[1,4]) <- c(100, 100)
    ##REQ/FIXME generates assertion
    ##(R:18255): Gtk-CRITICAL **: IA__gtk_table_attach: assertion 'child->parent == NULL' failed
    size(lyt_ctab[1,4])[2] <- c(100)
    #print(size(gg_ctab2))
    #print(size(lyt_ctab))
    #print(size(lyt_ctab[1,1]))
    #print(size(lyt_ctab[1,2]))

    
    ##initially focus the c_names search box
    ##FIXME not sure if you want this
    focus(ed) <- TRUE

    ##activate hidden panel
    if(hide) b_hide$invoke_change_handler()
    
    ###pop up notifications to users
    ##inform users of previous fixes to duplicate names
    if(dupl.names){
        galert("Duplicate names detected and made unique.", 
               "Duplicate names", 
               delay = 7, parent = w)
    }
    
    ##BUG only last one makes it through
    if(na.names){
        galert("NA names detected and made unique.", 
               "NA names", 
               delay = 7, parent = w)
    }
    
    ##inform users of failure to restore column selection
    if(!is.null(sel.col)){
        galert("Column selection couldn't be restored as the structure of the data frame has changed. Reverting to default selection.", 
               "Column selection", 
               delay = 7, parent = w)
    } 
    
    
    ##set some key-bindings
#     if(esc){
#         h_esc <- addHandlerKeystroke(w, function(h, ...){
#             if(h$key=="\033") dispose(w)
#         })
#         #print(h_esc)
#         #break.point()
#         addHandlerBlur(w, function(h, ...){
#             #print(h_signal <- addHandler(w, "key-release-event"))
#             #print(addHandler(h_esc))
#             blockHandler(w, h_esc)
#             #on.exit(unblockHandler(w, h_esc))
#         })
#     }
}

# require(MASS)
# Xa <- Cars93 ## this will be in a function... replace with your won
# Xa[3:7,1] <- NA
# Xa[3:7,"Price"] <- NA
# Xa$Model1 <- as.character(Xa$Model)
# Xa[2,'Model1'] <- paste(rep(letters, 26), collapse='')
# Xa$Man.trans.avail1 <- as.logical(Xa$Man.trans.avail)
# Xa$Man.trans.avail1 <- ifelse(Xa$Man.trans.avail=='Yes', TRUE, FALSE)
# x <- mtcars
# for(i in 1:400) x <- rbind(x, mtcars)
# for(i in 1:5) x <- cbind(x, x)
View <- dffilter

dffilter_reload <- function(...){
    #dffilter(data_set=.data_set, display, maximize, editable)
    dffilter(...)
}

##FIXME more efficient way of doing this? 
debug_data.frame <- function(data, 
                             funs.def=c("position"=invisible, 
                                        "class"=class, "mode"=mode, 
                                        "complete.cases"=function(x) sum(complete.cases(x)), 
                                        "is.na"=function(x) sum(is.na(x)), 
                                        "is.nan"=function(x) sum(is.nan(x)),
                                        "is.finite"=function(x) sum(is.finite(x)),
                                        "is.infinite"=function(x) sum(is.infinite(x)),
                                        "length(unique(nchar(x)))"=function(x) 
                                            length(unique(nchar(as.character(x)))),
                                        "unique(nchar(x))"=function(x) 
                                            paste(sort(unique(nchar(as.character(x)))), 
                                                  collapse=" "), 
                                        "is_alnum"=function(x) sum(is_alnum(x)),
                                        "is_alpha"=function(x) sum(is_alpha(x)),
                                        "is_digit"=function(x) sum(is_digit(x)),
                                        "is_punct"=function(x) sum(is_punct(x)),
                                        "is_notalnum"=function(x) sum(is_notalnum(x))
                             ), 
                             funs.add=NULL, full.names=data_set_nms){
    funs <- c(funs.def, funs.add)
    #out <- data[ FALSE , ]
    out <- as.data.frame(lapply(data[ FALSE , ], as.character), stringsAsFactors=FALSE)
    ##FIXME put checks on what fun outputs
    for(i in 1:length(funs)){
        ##DEBUG
        #if(names(funs[i])=="unique(nchar())") break.point()
        # browser()
        if(names(funs[i])=="position") 
            out[i, ] <- sapply(names(data), grep, full.names) else
                out[i, ] <- sapply(data, funs[[i]])
        row.names(out)[i] <- names(funs[i])
    }
    return(out)
}
#debug_data.frame(iris)

##FIXME add is_notalpha, is_notdigit, etc.?
is_alnum <- function(x) {grepl("[[:alnum:]]", x)}  ##Alphanumeric characters
is_alpha <- function(x) {grepl("[[:alpha:]]", x)}  ##Alphabetic characters
is_digit <- function(x) {grepl("[[:digit:]]", x)}  ##Digits
is_punct <- function(x) {grepl("[[:punct:]]", x)}  ##Punctuation characters
is_notalnum <- function(x) {grepl("[^[:alnum:]]", x)}  ##Non-Alphanumeric characters
landroni/dffilter documentation built on May 21, 2017, 8:30 a.m.