Mock up of factor editor for gdf

factor-editor.R

##' I want
##' * relabel a factor
##' * collapse one or more factors
##' * append a level to a factor
##' * Select a factor to be the reference
##' * reorder factors (and make ordered along the way)
##'
##'

library(gWidgets2)
options(guiToolkit="RGtk2")

library(MASS)
f <- Cars93$Type

## adjust these properties during dialog
cur_reference_level <- f[1]

w <- gwindow("Edit factor")
g <- gpanedgroup(container=w, expand=TRUE)

lg <- gvbox(container=g)
cur_levels <- gtable(levels(f), container=lg,
                     multiple=TRUE,
                     expand=TRUE, fill="y")
names(cur_levels) <- "Levels"
cur_levels$remove_popup_menu()

bg <- ggroup(cont=lg)
add_level <- gbutton("add", cont=bg, handler=function(h,...) {
  add_level_dialog()
})
tooltip(add_level) <- gettext("Add a new level to factor")

is_ordered <- gcheckbox("Ordered", container=bg, checked=is.ordered(f))
tooltip(is_ordered) <- gettext("Toggle if factor is ordered")


## right group
rg <- ggroup(container=g, expand=TRUE, fill="both")
cur_child <- gvbox(container=rg, expand=TRUE)
glabel("Directions...", cont=cur_child, anchor=c(-1,0))

## show different things based on selection...
none_selected <- function() {
  delete(rg, cur_child)
  cur_child <<- gvbox(container=rg, expand=TRUE)
  glabel("Directions...", cont=cur_child, anchor=c(-1, 0))
}

one_selected <- function() {
  ## if one_is selected
  delete(rg, cur_child)
  cur_child <<- gvbox(container=rg, expand=TRUE)

  ## offer to relabel
  glabel(gettext("Relabel:"), container=cur_child, anchor=c(-1,0))
  rename_level <- gedit(svalue(cur_levels),
        container=cur_child)
  gseparator(container=cur_child)
  
  ## give choice of making ordered, or adjusting order
  if(svalue(is_ordered)) {
    bg <- ggroup(cont=cur_child)
    move_up <- gbutton("up", cont=bg, handler=function(h,...) {
      ind <- svalue(cur_levels, ind=TRUE)
      cur <- cur_levels[]
      cur[c(ind-1,ind)] <- cur[c(ind, ind-1)]
      cur_levels[] <- cur
      svalue(cur_levels) <- ind - 1
      selection_changed()
    })
    move_down <- gbutton("down", cont=bg, handler=function(h,...) {
      ind <- svalue(cur_levels, ind=TRUE)
      cur <- cur_levels[]
      cur[c(ind,ind + 1)] <- cur[c(ind+1, ind)]
      cur_levels[] <- cur
      svalue(cur_levels) <- ind + 1
      selection_changed()
    })
    tooltip(move_up) <- gettext("Move selected level up in the order")
    tooltip(move_down) <- gettext("Move selected level down in the order")

    
    cur_ind <- svalue(cur_levels, ind=TRUE)
    nlevs <- length(cur_levels[])

    enabled(move_up) <- cur_ind > 1
    enabled(move_down) <- cur_ind < nlevs
  } else {
    ## can make ordered *or* make reference level
    bg <- ggroup(container=cur_child)
    ref_button <- gbutton("Set as reference", cont=bg, handler=function(h,...) {
      ind <- svalue(cur_levels, index=TRUE)
      if (ind == 1) return()
      
      cur_reference_level <<- svalue(cur_levels)
      blockHandler(cur_levels)
      tmp <- cur_levels[]
      tmp[c(1, ind)] <- tmp[c(ind, 1)]
      cur_levels[] <- tmp
      svalue(cur_levels, index=TRUE) <- 1
      unblockHandler(cur_levels)
    })
    tooltip(ref_button) <- "
For an unordered factor, the top most level is set
as the reference level.Clicking this button will
move the selected level to the top.
"
      
  }
  
  addSpring(cur_child)
  
  addHandlerChanged(rename_level, handler=function(h,...) {
    blockHandler(rename_level)
    ind <- svalue(cur_levels, index=TRUE)
    new_name <- svalue(h$obj)
    tmp <- cur_levels[]
    tmp[ind] <- new_name
    cur_levels[] <- tmp
    svalue(cur_levels, index=TRUE) <- ind
    svalue(rename_level) <- ""
    unblockHandler(rename_level)
    focus(cur_levels) <- TRUE
    

  })
}

more_than_one_selected <- function() {
  delete(rg, cur_child)
  cur_child <<- gvbox(container=rg, expand=TRUE)

  glabel("Collapse selected levels to:", container=cur_child, anchor=c(-1,0))
  collapse_levels <- gedit("", intial.msg="Collapse levels to...",
                           container=cur_child)
  addSpring(cur_child)
  
  addHandlerChanged(collapse_levels, handler=function(h,...) {
    blockHandler(cur_levels); 

    ind <- svalue(cur_levels, index=TRUE)
    if (length(ind) < 2)
      return()
    
    tmp <- cur_levels[]
    tmp[ind] <- svalue(collapse_levels)
    tmp <- tmp[-sort(ind)[-1]]
    cur_levels[] <- tmp
    unblockHandler(cur_levels)
    
    svalue(cur_levels, index=TRUE) <- sort(ind)[1]
  })
}

##
selection_changed <- function(...) {
  ind <- svalue(cur_levels, index=TRUE)
  if(length(ind) == 0)
    none_selected()
  else if(length(ind) == 1)
    one_selected()
  else
    more_than_one_selected()
}

  
addHandlerSelectionChanged(cur_levels, handler=selection_changed)
addHandlerChanged(is_ordered, handler=function(...) {
  ind <- svalue(cur_levels, index=TRUE)
  if (length(ind)==0 || ind < 1)
    ind <- 1
  svalue(cur_levels, index=TRUE) <- ind
})







##
add_level_dialog <- function() {
  ## add a level to current levels
  dlg <- gbasicdialog(parent=w, handler=function(...) {
    new_val <- svalue(e)
    tmp <- cur_levels[]
    if(nchar(new_val) > 0 && !(new_val %in% tmp)) {
      blockHandler(cur_levels)

      tmp <- c(tmp, new_val)
      cur_levels[] <- tmp

      unblockHandler(cur_levels)
      svalue(cur_levels, index=TRUE) <- length(tmp)
    }
  })
  g <- gvbox(cont=dlg)
  glabel("Add a new level to factor ...", cont=g, anchor=c(-1,0))
  e <- gedit("", container=g)
  visible(dlg, TRUE)
}