# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  percent functions.r                                                                    #
  #           Last Updated Funclist  :  19 Feb 2015, 12:52 PM (Thursday)                                                       #
  #                                                                                                                            #
  #           Author Name            :  Rick Saporta                                                                           #
  #           Author Email           :  RickSaporta@gmail.com                                                                  #
  #           Author URL             :  www.github.com/rsaporta                                                                #
  #                                                                                                                            #
  #           Packages Called        :  NA                                                                                     #
  #           Packages Used via NS   :  data.table                                                                             #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   as.perc              ( x )                                                                                               #
  #   validPercentage      ( x, min=0, max=1, nm=substitute(x), silent=FALSE, fixAttempt=TRUE, stopif=FALSE )                  #
  #   fix                  ( z )                                                                                               #
  #   fix                  ( z )                                                                                               #
  #   is.perc              ( x )                                                                                               #
  #   percToNumeric        ( x, divideBy100=TRUE )                                                                             #
  #   percOf               ( x, outOf, roundDigs=4, showWarnings=TRUE )                                                        #
  #   percOfTotal          ( x, na.rm=TRUE )                                                                                   #
  #   proportion           ( ..., DEPRECATED="use percOfTotal()" )                                                             #
  #   xaspercy             ( x, y )                                                                                            #
  #   percentIncrease      ( x, firstValueIs=NA )                                                                              #
  #   detectPercentColumns ( DT, thresh.for.values.gt.1=0.3, sampleSize=10000                                                  #
  #                          , percKeywords=c("perc", "precof", "percent", "percant", "%"), showWarnings=TRUE )                #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #


if (FALSE) {
  insertIntoFile_("/Users/rsaporta/git/misc/rscripts/utils/percent functions.r")
  " Note to self:  Remove the fix(z) functions "
}

## -------------- SCALE FUNCTIONS ------------------- ##
scale_minus_one_to_plus_one <- function (x) {
## sample x
##  x <- 10^seq(2:(-2)) %>% c(., -., 0) %>% sunique
  ifelse (abs(x) > 2, 
      sign(x) * (abs(log(abs(x), base=10) / (1 + log(abs(x), base=10))))
    ,
      (sqrt(abs(x)) / (1 + sqrt(abs(x)))) * sign(x) / 3
    )
}
percChangeScore <- function(Before, After) {
  B <- Before
  A <- After

  scale_minus_one_to_plus_one(
    ((A - B) ^ 3 + A + B) * ((sign(A-B) + 1) * (sign(B) + 1) * B + 1)
  )
}
sigmoid100 <- function(x, slowness_scaler=1e6) {
  10000 / (1 + exp(-x/slowness_scaler))
}
sigmoid <- function(x) {
  1 / (1 + exp(-x))
}
## -------------- SCALE FUNCTIONS ------------------- ##


as.perc <- function(x) {
  data.table::setattr(x, "class", c(class(x), "perc"))
}
is.perc <- function(x) {
  inherits(x, "perc")
}
print.perc <- function(x, dec=2, ...) {
  print(fwp(x, dec=dec, ...))
}

percToNumeric <- function(x, divideBy100=TRUE) {
  if (is.factor(x))
    stop ("x is a factor. Are the labels numerics or strings? Please manually convert\nHINT: consider using as.num.as.char()")
  if (!is.character(x) || !is.numeric(x))
    stop ("x shold be a string or a numeric")

  if (is.character(x))
    return(as.numeric(gsub("\\%|,", "", x)) / ifelse(divideBy100, 100, 1))
  if (is.numeric(x) && divideBy100)
    return(x / 100)
  else  ## just a plain numeric
    return(x)
}

## TEST CASES for percTRUE
if (FALSE) {
  x <- c(TRUE, NA, FALSE, TRUE)
  percTrue(x)
  percTrue(x, na.rm=TRUE)
  percTrue(x, of.FALSE=TRUE)
  percTrue(x, of.FALSE=TRUE, na.rm=TRUE)
  percFalse(x)
  percFalse(x, na.rm=TRUE)
}
percTrue <- function(x, na.rm=FALSE, as.perc=TRUE, of.FALSE=FALSE) {
## Given a logical vector, calculates what percentage are TRUE (or FALSE)
  if (!is.logical(x))
    stop ("x must be logical")

  total <- length(x)
  if (na.rm)
    total <- total - sum(is.na(x))

  counted <- if (of.FALSE) sum(!x, na.rm=TRUE) else sum(x, na.rm=TRUE)
  ret <- counted / total

  if (isTRUE(as.perc))
    ret <- as.perc(ret)
  return(ret)
}
percFalse <- function(x, na.rm=FALSE, as.perc=TRUE) {
  percTrue(x=x, na.rm=na.rm, as.perc=as.perc, of.FALSE=TRUE)
}


percOfTotal <- function(x, na.rm=TRUE, as.perc=TRUE, names=TRUE) {
## Wrapper function, takes the proportion element relative to group sum. 
## Wrapper useful when using get(), to avoid  get(ValueCol) / sum(get(ValueCol))
  if (is.logical(x))
    stop("x should be numeric\nHINT: did ou mean to call percTrue(x)")
  if (!is.numeric(x))
    stop("x should be numeric")

  ret <- x / sum(x, na.rm=na.rm)
  if (as.perc)
    ret <- as.perc(ret)

  names(ret) <- if (!is.null(names(x))) names(x) else format(x, scientific=FALSE)

  return(ret)
}

proportion <- function(..., DEPRECATED = "use percOfTotal()") {
  warning("proportion() is DEPRECATED -- use percOfTotal() instead")
  return(percOfTotal(...))
}


xaspercy <- function(x, y, as.perc=TRUE) {
  ret <- (x - y) / y

  if (as.perc)
    ret <- as.perc(ret)
  return(ret)
}

percOf <- function(x, outOf, roundDigs=4, as.perc=TRUE, showWarnings=TRUE) {
  ## 2015-11-01
  stop ("this function, percOf(), makes no sense -- \nI think you want   percOfTotal()  or  percChange()")

  force (x); force(outOf)
  verboseMsg(showWarnings, "percOf calculates 1 - (x/y).  Make sure this is what you want")
  ret <- round((outOf - x)/outOf, roundDigs)
  if (as.perc)
    ret <- as.perc(ret)
  return(ret)
}

percChange <- function(After=x, Before=outOf, x, outOf, as.perc=TRUE) {
  ret <- (After - Before) / Before
  if (as.perc)
    ret <- as.perc(ret)
  return(ret)
}

percentIncrease <- function(vec, firstValueIs=NA, as.perc=TRUE) {
## Calculates the percent increase from one element to the next
## For A vs B, use percChange
##
## returns vector of length(x)  where ret[j] = (x[j] - x[j-1]) / x[j - 1].  
##     ret[1] = firstValueIs by definition

  ## I had tested a few different alternatives for calculating
  ## ------------------------------------------------------------- ##
  # SLOWER:  c(firstValueIs,   diff(x) / x[-length(x)] )
  # FASTER:  c(firstValueIs,   (x[-1L] / x[-length(x)]) -1)
  # FASTEST: c(firstValueIs,   (tail(x, -1L) / head(x, -1L)) -1)
  ## ------------------------------------------------------------- ##

    ## Using FASTEST:
    ret <- c(firstValueIs,   (tail(vec, -1L) / head(vec, -1L)) -1)

  if (as.perc)
    ret <- as.perc(ret)
  return(ret)
}

# ----------------------------------------------------------------------------------- #

## TODO:  create function to add to this
options(percKeywords=c("perc", "precof", "percent", "percant", "%", "marketshare"))

detectPercentColumns <- function(DT, thresh.for.values.gt.1=0.3, sampleSize=1e4, percKeywords=getOption("percKeywords", default=c("perc", "precof", "percent", "percant", "%")), showWarnings=TRUE) {
  ## for each column in DT, returns TRUE if both
  ##   the name of the column contains one of percKeywords (using camelSplit on the name)
  ##   AND
  ##   most of the values in the column are between -1 and 1, where "most" means (1 - thresh.for.values.gt.1) OR the entire column is NA
  ## 
  ## thresh.for.values.gt.1 ::  range between 0 and 1, indicating what percentage of a column where the name matched must also be less than 1
  ##                            use negative values to indicate that percKeywords will not be used
  
  stopifnot(is.data.frame(DT))
  nms <- names(DT)
  ret <- sapply(nms, function(x) {
    is.perc(DT[[x]]) || (is.numeric(DT[[x]]) && {
      splat <- tolower(camelSplit(x, isolate=intersect("%", percKeywords)))
      any(percKeywords %in% splat) && 
        DT[!is.na(get(x))][, (.N == 0) || {.n <- min(.N, sampleSize); sum(abs(sample(get(x), .n)) > 1) / .n  <= thresh.for.values.gt.1}]
    })
  })
  ## warn for all-NA columns
  if (showWarnings && any(ret)) {
    wh.na <- sapply(nwhich(ret), function(x) all(is.na(DT[[x]])))
    if (any(wh.na))
      warning(warningCols("Some perc columns in the DT are fully-NA: ", wh.na))
  }
  return(ret)
}

# ----------------------------------------------------------------------------------- #
validPercentage.quick_0_1 <- function(x, thresh=0.7, verbose=TRUE)  {
  x.numb <- x
  if (is.factor(x))
    x.numb <- as.numeric(as.character(x))
  if (is.character(x))
    x.numb <- as.numeric(x)

  ## Make sure no NAs introduced
  if (any(errs <- xor(is.na(x), is.na(x.numb)))) {
    warning ("Did NOT change percentages, becuase NAs would have been introduced when converting. ie, for values: ", pasteQand(head(x[errs])))
    return(x)
  }

  how_valid <- percTrue(abs(x) > 1 | x == 0)

  if (how_valid >= thresh) {
    verboseMsg(verbose, "Converting x to a valid percentage, reutrning x / 100")
    return(x / 100)
  }
  if (how_valid < thresh && how_valid >= thresh / 3) {
    warning ("Ambigious if valid percentage or not -- how_valid is ", fwp(how_valid))
  }

  return(x)
}

validPercentage <- function(x, min=0, max=1, nm=substitute(x), silent=FALSE, fixAttempt=TRUE, stopif=FALSE) {
  #  Checks if x is inside [min, max]
  #  Returns the valid x if yes, FLASE if no
  #  fixAttempt:  if TRUE, this function will dividie or multiply by 100 to attempt to convert x to a valide percentage
  #               if x was modified and silent is TRUE, this function will throw a warning indicating as such
  #  stopif:  If TRUE and if x is not valid throws error.  
  #           If fixAttempt is also TRUE, will only throw error if failed to fix AND stopif is TRUE 

  nm <- capture.output(nm)

  if (length(x) > 1) {
    if (length(x) > 5000)
      stop ("x is too long (", length(x), ") and validPercentage is intended for single numbers (ie, function inputs for, say, thresholds)\n\nHINT: use validPercentage.quick_0_1()  if the intended range is [0, ±1]")

    ARGS <- collectArgs(except="x")
    return(sapply(x, function(x_i) do.call(validPercentage, c(ARGS, x=x_i))))
  }

  # # For now, this function only works on single values
  # if (length(x) > 1 || !is.atomic(x))
  #   stop("`validPercentage` can only be called on a single value. Support for vectors, lists, etc is planned.")

  x.orig <- x

  nm.char <- as.character(nm)
  nm <- ifelse (nm.char[[1]] == "[[", "x", paste0("`", deparse(nm), "`"))

  # Check for NA value in x
  if (is.na(x)) {
    if (!(silent))
      warning(nm, " has a value of NA and hence is not a valid percentage.\n")
    return(FALSE)
  }

  # Try to fix x.  
  x.was.fixed <- FALSE
  if (fixAttempt) {
    # how to fix
    if (max==1)
      fix <- function(z) z / 100
    if (max==100)
      fix <- function(z) z * 100

    # attempt to fix
    if (x < min || x > max) {
      x <- fix(x)
      x.was.fixed <- TRUE
    }
  }

  # If x is valid, return TRUE
  if (x >= min && x <= max) {
    if (!silent && x.was.fixed)
      warning("\n\n     ", nm, " should be a value in [", min, ", ", max, "].\n     ",
              nm, " was an invalid percentage, but has been\n     converted from ", x.orig, " to ", x, "\n")
    return(x)
    
  }

  msg <- paste0("\n", nm, " should be a value in [", min, ", ", max, "].\n", 
            nm, " = ", x.orig, " is not a valid precentage",
            ifelse(fixAttempt, " and could not be fixed.", ""),
            "\n")

  ## else, x is invalid
  
  # throw error, if flagged to do so
  if (stopif)
    stop(msg)

  # issue warning, unless flagged not to
  if (!silent)
    warning(msg)
#    warning("\n", nm, " should be a value in [", min, ", ", max, "].\n", 
#            nm, " = ", x.orig, " is not a valid precentage and could not be fixed.\n")

  # return FALSE (if no flag for errro)
  return(FALSE)
}


# ----------------------------------------------------------------------------------- #