# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  CleanTo1 and Equals0.r                                                                 #
  #           Last Updated Funclist  :  08 Feb 2015,  5:14 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                                                                                     #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   CleanTo1_          ( DT, colsToClean, byCols=key(DT), tol=1e-04, makeZero.values_that_are_close_to_zero=FALSE            #
  #                        , allowNegativeValues=TRUE, max_add=0.1 )                                                           #
  #   bumpAwayFromZero   ( x, tol=1e-04 )                                                                                      #
  #   equals0            ( x, tolerance=1e-06, na.check=FALSE, showWarnings=TRUE )                                             #
  #   equals1            ( x, tolerance=1e-06, na.check=FALSE, showWarnings=TRUE )                                             #
  #   equals0or1         ( x, tolerance=1e-06, na.check=FALSE, showWarnings=TRUE )                                             #
  #   equals             ( x, value, tolerance=1e-06, na.check=is.logical(x) && is.logical(value)                              #
  #                        , empty.value.yields=NA, showWarnings=TRUE, showWarnings.for.empty.value=showWarnings )             #
  #   sumsToOne          ( DT, col, by=NULL, tol=1e-06, na.rm=FALSE, treat.entire.group.NA.as=TRUE, headmx=10                  #
  #                        , fail.if.not=TRUE )                                                                                #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #

manual.all.equal <- function(x, y, SIMPLIFY=TRUE) {
  if (class(x)[[1]] != class(y)[[1]])
    return(FALSE)

  if (is.list(x) && is.list(y))
    return(mapply(manual.all.equal, x=x, y=y, SIMPLIFY=SIMPLIFY))

  if (length(x) != length(y))
    return(FALSE)

  all(x == y  & !xor(is.na(x), is.na(y)))
}


CleanTo1_ <- function (DT, colsToClean, byCols=key(DT), tol=1e-4, makeZero.values_that_are_close_to_zero=FALSE, allowNegativeValues=TRUE, max_add=0.1) {
## Accomplishes two things: 
##   (1) Any values *close to zero* (within tolerance) are either bumped away from zero or made zero (depending on makeZero)
##   (2) The largest value is given/losses any remainder from 1 so that they sum to exactly 1 (within machiene precision)

  if (tol > 1)
    warning ("tol is larger than 1. Did you forget a negative in the exponent?")


if (FALSE) 
{
  colsToClean <- c("tmp.perc_by_date_SC", "two")
  DT[, two := sample(c(rnorm(nrow(DT)/2, 0.000005, .0000005), runif(nrow(DT)/2, 0, .05)))]
}

  ## Confirm that the columns sum to one
  if (!all(sumsToOne(DT, colsToClean, by=byCols, tol=.1, fail=FALSE)))
    stop ("\nThe colsToClean do not sum to a value close to one (using a 0.1 tol)\nThe cleaning did *NOT* run\nHINT: Please check the DT and the columns and try again. Otherwise, modify the code in CleanTo1_() ")

  browser(expr=inDebugMode(c("CleanTo1_")), text="in CleanTo1_() before bumping zeros")

  if (isTRUE(makeZero.values_that_are_close_to_zero)) {
    DT[, (colsToClean) := lapply(.SD, function(x) ifelse(equals0(x, tol=tol), 0, x)), .SDcols = colsToClean]
  } else {
    DT[, (colsToClean) := lapply(.SD, bumpAwayFromZero, tol=tol), .SDcols = colsToClean]
  }

.inner <<- FALSE
  # DT[, (colsToClean) := lapply(.SD, function(x) {
  DT[, (colsToClean) := lapply(.SD, function(x) {
      ## If all are NAs, do nothing
      if (all(is.na(x)))
          return(x)

      if (sum(x, na.rm=TRUE) != 1) {
        ind.big <- which.max(x)
# browser(expr=any(is.na(x)) && .inner, text="There is an NA in x")
        to_add <- 1 - sum(x, na.rm=TRUE)
        if (to_add > max_add)
          warning ("ammount to_add (", round(to_add, 3), ") exceeds max for .BY = list(", pasteC(lapply(.BY, paste, sep=" "), C=","), ")")
        else 
          x[ind.big] <- x[ind.big] + to_add
      }
      ## Return x
      x
    }), .SDcols=colsToClean, by=byCols]


  ## Confirm that the columns sum to one
  if (!all(sumsToOne(DT, colsToClean, by=byCols, tol=tol, fail=FALSE)))
    stop ("\nThe colsToClean do not sum to one, even after the cleaning.\nThe cleaning did *HAS* ran and the DT *was* modified\nHINT: This may be due to needing to add too much to any single one value. \n     Please check the DT and the columns and try again. Otherwise, modify the code in CleanTo1_() ")

  return(invisible(DT))
}


bumpAwayFromZero <- function(x, tol=1e-4) {
  if (!length(x))
    return(x)

  nonZeros <- (x != 0)

  ## Quick return if all *are* Zero
  if (!any(nonZeros))
    return(x)

  inds.needBumping <- which(nonZeros & equals0(x, tol=tol))

  browser(expr = inDebugMode(c("bumpAwayFromZero", "bump")), text="in bumpAwayFromZero() before modifying x")

  x[inds.needBumping] <- (sign(x[inds.needBumping]) * tol) + x[inds.needBumping] / 10

  ## Confirm
  if (any(equals0(x, tol=tol, na.check=TRUE) & (x != 0)))
    stop ("Something went wrong. Some almost-zeros were not properly bumped away from the threshold\nHINT: Are there negative values?  This function was not properly tested for negatives")

  return(x)
}




equals0 <- function(x, tolerance=1e-6, na.check=FALSE, showWarnings=TRUE) {
  equals(x=x, value=0, tolerance=tolerance, na.check=na.check, showWarnings=showWarnings)
}
equals1 <- function(x, tolerance=1e-6, na.check=FALSE, showWarnings=TRUE) {
  equals(x=x, value=1, tolerance=tolerance, na.check=na.check, showWarnings=showWarnings)
}
equals0or1 <- function(x, tolerance=1e-6, na.check=FALSE, showWarnings=TRUE) {
  equals0(x=x, tolerance=tolerance, na.check=na.check, showWarnings=showWarnings) |  equals1(x=x, tolerance=tolerance, na.check=na.check, showWarnings=showWarnings)
}

equals <- function(x, value, tolerance=1e-6, na.check=is.logical(x) && is.logical(value), empty.value.yields=NA, showWarnings=TRUE, showWarnings.for.empty.value=showWarnings) {
## checks if x is essentially equal to value, with allotment for machine or rounding error
##
## na.check:  when na.check=TRUE, equals() returns for [j]   is.na(x[j]) & is.na(value[j])
##            when na.check=FALSE, equals() returns NA for [j] when either x[j] or value[j] is NA
##
## if value has no length, equals() returns empty.value.yields repeated to length of x
## if x has no length, equals returns x.  
##   (Note: that when both x and value have no length, the rep of empty.value.yields will yield an empty vector of class same as empty.value.yields)
## empty.value.yields : The value to be returned if value has no length. This value will be repeated to match length(x) 
##                      recomended to be a logical vector of length 1, but not required
## 

    if (!is.logical(empty.value.yields) || length(empty.value.yields) != 1) {
      if (showWarnings)
        warning("It is recomended that empty.value.yields be logical and of length 1, to ensure correct result type returned")
    }

    if (!length(value)) {
      len.x <- length(x)
      if (showWarnings.for.empty.value)
        warning("Value has length 0. x has length ", len.x, ". Returning rep(empty.value.yields, length(x))")
      return(rep(empty.value.yields, length(x)))
    }

    if (!length(x)) {
      if (showWarnings)
        warning("x has no length. Returning as.logical(x)")
      return(as.logical(x))
    }

    if (is.data.frame(x) && is.data.frame(value)) {
      if (missing(na.check))
        return(mapply(equals, x, value, tolerance=tolerance))
      else 
        return(mapply(equals, x, value, tolerance=tolerance, na.check=na.check))        
    }

    if ((length(value) != 1) && (length(value) != length(x))) {
      warning("x has length ", length(x), " while value has length ", length(value), ". Recycling will occur. \nHINT: equals() does NOT use `%in%`-like functionality.")
    }

    if (is.character(x) | is.character(value))
      ret <- value == x
    else 
      ret <- abs(value-x) < tolerance

    if (na.check) {
      ## these two lines are faster than doing
      ##     ret <- ifelse(is.na(ret), ret, (is.na(value) & is.na(x)))
      nas <- is.na(ret)
      if (any (nas))
        ret[nas] <- (is.na(value) & is.na(x)) [nas]

      ## Check infinites for date values
      if (inherits(x, c("Date", "POSIXct", "POSIXlt", "POSIXt"))) {
        infs <- is.infinite(value)
        if (any(infs))
          ret[infs] <- (is.infinite(value) & is.infinite(x)) [infs]
      }
    }

    names(ret) <- names(x)
    
    return(ret)
}

sumsToOne <- function(DT, col, by=NULL, tol=1e-6, na.rm=FALSE, treat.entire.group.NA.as=TRUE, headmx=10, fail.if.not=TRUE) {
## For each col, checks if the entire column sums to one.  
## Useuful for when the column, by group, are percentages that should sum to one, and combined with stopifnot()
## treat.entire.group.NA.as : if the valueCol is NA throughout the entire group, should this be treated as TRUE or FALSE, where these values correspond to succeed/fail

  ## Capture the name,  for messaging/output
  DT.nm <- capture.output(substitute(DT))

  if (!nrow(DT)) {
    warning("\nThere are no rows in ", DT.nm, " (thus returning treat.entire.group.NA.as) \n")
    return(treat.entire.group.NA.as)
  }

  if (any(by %ni% names(DT))) {
    stop ("Some names in `by` are not in names(DT) - namely ", by[by %ni% names(DT)])
  }
  if (any(col %ni% names(DT))) {
    stop ("Some names in `col` are not in names(DT) - namely ", col[col %ni% names(DT)])
  }
  
  ## Check for any columns that are fully NA
  if (any(fully_NA.columns <- DT[, sapply(.SD, function(x) all(is.na(x))), .SDcols=col]))
    warning("\nNote that the entirety of ", plrl("columns ", fully_NA.columns), pasteQand(nwhich(fully_NA.columns)), plrl(" are", fully_NA.columns), " NA in ", DT.nm)

  ## Split the code up into two lines so that it is faster 
  DT.TF <- DT[ , lapply(.SD, function(x) {
                    if (all(is.na(x))) 
                        treat.entire.group.NA.as 
                    else 
                        abs(sum(x, na.rm=na.rm) - 1) < tol
                  })
              , keyby=by, .SDcols=col]

  ret <- DT.TF[, sapply(.SD, all, na.rm=na.rm), .SDcols=col]

  browser(expr=inDebugMode(c("sum", "sumsToOne")), text="in sumsToOne, after ret was calculated")

  ## Columns with NAs will resolve to NA. These should be treated as FALSE (ie, did not sum to One)
  if (any(is.na(ret))) {
    warning("\nret in sumsToOne() had NAs, which will be treated as FALSE.\nset na.rm=TRUE if desired otherwise.")
    ret[is.na(ret)] <- FALSE
  }

  if (any(!ret)) {
    missing <- names(ret)[!ret]
    names(missing) <- missing
    attr(ret, "Sampling of Groups that dont sum to one") <- 
      lapply(missing, function(cc) {
          head(DT.TF[!sapply(get(cc), isTRUE)], headmx)
      })
    attr(ret, "How_Many_Groups_Sum_To_One") <- DT.TF[, sapply(.SD, function(x) sum(!x, na.rm=TRUE) + sum(is.na(x))), .SDcols=col]
    attr(ret, "Total_NonNA_Groups") <- DT.TF[, sapply(.SD, function(x) sum(!is.na(x))), .SDcols=col]

    if (fail.if.not) {
      print(ret)
      stop("There ", plrl("are ", !ret), sum(!ret), " columns with FALSE values")
    }
  }

  return(invisible(ret))
}