#########################################################
## 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: thread.r
## Internal functions supporting threading.
#########################################################

## Message strings.
thread.msgids <<- c(
		   "Create distance matrix",
		   "Cluster data",
		   "Compute ordering costs",
		   "Get best pair",
		   "Construct ordering",
		   "Order clusters",
		   "Initializing data for computation",
		   "Computing differentially expressed genes",
		   "Computing differentially expressed genes")

## Translates a number into a message string.
thread.getmessage <- function(msgid)
{
  if(is.null(msgid) || is.na(msgid) || !is.numeric(msgid))
    stop("msgid must be numeric and non-NA")

  if(msgid < 0 || msgid >= length(thread.msgids))
    stop(paste("msgid must be > 0 and <", length(thread.msgids)))

  return (thread.msgids[msgid+1])
}

if(!exists("thread.args"))
{
  thread.args <<- list()
}

## Starts a background thread and uses Tcl/Tk's "after idle" command to periodically
## poll the thread's progress.
##
## In reality, these R functions have no clue about threads per se. thread() merely
## calls a start function, then repeatedly calls an update function until that update
## function declares that the thread is finished. The actual threads must be managed
## internally by a C library.
##
## Arguments:
##    startfn - the function that starts the thread. Usually, this means
##      a function that calls a C function in a C library that starts
##      a thread internally.
##    startdata - optional data to pass to startfn
##    updatefn - the function that is called at regular intervals to check
##      on thread status
##    updatedata - optional data passed to updatefn
##    endfn - function to call when the thread finishes, stops, or is cancelled
##    updateInterval - number of milliseconds in between calls to updatefn
thread <- function(startfn, startdata=NULL, updatefn, updatedata=NULL, endfn, enddata=NULL, updateInterval=500)
{

  if(!is.function(startfn))
    stop("startfn is not a function")
  if(!is.function(updatefn))
    stop("updatefn is not a function")
  if(!is.function(endfn))
    stop("endfn is not a function")

  ## Track this thread in the thread.args global
  thread.args[[length(thread.args)+1]] <<-
    list(updatefn=updatefn, updatedata=updatedata, endfn=endfn, enddata=enddata)
  
  # Start the thread
  tid = startfn(startdata)
  names(thread.args)[length(thread.args)] <<- paste(tid)

  .Tcl("update idletasks")
  
  # Do the update function
  .Tcl(paste("after idle [list after", updateInterval,
             tcl.callback.with.args(threadupdate.func, tid = tid, 
                                    updateInterval = updateInterval, 
                                    argIndex = length(thread.args)
                                    ),
             "]"))
  
  return(tid)
}

## Checks a running thread for updates
threadupdate.func <- function(tid, updateInterval, argIndex)
  {
    ## Look up the thread in the global thread.args
    tid <- as.numeric(tid)
    if(is.na(tid) || is.null(tid))
      stop("No thread is running or no tid provided")

    if(is.null(thread.args))
      stop("thread.args is NULL")

    argIndex <- as.numeric(argIndex)
    if(is.na(argIndex) || is.null(argIndex))
      stop("argIndex is NULL, NA, or could not be coerced to a number")

    args <- thread.args[[argIndex]]
    if(is.null(args))
      stop(paste("thread.args[[", argIndex, "]] is null"))

    updatefn <- args$updatefn
    updatedata <- args$updatedata
    endfn <- args$endfn
    enddata <- args$enddata

    ## Check whether the thread finished
    progress <- thread.progress.func(tid)
    if (progress$done || progress$canceled)
    {
      ## The thread finished, so call endfn
      if(is.null(endfn))
        stop("endfn is null")
      if(!is.function(endfn))
        stop("endfn is not a function")
      endfn(tid, progress, enddata)

      progress <- thread.progress.func(tid)
      if(progress$done)
        thread.delete.func(tid)

      return(0)
    }
    else
    {
      ## The thread did not finish, so schedule another
      ## call to this function in updateInterval milliseconds
      if(is.null(updatefn))
        stop("updatefn is null")
      if(!is.function(updatefn))
        stop("updatefn is not a function")

     updatefn(tid, progress, updatedata)

      .Tcl("update idletasks")
      .Tcl(paste("after idle [list after", updateInterval, 
              tcl.callback.with.args(threadupdate.func, tid = tid, 
                                     updateInterval = updateInterval, 
				     argIndex = argIndex
				     ),
		 "]"))
    }
  }

## Update a Tcl/Tk label with % progress
## Arguments:
##   tid : the thread
##   progress : the list describing the thread's progress
##     (with min, max, current values)
##   updatedata : a Tk label object
threadupdatelbl.func <- function(tid, progress, updatedata)
{
  if(class(updatedata) != "tkwin")
    stop("updatedata must be a Tk label")

  pct <- floor(100 * progress$current / (progress$max - progress$min))
  tkconfigure(updatedata, text=paste(pct, "%", thread.getmessage(progress$msgid)))
}


#########################################################################
# This function calls a C function to get a thread's progress
#
# Arguments:       
#  An integer thread ID previously returned from thread()
#
# Return value: a list containing the following integer values:
#   min, max, current: Indicators of how far along the clustering process
#    is in the current stage.
#   done: 1 if clustering is finished, 0 otherwise.
#   msgid: (optional) Indicates which stage of clustering we are in. Possible values:
#      0 = Creating distance matrix (BCLUST_CREATE_DISTANCE_MATRIX)
#      1 = Creating clusters (BCLUST_CREATE_CLUSTERS)
#      2 = (Optimal ordering only) Computing costs (OPTORD_COMPUTECOSTS)
#      3 = (Optimal ordering only) Getting best pair (OPTORD_GETBESTPAIR)
#      4 = (Optimal ordering only) Backtracking (OPTORD_BACKTRACK)
#      5 = (Heuristic ordering only) Ordering leaves (HEURORD_ORDERLEAVES)
#
# Author(s): Eva Monsen           
#########################################################################
thread.progress.func <- function(tid)
{
  if(is.null(tid) || is.na(tid) || !is.numeric(tid))
    stop("tid must be a non-NA number")

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

  progress <- .Call("GetProgressValues", tid)

  progress$min <- 0
  return(progress)
}

#########################################################################
# This function explicitly deletes information associated with a thread
# from memory.
#
# Arguments:       
#  An integer previously returned from storeyclust.start.func
#
# Return value: none
#########################################################################
thread.delete.func <- function(tid)
{
  .Call("DeleteThread", tid)
}

#########################################################################
# This function stops a thread if it is running.
#
# Arguments:       
#  An integer thread id
#
# Return value: 0 if successful, nonzero otherwise
#########################################################################
thread.stop.func <- function(tid)
{
  status <- .Call("StopThread", tid)
  return(status)
}

