# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  rounding functions.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                                                                                     #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   roundLeft                 ( x, n=3, useCL=TRUE, pushup=1.5, noWarnOnChar=TRUE )                                          #
  #   roundToPower              ( x, pow=2, stops=1, digs.round=0, direction=c("closest", "up", "down") )                      #
  #   roundToNManyNonZeroDigits ( x, N.digits=3 )                                                                              #
  #   selfRound                 ( X, digs.remain..only.applies.to.units.and.up=3 )                                             #
  #   roundToWhat               ( X, digs.remain=3 )                                                                           #
  #   roundOutToX               ( obj, X=10, center=0, x=X, preserveAttributes=TRUE, from )                                    #
  #   roundOutToDig             ( obj, d=1 )                                                                                   #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #

# rounding functions.r

roundLeft <- function(x, n=3, useCL=TRUE, pushup=1.5, noWarnOnChar=TRUE) {
# n counts from the left. 

  if(is.factor(x) || is.character(x))
    x <- as.num.as.char(x, noWarnOnChar=noWarnOnChar)

  if(!is.numeric(x) || !is.atomic(x))
    stop("x must be numeric and atomic")

  if (length(n) != 1)
    stop("n must be of length 1")
  if (n < 1)
    warning("n should be a positive integer")

  if (useCL) {  
    cl <- ceiling(log(x, 10)+pushup)
    ex <- cl-n
  } else 
    ex <- n

  ret <- round(x / 10^ex) * 10^ex

  return(ret)
}

roundToPower <- function(x, pow=2, stops=1, digs.round=0, direction=c("closest", "up", "down")) {
## stops is fractions of power

  if (!length(x))
    return(x)

  if (stops <=0 || stops > 1) {
    stop ("'stops' should be between (0, 1]\neg  1/3  or 0.5")
  }

  direction <- match.arg(direction)
  below <- pow^floor(log(x, pow))

  ll <- log(x, pow)
  up <- ceiling(ll)
  dn <- floor(ll)

  vals <- pow^(seq(dn, up, by=stops))
  if (!is.null(digs.round))
    vals <- round(vals, digs.round)

  if (direction == "up")
    vals <- vals[vals >= x]
  if (direction == "down")
    vals <- vals[vals <= x]

  vals[which.min(abs(vals - x))]
}


roundToNManyNonZeroDigits <- function(x, N.digits=3) {
  round(x, -(locateFirstNonZeroDigit(x) - N.digits))
}

selfRound <- function(X, digs.remain..only.applies.to.units.and.up=3) {
  ret <- try(round(X, roundToWhat(X, digs.remain=digs.remain..only.applies.to.units.and.up)))
  if (isErr(ret)) {
    warning ("selfRound() failed. Returning un-rounded value")
    return(X)
  }
  return(ret)
}
  

roundToWhat <- function(X, digs.remain=3) {
## digs.remain :  How many digits (unit and above) remain unrounded
## 
##   roundToWhat( 12345678, 2)  returns  (-6)
##

  if (is.null(X) || !length(X) || !is.numeric(X))
    return(X)

  if (digs.remain == 0)
    warning ("digs.remain=0 does not make any sense. Returning 0.")

  ## if digs.remain is less than 0, then regular round(x, digs) can be used.  No need for this function
  if (digs.remain <= 0)
    return(rep(-digs.remain, length(X)))
  ## ELSE: 

  ## Take abs, since rounding to digits does not consider negative sign. 
  ##  Todo:  Consider dropping one digit for negative
  X <- abs(X)

  ## count the number of digits in X; subtract how many digits are requested
  ##    which leaves how many to round away. 
  ## For each value to return, if it is negative, return 0. (we do not want to round away more than all the digits)
  digitsInX <- ceiling(log10(X))
  digitsToRoundAway <- digitsInX-digs.remain

  ## Remove any values less than 0
  digitsToRoundAway <- ifelse(digitsToRoundAway < 0, 0, digitsToRoundAway)

  ## Take the negative, since we will be rounding to the left
  return( -digitsToRoundAway )

}


roundOutToX <- function(obj, X=10, center=0, x=X, preserveAttributes=TRUE, from) {
## rounds away from 'center' to the nearest 'x'
##
## TODO:  needs a measure for how many digits in x
##
## NOTE TO SELF:  This function is actually roundToNearestX()
##    If I were rounding OUT from CENTER, 
##         then I would take ceiling on x[x > center] 
##                         and floor on x[x < center] 

  ## xxxxxxxxxxxxxxxxxxxx ##
  ## I changed the argument from "from" to "center" to not conflict with seq() and to be more clear as to its purpose
  ## xxxxxxxxxxxxxxxxxxxx ##
  if (!missing(from)) {
    mc <- sys.call()
    mc <- capture.output(mc)
    warning("\n\n'from' has been deprecated in roundOutToX()\nUse 'center' instead\nPlease correct in \n  ", mc, "\n\n")
    center <- from
    rm(from)
  }
  ## xxxxxxxxxxxxxxxxxxxx ##

  ## bank the attributes
  orig.attribs <- attributes(obj)

  ## Avoid division by 0. 
  if(x==0) 
    return(round(obj)) 

  rounds <- cbind(   up = as.vector(floor   (obj/x) * x )
                 , down = as.vector(ceiling (obj/x) * x )
            ) + center
  ## recycling for a matrix happens column wise
  ## also, using negative abs() because there is no function min.col() only max.col()
  ret <- rounds[cbind(seq_along(obj), max.col((-abs(rounds - as.vector(obj))), ties="first"))]

  ## put the attributes back
  if (preserveAttributes) {
    attributes(ret) <- orig.attribs
  }

  return(ret)
}


roundOutToDig <- function(obj, d=1) {
  x <- floor( 10^(floor(log(obj, 10))-d))
  roundOutToX(obj, x)
}