# -------------------------------------------------------------------------------------------------------------------------  #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #           File Name              :  extract-type 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   :  NA                                                                                     #
  #                                                                                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  #                                                                                                                            #
  #   extractnms           ( pat, string, ignore.case=TRUE )                                                                   #
  #   extract              ( pat, string, ignore.case=TRUE, useValues=FALSE, sort=FALSE )                                      #
  #   extract_gregexpr     ( pat, string, ignore.case=TRUE, simplify=TRUE, multi.matches=c("allow", "fail", "first") )         #
  #   extractWordFollowing ( string, word_before, onlyOne=TRUE, breaks=c(",", "(", ")"), anySpace=TRUE                         #
  #                          , nchar_max.safety=5000, ignore.case=TRUE, showWarnings=TRUE )                                    #
  #   extractMatch         ( x, table, exact=FALSE, duplicates.ok=TRUE, grep.the.NAs=TRUE, ignore.case=TRUE                    #
  #                          , dont.be.a.sheep=FALSE, use.names.of.table=FALSE, fail.on.unmatched=FALSE                        #
  #                          , showWarnings=TRUE )                                                                             #
  #   matchExtract         ( x, table, nomatch=NA_integer_, incomparables=NULL, na.rm=TRUE, ignore.case=TRUE                   #
  #                          , partial.match.allowed=FALSE )                                                                   #
  #                                                                                                                            #
  #                                                                                                                            #
  #                                                     <END FUNCS>                                                            #
  #  -----------------------------------------------------------------------------------------------------------------------   #
  # -------------------------------------------------------------------------------------------------------------------------  #



extractnms <- function(pat, string, ignore.case=TRUE) {
## looks at the NAMES of an object, and matches pat against them.
## returns any matched names
  grep(pat, names(string), ignore.case=ignore.case, value=TRUE)
}


extract_headers_from_CSVs <- function(file, header=TRUE, nrows=12, ...) {
## reads in a CSV and extracts it's field names
  is.char_of_length1(file, fail.if.not=TRUE)

  names(fread(file, header=header, nrows=nrows, ...))
}

extract <- function(pat, string, ignore.case=TRUE, useValues=FALSE, sort=FALSE) {
## extracts pat from string
## if string has colnames, uses colnames(string) instead

  ## Safety check for user error. If arguments are swapped, R might hang if DF/DT is large
  if (is.data.frame(pat)) {
    stop("pat is a data.frame - do you have your arguments swapped for 'pat' & 'string' ?")
  }

  if (!is.null(colnames(string)) && !useValues) {
    ret <- extract(pat, colnames(string), ignore.case=ignore.case, sort=sort)
    setattr(ret, "names", sapply(ret, function(x) pasteC(sprintf("Col %02i", which(x==colnames(string))), C=" & ")))
    return(ret)
  }

  # ELSE
  matched <- grepl(pat, string, ignore.case=ignore.case)
  ret <- string[matched]

  ## Preserve the class
  if (is.character(string))
    class(ret) <- class(string)

  if (sort)
    ret <- sort(ret)
  return(ret)
}


extract_gregexpr <- function(pat, string, ignore.case=TRUE, simplify=TRUE, multi.matches=c("allow", "fail", "first")) {
## Written 2014-01-20
## multi.matches :: if allow, extracts all matches.  if first, only extract first match. Otherwise, fail

  multi.matches <- match.arg(multi.matches)

  if (length(pat) > 1)
    warning("extract_gregexpr is not vectorized on pat")
  
  matches <- gregexpr(pat, string)

  if(multi.matches == "fail" && any(sapply(matches, length)) > 1)
    stop("more than one match for certain strings\nHINT: use multi.matches = 'allow' or  multi.matches == 'first'")
  
  ## Create a bool, for quicker execution
  justFirst <- multi.matches=="first"

  mapply(function(s, m) if (all(m == -1)) NA_character_ else 
    if (justFirst || length(m) == 1)
        substr(s, m, m + attr(m, "match.length")-1)
    else
        mapply(function(st, en) substr(s, st, en), st=m, en=m + attr(m, "match.length")-1, SIMPLIFY=TRUE)
    , m=matches
    , s=string
    , SIMPLIFY=simplify)
}



extractWordFollowing <- function(string, word_before, onlyOne=TRUE, breaks=c(",", "(", ")"), anySpace=TRUE, nchar_max.safety=5000, ignore.case=TRUE, showWarnings=TRUE) {
## Looks for 'word_before' in string and returns the word following word_before
## where a word is defined as existing between two breaks and, if isTRUE(anySpace), between any space as well.

  if(nchar(string) > nchar_max.safety) {
    warning ("nchar of string (", nchar(string), ") exceeds nchar_max.safety (", nchar_max.safety ,")\nHINT:  set nchar_max.safety to a larger value ")
    return(NA)
  }

  if (!isTRUE(anySpace) && !length(breaks))
    stop ("One of 'anySpace' or length(breaks) must be TRUE")
  
  pat.split <- paste0(regOr(c(if(anySpace) "\\s", escapeRegEx(breaks))), "+")
  splat <- strsplit(string, pat.split)[[1]]

  if (ignore.case) {
    splat <- tolower(splat)
    word_before <- tolower(word_before)
  }


  matches <- word_before == splat
  if (!any(matches)) {
    verboseMsg(showWarnings, "No Matches found for '", word_before, "' -- returning NA")
    return(NA)
  }
  if (onlyOne && sum(matches) > 1) {
    verboseMsg(showWarnings, "More than one match found for '", word_before, "' -- returning NA")
    return(NA)
  }

  if (isTRUE(matches[length(matches)]))
    verboseMsg(showWarnings, "A match found for '", word_before, "' as the last word in the string. Returning NA for word following it")

  return(splat[which(matches) + 1] )
}



extractMatch <- function(x, table, exact=FALSE, duplicates.ok=TRUE, grep.the.NAs=TRUE, ignore.case=TRUE, dont.be.a.sheep=FALSE, use.names.of.table=FALSE, fail.on.unmatched=FALSE, showWarnings=TRUE) {
## extracts FROM table the values that most closely match it from x
## Note: the names of the matches will be the names of 'table' NOT the names of 'x'
##
## grep.the.NAs  :  if TRUE, if there are any non-matches using pmatch/charmatch, this function will next try to match those non-matches using grep
## duplicates.ok :  same as pmatch(x, table)



  ## we specifically do NOT want the user to change nomatch since we are not returning the results of pmatch() but rather an extraction using those results
  nomatch=NA_integer_

  if (use.names.of.table && is.null(names(table)))
    stop("'use.names.of.table' is set to TRUE, but 'table' does not have any names")

  if (!dont.be.a.sheep && {.l.x <- length(as.vector(unlist(x, use.names=FALSE)))} > 1000)
    stop("Sheepishly refusing to proceed with extractMatch()\n  There are ", .l.x, " elements in x and this function is not very fast.\n  HINT: set  dont.be.a.sheep=TRUE  to force proceed.")

  ## bank the original values, for final output. necessary since we might modify based on user-set flags
  table.orig <- table
  x.orig     <- x

  if (use.names.of.table)
    table <- names(table)
  if (ignore.case) {
    table <- tolower(table)
    x     <- tolower(x)
  }

  ## check for duplicates in table
  ## Note that 'table' is different from 'table.orig', thus, if we are removing duplicates, they should be removed from table.orig
  ##   If the duplicates of 'table' are DIFFERENT from the duplicates in 'table.orig'
  ##   Then it is not possible to proceed, since results might be innaccurate (ie, which of c("Value", "value") to return?)
  if (anyDuplicated(table)) {
    if (!identical(duplicated(table), {dups <- duplicated(table.orig)})) {
      ex.dup <- unique(table.orig[table == table[anyDuplicated(table)]])[1:2]
      stop ("With the current settings of extratMatch, duplicates have been introduced into 'table'.\n  eg: '", ex.dup[[1L]], "' and '", ex.dup[[2]], "' which with the flags (ignore.case, use.names, etc) have become identical.\n  HINT: change the flags in extractMatch() and try again.")
    }

    ## ELSE
    if (showWarnings)
      warning("There are duplicates in 'table' - while this will not affect results, be sure that there are no upstream bugs")

    ## must change table AND table.orig
    table      <- table[!dups]
    table.orig <- table.orig[!dups]
  }

  if (exact) {
    message("exact=TRUE is untested   Use  debugOn('exactMatch')   ")
    x <- paste0("^", x, "$")
    table <- paste0("^", table, "$")
  }

  ## Find the matches using pmatch
  if (is.character(x))
    matches <- charmatch(x=x, table=table, nomatch=nomatch)
  else
    matches <- pmatch(x=x, table=table, nomatch=nomatch, duplicates.ok=duplicates.ok)

  browser(expr=inDebugMode("extractMatch"), text="in extractMatch() after matches, before filtering")
  
  ## If there are NAs, we try harder to match, using grep
  ## Note that this is.na(matches) will be FALSE if nomatch is something other than an NA
  if (grep.the.NAs && any(is.na(matches))) {
    NAs <- is.na(matches)
    grepd.matches <- sapply(x[NAs], function(xx) {
      mm <- grep(xx, table, ignore.case=ignore.case)
      if (!duplicates.ok)
        mm <- setdiff(mm, matches)
      if (length(mm) == 1)
        return(mm)
      ## ELSE
      verboseMsg(showWarnings && length(mm) > 1, sprintf("'%s' matched %i different values (extractMatch will return %s):\n    * %s", xx, length(mm), as.character(nomatch), pasteC(head(table[mm]), C="\n    * ")))
      return(nomatch)
    })
    matches[NAs] <- grepd.matches
  }

  ## charmatch will return 0 (instead of nomatch) when a partial match is ambiguous (as opposed to not-found at all). Duplicate values in table would be ambiguous, hence removing at the top
  matches <- ifelse(matches==0, nomatch, matches)

  ## check if any remain unmatched
  isUnmatched <- is.na(matches)

  if (any(isUnmatched)) {
    msg <- warningCols("The following x values did NOT have a match:", x.orig[isUnmatched], if (!use.names.of.table && all(isUnmatched) && !is.null(names(table.orig))) "\n  HINT: did you mean to set   use.names.of.table=TRUE", endl=0)
    if (fail.on.unmatched)
      stop(msg)
    if (showWarnings)
      warning(msg)
  }

  ## We have to check for all NA, since vector[NA] yields rep(NA, length(vecotr)) -- and we dont want length table.orig, but rather length of x.orig
  if (all(isUnmatched))
    return(rep(nomatch, length(x.orig)))
  return(table.orig[matches])
}

matchExtract <- function(x, table, nomatch = NA_integer_, incomparables = NULL, na.rm=TRUE, ignore.case=TRUE, partial.match.allowed=FALSE) {
  # match(x, table, nomatch = NA_integer_, incomparables = NULL) 

  "NOTE TO SELF: matchExtract() is still used in one of the Jesus functions"

  warning("matchExtract()  is deprecated --  use extractMatch() instead")

  if (partial.match.allowed) {
    ret <- sapply(x, grep, table, ignore.case=ignore.case, value=TRUE)
    ## Put IN the NAs
    if (!na.rm)
      ret[sapply(ret, length) == 0] <- nomatch
    return(unlist(ret))
  }
  ## ELSE 

  ## Create a copy for extracting the values, since we may modify the original table
  table.vals <- table

  if (ignore.case) {
    x <- toupper(x)
    table[] <- toupper(table)
  }
  ret <- table.vals[ match(x=x, table=table, nomatch=nomatch, incomparables=incomparables) ]
  if (na.rm)
    ret <- removeNA(ret)
  return(ret)
}

extractAllMatches <- function(pattern, string, ignore.case=FALSE, remove_wildcard_from_pattern_tails=TRUE, showWarnings=TRUE) {

  # if (length(string) > 1)
  #   stop ("extractAllMatches not tested for multiple strings")
  if (length(pattern) > 1) {
    ARGS <- collectArgs(except="pattern")
    if (is.null(names(pattern)))
      names(pattern) <- pattern
    sapply(pattern, function(p) do.call(extractAllMatches, c(pattern=p, ARGS)))
    return(sapply(pattern, function(p) do.call(extractAllMatches, c(pattern=p, ARGS))))
    stop ("extractAllMatches not vectorized over pattern. Use sapply")
  }

  ## TODO:  Allow '.*?'
  if (remove_wildcard_from_pattern_tails) {
    pattern <- gsub("(^\\.\\*|\\.\\*$)", "", pattern)
  } else if (any(grepl("(^\\.\\*|\\.\\*$)", pattern)))
    warning ("The pattern contains '.*' at its start or end. This will stop the 'all' functionality of extractAllMatches\n\nHINT: set  remove_wildcard_from_pattern_tails=TRUE  to auto remove these")

  if (!grepl(pattern, string, ignore.case=ignore.case)) {
    if (showWarnings) 
        warning ("The string does not contain the pattern '", pattern, "'  -- returning character()")
    return(character())
  }

  repl_tmp <- "@@@@@888999TMPXX32123XXTMP888999@@@@"
  if (grepl(repl_tmp, string))
    stop ("The repl_tmp sting is found in the string. (Internally, we split on repl_tmp). Cannot proceed")

  ret <- strsplit(gsub(sprintf("(%s)", pattern), paste0(repl_tmp, "\\1", repl_tmp), string, ignore.case=ignore.case), repl_tmp)[[1]]
  ret[grepl(pattern, ret, ignore.case=ignore.case)]
}


## ------------------------------------------------ ##
##                HTML UTILS                        ##
## ------------------------------------------------ ##

extractAttrValueFromHTML <- function(
    html
  , attr_name="id"
  # , pat.attr="\\w+"
  , pat.attr=".*?"
  , fmt.attr='.*%s\\s*=\\s*"(%s)"'
  , ignore.case=TRUE
  , showWarnings=TRUE
) {

  ## If both attr_name and pat.attr have lengths greater than 1, they must have the same length
  if (length(attr_name) > 1 && length(pat.attr) > 1 && length(attr_name) != length(pat.attr))
    stop ("lengths of attr_name and pat.attr do not match")

  pattern <- sprintf(fmt.attr, attr_name, pat.attr)
  setattr(pattern, "names", attr_name)
  Attrs <- extractAllMatches(pattern=pattern, string=html, remove_wildcard_from_pattern_tails=TRUE, showWarnings=FALSE, ignore.case=ignore.case)

  if (!length(Attrs) && showWarnings)
    warning ("No Attrs found matching pattern   '", pattern, "'  -- returning character()", call.=FALSE)

  ## If there was more than one pattern, iterate using mapply
  if (length(pattern) > 1)
    return(mapply(gsub, pattern=pattern, replacement="\\1", x=Attrs, ignore.case=ignore.case))
  return(gsub(pattern, "\\1", Attrs, ignore.case=ignore.case))
}

extractInputAttrsFromHTML <- function(html, showWarnings=TRUE, output=c("DT", "list", "string")) {
## Returns:
##   DT     -- a data.table where the column names are the names of the attrs. NA filled for input strings where non applicable
##             One row for each input attr found
##   list   -- a list of vectors, one list element for each input attr found. Each vector (list element) contaings 
##             the parsed values of each attr with the name of the vectors being the name of the attr
##   string -- a character vector containing the raw, unparsed html string from '<' to '>'

  output <- match.arg(output)

  if (showWarnings)
    warning ("This function is not robust.\n  Specifically, it only works when a attr is cleanly formed and of the style '<INPUT TYPE=... ETC=... />'", call.=FALSE)
  pat <- "<input\\s+.*?>"
  strings_unparsed <- extractAllMatches(html, pat=pat)

  if (output == "string")
    return(strings_unparsed)

  ## Extract the attr names
  attr_names <- sapply(strsplit(strings_unparsed, "="), function(sp) {
                  ret <- gsub(".* ", "", head(sp, -1))
                  selfname_(ret)
                })

  LL <- mapply(extractAttrValueFromHTML, html=strings_unparsed, attr_name=attr_names, SIMPLIFY=FALSE)
  if (output == "list")
    return(LL)

  ## else, convert to data.table and return that
  require(data.table)
  DT <- rbindlist(lapply(LL, function(L) as.data.table(rbind(L))), fill=TRUE)
  ## Set the column order for some comonly found attr names
  colOrder <- c("type", "id", "name", "value", "class", "size")
  setcolorderpt(DT, startCols=colOrder, failOnMissingCols=FALSE, showWarnings=FALSE)
  return(DT)
}