#########################################################
## 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.
##
## Filename: include.r
## Utility functions.
#########################################################

#########################################################################
#    This function makes a vector of consecutive integers from a
#    vector of strings.
#########################################################################
make.consecutive.int <- function(y) {
  oldWarn = getOption("warn")
  ## Turn off warnings.
  options(warn = -1)

  if(is.null(y)) {return(NULL)}
  
  if(!is.vector(y))
    y = as.vector(as.character(y))

  out <- as.integer(as.factor(as.character(y)))
  
  options(warn = oldWarn)
  
  return(out)
}


#########################################################################
#   This function returns the square root of a matrix.                  #
#########################################################################
mat.sq <- function(X) {
  oo <- svd(X)
  return(oo$u %*% diag(sqrt(oo$d)) %*% t(oo$v))
}

#########################################################################
#       This function finds all unique sign changes in the 1-class      #
#         statex null distirbution                                      #
#       Author(s): John Storey                                          #
#       Language: R                                                     #
#       References:                                                     #
#       Arguments:                                                      #
#         grp - The vector of group labels (all 1's here)               #
#               or the sample size                                      #
#########################################################################
all.sgns <- function(grp) {
  if(length(grp)>1) {n <- length(grp)} else {n <- grp[1]}
  m <- 2^n
  xx <- matrix(rep(NA,n*m),ncol=n)
  
  for(i in 1:n) {
    xx[,i] <- rep( c( rep(1,m/(2^i)), rep(-1,m/(2^i)) ), 2^(i-1))
  }
  
  return(xx)
}


#########################################################################
#       This function finds all unique permutations in the k-class      #
#         statex null distirbution (k > 1)                              #
#       Author(s): John Storey                                          #
#       Language: R                                                     #
#       References:                                                     #
#       Arguments:                                                      #
#         grp - The vector of group labels (2 or more groups required)  #
#########################################################################
all.perms <- function(grp) {
  
  grp.perms <- function(n,k) {
    m <- 1
    b <- 1:k
    ans <- matrix(1:k,ncol=k)
    arr <- 1:n
    repeat {
      b <- arr[1:k]
      if (m>1)  ans <- rbind(ans,b)
      j <- k
      repeat {
        if (j <1)  break
        arr[j]<- arr[j] +1
        if (arr[j] <= j + n-k) break
        if (arr[j] > j + n-k) j <- j-1
      }
      if (arr[1] > n-k+1) break
      for (l in j:k)
        arr[l+1] <- arr[l] +1
      m <- m+1
    }
    return(ans)
  } 
  
  grp <- table(grp)
  tot <- sum(grp) 
  n <- tot
  
  for (rr in 1:length(grp)) {
    tmp <- grp.perms(tot,grp[rr])
    if (rr==1) tmp1 <- tmp
    else {
      tmp1 <- NULL
      for (i in 1:nrow(out)) {
        num <- (1:n)[-out[i,]]
        for (j in 1:nrow(tmp)) {
          tmp2 <- c(out[i,],num[tmp[j,]])
          tmp1 <- rbind(tmp1,tmp2)
        }
      }
    }
    out <- tmp1
    tot <- tot-grp[rr]
  }      
  
  return(out)
}

#########################################################################
#       This function computes empirical p-values.                      #
#       Author(s): John Storey                                          #
#       Language: R                                                     #
#       References:                                                     #
#       Arguments:                                                      #
#         lr  - The observed statistics.                                #
#         lr0 - The null permutation statistics.                        #
#########################################################################
get.pvalues <- function(lr, lr0, pool=TRUE, zero=FALSE) {
  m <- length(lr)
  if(pool==TRUE) {
    if(is.matrix(lr0)) {lr0 <- as.vector(lr0)}
    m0 <- length(lr0) 
    v <- c(rep(F, m0), rep(T, m))

    ## Order all "null" and "alternative" statistics together
    if(length(lr) < 10000)
      ord <- order(c(lr0, lr), decreasing = T)
    else
      ord <- quick.order(c(lr0, lr), decreasing = T)

    ## v is a vector containing "TRUE"s at the rankings of the alternative stats
    v <- v[ord]
    u <- 1:length(v)
    w <- 1:m
    p <- (u[v==TRUE]-w)/m0
    ## Reverse the effects of "order()" above
    p <- p[rank(-lr)]
    ## Set any p-value less than 1/m0 to 1/m0
    if(!zero) {p <- pmax(p,1/m0)}
  } else { ## MIGHT WANT TO CHANGE THIS TO NOT REQUIRE LRO TO HAVE M ROWS.  IT ONLY HAS M0 NOW.
    if(is.vector(lr0)) {post.msg("Error: lr0 must be a matrix.",bell=TRUE); return(NULL)}
    if(ncol(lr0)==m) {lr0 <- t(lr0)}
    if(nrow(lr0)!=m) {post.msg("Error: number rows of lr0 must equal length of lr.",bell=TRUE); return(NULL)}
    lr0 <- (lr0 - matrix(rep(lr,ncol(lr0)),byrow=FALSE,nrow=m)) >= 0
    p <- apply(lr0,1,mean)
    if(!zero) {p <- pmax(p,1/ncol(lr0))}
  }
  return(p)
}

edge.library.version <- function()
{
  if(!is.loaded("GetEdgeLibraryVersion"))
    dyn.load(paste("edge", .Platform$dynlib.ext, sep = ""))
  edge.lib.ver <- .Call("GetEdgeLibraryVersion")
  if(edge.lib.ver=="1.0.") {edge.lib.ver <- "1.1"}
  return(edge.lib.ver)
}

#########################################################################
#       This function applies a function to each item in a vector.
#       Author(s): Eva Monsen
#       Arguments:
#         v - the vector to transform
#         func - a function that takes one argument
#########################################################################
xform.vector <- function(v, func)
{
  for(i in 1:length(v))
    v[i] <- func(v[i])

  return(v)
}

#########################################################################
#       This function determines whether a pairlist has a member with the
#         specified name.
#       Author(s): Eva Monsen
#       Arguments:
#         lis - the list to check
#         name - the name to check for
#       Side Effects: Throws an error if 'lis' is not a list, or 
#        'name' is not a string
#########################################################################
list.has <- function(lis, name)
{
  if(!is.list(lis))
    stop("lis is not a list")

  if(!is.character(name))
    stop("name is not a string")

  for(lname in names(lis))
  {
    if(lname == name)
      return(TRUE)
  }
  return(FALSE)
}

#########################################################################
#       This function checks that a value is "set", i.e. it is not 
#       equal to NULL or NA.
#       Author(s): Eva Monsen
#       Arguments:
#         x - object to check
#       Side Effects: Throws an error if 'x' is NULL or NA or NaN
#########################################################################
check.not.nullna <- function(x)
{
  if(is.null(x))
    stop("argument is null")
  if(is.vector(x) || is.matrix(x))
  {
    if (length(x) == 1 && (is.na(x) || is.nan(x)))
      stop("value is na or nan")
    if (any(is.na(x)) || any(is.nan(x)))
      stop("vector/matrix contains na or nan values")
  }
  return(x)
}

#########################################################################
#       This function checks that a value is numeric, or is an
#       array of numeric values.
#       Author(s): Eva Monsen
#       Arguments:
#         x - object to check
#       Side Effects: Throws an error if 'x' is not numeric.
#########################################################################
check.numeric <- function(x)
{
  if(!is.numeric(x))
    stop("Value is not numeric")
}

data.frame.as.numeric <- function(df)
{
  sapply(df, function(x) as.numeric(x))
}

#########################################################################
# This function returns one row of a matrix.
#  Arguments:
#   m: the matrix
#   r: the row number (indexed starting at 1)
#########################################################################
matrix.row <- function(m, r, nr=nrow(m))
{
  m[seq(r, length(m), by=nr)]
}

#########################################################################
# This function returns several rows of a matrix.
#  Arguments:
#   m: the matrix
#   rows: a vector of row numbers
#  Return value:
#   A matrix with length(rows) rows
#########################################################################
matrix.rows <- function(m, rows, nr=nrow(m))
{
  m1 <- NULL
  for(r in rows)
    m1 <- c(m1, matrix.row(m, r, nr))

  matrix(m1, nrow=length(rows), byrow=TRUE)
}

# Concatenates reps copies of str into a string.
rep.str <- function(str, reps)
{
  paste(rep(str, reps), sep="", collapse="")
}

# If global debugOn is TRUE, write debug statements to a file
if(!exists("debugLevel")) debugLevel <- "info"
if(!exists("debugOn")) debugOn <- FALSE

# gah - change debug to edge.debug, so as not to conflict with R's debug()
edge.debug <- function(..., level="info", debugFile = "debug.txt")
{
  tryCatch(
  if(debugOn)
  {
    doit <- (debugLevel == "verbose" && (level == "info" || level == "verbose")) ||
    (debugLevel == "info" && level == "info")
    print(debugLevel)

    if (doit)
    {
      write.debug.timestamp(debugFile=debugFile)
      write.debug(..., debugFile=debugFile)
    }
  },
  error=function(e) warning(paste("Error in debug():", e$message)))
}

write.debug <- function(..., debugFile="debug.txt")
{
  f <- file(debugFile, "a")
  cat(..., file=f, sep="\n")
  close(f)
}

write.debug.timestamp <- function(debugFile="debug.txt")
{
  write.debug(paste("-----", format(Sys.time())))
}

debug.info <- function(..., debugFile="debug.txt")
{
  edge.debug(..., level="info", debugFile=debugFile)
}

debug.verbose <- function(..., debugFile="debug.txt")
{
  edge.debug(..., level="verbose", debugFile=debugFile)
}

debug.params <- function(debugFile="debug.txt")
{
  if (debugLevel != "verbose" && debugLevel != "info")
    return(0);
  
  write.debug.timestamp(debugFile=debugFile)
  
  # Print name of calling function
  write.debug(paste("Function call", sys.call(-1)[1], ":"), debugFile=debugFile)
  calls <- sys.calls()
  
  # Get all arguments to the calling function
  caller <- sys.function(-1)
  env <- sys.frame(-1)
  args <- formals(caller)
  for(i in 1:length(args))
  {
    name <- names(args[i])
    val <- get(name, envir=env)
    str <- paste(name, ":", class(val), ":")
    vec <- tryCatch(as.vector(val), error=function(e) {} )
    if(!is.null(vec))
    {
      if(debugLevel == "verbose")
      {
        if(class(val) == "matrix")
        {
          str <- paste(str, "matrix(")
        }
        str <- paste(str, "c(",  paste(val, collapse=", "), ")")
        if(class(val) == "matrix")
        {
          str <- paste(str, ", ncol=", ncol(val), ")")
        }
      }
      else if(debugLevel == "info")
      {
        if(length(vec) > 1)
        {
          str <- paste(str, " [length ", length(val), "]", sep="")
        }
        else
          {
            str <- paste(str, paste(val, collapse=" "))
          }
      }
    }
    write.debug(str, debugFile=debugFile)
  }
}

debug.object <- function(obj, debugFile="debug.txt")
{
  if (debugLevel != "verbose" && debugLevel != "info")
    return(0);

  write.debug.timestamp(debugFile=debugFile)

  stuff <<- sys.call()
  name <- paste(sys.call()[2])
  str <- paste(name, ":", class(obj), ":")
  vec <- tryCatch(as.vector(obj), error=function(e) {} )
  if(!is.null(vec))
  {
    if(debugLevel == "verbose")
    {
      if(class(obj) == "matrix")
      {
        str <- paste(str, "matrix(")
      }
      str <- paste(str, "c(",  paste(obj, collapse=", "), ")")
      if(class(obj) == "matrix")
      {
        str <- paste(str, ", ncol=", ncol(obj), ")")
      }
    }
    else if(debugLevel == "info")
    {
      if(length(vec) > 1)
      {
        if(class(vec) == "matrix")
          str <- paste(str, " [rows ", nrow(vec), ", cols ", ncol(vec), sep="")
        else
          str <- paste(str, " [length ", length(obj), "]", sep="")
      }
      else
        {
          str <- paste(str, paste(obj, collapse=" "))
        }
    }
  }
  write.debug(str, debugFile=debugFile)
}

########################################################################
# This function puts flat single quotes around a string or a vector of
# strings.
########################################################################
flatSQuote <- function(x)
{
  if(!is.vector(x))
  {
    stop("x must be a vector")
  }

  sapply(x, function(y) paste("'", y, "'", sep=""))
}

##############################################################
## Checks for the existence of a file, throwing a nice error
## message if it doesn't exist.
##############################################################
check.file.exists <- function(file)
{
  if(file.access(file, 0) < 0)
    stop(paste("File '", file, "' does not exist"))

}

##############################################################
## Checks whether a given file is readable, throwing a nicer
## message if it doesn't exist.
##############################################################
check.file.readable <- function(file)
{
  check.file.exists(file)
  if(file.access(file, 4) < 0)
    stop(paste("Permission denied reading file '", file, "'"))
}

with.warnings.as.errors <- function(expr)
{
  oldwarn <- getOption("warn")
  options(warn=2)
  tryCatch(expr, error=function(e) stop(e), finally=options(warn=oldwarn))
}

suppress.warnings <- function(expr)
{
  oldwarn <- getOption("warn")
  options(warn=-1)
  tryCatch(expr, error=function(e) stop(e), finally=options(warn=oldwarn))
}

quick.order <- function(x, ...)
{
  ord <- sort.na.last(x, method="quick",  ...)
  ord
}

get.os <- function()
{
  if(length(grep("darwin", R.version$os)) > 0) {
    return("macosx")
  } else if(length(grep("linux", R.version$os)) > 0) {
    return("linux")
  } else {
    return(.Platform$OS.type)
  }
}


###############################################################
## idError is an error object that has a unique identifier
## as well as an error message.
##
## Functions can check for certain error types using the unique
## id, independent of whether the error message changes or
## is translated into another language.
##############################################################

idError <- function(id, message, call = NULL){
  ierr <- list(id=id, message=message, call=call)
  class(ierr) <- c("idError", "error", "condition")
  ierr
}

conditionMessage.idError <- function(ierr) {
  ierr$message
}

conditionCall.idError <- function(ierr) {
  ierr$call
}

###############################################################
## Removes the quotes surrounding a filename (Windows only)
###############################################################
removequotes <- function(filename) {
  if(is.null(filename)) return(filename)

  pat1 <- "^ *\""
  pat2 <- "\" *$"
  sub(pat1, "", sub(pat2, "", filename))
}

###############################################################
## Evaluates an expression, catching errors.
## If an error is caught, it is returned.
###############################################################
tryCatchReturnError <- function(expr) {
  err <- NULL
  tryCatch(expr, error=function(e) err <<- e)
  return(err)
}

###############################################################
## Removes leading and trailing whitespace from a string
###############################################################
trim <- function(str) {
  if(is.null(str)) return(NULL)
  
  sub("^[ \t]*", "", sub("[ \t]*$", "", str))
}

###############################################################
## Returns TRUE if an object is not null and is a finite number.
###############################################################
is.valid.number <- function(x){
  is.numeric(x) && is.finite(x)
}

vector.is.valid.number <- function(x) {
  is.finite(x)
}

vector.is.na.or.nan <- function(x) {
  
}

###############################################################
## This function simulates
## sort(vec, index.return=TRUE, na.last=TRUE, ...)
## (This combination of arguments throws an error when passed
## to the native function)
###############################################################
sort.na.last <- function(vec, ...) {
  ## Sort leaves out NA and NaN, but not Inf

  vec.notnumeric.idx <- c(1:length(vec))[is.na(vec) | is.nan(vec)]
  vec.numeric.idx <- c(1:length(vec))[!is.na(vec) & !is.nan(vec)]

  vec.sorted.idx <- c(vec.numeric.idx[sort(vec, index.return=TRUE, ...)$ix],
                      vec.notnumeric.idx)
  vec.sorted.idx
}
