R.Version()$version.string 

librariesVersion <- c()

for(i in 1:length(libraries))
    librariesVersion <- c(librariesVersion, paste(packageVersion(libraries[i] )))

librariesLoaded <- lapply(libraries, require, character.only = TRUE) 

timeNeeded <- (proc.time()[3] -  source.starting.time);

sourceTimeNeeded <- c( sourceTimeNeeded, timeNeeded)


source.starting.time <- proc.time()[3]


## Base functions

# EPAS-DS
# @authors ds@eworx.gr
repository <- "/data/generic/"

getSourcePath <- function(filename, baseFolder = repository){
  return(paste(baseFolder, filename, sep = ""))
}

readData <- function(filename, colClasses = c(), baseFolder = repository, header = TRUE, sep = "\t", encoding = "UTF-8", stringsAsFactors = TRUE, na.strings = c("", "NULL"), verbose = FALSE){
  if(length(colClasses) == 0)
    return (data.table::fread(input = getSourcePath(filename, baseFolder), header = header, sep = sep, encoding = encoding, stringsAsFactors = stringsAsFactors, verbose = verbose, showProgress = TRUE, na.strings = na.strings ) )
  return (data.table::fread(input = getSourcePath(filename, baseFolder), colClasses = colClasses, header = header, sep = sep, encoding = encoding, verbose = verbose, showProgress = TRUE,   na.strings = na.strings )  )
}

#rds for small disk space & fst for fast load
saveBinary <- function(data, filename = filename, baseFolder = repository, format = "rds"){
  if(format == "rds"){saveRDS(data, getSourcePath(filename, baseFolder))}
  if(format == "fst"){fst::write_fst(data, getSourcePath(filename, baseFolder))}
}

#rds for small disk space & fst for fast load
loadBinary <- function(filename, baseFolder = repository, format = "rds", as.data.table = TRUE){
  if(format == "rds"){return(readRDS(getSourcePath(filename, baseFolder)))}
  if(format == "fst"){return(fst::read_fst(getSourcePath(filename, baseFolder), as.data.table = as.data.table))}
}

rowColumns <- function(data){
  return(paste( format(nrow(data),  big.mark=","), "Rows X ", ncol(data), "Columns"))
}

publishIncludeCss <- function(){
  sourceFile <- "/data/jobs/wp41.analysis/000.core/include.css"
  destinatinoFile <- "/data/tmpfs/results/include.css"
  if (!file.exists(destinatinoFile)) {
    return (file.copy(sourceFile, destinatinoFile))
  }else{
    return(TRUE);
  }

}
#as the mountstorage is on memory make sure the asset include.css is there.

summariseTable <- function(data){
  return(data.frame(unclass(summary(data)), check.names = FALSE, stringsAsFactors = FALSE))
  #return(do.call(cbind, lapply(data, summary)))
}

factoriseCharacterColumns <- function(data){
  for(name in names(data)){
    if( class(data[[name]]) =="character"){
      data[[name]] <- as.factor(data[[name]])
    }
  }
  return(data) 
}

############################
# https://rstudio.github.io/DT/010-style.html
#https://rpubs.com/marschmi/RMarkdown

capitalise <- function(x) paste0(toupper(substring(x, 1, 1)), substring(x, 2, nchar(x)))


styliseDTNumericalColumn <- function(data, result, columnName, color, columnsName_original ){

  if(columnName%in% columnsName_original){
    result <- result %>%   formatStyle(
      columnName,
      background = styleColorBar(data[[columnName]], color),
      backgroundSize = '100% 90%',
      backgroundRepeat = 'no-repeat',
      backgroundPosition = 'center'
    )
  }
  return(result)

}


reportTabularData <- function(data, anonymize=TRUE){

  if(anonymize)return()
  
  columnsName <- names(data)
  columnsName <- lapply(columnsName, capitalise)
  columnsName_original <- names(data)

  result <-
    DT::datatable(
      data,
      class = 'cell-border stripe',
      filter = 'top',
      rownames = FALSE,
      colnames = columnsName,
      extensions = 'Buttons',
      options = list(
        pageLength = 20,
        columnDefs = list(list(className = 'dt-left', targets = "_all")),
        dom = 'Bfrtip',
        buttons = c('copy', 'csv', 'excel', 'pdf'),
        searchHighlight = TRUE,
        initComplete = JS(
          "function(settings, json) {",
            "$(this.api().table().header()).css({'border': '1px solid'});",
          "}"
        )
      )

    )


  result <- styliseDTNumericalColumn(data,result, "Count", 'steelblue', columnsName_original)
  result <- styliseDTNumericalColumn(data,result, "sourceTimeNeeded", '#808080', columnsName_original)
  result <- styliseDTNumericalColumn(data,result, "timeNeeded", '#808080', columnsName_original)
  #result <- styliseDTNumericalColumn(data,result, "percentMatch", '#5fba7d', columnsName_original)
  result <- styliseDTNumericalColumn(data,result, "percentMatch", '#4682b4', columnsName_original)

  return(result)
}

#data persistance info
reportFileInfo <- function(filename, baseFolder = repository) {
  paste0(
    getSourcePath(filename, baseFolder), " of size ", 
    utils:::format.object_size(file.size(getSourcePath(filename, outputRepo)) + 1000000, "auto"))
}

fonts <- list(
 sans = "DejaVu Serif",
  mono = "DejaVu Serif",
  `Times New Roman` = "DejaVu Serif"
)

#read_xml_to_list <- function(filepath, is.gz = FALSE){
# if(is.gz){  
#     temp_data <- paste0(repository, "data/delete.me")
#     result <- xmlToList(xmlParse(gunzip(filepath, destname = temp_data, remove =FALSE)))
#     Sys.chmod(file.path(temp_data), "777", use_umask = FALSE)
#     unlink(temp_data)
#     result
# }else{
#   xmlToList(xmlParse(filepath))
# }
#}

#transpose_list_to_dt <- function(data_list){
#  dt <- t(as.data.table(data_list))
#  dt <- as.data.table(dt)
#  dt[, (names(dt)) := lapply(.SD, unlist), .SDcols = 1:ncol(dt)]
#  dt[, (names(dt)) := lapply(.SD, unlist), .SDcols = 1:ncol(dt)]
#  names(dt) <- names(data_list[[1]])
#  dt
#}

cleansingCorpus <- function(
  htmlString, rem.html =TRUE, rem.http = TRUE, rem.newline = TRUE,
  rem.nonalphanum = TRUE, rem.longwords = TRUE, rem.space = TRUE, 
  tolower = TRUE, add.space.to.numbers = TRUE, rem.country.begin = FALSE,
  rem.nonalphanum.begin = FALSE, rem.space.begin = FALSE, fix.greek = TRUE
){
  if(rem.html){text <- gsub("<.*?>", " ", htmlString)} # removing html commands
  if(rem.http){text <- gsub(" ?(f|ht)tp(s?)://(.*)[.][a-z]+", " ", text)} #removing http destinations
  if(rem.newline){text <- gsub("[\r\n\t]", " ", text)} 
  if(rem.nonalphanum){text <- gsub("[^[:alpha:]]", " ", text)} #removing non-alphanumeric
  if(rem.longwords){text <- gsub("\\w{35,}", " ", text)} ##Removing words with more than 30 letters
  if(rem.space){text <- gsub("\\s+", " ", text)}  #removing excess space 
  if(tolower){text <- tolower(text)}
  if(add.space.to.numbers){    #add space between number and letters
    text <- gsub("([0-9])([[:alpha:]])", "\\1 \\2", text)
    text <- gsub("([[:alpha:]]|[.])([0-9])", "\\1 \\2", text)
  }
  if(rem.space.begin){text <- gsub("^[[:space:]]*", "", text)} 
  if(rem.country.begin){text <- gsub("^EU", "", text)} #remove country codes from the beginning of the text
  if(rem.nonalphanum.begin){text <- gsub("^[?–-]*", "", text)} #remove special characters identified in the beginning of text
  if(rem.space.begin){text <- gsub("^[[:space:]]*", "", text)}
  if(rem.space.begin){text <- gsub("^[[:space:]]*", "", text)}
  if(fix.greek){
    text <- gsub("ς", "σ", text)
    text <- gsub("ά", "α", text)
    text <- gsub("έ", "ε", text)
    text <- gsub("ή", "η", text)
    text <- gsub("ί", "ι", text)
    text <- gsub("ύ", "υ", text)
    text <- gsub("ό", "ο", text)
    text <- gsub("ώ", "ω", text)
  }
  trimws(text)
}

cleansingEducationCorpus <- function(text) {
  text <- gsub("\\.", "", text) #removing periods
  text <- gsub("[[:punct:]]", " ", text) #removing other punctuation
  text <- gsub("\\s+", " ", text) #removing excess space
  text <- tolower(text) #changing case to lower
  #removing accent from Greek
  text <- gsub("ς", "σ", text)
  text <- gsub("ά", "α", text)
  text <- gsub("έ", "ε", text)
  text <- gsub("ή", "η", text)
  text <- gsub("ί", "ι", text)
  text <- gsub("ύ", "υ", text)
  text <- gsub("ό", "ο", text)
  text <- gsub("ώ", "ω", text)
  trimws(text) #trimming white-space
}

#This function removes dates that are "relics" from the xml parsing
removeDates <- function(text){
  days <-  "(Sunday,|Monday,|Tuesday,|Wednesday,|Thursday,|Friday,|Saturday,)"
  months <- "(January|February|March|April|May|June|July|August|September|October|November|December|Months)"
  date_form1 <- paste(days, months, "([0-9]|[0-9][0-9]), [0-9][0-9][0-9][0-9]")
  date_form2 <- "\\?[0-9][0-9][0-9][0-9]"
  text <- gsub(date_form1, " ", text)
  gsub(date_form2, " ", text)
}

xmlToDataTable <- function(xmlData, itemNames){
  itemList <- lapply(itemNames,
    function(x){
      xml_text(xml_find_all(xmlData, paste0(".//item/", x)))
    }
  )
  names(itemList) <- xmlItems
  as.data.table(itemList)
}

cleanCorpusHtml <- function(text){
  unlist(lapply(text, function(x){
    if(nchar(x) > 0){
      # because nodes were starting with tag keywords in li, we relocate at the end so the information remains and the description 
      # starts with the main content
    html <- gsub(">","> ", x) # add spaces after html tags so these aren't concatenated 
    xml <- read_xml(html, as_html = TRUE)
    lis <- xml_find_all(xml, ".//li")
    xml_remove(lis)
    text <- paste( paste(xml_text(xml), collapse ="") , paste(xml_text(lis) , collapse =""), collapse ="")
    text <- gsub("\\s+"," ",  text)

    }else {""}
  }))
}

#Split equally a vector into chunks of number n_chunks
equal_split <- function(vct, n_chunks) {
  lim <- length(vct)
  fstep <- lim%/%n_chunks
  idx_list <- list()
  for(i in seq(n_chunks - 1)){
    idx_list[[i]] <- vct[((i-1)*fstep + 1):(i*(fstep))]
  }
  idx_list[[n_chunks]] <- vct[((n_chunks - 1)*fstep + 1):(lim)]
  return(idx_list)
}

#Function that takes a vector, and returns thresholded first 10 sorted indexes
getThresholdOrderRwmd <- function(vct, idVec, threshold = 1e-6, numHead = 10){
  vct <- ifelse(vct > threshold, vct, Inf)
    indexVec <- head(order(vct), numHead)
    idVec[indexVec]
}


#Function to read xml nodes in description
maintainElements <- function(nodes, elementType = "a", attribute = "href"){
  xml_attr(xml_find_all(nodes, paste0(".//", elementType)), attribute)
}

#Function to add results to datatable
elementsToDataTable <- function(result, elementType){
  if(length(result) > 0)
    data.table(elementType = elementType, attributeValue = result)
  else
    data.table()
}

#Function to retrieve urls from text
keepHtmlElements <- function(feedItem){
  nodes <- read_xml(paste0("<div>",  feedItem, "</div>"), as_html = TRUE)
  rbind(
    elementsToDataTable(maintainElements(nodes, "a", "href"), "link"),
    elementsToDataTable(maintainElements(nodes, "img", "src"), "image"),
    elementsToDataTable(maintainElements(nodes, "img-src", "src"), "image")
    #All "img-src" are NA
  )
}

#retrieve list of parameters in a http request query
getQueryParams <- function(url){
  query <- httr::parse_url(url)$query
  queryValues <- unlist(query)
  queryNames <- names(query)
  dat <- data.table(varName = queryNames, value = queryValues)
  dat[queryValues != ""]
}

#Language detection
detectLanguage <- function(text, precision = 3) {
  if (precision < 1) return(cld3::detect_language(text))
  else if (precision == 2) return(cld2::detect_language(text))
  pred <- cld2::detect_language(text)
  ifelse(pred == cld3::detect_language(text), pred, NA_character_)
}

###################################################################################################
# Functions related to ESCO qualifications scrapping
###################################################################################################

# Returns a vector of the URIs in a particular results page for a given search query
getPageQualificationURIs <- function(locale = "en", eqfLevels = 1:8, pageNum = 1) {
  resultsPageURL <- paste0(
    "https://ec.europa.eu/esco/portal/qualificationSearch?",
    "conceptLanguage=", locale,
    "&searchTerm=",
    "&eqfFilters=", paste(eqfLevels, collapse = ","),
    "&page=", pageNum
  ) %>% url() # for Windows
  resultsHTML <- read_html(resultsPageURL) %>%
    xml_find_all(".//div[@class='content']") %>% 
    xml_children() %>% 
    xml_children() %>% 
    xml_attrs()
  qualificationURIs <- grep(pattern = "http", resultsHTML, value = TRUE)
  uriHead <- regexpr(pattern = "http", qualificationURIs)
  uriTail <- regexpr(pattern = "');", qualificationURIs) - 1
  substr(qualificationURIs, uriHead, uriTail)
}

# Returns total number of pages for a given search query
getNumOfPages <- function(locale = "en", eqfLevels = 1:8) {
  resultsPageURL <- paste0(
    "https://ec.europa.eu/esco/portal/qualificationSearch?",
    "conceptLanguage=", locale,
    "&searchTerm=",
    "&eqfFilters=", paste(eqfLevels, collapse = ","),
    "&page=", 1
  ) %>% url() #for Windows
  numOfQuals <- read_html(resultsPageURL) %>% 
    xml_find_all(".//h1") %>% xml_text() %>% as.numeric()
  qualsPerPage <- length(getPageQualificationURIs())
  round(0.5 + numOfQuals / qualsPerPage)
}

# Returns HTML of a qualification based on its URI for a given locale
getQualificationHTML <- function(uri, locale = "en") {
  paste0(
    "https://ec.europa.eu/esco/portal/qualificationDetails?",
    "conceptLanguage=", locale,
    "&uri=", uri
  ) %>% url() %>% #for Windows
    read_html()
}

# Parses an `xml_nodeset` object to extract useful data
parseXMLNodeSets <- function(xmlNodeSets) {
  lapply(xmlNodeSets, function(x) {
    labelText <- x %>% xml_find_all(".//p[@class='label']") %>% xml_text
    allXml <- x %>% xml_find_all(".//p | .//ul")
    varsIndex <- grep("class=\"label\"", allXml)
    textData <- allXml %>% xml_text
    limits <- c(varsIndex, length(textData) + 1) 
    data <- lapply(seq_along(varsIndex) , function(i) {
      toPaste <- head(limits[i]:limits[i+1], -1)[-1] 
      paste(textData[toPaste], collapse = " ")
    }) %>% as.data.table 
    setnames(data, textData[varsIndex])
    titleText <- x %>% xml_find_all(".//h1") %>% xml_text
    data[, "Title"] <- titleText[1]
    data
  }) %>% rbindlist(fill = TRUE)
}

# Extracts values from text structured in a "Label: Value" format
valuesFromLabeledText <- function(labeledText, label, otherLabels = c()){
  cleanTokens <- labeledText %>%
    paste("ENDLABEL:") %>%
    cleansingCorpus(tolower = FALSE, rem.longwords = FALSE, rem.http = FALSE, rem.nonalphanum = FALSE) %>%
    space_tokenizer()
  label <- gsub("$", ":", label)
  otherLabels <- gsub("$", ":", otherLabels)
  otherLabels <- c("ENDLABEL:", otherLabels[label != otherLabels], label)

  lapply(cleanTokens, function(tokens){
    textStart <- which(tokens %in% label) + 1
    textOther <- which(tokens %in% otherLabels) - 1
    lapply(textStart, function(start){
      fin <- textOther[which(textOther >= start) %>% min]
      tokens[start:fin] %>% paste(collapse = " ")
    }) %>% unlist() %>% paste(collapse = ", ")
  }) %>% unlist() %>% paste0(",")
}

###################################################################################################
# Functions related to TF-IDF calculation
###################################################################################################

# The augumented frequency is used to prevent bias towards longer documents. This choice is 
# justified by the fact that corpus size follows a roughly guassian distribution with respect to 
# EQF level.
# The smooth inverse document frequency is used to prevent IDF from nullifying the TF-IDF in cases 
# where TF can provide useful insigned on its own. That resolves the edge case where a word 
# appears in low frequency in every corpus, but in a significantly high frequency in one corpus.
findTFIDF <- function(corpus, stopwords, normalize = "double", min_char = 1, by.class = "class", threshold = -1) {

  tokensList <- strsplit(corpus[, value], " ")
  names(tokensList) <- corpus[, get(by.class)]

  tokensDT <- lapply(tokensList, as.data.table) %>% 
    rbindlist(idcol = TRUE) %>%
    setnames(c("class", "term"))

  tokensDT <- tokensDT[!term %in% stopwords][nchar(term) > min_char]
  #inverse document frequency smooth  
  idfDT <- tokensDT[!duplicated(tokensDT)][, .(docFreq = .N), by = "term"]
  idfDT[, idf :=  log(length(unique(tokensDT$class)) / (docFreq + 1)) + 1]  

  tfDT <- tokensDT[, .(term_count = .N), by = c("class", "term")]
  if(threshold > 0)tfDT[term_count > threshold, term_count := threshold]

  if(normalize == "double")tfDT[, tf := 0.5 + 0.5 * term_count / max(term_count)]
  if(normalize == "log")tfDT[, tf := log(1 +term_count)]
  
  merge(tfDT, idfDT, on = "term")[, tfIdf := tf*idf ][, .(term, class, tfIdf, docFreq)]
  
}

#silence warnings pipe
`%W>%` <- function(lhs,rhs){
  w <- options()$warn
  on.exit(options(warn=w))
  options(warn=-1)
  eval.parent(substitute(lhs %>% rhs))
}

getStopwords <- function(locale) { 
  stopwordsLocale <- c(stopwords_getlanguages(source = "misc"), stopwords_getlanguages(source = "snowball")) 
  stopWords <- ""
  if (locale %in% stopwordsLocale) 
    stopWords <- locale %W>% stopwords
  stopWords
}

###################################################################################################
# Text translation
###################################################################################################

translateText <- function(sourceText, sourceLang, translationLang, batchSize = 4800) {
  if (length(sourceText) == 0) {
    return ("")
  } else if (length(sourceText) == 1) {
    return (requestTranslation(sourceText, sourceLang, translationLang))
  } else if (length(sourceText) > 4800) {
    return (NA)
  }

  sourceQueries <- gsub("$", "\n >", sourceText)
  sourceQueries <- gsub("^", "< \n", sourceQueries)
  queries <- data.table(query = sourceQueries, size = nchar(sourceQueries), batch = nchar(sourceQueries))
  for (row in seq(nrow(queries) - 1)) {
    cumulativeSum <- queries[row, batch] + queries[row + 1, batch] + 3
    queries[row + 1, batch := ifelse(cumulativeSum > batchSize, batch, cumulativeSum)]
  }
  batchStarts <- which(queries[, size] == queries[, batch])
  batchFins <- c(batchStarts[-1] - 1, nrow(queries))
  batches <- lapply(seq_along(batchStarts), function(i) batchStarts[i]:batchFins[i])
  pastedQueries <- lapply(batches, function(batch) paste0(queries[batch, query], collapse = "\n")) %>% unlist()

  translatedText <- lapply(pastedQueries, requestTranslation, sourceLang, translationLang) %>% 
    unlist() %>%
    paste0(collapse = " ")
  translatedText <- gsub("\\s?<", "", translatedText)
  gsub(">$", "", translatedText) %>% 
    space_tokenizer(sep = ">") %>% 
    unlist() %>% 
    trimws()
}

requestTranslation <- function(sourceText, sourceLang, translationLang) { 
  googleTranslateURL <- paste0(
    "https://translate.google.com/m",
    "?hl=", sourceLang,
    "&sl=", sourceLang,
    "&tl=", translationLang,
    "&ie=UTF-8&prev=_m&q=", URLencode(sourceText, reserved = TRUE)
  )
  GET(googleTranslateURL, add_headers("user-agent" = "Mozilla/5.0")) %>%
    read_html() %>% 
    xml_child(2) %>%
    xml_child(5) %>%
    xml_text() %>%
    unlist()
}

###################################################################################################
# Text mining
###################################################################################################

findNGrams <- function(corpus, min_n, max_n = min_n, stopWords = NA_character_) {
  ngrams <- itoken(corpus, tokenizer = word_tokenizer, progressbar = FALSE) %>%
    create_vocabulary(stopwords = stopWords, c(min_n, max_n), sep_ngram = " ") %>%
    as.data.table()
  ngrams[order(-doc_count)][, .(term, count = doc_count)]
}

###########################################################################################################

(data.table(library = libraries, version = librariesVersion))

includeCssPublished <- publishIncludeCss()

sessionInfo()

timeNeeded <- (proc.time()[3] -  source.starting.time);

sourceTimeNeeded <- c( sourceTimeNeeded, timeNeeded)


source.starting.time <- proc.time()[3]

reportTabularData(source.blocks);