# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  facet and formula utils.r                                                              #
  #           Last Updated Funclist  :  30 Aug 2015,  9:05 PM (Sunday)                                                         #
  #                                                                                                                            #
  #           Author Name            :  Rick Saporta                                                                           #
  #           Author Email           :  RickSaporta@gmail.com                                                                  #
  #           Author URL             :  www.github.com/rsaporta                                                                #
  #                                                                                                                            #
  #           Packages Called        :  NA                                                                                     #
  #           Packages Used via NS   :  NA                                                                                     #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   makeFormula        ( Left, Right, plusOrTimes=c("+", "*") )                                                              #
  #   facetOn            ( x, lh.len=1, rh.len=NULL, hierarchies=list(), justFormula=FALSE )                                   #
  #   pastep             ( ... )                                                                                               #
  #   makeFacetGroups    ( DT, exclude.cols=c(), integers.included=FALSE, numerics.included=FALSE, sep="_x_"                   #
  #                        , max.size=4, min.size=0, hierarchies=list(), dropTotalHierarchies=TRUE                             #
  #                        , valueCol.toExclude=c(), verbose=FALSE )                                                           #
  #   Fun                ( x )                                                                                                 #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #


## facetOn() and makeFacetGroups() are two functions from early 2015 (or older still)
## Not well documented, not sure how they work.  something about hierarchies. 
## Check which code used them. 

makeFormula <- function(Left, Right, plusOrTimes=c("+", "*"), except=c(), DT) {
## makes a formula expressions;  useful for facetting and for dcasting
## If DT is given and only one of Left / Right is given, the other is caluclated using setdiff and excluding 'except' colnames

  mR <- missing(Right)
  mL <- missing(Left)
  if (!missing(DT)) {
    nms_DT <- names(DT)
    if (mL && mR)
      stop("At least one of 'Left' / 'Right' must be given explicitly when using DT in makeFormula(Left, Right, except, DT)", call.=FALSE)
    if (!mL && !mR)
      warning("DT is ignored when both Left and Right are given explicitly. What was the user's intention when specifying all three arguments?")
    else if (mL)
      Left <- setdiff(nms_DT, c(Right, except))
    else if (mR)
      Right <- setdiff(nms_DT, c(Left, except))

    if (length(wh.not_in_DT <- setdiff(c(Left, Right), nms_DT)))
      warning(warningCols("The following columns from Left/Right are not in DT: ", wh.not_in_DT))

  } else {
    if (mL || mR)
      stop("Both 'Left' and 'Right' must be specified.\nAlternatively you can specifiy exactly one of them AND ALSO specify DT")
  }

  if (!length(Left))
    stop("Left has no length")
  if (!length(Right))
    stop("Right has no length")


  plusOrTimes <- match.arg(plusOrTimes)
  plusOrTimes <- sprintf(" %s ", plusOrTimes)
  paste(pasteC(Left, C= plusOrTimes), "~", pasteC(Right, C= plusOrTimes))
}


facetOn <- function(x, lh.len=1, rh.len=NULL, hierarchies=list(), justFormula=FALSE) {
## creates a facet_grid  call by creating a formula from the elements in x. 
## 
## hierarchies:  a list of ordered tuples.
##               Any existing elements in x will be treated as a single +
##               Takes presedence over lh.len and rh.len
## rh.len : How many elements to include on the rhs of the equation.  Overrides lh.len

  ## For empty x, do not facet
  if (!length(x))
    return(NULL)

  ## Confirm hierarchies is list of vectors
  if (!is.list(hierarchies) ||  any(sapply(hierarchies, length) == 1) )
    stop ("hierarchies must be a list of string vectos, each element of hierarchies at least 2 long")

  ## Calculate how many elements on each side of eq
  # if (length(x) > 2) {

    pastep <- function(...) 
      paste(..., collapse="+")

    ## Collapse any hierarchies into a plus relationship (Eg Continet+Country)
    for (h in hierarchies) {
      ## If there is a match, find where 
      h.ind <- removeNA(match(h, x))
      # if (!any(is.na(h.ind))) {
      if (length(h.ind)>=2) {
        ## Find the smallest index > 1.  h should always be at least two elements, thus no risk of -Inf
        new.ind <- min(h.ind[h.ind>1])
        ## assign the formula portion into that index
        # x[new.ind] <- pastep(h)
        x[new.ind] <- pastep(x[h.ind])
        ## Drop the other indeces from x
        x <- x[-(setdiff(h.ind, new.ind))]
      }
    }

    x.len <- length(x)

    ## eror-check if lh.len is valid (ie, not an error)
    if (lh.len <= 0L || lh.len > x.len)
      stop ("\n lh.len=", lh.len, " is an invalid lh.len value.\nIt should be a value between 0 and length(x), which is ", x.len, ".\n")

    ## First check if rh.len is given and less than x.len. If so, set lh.len to the compliment relative to x.len
    if (!is.null(rh.len) && rh.len <= x.len)
      lh.len <- x.len - rh.len

    ## if lh.len is positive, collapse all elements upto lh.len into one formula, 
    ##   and shift all the elements of x over to the left
    if (lh.len > 0L) {
      ## if lh.len exceeds x.len, indexing at 'lh.len+1' will insert NAs. Thus, this next if clause.
      if (x.len > lh.len)
        x <- c(pastep(x[1:lh.len]), x[(lh.len+1):x.len])
      else  ## TODO:  This maybe should throw a warning? 
        x <- pastep(x[1:min(lh.len, x.len)])
    }

    ## However, if lh.len is exactly 0, prepend a "." to x
    if (lh.len == 0L)
      x <- c(".", x)

    ## A this point, if there are still multiple elements in x, collapse everything but 
    ##      the first element, into one formula.
    ## Note that this addresses both, the rh.len as well as lh.len==0.   
    if (length(x) > 1)
      x <- c(x[[1]], pastep(tail(x, -1)))

    ## If x only has a single element, append a "." to the end
    if (length(x) == 1L)
      x <- c(x, ".")

  ret.formula <- c(fmt="%s~%s",  x) %>% as.list %>% do.call(what=sprintf, args=.) %>% as.formula
  if (justFormula)
    return(ret.formula)
  else 
    return (facet_grid(ret.formula))

  ## OLD as of 2015-05-08
  ## facet_grid( as.formula(do.call(sprintf, as.list(c("%s~%s",  x))) ) )
}


makeFacetGroups <- function(DT, exclude.cols=c(), integers.included=FALSE, numerics.included=FALSE, sep="_x_"
                              , max.size=4, min.size=0, hierarchies=list(), dropTotalHierarchies=TRUE, valueCol.toExclude=c()
                              , verbose=FALSE)  {
## min.size / max.size  : bounds on the number of elements in a combination
## notUsing :  Columns to explicitly exclude, by name
## integers.included : If FALSE (default), will exclude any column of class integer
## numeric.included  : If FALSE (default), will exclude any column of class numeric.
##         NOTE that a columns class is determined by class(x)  NOT by is.class(x), so there are no inheritence issues
## sep:  Used in naming the groups.  Values will be collapsed using sep
## dropTotalHierarchies : if FALSE, will allow groups like c("Continent", "Country")
## valueCol.toExclude : Another vector of column names to exclude which will be c()' d into exclude.cols

  if (min.size > max.size) 
    stop ("min.size cannot exceed max.size")
  
  ## Confirm hierarchies is list of vectors
  if (!is.list(hierarchies) ||  any(sapply(hierarchies, length) == 1) )
    stop ("hierarchies must be a list of string vectos, each element of hierarchies at least 2 long")

  nms <- names(DT)
  nms.class <- desc(DT, quiet=TRUE)

  ## Collect in one vector, the names of classes that will not be included
  classes.dropping <- c(if (!integers.included) "integer", if (!numerics.included) "numerics.included")
  if (length(classes.dropping))
    nms.class <- nms.class[!.(classes.dropping)]

  ## Ignore any columns which user has specified as not to use
  nms.class <- nms.class[!Columns %in% c(exclude.cols, valueCol.toExclude)]

  Fun <- function(x) {
      setattr(as.list(x), "names", pasteC(x, C="_x_"))
  }

  cols <- nms.class[["Columns"]]

  ## Check that there are enough cols to exceed min.size
  if (min.size > length(cols)) {
    warning("In makeFacetGroups():\n  The min.size (", min.size, ") exceeds the number of included columns (", length(cols), ")\n  Returning character(0L)\n")
    return( character(0L) )
  }

  ## Inherent bounds.  This also allows user to sepcify Inf, NA or NULL for unbounded (or "natural" bounds)
  max.size <- min(max.size, length(cols), na.rm=TRUE)
  min.size <- max(min.size, 0L, na.rm=TRUE)

  ## Calculate the groups
  Grouping <- lapply(min.size:max.size, function(i) combn(cols, i, simplify=FALSE) )

  ## un-nest the list
  Grouping <- unlist(Grouping, recursive=FALSE)

  ## For verbose output. Compare previous length to after
  length.prior.h <- length(Grouping) 

  ## For hierarchies, we simply want to ensure that there is no group that contains all 
  ##   elements of a hierarchy AND that one of those elements is the first item (which will be on the axis)
  for (h in hierarchies) {
    # print(h)
    Grouping <- 
    lapply (Grouping, function(g) {
      m <- removeNA(match(h, g))
      # print(m)
      ## If all of g is in h
      if (all(g %in% h) && length(g) > 1 && dropTotalHierarchies) {
        g <- NULL 
      } else if (length(m)>=2) {
        ## If an element is in the first index of g, shove it over
        if (1 %in% m) {
          ## Grab the smallest of "the first g, not in m" or "the largest m"
          swap <- min(setdiff(seq(g), m), max(m, na.rm=TRUE))
          ## Move it away from the one-position
          g <- g[c(swap,  setdiff(seq(g), swap))]
        }
        ## Order by hierarchy.  m2 will index the values of g as ordered in h.
        ##  We cannot simply use g[m2] <- ..  because that will still be out of order. 
        m2 <- match(h, g, nomatch=0L)
        g[sort(m2)] <- g[m2]
      }
      return(g)
    }) # // end lapply
  }

  ## Drop any NULLs or duplicates
  Grouping <- unique(Grouping[sapply(Grouping, Negate(is.null))] )

  ## For verbose output. Compare previous length to after
  length.post.h <- length(Grouping) 
  verboseMsg(verbose, "Cleaned up Grouping. After hierarchies cleaning, diff in lengths is ", length.prior.h, " - ", length.post.h, time=FALSE)

  ## Name the list
  setattr(Grouping, "names", lapply(Grouping, pasteC, C=sep))

  return(Grouping)
}