#########################################################
## Copyright (c) 2005
## University of Washington
## Licensed under the terms set forth by University of
## Washington. If you did not sign such a license, you
## are using this software/code illegally and you do not
## have permission to use, modify, or redistribute
## this or any files in this software package.
##
## File: clusterui.r
##
## GUI elements for clustering in EDGE
#########################################################

require(tcltk, quietly = TRUE, keep.source = FALSE)  || stop("TCLTK support is absent.")

source("modal.r")
source("cluster.r")
source("includeui.r")
source("thread.r")

###################################################################
## Creates a "storeyclust.combo.options" object, that has
## settings for clustering and plotting data.
###################################################################
new.storeyclust.combo.options <- function(
  cluster.options,
  plot.options,
  action) {

  options <- list(cluster.options=cluster.options, plot.options=plot.options, action=action)
  class(options) <- "storeyclust.combo.options"
  return(options)
}

###################################################################
## Creates a Tcl/Tk frame with clustering and clusterplot options,
## and buttons that actually run the clustering or plotting
## algorithms.
## The frame may be packed into a Tcl/Tk window.
##
## Arguments:
##    parentwindow : the parent for the cluster options frame
##    data : the data to be clustered
##    uidefaults : (See includeui.r) a "uidefaults" list with the
##      fonts, colors etc. for the frame's text
##    rowNames : row names to add to the eventual plot
##    colNames : column names to add to the eventual plot
##    printmsg : a function for showing messages to the user (defaults
##      to print(), but generally some form of post.text.message is
##      used
##    error.handler : may be overridden to change the way errors
##      are handled
###################################################################
getclusteroptionsframe.func <- function(parentwindow, 
		       data,
		       uidefaults,
		       rowNames=NA,
		       colNames=NA,
		       printmsg = function(...) print(...),
		       error.handler = function(e) { printmsg(paste("Error: ",
                         e$message, "[", c(e$call), "]")) }
		       )
{
  if("tkwin" != class(parentwindow))
  {
    stop("parentwindow does not have class 'tkwin'")
  }

  ## defaults
  hc <- NULL 
  tid <- NA

  colorby.var <- tclVar("value")
  clustdist.var <- tclVar("euclidean")
  clustorder.var <- tclVar("heuristic")
  clustShowRowLabels.var <- tclVar("0")
  clustShowColLabels.var <- tclVar("0")
  cutoff.var <- tclVar("0")
  cutofftype.var <- tclVar("sd")
  cutoff.abs.var <- tclVar(paste(max(data)))
  cutoff.sd.var <- tclVar("3")
  logcolorscale.var <- tclVar("0")
  scalebyrow.var <- tclVar("0")

  plot.options <- new.storeyclust.plot.options()
  data.sd <- sd(as.vector(data))

  plot.options$rowLabels <- rowNames
  plot.options$colLabels <- colNames

  thread.data <- list(m=data, stages=c(0, 1))

  error.handler <- function(err) {
    printmsg(paste("Error:", err$message))
  }

  ## Tries to apply current settings,
  ## prints a message for the user if this fails
  applysettings.func <- function(...) {
    tryCatch(applysettings.func.int(...), error=error.handler)
  }

  ## Verifies and applies settings from the UI
  applysettings.func.int <- function() {
    ## Get settings from the UI and put in options objects

    thread.data$distance <<- tclvalue(clustdist.var)
    thread.data$orderfunc <<- tclvalue(clustorder.var)
    if(thread.data$distance == "heuristic")
      thread.data$stages <<- c(thread.data$stages, 5)
    else
      thread.data$stages <<- c(thread.data$stages, 2, 3, 4)

    plot.options$colorby <<- tclvalue(colorby.var)
    plot.options$showRowLabels <<- as.logical(as.numeric(tclvalue(clustShowRowLabels.var)))
    plot.options$showColLabels <<- as.logical(as.numeric(tclvalue(clustShowColLabels.var)))

    plot.options$rowLabels <<- if(plot.options$showRowLabels) rowNames else NA
    plot.options$colLabels <<- if(plot.options$showColLabels) colNames else NA
    
    if(as.logical(as.numeric(tclvalue(cutoff.var))))
    {
      cutofftype <- tclvalue(cutofftype.var)
      if(cutofftype == "abs")
        plot.options$cutoffvalue <<- as.numeric(tclvalue(cutoff.abs.var))
      else if (cutofftype == "sd")
        plot.options$cutoffvalue <<- as.numeric(tclvalue(cutoff.var))*data.sd
      else
        stop(paste("cutofftype is", cutofftype, "; should be either 'abs' or 'sd'"))
    }
    else
      plot.options$cutoffvalue <<- NA

    ## Other transforms
    ## Logarithmic color scale
    plot.options$log.color.scale <<- as.logical(as.integer(tclvalue(logcolorscale.var)))

    ## Scale by row
    if(as.logical(as.integer(tclvalue(scalebyrow.var))))
      plot.options$scaleby <<- "row"
    else
      plot.options$scaleby <<- "none"

    ## Ordering method
    

  }

  ui.notrunning <- function(...) {
    tryCatch(ui.notrunning.int(...), error=error.handler)    
  }
  
  ## Set the frame's state to "clustering not running"
  ## e.g. disable the "Cancel" button but enable the "Go"
  ## button
  ui.notrunning.int <- function() {
    clustplotbuts.reconfigure()
    
    tkconfigure(clustgo.but, state="normal")
    tkconfigure(clustcancel.but, state="disabled")
  }
  
  doplot.func <- function(...) {
    tryCatch(doplot.func.int(...), error=error.handler)
  }

  ## Plot the clustering results
  doplot.func.int <- function() {
    hc <- get("hc", parent.env(environment()))

    if(is.null(hc)) stop("hclust structure is null")
    if("hclust" != class(hc)) stop("hclust class is incorrect")

    plstoreyclust.func(data,
                       hc,
                       rowLabels=plot.options$rowLabels,
                       colLabels=plot.options$colLabels, 
                       colorby=plot.options$colorby,  
                       cutoffvalue=plot.options$cutoffvalue,
                       scaleby=plot.options$scaleby,
                       logcolors=plot.options$log.color.scale)
  
    printmsg("Plotting finished.", bell=TRUE)
  }

  clustfinish.func <- function(...) {
    tryCatch(clustfinish.func.int(...), error=error.handler)
  }

  ## Called after clustering finishes
  clustfinish.func.int <- function(tid, progress, enddata)
  {
    if(is.null(data))
      {
        stop("No data specified")
        return("error_no_data")
      }
    
    doplot.finally.func <- function(...) {
      tryCatch(doplot.finally.func.int(...), error=error.handler)
    }
    
    doplot.finally.func.int <- function() {
      ui.notrunning()
      
      tkevent.generate(cluster.frm, "<<ClusteringFinished>>")
      
      tkconfigure(clustprogress.lbl, text="Clustering done.")
      .Tcl("update idletasks")
    }      
    
    if(progress$canceled)
      {
        doplot.finally.func()
        tkconfigure(clustprogress.lbl, text="Clustering canceled.")
        .Tcl("update idletasks")
	return("canceled")
      }
    
    err <- tryCatchReturnError(hc <- storeyclust.finish.func(data, tid))
    ## Check for an error starting the clustering thread
    if(!is.null(err)) {
      doplot.finally.func()
      tkconfigure(clustprogress.lbl, text="Clustering failed.")
      
      ## Report error.
      error.handler(err)
    } else {
      
      ## If so, wrap it up
      assign("hc", hc, parent.env(environment()))

      print("Assigning hc globally")
      assign("hc", hc, .GlobalEnv)

      tkconfigure(clustprogress.lbl, text="Generating plot")
      .Tcl("update idletasks")
      
      printmsg("Clustering finished... generating plot.", bell=TRUE)
      
      tryCatch(doplot.func(), error=error.handler, finally=doplot.finally.func())
    }
  }
  

  clustgo.func <- function(...) {
    tryCatch(clustgo.func.int(...), error=error.handler)
  }

  ## Starts clustering after the "GO" button is clicked.
  clustgo.func.int <- function() {

    if(!exists("clustprogress.lbl"))
    {
      if(!exists("clustprogress.lbl", parent.env(environment())))
        stop("clustprogress.lbl does not exist in parent environment")
      clustprogress.lbl <<- get("clustprogress.lbl", parent.env(environment()))
    }
    if(!exists("clustprogress.lbl"))
      stop("clustprogress.lbl still does not exist")

    ## Do the clustering.
    if(is.null(data))
    {
      stop("No data specified")
      return("error_no_data")
    }   
    
    if(!is.matrix(data))
    {
      stop(paste("data is a", class(data), "expected a matrix"))
      return("error_invalid_data")
    }

    if(!is.loaded("StartClusteringThread"))
      try.load(paste("edge", .Platform$dynlib.ext, sep = ""))
  

    applysettings.func()
    printmsg("Clustering data... this may take a few minutes", bell=TRUE)

    ## disable buttons
    tkconfigure(clustgo.but, state="disabled")
    tkconfigure(clustcancel.but, state="normal")
    tkevent.generate(cluster.frm, "<<ClusteringStarted>>")
    .Tcl("update idletasks")

    ## call clustering function with expression data, using heuristic leaf ordering (1)
    err <- tryCatchReturnError(tid <<- thread(startfn=storeyclust.start.func,
    	    	   startdata=thread.data,
		   updatefn=clustthreadupdate.func, updatedata=thread.data,
		   endfn=clustfinish.func, enddata=thread.data))

    ## Check for an error starting the clustering thread
    if(!is.null(err)) {
      ui.notrunning()

      tkconfigure(clustprogress.lbl, text="Clustering failed to start.")
      tkevent.generate(cluster.frm, "<<ClusteringFinished>>")
      .Tcl("update idletasks")

      ## Report error.
      error.handler(err)
    }
  }

  clustthreadupdate.func <- function(...) {
    tryCatch(clustthreadupdate.func.int(...), error=error.handler)
  }

  ## Replaces the text in the progress text label
  ## (called every 1/2 second or so during clustering)
  clustthreadupdate.func.int <- function(tid, progress, updatedata) {
    ## Update the "X% complete" label
    threadupdatelbl.func(tid, progress, clustprogress.lbl)

    ## Update the "Time left" label
    if(progress$msgid == 0)
    {
    }
    else if (progress$msgid == 1)
    {
    }
  }

  clustcancel.func <- function(...) {
    tryCatch(clustcancel.func.int(...), error=error.handler)
  }

  ## Cancels a running clustering thread
  ## (response to CANCEL button)
  clustcancel.func.int <- function() {
    if (0 != thread.stop.func(tid))
      stop("Could not stop thread")
    tkconfigure(clustprogress.lbl, text="Stopped")
  }

  clustplotbuts.reconfigure <- function(...) {
    tryCatch(clustplotbuts.reconfigure.int(...), error=error.handler)
  }

  ## If there are clustering results (hc),
  ## enable the plotting buttons
  ## Otherwise, disabgle them
  clustplotbuts.reconfigure.int <- function() {
    if(!is.null(hc))
    {
      tkconfigure(clustreplot.but, state="normal")
	tkconfigure(clustsave.but, state="normal")
    }
    else
    {
      tkconfigure(clustreplot.but, state="disabled")
	tkconfigure(clustsave.but, state="disabled")
    }

  }

  clustsave.func <- function(...) {
    tryCatch(clustsave.func.int(...), error=error.handler)
  }

  clustsave.func <- function() {
      hc <- get("hc", parent.env(environment()))

      ## get clustering
      if(is.null(hc) )
      {
        printmsg("Error: No clustering data available")
	return("error_no_data")
      }

      if(is.null(data) || is.na(data))
      {
        printmsg("Error: No input data available")
	return("error_no_data")
      }

      ## prompt for a filename
      pdffile <- tclvalue(tkgetSaveFile(initialfile="cluster.pdf",filetypes="{{PDF} {.pdf}}"))
      if(pdffile != "")
      {
        ## save the plot
	pdf(pdffile, width=8.5, height=11)
	printmsg("Saving plot... this may take a few minutes.")
	tryCatch(doplot.func(), error=error.handler, finally=dev.off())
	printmsg("Plot saved.")
      }
      else
      {
        printmsg("Plot not saved.")
      }
  }

  clustreplot.func <- function(...) {
    tryCatch(clustreplot.func.int(...), error=error.handler)
  }

  ## Plots the clustering results without re-running the clustering
  clustreplot.func.int <- function() {
    hc <- get("hc", parent.env(environment()))
    applysettings.func()
    doplot.func()
    printmsg("Check the R plot window.")
  }
  
  cutoff.func.int <- function(...) {
    tryCatch(cutoff.func.int(...), error=error.handler)
  }

  ## Sets the standard deviation cutoff
  cutoff.func <- function() {
    ## Disable/enable appropriate
    sd.cutoff <- as.logical(as.numeric(tclvalue(cutoff.var)))

    if(sd.cutoff)
    {
      tkconfigure(cutoff.abs.rbtn$radiobutton, state = "normal")
      tkconfigure(cutoff.sd.rbtn$radiobutton, state = "normal")

      sd.cutofftype <- tclvalue(cutofftype.var)

      if(sd.cutofftype == "abs")
      {
        tkconfigure(cutoff.abs.ety, state = "normal")
        tkconfigure(cutoff.sd.ety, state = "disabled")
      }
      else if (sd.cutofftype == "sd")
      {
        tkconfigure(cutoff.abs.ety, state = "disabled")
        tkconfigure(cutoff.sd.ety, state = "normal")
      }
      else
        stop(paste("sd.cutofftype is", sd.cutofftype, "; should be either 'abs' or 'sd'"))
    }
    else
    {
      tkconfigure(cutoff.abs.rbtn$radiobutton, state = "disabled")
      tkconfigure(cutoff.sd.rbtn$radiobutton, state = "disabled")
      tkconfigure(cutoff.abs.ety, state = "disabled")
      tkconfigure(cutoff.sd.ety, state = "disabled")
    }
  }

  ## At last, here's where we actually create the window and its various elements
  cluster.frm <- tkframe(parentwindow, 
    bg = uidefaults$background)

  ## Create a "Cluster Options" frame
  top.frm <-tkframe(cluster.frm,bg=uidefaults$background)

  clustopts.frm <- tkframe(top.frm, bd = 2, bg = uidefaults$background, relief="raised")
  tkpack(tklabel(clustopts.frm, text = "Cluster Options", font = uidefaults$titleFont,
    bg = uidefaults$background, fg = uidefaults$bigForeground))

  ## Create a "Distance Function" sub-frame
  clustdist.frm <- tkframe(clustopts.frm, bd = 2, bg = uidefaults$background)
  tkpack(tklabel(clustdist.frm, text = "Distance", 
    font = uidefaults$titleFont, bg = uidefaults$background, fg = uidefaults$bigForeground), 
    anchor = "w")
  tkpack(tklabel(clustdist.frm, 
    text = "This is how the difference between two gene expressions is measured", 
    font = uidefaults$normalFont,
    bg = uidefaults$background,
    fg = uidefaults$bigForeground), anchor="w")
  euclidean.rbtn <- new.radiobutton(clustdist.frm, uidefaults=uidefaults,
    text = "Euclidean", variable = clustdist.var, value="euclidean")
  correlation.rbtn <- new.radiobutton(clustdist.frm, uidefaults=uidefaults,
    text = "Correlation [distance = (1-p)]", variable = clustdist.var, value="correlation")

  tkpack(euclidean.rbtn$frame, anchor="w", padx="15 0")
  tkpack(correlation.rbtn$frame, anchor="w", padx="15 0")
  tkpack(clustdist.frm, anchor="w")

  clustorder.frm <- tkframe(clustopts.frm, bd=3, bg=uidefaults$background)
  tkpack(tklabel(clustopts.frm, text = "Ordering", 
    font = uidefaults$titleFont, bg = uidefaults$background, fg = uidefaults$bigForeground), 
    anchor = "w")
  tkpack(tklabel(clustopts.frm, 
    text = "This is how the clusters are ordered",
    font = uidefaults$normalFont, bg = uidefaults$background, fg = uidefaults$bigForeground), anchor="w")
  heuristic.rbtn <- new.radiobutton(clustopts.frm, uidefaults=uidefaults,
    text = "Heuristic (fastest)", variable = clustorder.var, value="heuristic")
  optimal.rbtn <- new.radiobutton(clustopts.frm, uidefaults=uidefaults,
    text = "Optimal (most accurate)", variable = clustorder.var, value="optimal")
  tkpack(heuristic.rbtn$frame, anchor="w", padx="15 0")
  tkpack(optimal.rbtn$frame, anchor="w", padx="15 0")
  tkpack(clustopts.frm, anchor="w")

  ## "CLUSTER" button
  clustgo.but <- tkbutton(clustopts.frm, text = "CLUSTER", command = clustgo.func, 
    bg = uidefaults$buttonBackground,
    fg = uidefaults$buttonForeground,
    font = uidefaults$titleFont)
  tkpack(clustgo.but, pady="15 0")

  ## Create a "Plot Options" frame
  clustplot.frm <- tkframe(top.frm, bd = 2, bg = uidefaults$background, relief="raised")
  tkpack(tklabel(clustplot.frm, text = "Plot Options", 
                 font = uidefaults$titleFont, bg = uidefaults$background, 
		 fg = uidefaults$bigForeground))
  
  ## Row/column labeling options
  tkpack(tklabel(clustplot.frm, text = "Labels", 
                 font = uidefaults$normalFont, bg = uidefaults$background, 
		 fg = uidefaults$bigForeground), 
    anchor = "w")
  rowlabels.cb <- new.checkbutton(clustplot.frm, uidefaults,
    text = "Show gene names (not recommended for > 50 genes)", 
    variable = clustShowRowLabels.var)
  if(nrow(data) < 50)
  {
    tkselect(rowlabels.cb$checkbutton)
  }
  collabels.cb <- new.checkbutton(clustplot.frm, uidefaults,
    text = "Show array names (not recommended for > 50 arrays)", 
    variable = clustShowColLabels.var)
  if(ncol(data) < 50)
  {
    tkselect(collabels.cb$checkbutton)
  }

  tkpack(rowlabels.cb$frame, anchor="w", padx="15 0")
  tkpack(collabels.cb$frame, anchor="w", padx="15 0")

  ## Plot coloring options
  coloring.frm <- tkframe(clustplot.frm, bd=2, bg=uidefaults$background)
  tkpack(tklabel(coloring.frm, text = "Coloring", 
                 font = uidefaults$normalFont,
                 bg = uidefaults$background,
                 fg = uidefaults$bigForeground),
         anchor = "w")
  logcolors.cb <- new.checkbutton(coloring.frm,
    text = "Logarithmic color scale", uidefaults=uidefaults, variable=logcolorscale.var)
  tkpack(logcolors.cb$frame, anchor="w", padx="15 0")
  
  tkpack(tklabel(coloring.frm, text = "Color data by:", 
                 font = uidefaults$normalFont,
                 bg = uidefaults$background,
                 fg = uidefaults$bigForeground),
         anchor = "w", padx="15 0")
  colorbyvalue.rbtn <- new.radiobutton(coloring.frm, 
    text = "Value", uidefaults=uidefaults, value="value", variable = colorby.var)
  colorbyrank.rbtn <- new.radiobutton(coloring.frm, 
    text = "Rank", uidefaults=uidefaults, value="rank", variable = colorby.var)
  tkpack(colorbyvalue.rbtn$frame,anchor="w", padx="15 0")
  tkpack(colorbyrank.rbtn$frame, anchor="w", padx="15 0")
  tkpack(coloring.frm, anchor="w")
  

  ## Data transformation options
  ## Gene centering
  transform.frm <- tkframe(clustplot.frm, bd=2, bg=uidefaults$background)
  tkpack(tklabel(transform.frm, text="Scaling, Centering, and Transforms", 
                 font = uidefaults$normalFont,
                 bg = uidefaults$background, fg = uidefaults$bigForeground),
         anchor = "w")
  scalebyrow.cb <- new.checkbutton(transform.frm, text="Center each gene",
                                   uidefaults=uidefaults, variable=scalebyrow.var)
  tkpack(scalebyrow.cb$frame, anchor="w", padx="15 0")

  cutoff.cb <- new.checkbutton(transform.frm,
    text = "Truncate data values", uidefaults=uidefaults,
                               variable=cutoff.var, command=cutoff.func)
  ## if truncation is on, these are enabled:
  ## absolute value vs. coeff*sd
  cutoff.abs.frm <- tkframe(transform.frm, bg=uidefaults$background)
  cutoff.abs.rbtn <- new.radiobutton(cutoff.abs.frm, value="abs",
                                     text = "Absolute cutoff: ",
                                     uidefaults=uidefaults,
                                     variable=cutofftype.var,
                                     command=cutoff.func)
  cutoff.abs.ety <- tkentry(cutoff.abs.frm, textvariable = cutoff.abs.var, 
    font = uidefaults$normalFont, width = 10, bg = uidefaults$listBackground,
    fg = uidefaults$listForeground)
  cutoff.sd.frm <- tkframe(transform.frm, bg=uidefaults$background)
  sdtext <- paste("Multiples of standard deviation (sd =", sprintf("%g", data.sd), ")")
  cutoff.sd.rbtn <- new.radiobutton(cutoff.sd.frm, value="sd",
    text = sdtext, uidefaults=uidefaults, variable=cutofftype.var, command=cutoff.func)
  cutoff.sd.ety <- tkentry(cutoff.sd.frm, textvariable = cutoff.sd.var, 
    font = uidefaults$normalFont, width = 5, bg = uidefaults$listBackground,
    fg = uidefaults$listForeground)
  tkpack(cutoff.cb$frame, anchor="w", padx="15 0")
  tkgrid(cutoff.abs.rbtn$frame, cutoff.abs.ety, sticky="w")
  tkpack(cutoff.abs.frm, anchor="w", padx="30 0")
  tkgrid(cutoff.sd.rbtn$frame, cutoff.sd.ety)
  tkpack(cutoff.sd.frm, anchor="w", padx="30 0")
  cutoff.func()
  tkpack(transform.frm, anchor="w")

  ## Create the buttons
  clustplotbuts.frm <- tkframe(clustplot.frm,bd=2,bg=uidefaults$background)
  clustreplot.but <- tkbutton(clustplotbuts.frm, text = "PLOT AGAIN",
    command = clustreplot.func, bg = uidefaults$buttonBackground, 
    fg = uidefaults$buttonForeground, font = uidefaults$titleFont)
  clustsave.but <- tkbutton(clustplotbuts.frm, text = "SAVE PLOT AS PDF", 
    command = clustsave.func, bg = uidefaults$buttonBackground, 
    fg = uidefaults$buttonForeground, font = uidefaults$titleFont)
  tkgrid(clustreplot.but, clustsave.but)
  clustplotbuts.reconfigure()
  tkpack(clustplotbuts.frm, pady="15 0")

  ## Create a progress frame
  clustprogress.frm <- tkframe(clustopts.frm, bd = 2, bg = uidefaults$background, relief="raised")
  clustprogstatic.lbl <- tklabel(clustprogress.frm, width=60, bg=uidefaults$background, 
    fg=uidefaults$bigForeground, font=uidefaults$normalFont,
    text = "Clustering progress: ")
  clustprogress.lbl <- tklabel(clustprogress.frm, width=60, bg=uidefaults$background, 
    fg=uidefaults$bigForeground, font=uidefaults$normalFont)
  clusttime.lbl <- tklabel(clustprogress.frm, width=60, bg=uidefaults$background, 
    fg=uidefaults$bigForeground, font=uidefaults$normalFont)
  clustcancel.but <- tkbutton(clustprogress.frm, text="CANCEL", bg = uidefaults$buttonBackground,
    fg = uidefaults$buttonForeground, font = uidefaults$titleFont, command = clustcancel.func)
  tkconfigure(clustcancel.but, state="disabled")
  tkpack(clustprogstatic.lbl)
  tkpack(clustcancel.but)
  tkpack(clustprogress.lbl, anchor = "w")
  tkpack(clusttime.lbl, anchor = "w")
  tkpack(clustprogress.frm, pady="15 0", anchor="w")


##  tkgrid(clustopts.frm, clustplot.frm)
tkpack(clustopts.frm, side="left", anchor="n")
tkpack(clustplot.frm)
  tkpack(top.frm)


  return(cluster.frm)
}

######################################################################### 
#     This function opens a "Cluster Options" window.                   #
#     Author(s): Eva Monsen                                             #
#     Language: R                                                       #
#     Return Value: a "storeyclust.options" object                      #
######################################################################### 
getclusteroptionswindow.func <- function(parentwindow, 
		       data,
		       uidefaults,
		       rowNames=NA,
		       colNames=NA
		       )
{
  if("tkwin" != class(parentwindow))
  {
    stop("parentwindow does not have class 'tkwin'")
  }

  
  ## Create the "Cluster" Window 
  cluster.base <- tktoplevel(bg=uidefaults$background)
  tkwm.title(cluster.base, "EDGE - Clustering Options")

  clustbuts.frm <- tkframe(cluster.base, bg=uidefaults$background)

  clustdone.but <- tkbutton(clustbuts.frm, text = "DONE", 
    command = function() { tkdestroy(cluster.base) }
    , bg = uidefaults$buttonBackground
    , fg = uidefaults$buttonForeground 
    , font = uidefaults$titleFont
    )
    
  om <- tclServiceMode(TRUE)
  cluster.frm <- getclusteroptionsframe.func(cluster.base, data, uidefaults, rowNames, colNames,
    printmsg=function(...) post.txt.msg(messages.txt, ...) )

  tkbind(cluster.frm, "<<ClusteringStarted>>", function() { tkconfigure(clustdone.but, state="disabled") })
  tkbind(cluster.frm, "<<ClusteringFinished>>", function() { tkconfigure(clustdone.but, state="normal") })

  tkpack(cluster.frm)
  tkgrid(clustdone.but)
  tkpack(clustbuts.frm)
  tclServiceMode(om)

  ## Create a messages window
  messages <- create.message.frame(cluster.base, uidefaults)
  messages.txt <- messages$textarea
  tkpack(messages$frame)
  post.txt.msg(messages.txt, "Messages will appear in this window.")

  ## temporarily set error handling
  oldError = getOption("error")
  options(error=function() { post.txt.msg(messages.txt, geterrmessage()); })
  nonmodal.window(cluster.base, parentwindow, hideParent=TRUE)
  options(error=oldError)
}



