# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  idcol.r                                                                                #
  #           Last Updated Funclist  :  25 Feb 2015,  8:34 AM (Wednesday)                                                      #
  #                                                                                                                            #
  #           Author Name            :  Rick Saporta                                                                           #
  #           Author Email           :  RickSaporta@gmail.com                                                                  #
  #           Author URL             :  www.github.com/rsaporta                                                                #
  #                                                                                                                            #
  #           Packages Called        :  NA                                                                                     #
  #           Packages Used via NS   :  data.table                                                                             #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   is.idcol                   ( x )                                                                                         #
  #   as.idcol                   ( x )                                                                                         #
  #   as.idcol.idcol             ( x )                                                                                         #
  #   as.idcol.character         ( x )                                                                                         #
  #   as.idcol.default           ( x )                                                                                         #
  #                                                                                                                            #
  #   is.idcolfactor             ( x )                                                                                         #
  #   as.idcolfactor             ( x, ... )                                                                                    #
  #   as.idcolfactor.idcolfactor ( x, ... )                                                                                    #
  #   as.idcolfactor.factor      ( x, ..., showWarnings=TRUE )                                                                 #
  #   as.idcolfactor.character   ( x, ... )                                                                                    #
  #   as.idcolfactor.default     ( x, ... )                                                                                    #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #


detectIDColumns <- function(DT, showWarnings=TRUE) {
## returns T/F vector whose names are names(DT)
  pat = "id$"
  addl_candidates = c("upc", "vendor_catalog_number", "display_upc", "release_parent_upc", "Upc", "UPC", "original_upc", "parent_upc", "min_upc_in_group", "album_code", "ean")

  candidate_names <- extract(pat, DT)
  candidate_names %<>% c(addl_candidates) %>% intersect(., names(DT))

  non_candidate_names <- c("count", "numberof", "number_of") %>% lapply(extract, candidate_names) %>% unlist
  ## non_candidate_names accidentally picks up 'subaccount' because of the word 'count'
  non_candidate_names %<>% {setdiff(., extract("subaccount", .))}
  
  if (length(non_candidate_names)) {
    verboseMsg(showWarnings, warningCols("The following seemingly ID-like columns are ambiguous (and will not be changed in setIDcols): ", non_candidate_names))
    candidate_names %<>% setdiff(non_candidate_names)
  }

  sapply(names(DT), function(x) {x %in% candidate_names})
}

detectUSDColumns <- function(DT) {
## returns T/F vector whose names are names(DT)
  pat = "(\\b|_)USD(\\b|_)"
  addl_candidates = c("gross", "revenue", "net_rev")

  candidate_names <- extract(pat, DT)
  candidate_names %<>% c(addl_candidates) %>% intersect(., names(DT))
  sapply(names(DT), function(x) {x %in% candidate_names})
}

detectEURColumns <- function(DT) {
## returns T/F vector whose names are names(DT)
  pat = "(\\b|_)EUR(\\b|_)"
  addl_candidates = c()

  candidate_names <- extract(pat, DT)
  candidate_names %<>% c(addl_candidates) %>% intersect(., names(DT))
  sapply(names(DT), function(x) {x %in% candidate_names})
}

detectBoolColumns <- function(DT, ignoreLogical=TRUE, max_sample_size=100000) {
## returns T/F vector whose names are names(DT)
  pat = "is_|has_"
  addl_candidates = c()
  
  candidate_names <- extract(pat, DT)
  candidate_names %<>% c(addl_candidates) %>% intersect(., names(DT))

  if (ignoreLogical)
    candidate_names %<>% setdiff(., nwhich(sapply(DT, is.logical)))

  if (length(candidate_names)) {
    N.samp <- min(max_sample_size, nrow(DT))
    samp <- {. %>% sample(., size=N.samp, replace=FALSE)}
    candidate_names <- nwhich(DT[, sapply(.SD, function(x) {
            (is.numeric(x) && all(samp(x) %in% c(1, 0, NA))) ||
            ((is.character(x) || is.factor(x)) && all(toupper(substr(samp(x), 1, 1)) %in% c('Y', 'N', NA)))
      }), .SDcols=candidate_names])
  }

  ## If we are not ignoring logicals, then we explictily add them
  if (!ignoreLogical)
    candidate_names %<>% c(., nwhich(sapply(DT, is.logical))) %>% unique

  sapply(names(DT), function(x) {x %in% candidate_names})
}

setIDCols <- function(DT, idCols=nwhich(detectIDColumns(DT, showWarnings=showWarnings)), verbose=TRUE, showWarnings=TRUE) {
  idCols <- intersect(idCols, names(DT))

  if (!length(idCols)) {
    verboseMsg(verbose, "No idCols found", func=ifelse(missing(idCols), "message", "warning"), time=FALSE)
    return(invisible(DT))
  }

  already_idCols <- DT[, sapply(.SD, is.idcol), .SDcols=idCols]
  if (all(already_idCols)) {
    verboseMsg(verbose, "All idCols are already of the proper idCol class;  nothing to convert", func="message", time=FALSE)
    return(invisible(DT))
  }

  idCols <- idCols[!already_idCols]

  verboseMsg(verbose, sprintf("Will be converting %i columns: %s", length(idCols), pasteQand(idCols)))

  DT[, (idCols) := lapply(.SD, as.idcol), .SDcols=idCols]
  return(invisible(DT))
}

## BOOL EQUIVALENT
setBoolCols <- function(DT, boolCols=nwhich(detectBoolColumns(DT, ignoreLogical=TRUE)), verbose=TRUE, showWarnings=TRUE) {
  boolCols <- intersect(boolCols, names(DT))

  if (!length(boolCols)) {
    verboseMsg(verbose, "No boolCols found", func=ifelse(missing(boolCols), "message", "warning"), time=FALSE)
    return(invisible(DT))
  }

  already_boolCols <- DT[, sapply(.SD, is.logical), .SDcols=boolCols]
  if (all(already_boolCols)) {
    verboseMsg(verbose, "All boolCols are already of the proper logical class;  nothing to convert", func="message", time=FALSE)
    return(invisible(DT))
  }

  boolCols <- boolCols[!already_boolCols]

  verboseMsg(verbose, sprintf("Will be converting %i columns: %s", length(boolCols), pasteQand(boolCols)))

  DT[, (boolCols) := lapply(.SD, function(x) {
      if (is.numeric(x)) 
        as.logical(x) 
      else if (is.character(x) | is.factor(x))
        toupper(substring(x, 1, 1)) == "Y"
      else
        warning ("Do not know how to handle boolCol of type '", class(x)[[1]], "'")
  })
  , .SDcols=boolCols]
  return(invisible(DT))
}


is.idcol <- function(x) {
  return(inherits(x, "idcol"))
}

as.idcol <- function (x)  {
    UseMethod("as.idcol")
}

as.idcol.idcol <- function (x)  {
    return(x)
}

as.idcol.character <- function (x)  {
    data.table::setattr(x, "class",  c("idcol", class(x)) )
    return(x)
}

as.idcol.default <- function (x)  {
    if (inherits(x, "idcol"))
        return(x)

    x <- as.character(x)
    data.table::setattr(x, "class",  c("idcol", class(x)) )
    return(x)
}

as.idcol.numeric <- function (x)  {
    if (inherits(x, "idcol"))
        return(x)

    zeros <- which(x == 0)
    x <- format(x, scientific=FALSE, trim=TRUE, zero.print=NULL)
    x[zeros] <- "0"
    data.table::setattr(x, "class",  c("idcol", class(x)) )
    return(x)
}


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


is.idcolfactor <- function(x) {
  return(inherits(x, "idcolfactor"))
}


as.idcolfactor <- function (x, ...)  {
    UseMethod("as.idcolfactor")
}

as.idcolfactor.idcolfactor <- function (x, ...)  {
    return(x)
}

as.idcolfactor.factor <- function (x, ..., showWarnings=TRUE)  {
    if (length(list(...)) && showWarnings)
      warning ("x is already a factor. Additional arguments will be ignored\nHINT:  Call as.idcolfactor.default(x, ...) to override")

    data.table::setattr(x, "class",  c("idcolfactor", class(x)) )
    return(x)
}

as.idcolfactor.character <- function (x, ...)  {
    x <- factor(x, ...)
    data.table::setattr(x, "class",  c("idcolfactor", class(x)) )
    return(x)
}

as.idcolfactor.default <- function (x, ...)  {
    if (inherits(x, "idcolfactor") && !length(list(...)))
        return(x)

    x <- factor(x, ...)
    data.table::setattr(x, "class",  c("idcolfactor", class(x)) )
    return(x)
}