# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  transformations.R                                                                      #
  #           Last Updated Funclist  :  08 Feb 2015,  5:12 AM (Sunday)                                                         #
  #                                                                                                                            #
  #           Author Name            :  Rick Saporta                                                                           #
  #           Author Email           :  RickSaporta@gmail.com                                                                  #
  #           Author URL             :  www.github.com/rsaporta                                                                #
  #                                                                                                                            #
  #           Packages Called        :  NA                                                                                     #
  #           Packages Used via NS   :  NA                                                                                     #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   standardize        ( x )                                                                                                 #
  #   txform             ( x, tx=c("identity", "log", "standardize", "scale.0.1"), leftToRight=TRUE, roundTo=NULL              #
  #                        , na.rm=TRUE, allowNegLog=FALSE )                                                                   #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #

standardize <- function(x) { 
# a faster version of scale(x)
    if(!any(is.na(x))) 
        (x-mean(x))/sd(x) 
    else
        (x-mean(x,na.rm=T))/sd(x,na.rm=T)
}


txform <- function(x, tx=c("identity", "log", "standardize", "scale.0.1"), leftToRight=TRUE, roundTo=NULL, na.rm=TRUE, allowNegLog=FALSE) {

  if (!is.atomic(x))
    stop("[txform] x must be atomic")

  funcs <-list(
              identity = identity
            , log = log
            , standardize = function(vec) (vec-mean(vec)) / sd(vec) 
            , scale.0.1   = function(vec) {mn <- min(vec); (vec-mn) / (max(vec)-mn) }
            )

  tx <- match.arg(tx, names(funcs))

  if (na.rm)
    x <- removeNA(x)

  if (!allowNegLog && "log" %in% tx && any(x < 0)) 
    stop ("x contains negative values, cannot take log")
 
  if (leftToRight) 
    tx <- rev(tx)

  ## Apply the functions in sequence
  ret <- x
  for (f in funcs[tx])
    ret <- f(ret)
  
  ## Round. Usually just for immediate printing
  if (isTRUE(roundTo))  ## allow for `roundTo` to be logical
    roundTo <- 0
  if (isTRUE(is.finite(roundTo)))
    ret <- round(ret, roundTo)

  return(ret)
}

## EXAMPLES 
## XL <- {set.seed(1); sort(rnorm(80, -250, 10000))}
## XL[sample(seq_along(XL), 10)] <- NA
## X <- setNames(nm=XL) # choose XS or XL
## tx <- c("identity", "log", "standardize", "scale.0.1")
## ret <- lapply(tx, function(tt) txform(X, tt, roundTo=2))
## do.call(data.table, ret)

# TESTING: #     ## TESTING TRANSFORMATION
# TESTING: #     XL <- {set.seed(1); sort(rnorm(80, -250, 10000))}
# TESTING: #     XS <- {set.seed(1); sort(sample(-20:20, 4, TRUE))}
# TESTING: #     
# TESTING: #     X <- setNames(nm=XL) # choose XS or XL
# TESTING: #     
# TESTING: #     tx <- c("standardize", "scale.0.1")
# TESTING: #     tx <- c("identity", "log", "standardize", "scale.0.1", "scale")
# TESTING: #     tx  <- setNames(nm=tx)
# TESTING: #     ret <- lapply(tx, function(tt) txform(X, tt, roundTo=2))
# TESTING: #     
# TESTING: #     PP <- lapply(tx, function(tt) {x <- ret[[tt]]; qplot(x=seq_along(x), y=as.vector(x)) + geom_line()+ggtitle(tt) + geom_hline(aes(yintercept=mean(x)), color="red") +  geom_hline(aes(yintercept=x), color="green") })
# TESTING: #     try(dev.off(), silent=TRUE); dev.new(); print(do.call(grid.arrange, c(PP, ncol=2) ))