# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  memoryFunctions.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                                                                                     #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   lsosdt             ( DF.included=TRUE, pos=1, envir=globalenv(), pattern=NULL )                                          #
  #   ls.objects         ( pos=1, pattern, order.by, decreasing=FALSE, head=FALSE, n=5, type="", all.names=FALSE               #
  #                        , ignore.case=TRUE )                                                                                #
  #   napply             ( names, fn )                                                                                         #
  #   lsos               ( pattern="", order.by="Size", decreasing=TRUE, n=10, MB=TRUE, KB=TRUE, type=""                       #
  #                        , all.names=FALSE, showfuncs=FALSE, byteMin=b, b=1000, mb=NA, ignore.case=TRUE                      #
  #                        , functions.returned.normally=FALSE, copy=FALSE, showWarnings=TRUE )                                #
  #   sc                 ( n )                                                                                                 #
  #   listType           ( L )                                                                                                 #
  #   formatKB           ( x, MB=GB, MBthresh=600, GB=FALSE )                                                                  #
  #   isErr              ( expression )                                                                                        #
  #   topropper          ( x )                                                                                                 #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #

cleanTrueLengthOfDTs <- function(DTs = lsosdt(envir=envir, onempty_list=TRUE)$name, verbose=TRUE, envir=globalenv(), length_expected=100) {

  ## If it is a single data.table, try cleaning it
  if (is.data.table(DTs)) {
      if (truelength(DTs) < length_expected) {
          if (verbose) cat("DT needs fixing ... ")
          alloc.col(DTs, length_expected)
          if (verbose) cat(ifelse (truelength(DTs) < length_expected, " ERROR - was not fixed", " fixed."), "\n")
      } else {
          if (verbose) cat("DT does not need fixing.")
      }
      return(invisible(DTs))
  }

  if (!is.character(DTs))
    stop ("DTs must be a data.table or a character vector of data.table names")

  do_any_of_the_DTs_need_fixing <- FALSE

  ## undocumented, set verbose to NULL to only have verbose output if changes are needed
  if (is.null(verbose)) {
    do_any_of_the_DTs_need_fixing <- TRUE
    verbose <- TRUE
  }

  for (DT in DTs) {
    if (truelength(get(DT, envir=envir)) < length_expected) {
      do_any_of_the_DTs_need_fixing <- TRUE
      if(verbose) cat(sprintf("%30s  needs fixing .... ", DT))
      eval(parse(text=sprintf("alloc.col(%s, %s)", DT, length_expected)), envir=envir)
      if (verbose) cat(ifelse(truelength(get(DT, envir=envir) < length_expected), "fixed", " ERROR - Needs attention"), "\n")
    }
  }
  if (!(do_any_of_the_DTs_need_fixing) && verbose && length(DTs))
    cat("None of the", length(DTs), "data.tables needed fixing\n")

  return(invisible(NULL))
}

lsosdt <- function(DF.included=TRUE, pos=1, envir=globalenv(), pattern=NULL, onempty_list=FALSE) {
# When data.tables are large, regular lsos takes a long time. 
# specifically, it is getting object size that takes long. 
# This gives similar info, without size

  ## If there are DFs as well as DTs, we probably want to show those as well
  ## DTCLASS is the value used in the call to inherits
  DTCLASS <- ifelse(DF.included, "data.frame", "data.table")

  if (!missing(pos))
    e <- parent.frame(pos)
  else 
    e <- envir

  res.ls <- if (!is.null(pattern)) ls(pattern=pattern, envir=e) else ls(envir=e)

  name <- res.ls[gapply(res.ls, inherits, DTCLASS, simplify=TRUE)]

  if (!length(name)) {
    cat("There are no data.tables", ifelse(DF.included, " or data.frames", ""), " currently loaded in '", capture.output(e), "'\n", sep="")
    if (onempty_list)
      return(invisible(list(name=name)))
    return(invisible(name))
  }

  data.table(  name=name, 
               rows=formnumb(gapply(name, nrow, simplify=TRUE)), 
               cols=gapply(name, ncol, simplify=TRUE), 
               keys=gapply(name, function(x) cropStringTo(paste(key(x), collapse=", "), 55), simplify=TRUE)
            )[order(rows, decreasing=TRUE)]
}

# QUICK USAGE: 

## BASIC: 
#  lsos()  ## Show all objects with memory size over 1KB, not including functions

## RESTRICT NUMBER OF OUTPUTS
#  lsos(n=12)  ## Same as above, but just top 12, by `order.by` (default: decreasing size) 

## SPECIAL USAGE: DATA.TABLES
# lsos(DT)    ## show just data.tables.   different from...
# lsos("DT")  ## show any object whose name contains "DT"
# lsos("DT", type="data.table")   ## Show data.tables whos name contains "DT"
# lsos(DT, mb=11)  ## show data.tables whose size is >= 11 MB


## DON'T SHOW CHARACTERS OR LOGICALS.  Any of the following work
#  lsos(type=c("!character", "!logical"))  # ! to indicate not. Quoted vecotr
#  lsos(type=c("!character", "logical"))  # ! on first element, applied to ALL elements
#  lsos(type=c("!character,logical"))  # single quoted string, comma separated, works too

## NOTE: `type` defaults to "!function", but if the desired output is (for example) 
##        'not functions and not characters', then both need to be specified
#  lsos(type="!function,!character")  OR:   lsos(type="!function,character")

# .ls.objects was adapted from Petr Pikal and David Hinds via Dirk Eddelbuettel
# http://stackoverflow.com/questions/1358003/tricks-to-manage-the-available-memory-in-an-r-session

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

.ls.objects <- function (pos = 1, pattern, order.by, decreasing=FALSE, head=FALSE, n=5, type="", all.names = FALSE, ignore.case=TRUE) {

  napply <- function(names, fn) {
      fn <- match.fun(fn)
      sapply(names, function(x) fn(get(x, pos = pos)))
  }

  names     <- ls(pos = pos, all.names=all.names)
  names     <- grep(pattern, names, value=TRUE, ignore.case=ignore.case)

  # if no names found that match the pattern, return an empty data.frame
  if (!length(names)) {
    return(data.frame(matrix(nrow=0,ncol=4
           , dimnames=list(NULL, c("Size", "Type", "Rows", "Columns")))))
  }

  obj.class <- napply(names, function(x) as.character(class(x))[1])
  obj.mode  <- napply(names, mode)
  obj.type  <- ifelse(is.na(obj.class), obj.mode, obj.class)

  obj.dim   <- t(napply(names, function(x) as.numeric(dim(x))[1:2]))

  vec <- is.na(obj.dim)[, 1] & (obj.type != "function")
  obj.dim[vec, 1] <- napply(names, length)[vec]

  out        <- data.frame(obj.type, obj.dim)
  names(out) <- c("Type", "Rows", "Columns")

  ### FILTER BY type  BEFORE GETTING obj.size
  # only return objects of type specified
  if (nchar(type) && !is.na(type)) { 

    if (type=="all")
      return(out)

    # split it, to allow for quoted string or vector of quote strings
    type <- unlist(strsplit(type, ","))

    ## TODO: Allow for plural & mis-typings, eg data.frames, dataframes, etc
    type <- gsub("^f$", "function", type, ignore.case=TRUE) 
    type <- gsub("functions", "function", type, ignore.case=TRUE) 
    type <- gsub("dataframe", "data.frame", type, ignore.case=TRUE) 
    type <- gsub("df", "data.frame", type, ignore.case=TRUE) 
    type <- gsub("dt", "data.table", type, ignore.case=TRUE) 


    # look for "!" prefix
    isneg <- grepl("^!", type)

    # negative in **only** the first element is considered negative to all. 
    # negative mixed in other manner is considered positive and issues warning due to ambiguity
    if (isneg[[1]])
      isneg[ ] <- TRUE

    # should not be mixed neg/pos
    if (any(isneg) && !all(isneg)) {
      warning("Cannot mix positive and negative types. Ignoring negative types.")
      out <- out[out$Type %in% type[!isneg], ]
    } else if (all(isneg)) { 
      type <- gsub("^!", "", type)
      out <- out[! out$Type %in% type, ]
    } else
      out <- out[out$Type %in% type, ]
  } # close if( type )


  ## we want to avoid calling objects.size() on ALL objects, because this takes a while
  out$Size  <- napply(rownames(out), object.size)


  # ordering:  (Note that at this point `Name` is the rownames, and already ordered by, thus we do nothing if Name requested)
  if (!missing(order.by)){

    # check to make sure that the requested column is valid
    if (!(order.by %in% c("Name", names(out)))) {
      warning("Cannot order by ", order.by, " since it is not a valid column name.")
    } else {
      if (order.by == "Name") 
        ordering <- order(tolower(rownames(out)), decreasing=decreasing) 
      else
        ordering <- order(out[[(order.by)]], decreasing=decreasing) 

      out <- out[ordering, ]
    }
  }

  if (head)
      out <- head(out, n)

  return(out)
}

# ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------- #
lsos <- function(pattern="", order.by="Size", decreasing=TRUE, n=10, MB=TRUE, KB=TRUE
                  , type="", all.names = FALSE, showfuncs=FALSE, byteMin=b
                  , b=1000, mb=NA, ignore.case=TRUE, functions.returned.normally=FALSE
                  , copy=FALSE, showWarnings=TRUE) {
# shorthand wrapper to .ls.objects
# cleaner output and uses data.table if available
#
#  b  : minimum amount of bytes
#  mb : alternatively, the minimum amount of megabytes
# MB / KB : logical.  Should Size be converted to either of these. MB superscedes KB
# type :  Which type of objects to display or not display

  # for if statement later
  byteMinMissing <- missing(byteMin)


  if (!missing(mb))
    byteMin <- mb * 1e6

  if(missing(type) && !showfuncs)
    type <- "!function"

  ## To avoid errors when sys.call()[[n]] is out of bounds
  L.sc <- length(sys.call())
  .sc <- function(n) n <= L.sc

  # ------------------------------------------ #
  #    Allow for lsos(funcname, f, c)          # 
  # ------------------------------------------ #
  if (.sc(3) && as.character(sys.call()[[3]]) == "f") {
      type <- "function"
      order.by <- "Name"
  }
  if (missing(copy) && .sc(4) && identical(tolower(as.character(sys.call()[[4]])), "c")) {
    copy <- TRUE
    decreasing <- TRUE
    if (identical(substitute(order.by), sys.call()[[4]]))
      order.by <- "Size"  ## if type was 'f', order.by would have already been changed
  }

  # ------------------------------------------ #
  #    Allowing for flexibility in order.by    #
  # ------------------------------------------ #
  if (!missing(order.by)) {
    # Check if order.by can be coerced to character. If not, then substitute its value. (If that still fails, R will throw an error.)
    if (isErr(order.by.new <- try(as.character(order.by), silent=TRUE)))
      order.by <- as.character(substitute(order.by))
    else 
      order.by <- order.by.new
  }

  # The 'Size' column is sometimes displayed as MB or KB, but order.by should still be "Size"
  if (order.by=="Kb" || order.by=="Mb")
    order.by <- "Size"
  # ------------------------------------------ #


  # ------------------------------------------ #
  # This allows for calls such as lsos("check", f) "show all functions with the name check"
  if (tolower(order.by) == "f" || tolower(substr(order.by, 1, 3)) == "fun") {
    order.by <- "Name"
    type <- "function"
  }

  # ------------------------------------------ #
  if (!missing(type)) {
    # allow for `t=f`
    if (as.character(substitute(type)) == "f")
      type <- "function"
    # otherwise: 
    # Check if type can be coerced to character. If not, then substitute its value. (If that still fails, R will throw an error.)
    if (isErr(type.new <- try(as.character(type), silent=TRUE)))
      type <- as.character(substitute(type))
    else 
      type <- type.new
  }

  # ------------------------------------------ #
  #   FLEXIBILITY IN c=T
  # ------------------------------------------ #

  if (!missing(copy) && identical(toupper(as.character(match.call()[["copy"]])), "T")) {
    copy <- TRUE
  }

  if ((missing(order.by) && tolower(type) %in% c("f", "fun", "func", "functions", "function")) || is.null(order.by)) {
    order.by <- "Name"
  }


  ## This has to come after any checks for `missing(order.by)`
  # All column names are proper-caps and hence so should order.by 
  order.by <- topropper(order.by)


  # change default of `decreasing` when `order.by` is "Name" 
  if ( missing(decreasing) && order.by=="Name")
    decreasing <- FALSE

  mc <- match.call()
  # if only one argument, and not a character
  if (length(mc) > 1 && is.name(mc[[2]])) {
    pat <- as.character(mc[[2]])

    if (pat == "DT" && type=="!function") {
      pattern <- ""
      type    <- "data.table"

    # check if the input is a variable containing a valid pattern (ie a character). If so, do nothing. 
    #          NOT:     Is it a variable?          if so,       Is the value a character
    } else if (! (exists(pat, envir =parent.frame()) && is.character(get(pat, envir=parent.frame())))) {
      pattern <- pat
    }
    # else, do nothing  
  }

  ## Allow for `type=bool` and `type=boolean` in the function call
  if (substr(tolower(type), 1, 4) == "bool")
    type <- "logical"

  out <- .ls.objects(pattern=pattern, order.by=order.by, n=n, type=type, decreasing=decreasing, all.names=all.names, head=!missing(n), ignore.case=ignore.case)
  
  # no objects found
  if (nrow(out)==0) {
    if (showWarnings)
      warning("\n\tNo objects of selected type in memory.\n\tTry argument:  lsos(type=\"all\") ")
    return(invisible(data.table(Name=character(), Type=character(), Rows=integer(), Columns=integer(), Size=character())))
  }

  # as long as byteMin is a valid number
  suppressWarnings(byteMin <- as.numeric(byteMin))
  if(!(is.null(byteMin) || is.na(byteMin))) {
    aboveSize <- out$Size > byteMin
    
    # no values larger than requested limit
    if(!any(aboveSize)) {
      if (!byteMinMissing) 
        warning("No object is larger than ", ifelse(missing(mb), paste(byteMin, "bytes"), paste(byteMin / 1e6, "MB")), ". Displaying all objects of (un)selected type(s).")
    } else {
      out <- out[aboveSize, ]
    }
  }

  if (missing(MB) && missing(KB)) { 
    maxsize <- max(as.numeric(as.character(out[["Size"]])))
    if (maxsize < 1e3){
      MB <- KB <- FALSE
    } else if (maxsize >= 1e3 && maxsize < 1e6) {
      KB <- TRUE
      MB <- FALSE
    } else {
      MB <- TRUE
    }
  }

  #  # Note that "MB" will be appended row-by-row to each size
  #  if (MB) {
  #    out[, "KB"] <- formatKB(out[, "Size"] / 2^10, MB=TRUE)
  #    out <- out[ , c("KB", setdiff(names(out), c("KB", "Size")))]
  #  }
  #
  #  if (KB & !MB)  {
  #    out[, "Size"] <- formatKB(out[, "Size"] / 2^10)
  #    names(out)[names(out) == "Size"] <- "KB"    
  #  }

  out[, "Size"] <- formatBytes(out[, "Size"])
 

  # Add a column for lists, indicating their type
  if (any(out.l <- out$Type=="list")) {
    out$ListContent <- ""
    out[out.l, "ListContent"] <- sapply(rownames(out[out.l, ]), function(x) listType(get(x)) )
  }

  # replace NA `Columns` value with blank
  out[is.na(out[, "Columns"]), "Columns"] <- ""

  if (copy && exists("clipCopy"))
    clipCopy(rownames(out))

  # if returning only function, return that as a vector, to show them all
  if (all(out[, "Type"] == "function") && !functions.returned.normally) {
      ret <- rownames(out)[order(toupper(rownames(out)))]
      cat("", paste_l(ret, spacer="  \t" ))
      return(invisible(ret))
  }
  
  if (!exists("data.table"))
    return(out)
  # else

  ret <- data.table(Name=rownames(out), out)
  if ("data.table" %in% ret[["Type"]]) {
      ret[, Key := ""]
      ret[Type == "data.table", Key := ifelse(haskey(get(Name)), paste(key(get(Name)), collapse=", "), "(<not set>)"), by=Name]
      ret[nchar(Key) > 23, Key := paste0(" ", substr(Key, 1, 20), "..")]
      setcolorderpt(ret, endCols="ListContent", showWarnings=FALSE)
    }
  
  return(ret)
  ## add key column if any values are data.table

}

# ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------- #
listType <- function(L) { 
  are <- lapply(L, is)

  are <- unique(are)

  if (length(are) == 1)
    return(are[[1]][[1]])

  if (length(are) == 2)
    return( paste( are[[1]][[1]], "&", are[[2]][[1]])  )

  return("Mixed")
}

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

### ------ deprecated ------
### ------ deprecated ------
#  formatKB <- function(x, MB=GB, MBthresh=600, GB=FALSE) { 
#  
#  ### TODO:  Deprecate this and use `formatBytes()` instead
#  
#  # This is a quick and dirty function to convert bytes to KB
#  # for cleaner output
#  
#    ret <- x
#    for (i in 5:(-2))
#      ret[x < 5 * 10^(i)] <- round( x[x < 5 * 10^(i)],  -(i)+1)
#  
#    if (MB) {
#      mb <- ret[ret>MBthresh]/1000
#      ret[ret>MBthresh] <- ifelse(mb > 100, paste(round(mb), "MB"), paste(round(mb, 1), "MB"))
#    }
#    prettyNum(ret, big.mark=",")
#  }

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

if(!exists("isErr"))
isErr <- function(expression)  {
  #  Boolean; Tries to evaluate the expresion; returns T if an error is thrown
  #  Args:
  #    expression:  Make sure to use expression() to pass an expression (dont use Strings)
  #  Returns:
  #    T if expression throws an Error // F if expression is evaluated without error
  #    NOTE:  The actual evaluation of the expression is NOT RETURNED
  
  return( inherits(try(eval(expression), silent=T), "try-error") )
}

if(!exists("topropper"))
topropper <- function(x)
    gsub("\\b([a-zA-Z])([a-zA-Z]+)", "\\U\\1\\L\\2", x, perl=TRUE)