Abstract
This process calculates bigrams from the skills free-text data based on the category of the skill or the occupation of the respondent.Information about the libraries, environment, sources used and their execution is reported. Aditional information is provided within section tabs. Navigating through the report is also possible through the table of contents. Tables reported, can be dynamically filtered, searched ordered and exported into various formats.
librariesVersion <- c()
for(i in 1:length(libraries))
librariesVersion <- c(librariesVersion, paste(packageVersion(libraries[i] )))
librariesLoaded <- lapply(libraries, require, character.only = TRUE) ## Loading required package: magrittr## Loading required package: DT## Loading required package: ggplot2## Loading required package: jsonlite## Loading required package: parallel## Loading required package: stopwords## Loading required package: text2vec../000.core/00.01.libraries.R completed in 2.11 seconds
sourceTimeNeeded <- c( sourceTimeNeeded, timeNeeded)
source.starting.time <- proc.time()[3]
## Base functions
# ESCO skills
# @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"){
fileName <- getSourcePath(filename, baseFolder)
dir.create(dirname(fileName), recursive = TRUE, showWarnings = FALSE)
if(format == "rds") saveRDS(data, fileName)
if(format == "fst") fst::write_fst(data, fileName)
}
#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)
}
codeBook <- function(dataset){
out <- lapply(names(dataset), function(var_name) {
knitr::knit_expand(text = readLines("../000.core/codeBook.template"))
})
cat(
knitr::knit(
text = unlist(paste(out, collapse = '\n')),
quiet = TRUE)
)
}
fwrite_zip <- function(data, filename, quote = TRUE){
dir.create(dirname(filename), recursive = TRUE, showWarnings = FALSE)
filename_csv <- strsplit(filename, "/") %>% unlist %>% tail(1)
filename_csv <- gsub(".zip", ".csv", filename_csv)
fwrite(data, filename_csv, quote = quote)
if(file.exists(filename))unlink(filename)
zip(filename, filename_csv)
unlink(filename_csv)
}
############################
# 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)
}
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
){
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)}
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 != ""]
}
keepCountryName <- function(string){
string <- gsub(".*_", "", string)
gsub("\\..*", "", string)
}
keepNTokens <- function(string, num){
tokenList <- strsplit(string, split = " ")
sapply(tokenList, function(tokens){
tokens <- sort(tokens)
tokensShift <- shift(tokens, -num, fill = FALSE)
paste(tokens[tokens != tokensShift], collapse = " ")
})
}
findTFIDF <- function(corpus, stopwords, normalize = "double", min_char = 1) {
tokensList <- strsplit(corpus[, text], " ")
names(tokensList) <- corpus[, code]
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(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)]
}
tidyJsonData <- function(jsonList){
if(length(jsonList) == 0)return(NULL)
unlistOccupations <- jsonList %>% unlist
codesMaleFemale <- names(unlistOccupations)
epasMapping <- data.table(unlistOccupations)
epasMapping[ , code := gsub("\\.[[:alpha:]]$", "", codesMaleFemale)]
uniqueMappingBoolean <- epasMapping[ , unlistOccupations != c(unlistOccupations[-1], F), by = code]$V1
codesEpasDB <- epasMapping[uniqueMappingBoolean]
names(codesEpasDB) <- c("title", "code")
codesEpasDB[ , title := cleansingCorpus(title)]
}
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)]
}
`%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()
}
############################################################################################################# R version 4.0.5 (2021-03-31)
## Platform: x86_64-pc-linux-gnu (64-bit)
## Running under: Ubuntu 20.04.2 LTS
##
## Matrix products: default
## BLAS/LAPACK: /usr/lib/x86_64-linux-gnu/openblas-pthread/libopenblasp-r0.3.8.so
##
## locale:
## [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
## [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8
## [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=C
## [7] LC_PAPER=en_US.UTF-8 LC_NAME=C
## [9] LC_ADDRESS=C LC_TELEPHONE=C
## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C
##
## attached base packages:
## [1] parallel stats graphics grDevices utils datasets methods
## [8] base
##
## other attached packages:
## [1] text2vec_0.6 stopwords_2.2 jsonlite_1.7.2 ggplot2_3.3.3
## [5] DT_0.18 magrittr_2.0.1 rmarkdown_2.8 data.table_1.14.0
##
## loaded via a namespace (and not attached):
## [1] Rcpp_1.0.6 bslib_0.2.5 compiler_4.0.5
## [4] pillar_1.6.0 jquerylib_0.1.4 highr_0.9
## [7] tools_4.0.5 digest_0.6.27 lattice_0.20-41
## [10] evaluate_0.14 lifecycle_1.0.0 tibble_3.1.1
## [13] gtable_0.3.0 pkgconfig_2.0.3 rlang_0.4.11
## [16] Matrix_1.3-2 mlapi_0.1.0 RhpcBLASctl_0.20-137
## [19] yaml_2.2.1 xfun_0.23 withr_2.4.2
## [22] stringr_1.4.0 dplyr_1.0.6 knitr_1.33
## [25] generics_0.1.0 htmlwidgets_1.5.3 sass_0.4.0
## [28] vctrs_0.3.8 grid_4.0.5 tidyselect_1.1.1
## [31] glue_1.4.2 R6_2.5.0 fansi_0.4.2
## [34] lgr_0.4.2 purrr_0.3.4 scales_1.1.1
## [37] htmltools_0.5.1.1 ellipsis_0.3.2 float_0.2-4
## [40] rsparse_0.4.0 colorspace_2.0-1 utf8_1.2.1
## [43] stringi_1.6.2 munsell_0.5.0 crayon_1.4.1../000.core/00.02.base.functions.R completed in 0.16 seconds
Dimensions: 1303728, 35
fileName <- "jobsOutput/skills/cleansedEPASskills.rds"
cleansedEPASskills <- loadBinary(fileName, format = "rds")Dimensions: 1761673, 4
1.load.data.R completed in 16.3 seconds
The 4 broad (free-text) categories are:
Subset the free-text with the 4 broad categories.
stopw <- lapply(unique(cleansedEPASskills$locale), function(loc)getStopwords(locale = loc)) %>% unlist
topLocale <- cleansedEPASskills[, .(count = .N), by = locale][order(-count)]$locale %>% head(20)
categories_ngrams_DT <- lapply(broadSkillCategories, function(category){
skills_for_category <- cleansedEPASskills[variable == category]
skills_ngrams_for_category_DT <- lapply(topLocale, function(loc){
skills_ngrams_for_category <- findNGrams(corpus = skills_for_category[locale == loc]$value, min_n = 2, max_n = 2, stopWords = stopw)[count > 3]
skills_ngrams_for_category[, locale := loc]
}) %>% rbindlist
skills_ngrams_for_category_DT[, .(locale, category = category, term, count)]
}) %>% rbindlist
setnames(categories_ngrams_DT,
c("term", "category", "count"),
c("bigram", "skill_type", "responses")
)
aggregate_cols <- c("bigram", "skill_type", "locale", "responses")
skills_type_ngrams <- categories_ngrams_DT[, .SD, .SDcols = aggregate_cols] %>% setorderv(aggregate_cols, na.last = TRUE)2.process.data.R completed in 52.89 seconds
topOccupations <- workStat[!is.na(iscoLabel3), .(count = .N), by = .(iscoLabel3)][order(-count)]$iscoLabel3 %>% head(70)
occupations_ngrams_DT <- lapply(topOccupations, function(occupation){
skills_for_occupation <- cleansedEPASskills[id %in% workStat[iscoLabel3 == occupation]$id]
skills_ngrams_for_occupation_DT <- lapply(topLocale, function(loc){
corpus_loc <- skills_for_occupation[locale == loc]$value
if(length(corpus_loc) == 0) return()
skills_ngrams_for_occupation <- findNGrams(corpus = corpus_loc,
min_n = 2, max_n = 2, stopWords = stopw)[count > 3]
skills_ngrams_for_occupation[, locale := loc]
}) %>% rbindlist
skills_ngrams_for_occupation_DT[, .(locale, occupation = occupation, term, count)]
}) %>% rbindlist
setnames(occupations_ngrams_DT,
c("term", "occupation", "count"),
c("bigram", "job_isco", "responses")
)
aggregate_cols <- c("bigram", "job_isco", "locale", "responses")
skills_occupation_ngrams <- occupations_ngrams_DT[, .SD, .SDcols = aggregate_cols] %>% setorderv(aggregate_cols, na.last = TRUE)3.process.data.R completed in 347.66 seconds
fst formatfilename <- "jobsOutput/code_book/free_text/skills_type_ngrams.fst"
saveBinary(skills_type_ngrams, filename, format = "fst")Datasource : /data/generic/jobsOutput/code_book/free_text/skills_type_ngrams.fst of 9,306,886 bytes.
csv formatfilename <- "/data/tmpfs/results/survey_data/csv/skills_type_ngrams.zip"
fwrite_zip(skills_type_ngrams, filename)Datasource : /data/tmpfs/results/survey_data/csv/skills_type_ngrams.zip of 2,162,992 bytes.
fst formatfilename <- "jobsOutput/code_book/free_text/skills_occupation_ngrams.fst"
saveBinary(skills_occupation_ngrams, filename, format = "fst")Datasource : /data/generic/jobsOutput/code_book/free_text/skills_occupation_ngrams.fst of 23,021,541 bytes.
csv formatfilename <- "/data/tmpfs/results/survey_data/csv/skills_occupation_ngrams.zip"
fwrite_zip(skills_occupation_ngrams, filename)Datasource : /data/tmpfs/results/survey_data/csv/skills_occupation_ngrams.zip of 4,503,421 bytes.
4.save.data.R completed in 6.75 seconds
Completed in 425.88 seconds.