Nothing
# URL root to call the API
API_URL = "https://servicios.ine.es/wstempus/js"
# API version
API_version <- "3"
# Number of rows per page
page_lenght = 500
# column names for different API version
column_names <- list("3" = list("variable.code" = list("es" = "Variable.Codigo"),
"variable.id" = list("es" = "Variable.Id"),
"variable.fk" = list("es" = "Fk_Variable"),
"variable.name" = list("es" = "Variable.Nombre"),
"value.code" = list("es" = "Codigo"),
"value.id" = list("es" = "Id"),
"value.name" = list("es" = "Nombre"),
"id" = list("es" = "Id"),
"ioe" = list("es" = "Cod_IOE"),
"codigo" = list("es" = "Codigo"),
"jerarquia.fk" = list("es" = "FK_JerarquiaPadres"),
"jerarquia" = list("es" = "JerarquiaPadres")),
"4" = list("variable.code" = list("es" = "Variable.Codigo"),
"variable.id" = list("es" = "Variable.Id"),
"variable.fk" = list("es" = "FK_Variable"),
"variable.name" = list("es" = "Variable.Nombre"),
"value.code" = list("es" = "Codigo"),
"value.id" = list("es" = "Id"),
"value.name" = list("es" = "Nombre"),
"id" = list("es" = "Id"),
"ioe" = list("es" = "Cod_IOE"),
"codigo" = list("es" = "Codigo"),
"jerarquia.fk" = list("es" = "FK_JerarquiaPadres"),
"jerarquia" = list("es" = "JerarquiaPadres")))
# Shortcuts used in filters
shortcuts_filter <- list(nac = "349", # national
prov = "115" , # provinces
ccaa = "70", # ccaa
mun = "19", # municipalities
isla = "20", island = "20", # islas
grupo = "762", group = "762", # cpi groups
subgrupo = "763", subgroup = "763", # cpi subgroups
clase = "764", class = "764", # cpi class
subclase = "765", subclass = "765", # cpi subclass
rubrica = "270", # cpi headings
heading = "270", # cpi headings
grupoespecial = "269", # cpi special groups
specialgroup = "269", # cpi special groups
tipodato = "3", datatype = "3", # type of data
sexo = "18", sex = "18", # sex
edad1 = "355", age1 = "355", # simple age
edadt = "356", aget = "356", # total age
edadg = "360", ageg = "360", # age groups
edads = "357", ages = "357", # semi-age intervals
edad = c("355", "356", "360", "357"),
age = c("355", "356", "360", "357"),
nacionalidad = "141", nationality = "141",
generacion = "612", generation = "612", # generation ages
paisnacimiento = c("431", "432"), # country of birth
birthcountry = c("431", "432"), # country of birth
lugarnacimiento = c("97"), # place of birth
birthplace = c("97"), # place of birth
efectoscorr = "544", # correction of effects
effectscorr = "544" # correction of effects
)
shortcuts_filter_comments <- list(nac = list(comment ="National", lang = "ALL"),
prov = list(comment ="Provinces", lang = "ALL") ,
ccaa = list(comment ="Autonomous Communities", lang = "ALL"),
mun = list(comment ="Municipalities", lang = "ALL"),
isla = list(comment ="Islands", lang = "ES"),
island = list(comment ="Islands", lang = "EN"),
grupo = list(comment ="CPI groups", lang = "ES"),
group = list(comment ="CPI groups", lang = "EN"),
subgrupo = list(comment ="CPI subgroups", lang = "ES"),
subgroup = list(comment ="CPI subgroups", lang = "EN"),
clase = list(comment ="764", lang = "ES"),
class = list(comment ="764", lang = "EN"),
subclase = list(comment ="CPI class", lang = "ES"),
subclass = list(comment ="CPI class", lang = "EN"),
rubrica = list(comment ="CPI headings", lang = "ES"),
heading = list(comment ="CPI headings", lang = "EN"),
grupoespecial = list(comment ="CPI special groups", lang = "ES"),
specialgroup = list(comment ="CPI special groups", lang = "EN"),
tipodato = list(comment ="Type of data", lang = "ES"),
datatype = list(comment ="Type of data", lang = "EN"),
sexo = list(comment ="Sex", lang = "ES"),
sex = list(comment ="Sex", lang = "EN"),
edad1 = list(comment ="Simple age", lang = "ES"),
age1 = list(comment ="Simple age", lang = "EN"),
edadt = list(comment ="Age totals", lang = "ES"),
aget = list(comment ="Age totals", lang = "EN"),
edadg = list(comment ="Age groups", lang = "ES"),
ageg = list(comment ="Age groups", lang = "EN"),
edads = list(comment ="Age semi-intervals", lang = "ES"),
ages = list(comment ="Age semi-intervals", lang = "EN"),
edad = list(comment ="Age wrapper", lang = "ES"),
age = list(comment ="Age wrapper", lang = "EN"),
nacionalidad = list(comment ="Nationality", lang = "ES"),
nationality = list(comment ="Nationality", lang = "EN"),
generacion = list(comment ="Generation/ages", lang = "ES"),
generation = list(comment ="Generation/ages", lang = "EN"),
paisnacimiento = list(comment ="Country of birth", lang = "ES"),
birthcountry = list(comment ="Country of birth", lang = "EN"),
lugarnacimiento = list(comment ="Place of birth", lang = "ES"),
birthplace = list(comment ="Place of birth", lang = "EN"),
efectoscorr = list(comment ="Correction of effects", lang = "ES"),
effectscorr = list(comment ="Correction of effects", lang = "EN")
)
shortcut_wrapper <- c("values")
# Function to retrieve data from the aPI
get_api_data <- function(url, request){
result <- NULL
# Initiate a call to the aPI
tryCatch(
{
# if the url is too large we used the method POST
if(nchar(url$complete) > 2000){
if(request$addons$verbose){
cat(sprintf("- API URL: %s\n", url$endpointpar))
}
response <- httr::VERB("POST",
url = url$endpoint,
query = url$parameters,
body = url$filter,
encode = "form",
httr::content_type("application/x-www-form-urlencoded"),
httr::user_agent("ineapir")
)
# we use the GET method
}else{
if(request$addons$verbose){
cat(sprintf("- API URL: %s\n", url$complete))
}
response <- httr::VERB("GET",
url = url$endpoint,
query = url$totalpar,
httr::user_agent("ineapir")
)
}
# Get the content of the response
content <- httr::content(response, "text", encoding = "UTF-8")
if(jsonlite::validate(content)){
result <- jsonlite::fromJSON(content , flatten = TRUE)
}
},
error=function(e) {
message('An error occurred calling the API')
print(e)
},
warning=function(w) {
message('A warning occurred calling the API')
print(w)
}
)
# Check the result retrieved for the API
if(check_result(result, response)){
# extract metadata to columns
if((!is.null(request$addons$metanames) && request$addons$metanames) ||
(!is.null(request$addons$metacodes) && request$addons$metacodes)){
result <- extract_metadata(result, request)
}
# Unnest the Data column in one single dataframe
if(!is.null(request$addons$unnest) && request$addons$unnest){
result <- unnest_data(result)
}
# get the hierarchy tree of values
if(!is.null(request$addons$hierarchy)){
result <- get_values_hierarchy(result, request)
}
}
return(result)
}
# Function to retrieve data from the aPI when the result is paginated
get_api_data_all_pages <- function(url, request){
result <- NULL
# Request all pages
if(request$parameters$page == 0){
# Page counter
numpage <- 1
# Update page
request$parameters[["page"]] <- numpage
# Build the URL to call the API
url <- get_url(request)
# Call de API
result <- get_api_data(url, request)
# Number of rows
numrows <- if(!is.null(nrow(result))) nrow(result) else -1
# if the number of rows is equal to the length of a page, we query the next page
while (numrows > 0){
numpage <- numpage + 1
# Update page
request$parameters[["page"]] <- numpage
# Update the URL to call the API
url <- get_url(request)
# Call the API
resultpage <- get_api_data(url, request)
# Number of rows
numrows <- if(!is.null(nrow(resultpage))) nrow(resultpage) else -1
# Accumulated result
result <- rbind(result, resultpage)
}
# Request a specific page
}else{
result <- get_api_data(url, request)
}
return(result)
}
# Get the url endpoint
get_definition_path <- function(request){
path <- ""
# Build the definition part. We remove tag (last one) from definition
for(x in unlist(request$definition[-length(request$definition)])){
if(!is.null(x)){
path <- paste0(path,"/", x)
}
}
return(path)
}
# Get url parameters minus filter
get_parameters_query <- function(request){
parameters <- list()
for(x in names(request$parameters)){
val <- request$parameters[[x]]
# Discard parameters with null value
if(x != "filter" && !is.null(val)){
# We have to format the input date
if(x == "date"){
val <- build_date(val)
# manage array of dates
for(i in 1:length(val)){
parameters <- append(parameters, list(date = val[i]))
}
# Since the list also contains the operation
}else if(x %in% c("p", "clasif")){
val <- val[[x]]
parameters[[x]] <- val
}else{
parameters[[x]] <- val
}
}
}
# include version API
parameters[["ver"]] <- API_version
return(parameters)
}
# Get url filter
get_parameters_filter <- function(request){
val <- request$parameters[["filter"]]
lval <- NULL
if(!is.null(val)){
lval <- build_filter(val, request$definition, request$addons, request$check$parameters$filter, det = request$parameters$det)
}
return(lval)
}
# Get url and its components
get_url <- function(request){
# API url
url <- httr::parse_url(API_URL)
# Get the endpoint
definition <- get_definition_path(request)
# Get the parameters of the query
parameters <- get_parameters_query(request)
# Get the filter of the query
parfilter <- get_parameters_filter(request)
parfilter <- parfilter$filter
# Update the path with the endpoint
url$path <- paste0(url$path, definition)
# Build the url endpoint
endpoint <- httr::build_url(url)
# Update the query of the url
url$query <- parameters
# Build the url with parameters
endpointpar <- httr::build_url(url)
# Update the query of the url adding the filter
url$query <- append(parameters, parfilter)
# Build the complete url
complete <- httr::build_url(url)
result <- list(complete = complete,
endpoint = endpoint,
endpointpar = endpointpar,
parameters = parameters,
filter = parfilter,
totalpar = append(parameters, parfilter)
)
return(result)
}
# Return the dates in the format used by the API
build_date <- function(date){
dateStart <- format.Date(date$dateStart,'%Y%m%d')
dateEnd <- append(format.Date(date$dateEnd,'%Y%m%d'), rep("", length(date$dateStart)- length(date$dateEnd)))
return(paste(dateStart, dateEnd, sep = ":"))
}
# Return the cross of variables and values in the format used by the API
build_filter <- function(parameter, definition, addons, checkfilter, det = 0){
# Values to return
val <- character()
lval <- list()
# id to identify a table or a operation
id <- parameter[[1]]
# List of variables and values
filter <- parameter[[2]]
# Names in the list of the parameter
parnames <- tolower(names(parameter))
if(addons$verbose){
cat("- Processing filter: 0% \r")
}
# If validate = TRUE there exists a dataframe with values
if(addons$validate){
# Dataframe with the values
dfval <- checkfilter$values
# If there are shortcuts present in the filter
shortcut <- checkfilter$shortcut
# Type of object: pxtable, tempus table or series
origin <- checkfilter$origin
# If validate = FALSE we get the values
}else{
# If there are shortcuts present in the filter
shortcut <- check_shortcut(filter, definition)
# Take into account negative values
shortcut <- if(is_negative_filter_values(filter)) TRUE else shortcut
# Dataframe with the values
dfval <- get_filter_values(parameter, definition$lang, shortcut, verbose = FALSE, progress = addons$verbose, det = det, addons)
if(!is.null(dfval)){
origin <- dfval$origin
dfval <- dfval$values
}
}
# We go through all the variables
i <- 1
j <- 1
for(n in names(filter)){
# check if in the filter there are shortcuts
short <- is.element(n, c(names(shortcuts_filter), shortcut_wrapper))
# It is necessary to include shortcut in the case of a px table with a code equal to a shortcut (eg sexo)
if(shortcut && short){
if(!is.null(dfval)){
# filter with ids
filterout <- list()
if(origin == "tablepx"){
# column name depending on det parameter
colname <- column_names[[API_version]][["variable.code"]][["es"]]
# Select codes
varid <- unique(dfval[[colname]])
# We select only the values of variables present in the filter
dfvalfilter <- subset(dfval, dfval[[colname]] %in% varid)
}else if(origin == "tablepxid"){
# column name depending on det parameter
colname <- column_names[[API_version]][["variable.id"]][["es"]]
# Select codes
varid <- c(unique(dfval[[column_names[[API_version]][["variable.code"]][["es"]]]]), unique(dfval[[colname]]))
# We select only the values of variables present in the filter
dfvalfilter <- subset(dfval, dfval[[column_names[[API_version]][["variable.code"]][["es"]]]] %in% varid | dfval[[colname]] %in% varid)
}else{
# column name depending on det parameter
colname <- if(det > 0 ) column_names[[API_version]][["variable.id"]][["es"]] else column_names[[API_version]][["variable.fk"]][["es"]]
if(tolower(n) %in% shortcut_wrapper){
# Select ids
varid <- unique(dfval[[colname]])
}else{
# id of variables
varid <- shortcuts_filter[[tolower(n)]]
}
# We select only the values of variables present in the filter
dfvalfilter <- subset(dfval, dfval[[colname]] %in% varid)
}
# Reset the values found
dfvalgrep <- NULL
# Find a match between the filter inputs and the possible values
for(f in filter[[n]]){
# check if there is any negative value
neg <- grepl("^-.*", as.character(f))
# remove minus sign
f <- if(sum(neg) > 0) gsub("^-", "", as.character(f)) else f
### Way one: find a value for the largest word
# Split the phrase
valshort1 <- if(nchar(f) > 0 ) unlist(strsplit(as.character(f), "\\s+")) else f
# Find the largest word
valshort1 <- valshort1[which.max(nchar(valshort1))]
# Find a match for the largest word and the possible values
ind1 <- grepl(valshort1, dfvalfilter[[column_names[[API_version]][["value.name"]][["es"]]]], ignore.case = TRUE)
# Dataframe with the matches
dfvalgrep1 <- subset(dfvalfilter, ind1)
### Way two: find a value for the entire string
# Find a match for the entire phrase and the possible values
ind2 <- grepl(f, dfvalfilter[[column_names[[API_version]][["value.name"]][["es"]]]], ignore.case = TRUE)
# Dataframe with the matches
dfvalgrep2 <- subset(dfvalfilter, ind2)
# Intersect the values from these two different ways
if(nrow(dfvalgrep1) > 0 && nrow(dfvalgrep2) == 0){
dfvalgreptmp <- dfvalgrep1
}else if(nrow(dfvalgrep1) == 0 && nrow(dfvalgrep2) > 0){
dfvalgreptmp <- dfvalgrep2
}else if(nrow(dfvalgrep1) > 0 && nrow(dfvalgrep2) > 0){
if(origin == "tablepx"){
dfvalgrep2 <- subset(dfvalgrep2, select = c(column_names[[API_version]][["value.code"]][["es"]], colname))
dfvalgreptmp <- merge(dfvalgrep1, dfvalgrep2, by = c(column_names[[API_version]][["value.code"]][["es"]], colname))
}else if(origin == "tablepxid"){
dfvalgrep2 <- subset(dfvalgrep2, select = c(column_names[[API_version]][["value.id"]][["es"]], colname))
dfvalgreptmp <- merge(dfvalgrep1, dfvalgrep2, by = c(column_names[[API_version]][["value.id"]][["es"]], colname))
}else{
dfvalgrep2 <- subset(dfvalgrep2, select = c(column_names[[API_version]][["value.id"]][["es"]], colname))
dfvalgreptmp <- merge(dfvalgrep1, dfvalgrep2, by = c(column_names[[API_version]][["value.id"]][["es"]], colname))
}
}else{
dfvalgreptmp <- dfvalgrep1
}
# If there is no match result look in the id
if(nrow(dfvalgreptmp) == 0){
if(origin == "tablepx"){
dfvalgreptmp <- subset(dfvalfilter, grepl(paste0("^",f,"$"), dfvalfilter[[column_names[[API_version]][["value.code"]][["es"]]]]))
}else if(origin == "tablepxid"){
dfvalgreptmp <- subset(dfvalfilter, grepl(paste0("^",f,"$"), c(dfvalfilter[[column_names[[API_version]][["value.code"]][["es"]]]], dfvalfilter[[column_names[[API_version]][["value.id"]][["es"]]]])))
}else{
dfvalgreptmp <- subset(dfvalfilter, grepl(paste0("^",f,"$"), dfvalfilter[[column_names[[API_version]][["value.id"]][["es"]]]]))
}
}
# We add a column with the counter
dfvalgreptmp$i <- rep(i,nrow(dfvalgreptmp))
# Transform the filter in a the format used by the API
if(nchar(f) > 0){
# When grep found something
if(nrow(dfvalgreptmp) > 0){
# We go through all the matches
for(r in 1:nrow(dfvalgreptmp)){
if(origin == "tablepx"){
# Variable code
var <- dfvalgreptmp[[colname]][r]
# Value code
filterout[[var]] <- if(sum(neg) > 0) paste0("-", dfvalgreptmp[[column_names[[API_version]][["value.code"]][["es"]]]][r]) else dfvalgreptmp[[column_names[[API_version]][["value.code"]][["es"]]]][r]
}else if(origin == "tablepxid"){
# Variable id
var <- dfvalgreptmp[[colname]][r]
# Value id
filterout[[var]] <- if(sum(neg) > 0) paste0("-", dfvalgreptmp[[column_names[[API_version]][["value.id"]][["es"]]]][r]) else dfvalgreptmp[[column_names[[API_version]][["value.id"]][["es"]]]][r]
}else{
# Variable id
var <- dfvalgreptmp[[colname]][r]
# Value id
filterout[[var]] <- if(sum(neg) > 0) paste0("-", dfvalgreptmp[[column_names[[API_version]][["value.id"]][["es"]]]][r]) else dfvalgreptmp[[column_names[[API_version]][["value.id"]][["es"]]]][r]
if(exists("dfvalgrep") && is.data.frame(get("dfvalgrep")) ){
# If the variable id has been used in the filter, set the same counter
if(is.element(var, dfvalgrep[[colname]])){
i <- dfvalgrep[dfvalgrep[[colname]] == var,]$i[1]
dfvalgreptmp$i[r] <- i
}else{
if(nrow(dfvalgrep) > 0){
i <- max(dfvalgrep$i) + 1
}
}
}
}
# Check the filter comes from a table or a series
parurl <- if(is.element("idtable",parnames)) "tv" else paste0("g", i)
# check if there are negative values and remove
filterout_neg <- check_negative_values(dfval, var, filterout[[var]], origin)
# Build the filter with the format of the API
#tmp <- paste0(parurl, "=", var, ":", filterout[[var]])
tmp <- paste0(parurl, "=", filterout_neg)
# Vector with all the values in the format of the API
val <- append(val, tmp)
if(length(lval) > 0){
# in case we have to remove repeated values included in the negative check
if(sum(neg) > 0){
# elements in the filter with variable equal to var
fvar <- lapply(strsplit(unlist(lval), ":"), function(x) x[1] == var)
# elements in the filter with variable not equal to var
fnovar <- lapply(strsplit(unlist(lval), ":"), function(x) x[1] != var)
lval1 <- list()
if(sum(unlist(fvar)) > 0){
# select from filter only the values for variable var
ulval <- lval[unlist(fvar)]
# format of the API
ulval <- paste0(names(ulval),"=",unlist(ulval))
# remove values with negative sign from filter
ulval <- intersect(ulval, tmp)
# format of the filter to return
lval1 <- lapply(strsplit(ulval, "="), `[[`, 2)
names(lval1) <- unlist(lapply(strsplit(ulval, "="), `[[`, 1))
}else{
lval1 <- lapply(strsplit(tmp, "="), `[[`, 2)
names(lval1) <- unlist(lapply(strsplit(tmp, "="), `[[`, 1))
}
# union
lval <- append(lval[unlist(fnovar)], lval1)
}else{
# List with all the values
#for(fo in filterout[[var]]){
for(fo in filterout_neg){
#lval <- append(lval, list(paste0(var, ":", fo)))
lval <- append(lval, list(fo))
names(lval)[length(lval)] <- parurl
}
}
}else{
# List with all the values
for(fo in filterout_neg){
#lval <- append(lval, list(paste0(var, ":", fo)))
lval <- append(lval, list(fo))
names(lval)[length(lval)] <- parurl
}
}
}
}
}else{
# Case when the value introduced is and empty character ""
if(length(varid) == 1){
# value set to ""
filterout[[varid]] <- f
# Check the filter comes from a table or a series
parurl <- if(is.element("idtable",parnames)) "tv" else paste0("g", i)
# Build the filter with the format of the API
tmp <- paste0(parurl, "=", varid, ":", filterout[[varid]])
# Vector with all the values in the format of the API
val <- append(val, tmp)
# List with all the values
lval <- append(lval, list(paste0(varid, ":", filterout[[varid]])))
names(lval)[length(lval)] <- parurl
}
}
if (exists("dfvalgrep") && is.data.frame(get("dfvalgrep"))){
dfvalgrep <- rbind(dfvalgrep,dfvalgreptmp)
}else{
dfvalgrep <- dfvalgreptmp
}
if(addons$verbose){
cat(sprintf("- Processing filter: %s%% \r", round(50 + j/sum(lengths(filter))*50,0)))
}
i <- i + 1
j <- j + 1
}
}
# When there are no shortcuts in the filter
}else{
# Check the filter comes from a table or a series
parurl <- if(is.element("idtable",parnames)) "tv" else paste0("g", i)
# check if there are negative values and remove
filter_neg <- check_negative_values(dfval, n, filter[[n]], origin)
# Build the filter with the format of the API
#tmp <- paste0(parurl, "=", n, ":", filter[[n]])
tmp <- paste0(parurl, "=", filter_neg)
# Vector with all the values in the format of the API
val <- append(val, tmp)
#for(f in filter[[n]]){
for(f in filter_neg){
# List with all the values
#lval <- append(lval, list(paste0(n, ":", f)))
lval <- append(lval, list(f))
names(lval)[length(lval)] <- parurl
if(addons$verbose){
cat(sprintf("- Processing filter: %s%% \r", round(50 + j/sum(lengths(filter))*50,0)))
}
j <- j + 1
}
i <- i + 1
}
}
if(addons$verbose){
cat("- Processing filter: 100% \n")
}
return(list(filter = lval, df = dfval))
}
# Get the all values used in a table or operation
get_filter_values <- function(parameter, lang, shortcut, verbose, progress = TRUE, det = 0, addons = NULL){
# id to identify a table or a operation
id <- parameter[[1]]
# List of variables and values
filter <- parameter[[2]]
# Names in the list of the parameter
parnames <- tolower(names(parameter))
# Dataframe to return the values
dfval <- NULL
# The filter includes shortcuts in the names of variables and values
if(shortcut){
# The filter comes from a table
if(is.element("idtable",parnames)){
# Get the metadata information of the table
dfval <- get_metadata_variable_values_table(idTable = id, verbose = verbose, validate = FALSE, lang = lang, progress = progress, det = det)
# The filter comes from a series
}else if (is.element("operation",parnames)){
# We obtain the variables and values from the operation of the series
dfval <- get_metadata_variable_values_operation(operation = id, verbose = verbose, validate = FALSE, lang, progress = progress, det = det)
}else{
# We obtain the variables and values from hierarchy tree
dfval <- get_metadata_variable_values_hierarchy(variable = id, verbose = verbose, validate = FALSE, lang, progress = progress, det = det, hierarchy = addons$hierarchy)
}
}
return(dfval)
}
# Check the request
check_request <- function(request){
# Check addons
cadd <- check_addons(request$parameters, request$addons, request$definition)
# Check definition
cdef <- check_definition(request$definition, request$addons)
# Check parameters
cpar <- check_parameters(request$parameters, request$addons, request$definition)
# Check results to return
check <- list()
check <- append(check, list(definition = cdef))
check <- append(check, list(addons = cadd))
check <- append(check, list(parameters = cpar))
request <- append(request, list(check = check))
return(request)
}
# Check the definition of the request
check_definition <- function(definition, addons){
result <- list()
# Validate or not the definition
check <- addons$validate
if(check){
for(x in names(definition)){
val <- definition[[x]]
if(!is.null(val)){
r <- switch (x,
"lang" = check_lang(val, addons$verbose),
"input" = check_input(definition$tag, val, addons$verbose)
)
# Check results to return
result <- append(result, r)
names(result)[length(result)] <- x
}
}
}
return(result)
}
# Check the parameters of the request
check_parameters <- function(parameters, addons, definition){
result <- list()
# Validate or not the parameters
check <- addons$validate
if(check){
for(x in names(parameters)){
val <- parameters[[x]]
if(!is.null(val)){
r <- switch (x,
"date" = check_dates(val, addons$verbose),
"p" = check_periodicity(val[[1]], val[[2]], addons$verbose),
"nult" = check_nlast(val, addons$verbose),
"det" = check_det(val, addons$verbose),
"tip" = check_tip(val, addons$verbose),
"geo" = check_geo(val, addons$verbose),
"page" = check_page(val, addons$verbose),
"filter" = check_filter(val, addons, definition, parameters$det),
"clasif" = check_classification(val[[1]], val[[2]], addons$verbose)
)
# Check results to return
result <- append(result, r)
names(result)[length(result)] <- x
}
}
}
return(result)
}
# Check the addons of the request
check_addons <- function(parameters, addons, definition){
result <- list()
# Validate or not the addons
check <- addons$validate
if(check){
for(x in names(addons)){
val <- addons[[x]]
if(!is.null(val)){
r <- switch (x,
"validate" = check_islogical(x, val),
"verbose" = check_islogical(x, val),
"unnest" = check_islogical(x, val),
"metanames"= check_extractmetadata(x, val, parameters$tip),
"metacodes"= check_extractmetadata(x, val, parameters$tip),
"hierarchy" = check_hierarchy(val, addons$verbose),
"filter" = check_filter(val, addons, definition, parameters$det)
)
# Check results to return
result <- append(result, r)
names(result)[length(result)] <- x
}
}
}
return(result)
}
#Check the result retrieved for the API
check_result <- function(result, response = NULL){
check <- FALSE
if(!is.null(result)){
if(!check_result_status(result)){
if(is.data.frame(result) && nrow(result) > 0){
check <- TRUE
}
if(is.list(result) && !is.data.frame(result) && length(result) > 0){
check <- TRUE
}
}
}else{
if(!is.null(response)){
if(response$status_code != 200){
# GRUPOS_TABLA used to check px tables
if(!grepl("/GRUPOS_TABLA/", response$url, ignore.case = TRUE)){
message(sprintf("An error occurred calling the API (status %s).\n%s", response$status_code, response$url))
}
}
}
}
return(check)
}
#Check the result retrieved for the API
check_result_status <- function(result){
check <- FALSE
if(is.element("status", names(result))){
check <- TRUE
cat(sprintf("- %s\n", result$status))
}
return(check)
}
# check if lang argument in the definition is valid
check_lang <- function(lang, verbose){
result <- TRUE
if(!is.character(lang)){
result <- FALSE
stop("lang must be a string equal to 'ES' for Spanish or equal to 'EN' for English")
}else{
if(lang != "ES" && lang != "EN"){
result <- FALSE
stop("lang must be a string equal to 'ES' for Spanish or equal to 'EN' for English")
}
}
if(verbose){
cat(sprintf("- Check lang: OK\n"))
}
return(result)
}
# Check the input part of the definition
check_input <- function(tag, input, verbose){
result <- list()
r <- switch(
tag,
"operation" = check_operation(input, verbose = verbose),
"operation_active_null" = check_operation(input, active_null = TRUE, verbose = verbose),
"codSeries" = check_isnull(tag, input, verbose),
"variable_operation" = check_variables_operation(input, verbose),
"publication" = check_publication(input, verbose),
"idTable" = check_isnull(tag, input, verbose),
"idTable_idGroup" = check_idtable_idgroup(input, verbose)
)
# Check results to return
result <- append(result, r)
names(result)[length(result)] <- tag
return(result)
}
# Check operation argument in API call
check_operation <- function(operation, active_null = FALSE, verbose){
result <- TRUE
if(!is.null(operation)){
# Get all operations
opes <- get_metadata_operations(validate = FALSE, verbose = verbose, page = 0)
# Logical controls
id <- FALSE
ioe <- FALSE
cod <- FALSE
# Check id
tmp <- opes$Id[trimws(opes[[column_names[[API_version]][["id"]][["es"]]]]) != ""]
if(!is.element(operation,tmp)){
id <- TRUE
}
# Check cod_IOE
tmp <- paste0("IOE", opes[[column_names[[API_version]][["ioe"]][["es"]]]][trimws(opes[[column_names[[API_version]][["ioe"]][["es"]]]]) != ""])
if(!is.element(operation,tmp)){
ioe <- TRUE
}
# Check code
tmp <- opes[[column_names[[API_version]][["codigo"]][["es"]]]][trimws(opes[[column_names[[API_version]][["codigo"]][["es"]]]]) != ""]
if(!is.element(operation,tmp)){
cod <- TRUE
}
result <- !(id & ioe & cod)
if(!result){
stop("The operation not exists")
}
}else{
if(!active_null){
result <- FALSE
stop("The operation must be specified")
}
}
if(verbose){
cat(sprintf("- Check operation: OK\n"))
}
return(result)
}
# Check variables
check_variables_operation <- function(input, verbose){
result <- TRUE
# Variable id
variable <- input$variable
# Operation id
operation <- if("operation" %in% names(input)) input$operation else NULL
# Value id
value <- if("value" %in% names(input)) input$value else NULL
if(!is.null(operation)){
# First we check if the operation is valid
check_operation(operation, verbose = verbose)
# Second we check if the variable is valid for the operation
result <- check_variablesoperation(operation, variable, verbose)
}else{
# Check if the variable is valid
result <- check_variable(variable, verbose)
if(!is.null(value)){
# Check if the value is valid
result <- check_value(variable, value, verbose)
}
}
return(result)
}
# Check if a variable is valid for an operation
check_variablesoperation <- function(operation, variable, verbose){
result <- TRUE
if(!is.null(variable)){
vars <- get_metadata_variables(operation = operation, validate = FALSE, verbose = verbose, page = 0)
if(!is.element(variable, vars[[column_names[[API_version]][["id"]][["es"]]]])){
result <- FALSE
stop(sprintf("%s is not a valid variable for operation %s. Valid ids: %s", variable, operation, paste0(vars$Id, collapse = ", ")))
}
}else{
result <- FALSE
stop("variable argument must be specified")
}
if(verbose){
cat(sprintf("- Check variable: OK\n"))
}
return(result)
}
# Check if the variable is valid
check_variable <- function(variable, verbose){
result <- TRUE
if(!is.null(variable)){
vars <- get_metadata_variables(validate = FALSE, verbose = verbose, page = 0)
if(!is.element(variable, vars[[column_names[[API_version]][["id"]][["es"]]]])){
result <- FALSE
stop(sprintf("%s variable not exists", variable))
}
}else{
result <- FALSE
stop("variable argument must be specified")
}
if(verbose){
cat(sprintf("- Check variable: OK\n"))
}
return(result)
}
# Check if a variable is valid for an operation
check_value <- function(variable, value, verbose){
result <- TRUE
if(!is.null(value)){
vars <- get_metadata_values(variable = variable, validate = FALSE, verbose = verbose, page = 0)
if(!is.element(value, vars[[column_names[[API_version]][["id"]][["es"]]]])){
result <- FALSE
stop(sprintf("%s is not a valid value for variable %s. Valid ids: %s", value, variable, paste0(vars$Id, collapse = ", ")))
}
}
if(verbose){
cat(sprintf("- Check value: OK\n"))
}
return(result)
}
# check if a publication is valid
check_publication <- function(publication, verbose){
result <- TRUE
if(!is.null(publication)){
# Get all the publications
pubs <- get_metadata_publications(validate = FALSE, verbose = verbose, page = 0)
if(!is.element(publication, pubs[[column_names[[API_version]][["id"]][["es"]]]])){
result <- FALSE
stop(sprintf("%s publication not exists", publication))
}
}else{
result <- FALSE
stop("publication argument must be specified")
}
if(verbose){
cat(sprintf("- Check publication: OK\n"))
}
return(result)
}
# Check if the argument is NULL
check_isnull <- function(name, id, verbose){
result <- TRUE
if(is.null(id)){
result <- FALSE
stop(sprintf("%s argument must be specified", name))
}
if(verbose){
cat(sprintf("- Check %s: OK\n", name))
}
return(result)
}
# Check if both, table and group, are NULL
check_idtable_idgroup <- function(input, verbose){
result <- TRUE
idTable <- input$idTable
idGroup <- input$idGroup
nameid <- names(input)
check_isnull(nameid[1], idTable, verbose)
check_isnull(nameid[2], idGroup, verbose = FALSE)
if(!is.null(idTable) && !is.null(idGroup)){
# Get all the groups of the table
groups <- get_metadata_table_groups(idTable = idTable, validate = FALSE, verbose = verbose)
if(!is.element(idGroup, groups[[column_names[[API_version]][["id"]][["es"]]]])){
result <- FALSE
stop(sprintf("%s is not a valid group for table %s. Valid ids: %s", idGroup, idTable, paste0(groups$Id, collapse = ", ")))
}
}
if(verbose){
cat(sprintf("- Check idGroup: OK\n"))
}
return(result)
}
# Check date argument in API CALL
check_dates <- function(date, verbose){
result <- TRUE
dateStart <- date$dateStart
dateEnd <- date$dateEnd
namesdate = names(date)
check_date_format(namesdate[1], dateStart)
check_date_format(namesdate[2], dateEnd)
if(!is.null(dateEnd)){
if(!is.null(dateStart)){
if(length(dateEnd) > length(dateStart)){
result <- FALSE
stop("the length of dateEnd must be less than or equal to the length of dateStart.")
}else{
for(i in 1:length(dateEnd)){
if(dateStart[i] > dateEnd[i]){
result <- FALSE
stop(sprintf("dateStart (%s) must be previous to dateEnd (%s) or the same.", dateStart[i], dateEnd[i]))
}
}
}
}else{
result <- FALSE
stop("dateStart must be specified.")
}
}
if(verbose){
cat(sprintf("- Check date: OK\n"))
}
return(result)
}
# Check the input format of the date
check_date_format <- function(name, date){
for(f in date){
# Remove white spaces
#f <- if(!is.null(f)) gsub("\\s+", "", f) else f
# Input format must be yyyy/mm/dd
format <- if(!is.null(f)) grepl("[0-9]{4}/[0-9]{2}/[0-9]{2}", f) else FALSE
if(format){
y <- substr(f, 1, 4)
m <- substr(f, 6, 7)
d <- substr(f, 9, 10)
if(m > 12){
stop(sprintf("%s month can not be greater than 12", name))
}
if(d > 31){
stop(sprintf("%s day can not be greater than 31", name))
}
}else{
if(!is.null(f)){
stop(sprintf("%s format is not correct. Date format must be as follow: yyyy/mm/dd", name))
}
}
}
}
# check if the periodicity argument is valid
check_periodicity <- function(operation, p, verbose){
result <- TRUE
if(!is.null(p)){
# Get periodicities of an operation
periodicity <- get_metadata_periodicity(operation = operation, validate = FALSE, verbose = verbose)
if(!is.element(p, periodicity[[column_names[[API_version]][["id"]][["es"]]]])){
result <- FALSE
stop(sprintf("%s is not a valid periodicity for operation %s. Valid ids: %s", p, operation, paste0(periodicity[[column_names[[API_version]][["id"]][["es"]]]], collapse = ", ")))
}
}else{
result <- FALSE
stop("periodicity must be specified")
}
if(verbose){
cat(sprintf("- Check periodicity: OK\n"))
}
return(result)
}
# Check if the nlast argument is valid
check_nlast <- function(nlast, verbose){
result <- TRUE
if(!is.numeric(nlast)){
result <- FALSE
stop("nlast must be a number greater or equal to 1")
}else{
if(nlast < 1){
result <- FALSE
stop("nlast must be a number greater or equal to 1")
}
}
if(verbose){
cat(sprintf("- Check nlast: OK\n"))
}
return(result)
}
# Check if the det argument is valid
check_det <- function(det, verbose){
result <- TRUE
if(!is.numeric(det)){
result <- FALSE
stop("det must be a number between 0 and 2")
}else{
if(det < 0 || det > 2){
result <- FALSE
stop("det value must be between 0 and 2")
}
}
if(verbose){
cat(sprintf("- Check det: OK\n"))
}
return(result)
}
# Check if the tip argument is valid
check_tip <- function(tip, verbose){
result <- TRUE
if(!is.null(tip)){
tip <- toupper(tip)
if(tip != "A" && tip != "M" && tip != "AM" && tip != "MA"){
result <- FALSE
stop("tip must be equal to 'A', 'M' or 'AM'")
}
}
if(verbose){
cat(sprintf("- Check tip: OK\n"))
}
return(result)
}
# Check if the geo argument is valid
check_geo <- function(geo, verbose){
result <- TRUE
if(!is.null(geo)){
if(!is.numeric(geo)){
result <- FALSE
stop("geo must be a number equal to 0 or 1")
}else{
if(geo < 0 || geo > 1){
result <- FALSE
stop("geo must be a number equal to 0 or 1")
}
}
}
if(verbose){
cat(sprintf("- Check geo: OK\n"))
}
return(result)
}
# check if the page argument is valid
check_page <- function(n, verbose){
result <- TRUE
if(!is.numeric(n)){
result <- FALSE
stop("page must be a number greater or equal to 0")
}else{
if(n < 0){
result <- FALSE
stop("page must be a number greater or equal to 0")
}
}
if(verbose){
cat(sprintf("- Check page: OK\n"))
}
return(result)
}
# Check if the filter argument is valid
check_filter <- function(parameter, addons, definition, det = 0){
result <- TRUE
# If there are shortcuts in the filter
shortcut <- FALSE
# check if there are negative values in the filter
if(is_negative_filter_values(parameter[[2]])){
# remove the negative signs
parameter[[2]] <- remove_filter_negative_values(parameter[[2]])
}
# id to identify a table or a operation
id <- parameter[[1]]
# List of variables and values
filter <- parameter[[2]]
# Names in the list of the parameter
parnames <- tolower(names(parameter))
# Get the values from metadata of tables or operations
df <- get_filter_values(parameter, definition$lang, shortcut = TRUE, verbose = addons$verbose, progress = FALSE, det = det, addons = addons)
# Make sure the response is valid or null
if(check_result(df$values)){
# The filter comes from a px table
if(df$origin == "tablepx"){
check <- check_table_px_filter(id, filter, addons$verbose, df$values)
result <- check$result
shortcut <- check$shortcut
# The filter comes from a px table with ids
}else if(df$origin == "tablepxid"){
check <- check_table_px_id_filter(id, filter, addons$verbose, df$values)
result <- check$result
shortcut <- check$shortcut
# The filter comes from a tempus table
}else if(df$origin == "tablet3"){
check <- check_table_tempus_filter(parameter, addons$verbose, df$values, det = det)
result <- check$result
shortcut <- check$shortcut
}
# The filter comes from a series
else if(df$origin == "series") {
check <- check_series_filter(parameter, addons$verbose, df$values, det = det)
result <- check$result
shortcut <- check$shortcut
}
# The filter comes from variables
else if(df$origin == "variables") {
check <- check_variables_filter(parameter, addons$verbose, df$values, det = det)
result <- check$result
shortcut <- check$shortcut
}
}
# If there are shortcuts in the filter
df$shortcut <- shortcut
return(list(df))
}
# check if the classification argument is valid
check_classification <- function(operation, clasif, verbose){
result <- TRUE
if(!is.null(clasif)){
# Get periodicities of an operation
classification <- get_metadata_classifications(operation = operation, validate = FALSE, verbose = verbose)
if(!is.element(clasif, classification[[column_names[[API_version]][["id"]][["es"]]]])){
result <- FALSE
if(is.null(operation)){
stop(sprintf("%s is not a valid classification. Valid ids: %s", clasif, paste0(classification[[column_names[[API_version]][["id"]][["es"]]]], collapse = ", ")))
}else{
stop(sprintf("%s is not a valid classification for operation %s. Valid ids: %s", clasif, operation, paste0(classification[[column_names[[API_version]][["id"]][["es"]]]], collapse = ", ")))
}
}
}
if(verbose){
cat(sprintf("- Check classification: OK\n"))
}
return(result)
}
# Check if the det argument is valid
check_hierarchy <- function(depth, verbose){
result <- TRUE
if(!is.numeric(depth)){
result <- FALSE
stop("hierarchy must be a number between 0 and 10")
}else{
if(depth < 0 || depth > 10){
result <- FALSE
stop("hierarchy value must be between 0 and 10")
}
}
if(verbose){
cat(sprintf("- Check hierarchy: OK\n"))
}
return(result)
}
# Confirm if the metadata of the table contains information about the values id
exists_values_id <- function(metadata){
result <- FALSE
# Column names of the metadata of the table
metacols <- tolower(unique(unlist(lapply(metadata, names))))
# If there is a id column then
if(is.element("id", metacols)){
result <- TRUE
}
return(result)
}
# Confirm if the metadata of the table contains information about the values id
exists_variables_id <- function(metadata){
result <- FALSE
colname <- ""
# Column names of the metadata of the table
metacols <- unique(unlist(lapply(metadata, names)))
# If there is a id column
if(is.element("variable.id", tolower(metacols))){
result <- TRUE
colname <- metacols[grep("variable.id", metacols, ignore.case = TRUE)]
}
if(is.element("fk_variable", tolower(metacols))){
result <- TRUE
colname <- metacols[grep("fk_variable", metacols, ignore.case = TRUE)]
}
if(is.element("t3_variable", tolower(metacols))){
result <- TRUE
colname <- metacols[grep("t3_variable", metacols, ignore.case = TRUE)]
}
return(list(result = result, name = colname))
}
# Check if the filter argument is valid for a px table
check_table_px_filter <- function(idTable, pxfilter, verbose, df){
result <- TRUE
# If there are shortcuts in the filter
shortcut <- FALSE
# The filter must be a list
if(is.list(pxfilter)){
# Variables of the filter
var <- names(pxfilter)
# Go through all the variables
for(v in var){
# If the variable in the filter is not in the metadata is not valid
if(!is.element(v, c(df[[column_names[[API_version]][["variable.code"]][["es"]]]], shortcut_wrapper))){
result <- FALSE
msg <- sprintf("%s is not a valid variable for %s idTable. Valid variable codes: %s",v,idTable, paste0(unique(df[[column_names[[API_version]][["variable.code"]][["es"]]]]), collapse = ", "))
msg <- if(is.element(v, names(shortcuts_filter))) paste0(msg,"\nThe only shortcut valid for this table is the wrapper 'values'") else msg
stop(msg)
}
# Has been used a shortcut name for the variable or not
short <- is.element(tolower(v), shortcut_wrapper)
# Identify a filter with shortcuts
shortcut <- shortcut | short
# subset of the metadata for an specific variable
metavar <- if(v %in% shortcut_wrapper) df else df[df[[column_names[[API_version]][["variable.code"]][["es"]]]] == v,]
# Go through all the values in the filter for the specific variable
for(val in pxfilter[[v]]){
# Split the value
valshort <- if(nchar(val) > 0 ) unlist(strsplit(as.character(val), "\\s+")) else val
validnames <- TRUE
for(vs in valshort){
validnames <- validnames & sum(grepl(vs, metavar[[column_names[[API_version]][["value.name"]][["es"]]]], ignore.case = TRUE)) > 0
}
# If the value in the filter is not in the metadata is not valid
if(val != "" && !(is.element(val, metavar[[column_names[[API_version]][["value.code"]][["es"]]]]) || validnames )){
result <- FALSE
stop(sprintf("%s is not a valid value for variable %s", val, v))
}
}
}
}else{
result <- FALSE
stop("filter must be a list")
}
if(verbose){
cat(sprintf("- Check filter: OK\n"))
}
return(list(result = result, shortcut = shortcut))
}
# Check if the filter argument is valid for a px table
check_table_px_id_filter <- function(idTable, pxfilter, verbose, df){
result <- TRUE
# If there are shortcuts in the filter
shortcut <- FALSE
# The filter must be a list
if(is.list(pxfilter)){
# check for alias ~ in the filter
pxfilter <- check_alias_filter(pxfilter)
# Variables of the filter
var <- names(pxfilter)
# Go through all the variables
for(v in var){
# If the variable in the filter is not in the metadata is not valid
if(!is.element(v, c(df[[column_names[[API_version]][["variable.code"]][["es"]]]], df[[column_names[[API_version]][["variable.id"]][["es"]]]], shortcut_wrapper))){
result <- FALSE
msg <- sprintf("%s is not a valid variable for %s idTable. Valid variable codes: %s. Valid variable ids: %s",
v,
idTable,
paste0(unique(df[[column_names[[API_version]][["variable.code"]][["es"]]]][nchar(df[[column_names[[API_version]][["variable.code"]][["es"]]]]) > 0]), collapse = ", "),
paste0(unique(df[[column_names[[API_version]][["variable.code"]][["es"]]]]), collapse = ", "))
msg <- if(is.element(v, names(shortcuts_filter))) paste0(msg,"\nThe only shortcut valid for this table is the wrapper 'values'") else msg
stop(msg)
}
# Has been used a shortcut name for the variable or not
short <- is.element(tolower(v), shortcut_wrapper)
# Identify a filter with shortcuts
shortcut <- shortcut | short
# subset of the metadata for an specific variable
metavar <- if(v %in% shortcut_wrapper) df else df[df[[column_names[[API_version]][["variable.code"]][["es"]]]] == v | df[[column_names[[API_version]][["variable.code"]][["es"]]]] == v,]
# Go through all the values in the filter for the specific variable
for(val in pxfilter[[v]]){
# Split the value
valshort <- if(nchar(val) > 0 ) unlist(strsplit(as.character(val), "\\s+")) else val
validnames <- TRUE
for(vs in valshort){
validnames <- validnames & sum(grepl(vs, metavar[[column_names[[API_version]][["value.name"]][["es"]]]], ignore.case = TRUE)) > 0
}
# If the value in the filter is not in the metadata is not valid
if(val != "" && !(is.element(val, c(metavar[[column_names[[API_version]][["value.code"]][["es"]]]], metavar[[column_names[[API_version]][["value.id"]][["es"]]]])) || validnames )){
result <- FALSE
stop(sprintf("%s is not a valid value for variable %s", val, v))
}
}
}
}else{
result <- FALSE
stop("filter must be a list")
}
if(verbose){
cat(sprintf("- Check filter: OK\n"))
}
return(list(result = result, shortcut = shortcut))
}
# Check if the filter argument is valid for a tempus table
check_table_tempus_filter <- function(parameter, verbose, df, det = 0){
result <- TRUE
# If there are shortcuts in the filter
shortcut <- FALSE
# id to identify a table or a operation
id <- parameter[[1]]
# List of variables and values
filter <- parameter[[2]]
# Names in the list of the parameter
parnames <- tolower(names(parameter))
# The filter must be a list
if(is.list(filter)){
check <- check_tempus_filter(id, filter, parnames, df, det = det)
shortcut <- check$shortcut
}else{
result <- FALSE
stop("filter must be a list")
}
if(verbose){
cat(sprintf("- Check filter: OK\n"))
}
return(list(result = result, shortcut = shortcut))
}
# Check if the filter argument is valid for a series
check_series_filter <- function(parameter, verbose, df, det = 0){
result <- TRUE
# If there are shortcuts in the filter
shortcut <- FALSE
# id to identify a table or a operation
id <- parameter[[1]]
# List of variables and values
filter <- parameter[[2]]
# Names in the list of the parameter
parnames <- tolower(names(parameter))
# The filter must be a list
if(is.list(filter)){
# Variables of the filter
var <- names(filter)
# Values of the filter
val <- unlist(filter, use.names = FALSE)
# The list must contain at least two values in the filter
if(length(var) > 1 || (length(var) < 2 && length(val) > 1)){
check <- check_tempus_filter(id, filter, parnames, df, det = det)
shortcut <- check$shortcut
}else{
result <- FALSE
stop("The list must contain at least two values in the filter")
}
}else{
result <- FALSE
stop("filter must be a list")
}
if(verbose){
cat(sprintf("- Check filter: OK\n"))
}
return(list(result = result, shortcut = shortcut))
}
# Check if the filter argument is valid for variables
check_variables_filter <- function(parameter, verbose, df, det = 0){
result <- TRUE
# If there are shortcuts in the filter
shortcut <- FALSE
# id to identify a table or a operation
id <- parameter[[1]]
# List of variables and values
filter <- parameter[[2]]
# Names in the list of the parameter
parnames <- tolower(names(parameter))
# The filter must be a list
if(is.list(filter)){
check <- check_tempus_filter(id, filter, parnames, df, det = det)
shortcut <- check$shortcut
}else{
result <- FALSE
stop("filter must be a list")
}
if(verbose){
cat(sprintf("- Check filter: OK\n"))
}
return(list(result = result, shortcut = shortcut))
}
# Check if the filter argument is valid
check_tempus_filter <- function(id, filter, parnames, df, det = 0){
result <- TRUE
# If there are shortcuts in the filter
shortcut <- FALSE
# column name depending on det parameter
colname <- if(det > 0 ) column_names[[API_version]][["variable.id"]][["es"]] else column_names[[API_version]][["variable.fk"]][["es"]]
# Variables of the filter
var <- names(filter)
for(v in var){
# Has been used a shortcut name for the variable or not
short <- is.element(tolower(v), c(names(shortcuts_filter), shortcut_wrapper))
# Identify a filter with shortcuts
shortcut <- shortcut | short
if(short){
# The values wrapper is present
if(tolower(v) %in% shortcut_wrapper){
variable <- unique(df[[colname]])
# A shortcut is present
}else{
variable <- shortcuts_filter[[tolower(v)]]
}
}else{
variable <- v
}
# The variable id is in the metadata information
validvar <- intersect(variable, df[[colname]])
if(!(is.element(v, df[[colname]]) || length(validvar) > 0 )){
result <- FALSE
stop(sprintf("%s is not a valid variable for %s %s",v, parnames[1],id))
}
# If the shortcut name includes more than one variable
# obtain the metadata information for all the variables
metavar <- subset(df, df[[colname]] %in% validvar)
# Go through all the values of an specific variable
for(val in filter[[v]]){
# Multiple values
for(f in val){
# Split the value
valshort <- if(nchar(f) > 0 ) unlist(strsplit(as.character(f), "\\s+")) else f
validnames <- TRUE
# Check each part of the value
for(vs in valshort){
validnames <- validnames & sum(grepl(vs, metavar[[column_names[[API_version]][["value.name"]][["es"]]]], ignore.case = TRUE)) > 0
}
# The id or the shortcut name of the value must exist in the metadata information
if(f != "" && !(is.element(f, metavar[[column_names[[API_version]][["value.id"]][["es"]]]]) || validnames)){
result <- FALSE
if(is.element("idtable",parnames)){
stop(sprintf("%s is not a valid value for variable %s or is not present in the values of the groups of the table", f, v))
}else{
stop(sprintf("%s is not a valid value for variable %s", f, v))
}
}
}
}
}
return(list(result = result, shortcut = shortcut))
}
# Check if an argument is logical
check_islogical <- function(name, par){
result <- TRUE
if(!is.logical(par)){
result <- FALSE
stop(sprintf("%s must be logical", name))
}
return(result)
}
# Check if the argument shortcut is set correctly
check_shortcut <- function(filter, definition){
result <- FALSE
if(!is.null(filter)){
# Tables
if(grepl("IdTable", definition$tag, ignore.case = TRUE)){
# check the type of the table
checktable <- check_type_table(idTable = definition$input)
# PX table
if(checktable$ispxtable){
if(sum(is.element(tolower(names(filter)), shortcut_wrapper)) > 0){
result <- TRUE
}
# Tempus table
}else{
# There are shortcuts in the filter
if(sum(is.element(tolower(names(filter)), c(names(shortcuts_filter), shortcut_wrapper))) > 0 ){
result <- TRUE
}
}
# Tempus series
}else{
# There are shortcuts in the filter
if(sum(is.element(tolower(names(filter)), c(names(shortcuts_filter), shortcut_wrapper))) > 0 ){
result <- TRUE
}
}
}
return(result)
}
# Check if the extractmetadata argument is valid
check_extractmetadata <- function(name, val, tip){
result <- check_islogical(name, val)
if(!is.null(tip)){
tip <- toupper(tip)
if(val && tip != "M" && tip != "AM" && tip != "MA"){
result <- FALSE
stop(sprintf("when %s is set TRUE, tip must be equal to 'M' or 'AM'", name))
}
}else{
if(val){
result <- FALSE
stop(sprintf("when %s is set TRUE, tip must be equal to 'M' or 'AM'", name))
}
}
return(result)
}
# Obtain an unique dataframe from a list of dataframes
unnest_data <- function(datain){
# We have a dataframe
if(is.data.frame(datain)){
# Discard data and notas columns
sel <- tolower(names(datain)) != "data" & tolower(names(datain)) != "notas"
# Dataframe header without the data and notas columns
dataout <- as.data.frame(datain[c(),sel])
names(dataout) <- names(datain)[sel]
# Data Dataframes of the list not empty
datasel <- lengths(datain$Data) > 0
# Only dataframes with Data
datacol <- datain$Data[datasel]
# Dataframes without Data
nodata <- datain[!datasel,sel]
# Go through all the dataframes with data
if(length(datacol) > 0){
# index of the dataframe with lower number of data columns
ind <- which.min(lengths(datacol))
# Data columns
col_data <- as.data.frame(datacol[[ind]][c(),])
names(col_data) <- names(datacol[[ind]])
# Adding Data column to the header
dataout <- cbind(dataout,col_data)
# Repeat each row by the number of data values
tmp <- datain[rep(seq_len(nrow(datain)), times = sapply(datain$Data, nrow)), sel]
# Unique dataframe of data normalizing the data columns
data <- do.call(rbind, lapply(datain$Data, function(x) if (length(x) > 0) subset(x, select = names(col_data))))
# Adding data
dataout <- cbind(tmp,data)
# In case we have only one column
if(sum(sel) == 1){
names(dataout)[1] <- names(datain)[1]
}
}
# In case of dataframes without Data
if(!is.null(nrow(nodata)) && nrow(nodata) > 0){
if(length(datacol) > 0){
# index of the dataframe with more values of data
ind <- which.max(lapply(datacol, nrow))
# Dataframe with values
data <- datacol[[ind]][names(col_data)]
# Change value for NA
data$Valor <- NA
# Repeat each row by the number of data values
tmp <- nodata[rep(seq_len(nrow(nodata)), each = nrow(data)),]
# Repeat each row by the number of nodata rows
nodata <- data[rep(seq_len(nrow(data)), times = nrow(nodata)),]
# Adding columns
nodata <- cbind(tmp, nodata)
# Adding rows
dataout <- rbind(dataout, nodata)
}else{
dataout <- datain
}
}
}
# We have a list (series case)
if(is.list(datain) && !is.data.frame(datain)){
# Selection of single columns
sel <- lengths(datain) == 1
# Selection of metadata
selmeta <- lengths(datain) > 1 & tolower(names(datain)) != "data" & tolower(names(datain)) != "notas"
# Dataframe without metadata, data and notas columns
tmp <- as.data.frame(datain[sel])
# Adding metadata
if(sum(selmeta) > 0){
for(n in names(selmeta)){
if(selmeta[[n]]){
tmp[[n]] <- datain[n]
}
}
}
# Repeat each row by the number of data values
tmp <- tmp[rep(seq_len(nrow(tmp)), each = max(lengths(datain$Data))),]
# Obtain data
data <- datain$Data
# Adding data
dataout <- cbind(tmp,data)
}
return(dataout)
}
# Check if the table is a px file or not
check_type_table <- function(idTable, verbose = FALSE, validate = FALSE, lang = "ES"){
# Get the groups of the table
groups <- get_metadata_table_groups(idTable = idTable, verbose = verbose, validate = validate, lang = lang)
# If the result of the query is null is a px table
result <- if(is.null(groups)) TRUE else FALSE
origin <- if(result) "tablepx" else "tablet3"
return(list(groups = groups, ispxtable = result, origin = origin))
}
check_alias_filter <- function(f){
val <- f
# Get variables
n <- names(f)
# Check if there are variables with aliases
login <- grepl("~", n)
# Check if there are values with aliases
logif <- grepl("~", f)
if(sum(login) != sum(logif)){
stop("Filter aliases missing")
}else{
if(sum(login) > 0){
# Get variables without aliases
var <- unlist(lapply(n, function(x) gsub("~id|~cod","",x)))
# Check if the aliases are valid
if(length(grep("~", var)) > 0){
stop("The alias in the variables of the filter is not valid. Valid aliases are 'id' and 'cod'")
}
# Get values without aliases
val <- lapply(f, function(x) gsub("~id|~cod","",tolower(x)))
# Check if the aliases are valid
if(length(grep("~", unlist(val))) > 0){
stop("The alias in the values of the filter is not valid. Valid aliases are 'id' and 'cod'")
}
# Get aliases of variables
varalias <- rep(unlist(lapply(strsplit(names(f), "~"),
function(x) {if(length(x) > 1) x[2] else ""})),
times = lengths(f))
# Get aliases of values
valalias <- unlist(lapply(strsplit(unlist(f, use.names = FALSE), "~"),
function(x) {if(length(x) > 1) x[2] else ""}))
if(sum(varalias == valalias) != length(valalias)){
stop("The alias of a variable and its values must be the same. Valid aliases are 'id' and 'cod'")
}
names(val) <- var
}
}
return(val)
}
# Extract metadata information from tables into columns
extract_metadata <- function(datain, request){
# Obtain metadata
metadata <- datain$MetaData
dataout <- datain
# Metadata columns to extract
metacols <- character()
metacolsnames <- character()
if(request$addons$metanames){
metacols <- append(metacols, "Nombre")
metacolsnames <- append(metacolsnames, "")
}
if(request$addons$metacodes){
metacols <- append(metacols, "Codigo")
metacolsnames <- append(metacolsnames, ".Codigo")
}
# Tables
if(grepl("IdTable",request$definition$tag, ignore.case = TRUE)){
# check the type of the table
checktable <- check_type_table(idTable = request$definition$input, lang = request$definition$lang)
# Check if exits and id for variables
existsvarid <- exists_variables_id(metadata)
# Case one: tpx or px table
if(checktable$ispxtable){
# Number of variables in metadata information
nummeta <- min(unique(do.call(rbind,lapply(metadata,nrow))))
# Column to extract metadata
varmeta <- if(exists_values_id(metadata) && existsvarid$result) existsvarid$name else column_names[[API_version]][["variable.code"]][["es"]]
if(exists_values_id(metadata)){
metacols <- append(metacols, "Id")
metacolsnames <- append(metacolsnames, ".Id")
}
# Obtain variable codes for each row in metadata information
varcode <- list()
for(i in 1:nummeta){
varcode <- append(varcode,
as.data.frame(unique(do.call(rbind,
lapply(metadata, '[',c(i),c(varmeta))))))
}
# Loop through all variables
for(var in varcode){
# Select a variable code and build a Unique dataframe of variable names
dfcodes <- do.call(rbind,
lapply(metadata,
function(x) subset(x,
x[[varmeta]] %in% var,
select = metacols)))
# Rename column with variable code
newname <- paste0(gsub("\\s+",".", var), collapse = "_")
names(dfcodes) <- paste0(newname, metacolsnames)
# Adding column to dataframe
if(nrow(dfcodes) == nrow(dataout)){
dataout <- cbind(dataout, dfcodes)
}
}
# Case two: tempus table
}else{
if(request$addons$metacodes){
metacols <- append(metacols, "Id")
metacolsnames <- append(metacolsnames, ".Id")
}
# Loop through all groups
for (g in checktable$groups$Id){
# Get th values of the group
values <- get_metadata_table_values(idTable = request$definition$input, idGroup = g, validate = FALSE, lang = request$definition$lang, det = 2)
# name of the variable column
colname <- if(tolower(existsvarid$name) == "t3_variable") "variable.name" else "variable.id"
# Select a variable id and build a Unique dataframe of variable names
dfcodes <- do.call(rbind,
lapply(metadata,
function(x) subset(x,
x[[existsvarid$name]] %in% unique(values[[column_names[[API_version]][[colname]][["es"]]]]),
select = metacols)))
# New name of the column
newname <- unlist(subset(checktable$groups, checktable$groups$Id == g, select = c("Nombre")))
newname <- gsub("\\s+",".", newname)
# Rename column
names(dfcodes) <- paste0(newname, metacolsnames)
# Adding column to dataframe
dataout <- cbind(dataout, dfcodes)
}
}
# Series
}else{
# Number of variables in metadata information
nummeta <- min(unique(do.call(rbind,lapply(metadata,nrow))))
# Obtain variable codes for each row in metadata information
varcode <- list()
varname <- list()
for(i in 1:nummeta){
varcode <- append(varcode,
as.data.frame(unique(do.call(rbind,
lapply(metadata, '[',c(i),c("Variable.Id"))))))
varname <- append(varname,
as.data.frame(unique(do.call(rbind,
lapply(metadata, '[',c(i),c("Variable.Nombre"))))))
}
if(request$addons$metacodes){
metacols <- append(metacols, "Id")
metacolsnames <- append(metacolsnames, ".Id")
}
# Loop through all variables
k <- 1
for(var in varcode){
# Select a variable code and build a Unique dataframe of variable names
dfcodes <- do.call(rbind,
lapply(metadata,
function(x) subset(x,
x[[column_names[[API_version]][["variable.id"]][["es"]]]] %in% var,
select = metacols)))
# Rename column with variable code
newname <- gsub("\\s+",".", varname[[k]][1])
names(dfcodes) <- paste0(newname, metacolsnames)
# Adding column to dataframe
if(nrow(dfcodes) == nrow(dataout)){
dataout <- cbind(dataout, dfcodes)
}
k <- k + 1
}
}
return(dataout)
}
# Get metadata information about the variables and values present in a table
get_metadata_variable_values_table <- function(idTable, filter = NULL, verbose, validate, lang, progress = FALSE, det = 0, request = NULL){
# Check the type of the table
checktable <- check_type_table(idTable = idTable, validate = validate, verbose = verbose, lang = lang)
dfvalues <- NULL
origin <- ""
# Make sure the response is valid or null
if(!check_result_status(checktable$groups)){
# The table is in px or tpx format
if(checktable$ispxtable){
origin <- checktable$origin
# internal call of the funtion
#if(is.null(request)){
if(progress){
cat(sprintf("- Processing filter: %s%% \r", 50))
}
# Obtain metadata information
df <- get_metadata_series_table(idTable = idTable, filter = filter, tip = "M", validate = FALSE, verbose = verbose, lang = lang, det = det)
# Check if exits and id for variables
existsvarid <- exists_variables_id(df$MetaData)
# If exists variable's id and value's id add new origin and include ids in the selection
if(exists_values_id(df$MetaData) && existsvarid$result) {
#selcol <- c("Nombre", "Codigo", "Id", "Variable.Nombre","Variable.Codigo", existsvarid$name)
selcol <- names(df$MetaData[[1]])[grepl("id|nombre|codigo|variable", names(df$MetaData[[1]]), ignore.case = TRUE)]
origin <- "tablepxid"
}else{
#selcol <- c("Nombre", "Codigo", "Variable.Nombre","Variable.Codigo")
selcol <- names(df$MetaData[[1]])[grepl("id|nombre|codigo|variable", names(df$MetaData[[1]]), ignore.case = TRUE)]
}
# Get the metadata with information of variables and values
dfvalues <- lapply(df$MetaData,
function(x) subset(x, select = selcol))
dfvalues <- unique(do.call(rbind, dfvalues))
# call from get_metadata_table_varval
# }else{
# # if(is.null(filter)){
# if(progress){
# cat(sprintf("- Processing filter: %s%% \r", 50))
# }
#
# # Obtain metadata information
# df <- get_metadata_series_table(idTable = idTable, filter = filter, tip = "M", validate = FALSE, verbose = verbose, lang = lang)
#
# # Check if exits and id for variables
# existsvarid <- exists_variables_id(df$MetaData)
#
# # If exists variable's id and value's id add new origin and include ids in the selection
# if(exists_values_id(df$MetaData) && existsvarid$result) {
# selcol <- names(df$MetaData[[1]])[grepl("id|nombre|codigo|variable", names(df$MetaData[[1]]), ignore.case = TRUE)]
# origin <- "tablepxid"
#
# }else{
# selcol <- names(df$MetaData[[1]])[grepl("id|nombre|codigo|variable", names(df$MetaData[[1]]), ignore.case = TRUE)]
# }
#
# # Get the metadata with information of variables and values
# dfvalues <- lapply(df$MetaData,
# function(x) subset(x, select = selcol))
#
# dfvalues <- unique(do.call(rbind, dfvalues))
# }else{
# if(validate){
# # rerieve the filter values
# lvarval <- get_parameters_filter(request)
#
# # filter values
# fvarval <- lvarval$filter
#
# # dataframe of variables and values ids
# dfvalues <-lvarval$df
#
# if(origin == "tablepxid"){
# # create column variable_id:value_id
# dfvalues$varval <- paste(as.character(dfvalues[, column_names[[API_version]][["variable.id"]][["es"]]]), as.character(dfvalues[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
#
# }else{
# # create column variable_cod:value_cod
# dfvalues$varval <- paste(as.character(dfvalues[, column_names[[API_version]][["variable.code"]][["es"]]]), as.character(dfvalues[, column_names[[API_version]][["value.code"]][["es"]]]), sep = ":")
# }
#
# # vector of var_id:val_id
# fvarval <- unique(unname(unlist(fvarval)))
#
# # vector of var_id
# fvar <- unique(unlist(lapply(strsplit(fvarval, ":"), `[[`, 1)))
#
# # retrieve varval in the filter
# df1 <- subset(dfvalues, dfvalues$varval %in% fvarval)
#
# if(origin == "tablepxid"){
# # retrieve variables not in the filter
# df2 <- subset(dfvalues, !(dfvalues[[column_names[[API_version]][["variable.id"]][["es"]]]] %in% fvar))
# }else{
# # retrieve variables not in the filter
# df2 <- subset(dfvalues, !(dfvalues[[column_names[[API_version]][["variable.code"]][["es"]]]] %in% fvar))
# }
#
# dfvalues <- rbind(df1, df2)
# dfvalues$varval <- NULL
# rm(df1)
# rm(df2)
#
# }else{
# if(progress){
# cat(sprintf("- Processing filter: %s%% \r", 50))
# }
#
# # Obtain metadata information
# df <- get_metadata_series_table(idTable = idTable, filter = filter, tip = "M", validate = FALSE, verbose = verbose, lang = lang)
#
# # Check if exits and id for variables
# existsvarid <- exists_variables_id(df$MetaData)
#
# # If exists variable's id and value's id add new origin and include ids in the selection
# if(exists_values_id(df$MetaData) && existsvarid$result) {
# selcol <- names(df$MetaData[[1]])[grepl("id|nombre|codigo|variable", names(df$MetaData[[1]]), ignore.case = TRUE)]
# origin <- "tablepxid"
#
# }else{
# selcol <- names(df$MetaData[[1]])[grepl("id|nombre|codigo|variable", names(df$MetaData[[1]]), ignore.case = TRUE)]
# }
#
# # Get the metadata with information of variables and values
# dfvalues <- lapply(df$MetaData,
# function(x) subset(x, select = selcol))
#
# dfvalues <- unique(do.call(rbind, dfvalues))
# }
# }
#}
# The table is stored in tempus
}else{
origin <- checktable$origin
# internal call of the funtion
if(is.null(request)){
i <- 1
for(g in checktable$groups$Id){
if(progress){
cat(sprintf("- Processing filter: %s%% \r", round(i/nrow(checktable$groups)*50,0)))
i <- i + 1
}
df <- get_metadata_table_values(idTable = idTable, idGroup = g, det = det, validate = FALSE, lang = lang, verbose = verbose)
if(!is.null(df)){
#df <- subset(df, select = c("Id", "Fk_Variable", "Nombre", "Codigo"))
df <- subset(df, select = names(df)[grepl("id|nombre|codigo|variable", names(df), ignore.case = TRUE)])
df$group <- g
}
if (exists("dfvalues") && is.data.frame(get("dfvalues"))){
dfvalues <- rbind(dfvalues,df)
}else{
dfvalues <- df
}
}
# create column fk_variable:id
if(det > 0 ){
dfvalues$varval <- paste(as.character(dfvalues[, column_names[[API_version]][["variable.id"]][["es"]]]), as.character(dfvalues[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
}else{
dfvalues$varval <- paste(as.character(dfvalues[, column_names[[API_version]][["variable.fk"]][["es"]]]), as.character(dfvalues[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
}
# call from get_metadata_table_varval
}else{
if(is.null(filter)){
i <- 1
for(g in checktable$groups$Id){
if(progress){
cat(sprintf("- Processing filter: %s%% \r", round(i/nrow(checktable$groups)*50,0)))
i <- i + 1
}
df <- get_metadata_table_values(idTable = idTable, idGroup = g, det = det, validate = FALSE, lang = lang, verbose = verbose)
if(!is.null(df)){
#df <- subset(df, select = c("Id", "Fk_Variable", "Nombre", "Codigo"))
df <- subset(df, select = names(df)[grepl("id|nombre|codigo|variable", names(df), ignore.case = TRUE)])
}
if (exists("dfvalues") && is.data.frame(get("dfvalues"))){
dfvalues <- rbind(dfvalues,df)
}else{
dfvalues <- df
}
}
}else{
# rerieve the filter values
lvarval <- get_parameters_filter(request)
# filter values
fvarval <- lvarval$filter
if(validate){
# dataframe of variables and values ids
dfvalues <-lvarval$df
}else{
i <- 1
for(g in checktable$groups$Id){
if(progress){
cat(sprintf("- Processing filter: %s%% \r", round(i/nrow(checktable$groups)*50,0)))
i <- i + 1
}
df <- get_metadata_table_values(idTable = idTable, idGroup = g, det = det, validate = FALSE, lang = lang, verbose = verbose)
if(!is.null(df)){
#df <- subset(df, select = c("Id", "Fk_Variable", "Nombre", "Codigo"))
df <- subset(df, select = names(df)[grepl("id|nombre|codigo|variable", names(df), ignore.case = TRUE)])
df$group <- g
}
if (exists("dfvalues") && is.data.frame(get("dfvalues"))){
dfvalues <- rbind(dfvalues,df)
}else{
dfvalues <- df
}
}
}
# vector of var_id:val_id
fvarval <- unique(unname(unlist(fvarval)))
# vector of var_id
fvar <- unique(unlist(lapply(strsplit(fvarval, ":"), `[[`, 1)))
# create column fk_variable:id
if(det > 0 ){
dfvalues$varval <- paste(as.character(dfvalues[, column_names[[API_version]][["variable.id"]][["es"]]]), as.character(dfvalues[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
# group id of the variables in the filter
fgroup <- subset(dfvalues, dfvalues[[column_names[[API_version]][["variable.id"]][["es"]]]] %in% fvar, select = "group")
}else{
dfvalues$varval <- paste(as.character(dfvalues[, column_names[[API_version]][["variable.fk"]][["es"]]]), as.character(dfvalues[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
# group id of the variables in the filter
fgroup <- subset(dfvalues, dfvalues[[column_names[[API_version]][["variable.fk"]][["es"]]]] %in% fvar, select = "group")
}
fgroup <- unique(unlist(fgroup))
# retrieve varval in the filter
df1 <- subset(dfvalues, dfvalues$varval %in% fvarval)
# retrieve variables not in the filter
if(det > 0 ){
df2 <- subset(dfvalues, !(dfvalues[[column_names[[API_version]][["variable.id"]][["es"]]]] %in% fvar) & !(dfvalues$group %in% fgroup))
}else{
df2 <- subset(dfvalues, !(dfvalues[[column_names[[API_version]][["variable.fk"]][["es"]]]] %in% fvar) & !(dfvalues$group %in% fgroup))
}
dfvalues <- rbind(df1, df2)
dfvalues$varval <- NULL
dfvalues$group <- NULL
rm(df1)
rm(df2)
}
}
}
}
return(list(origin = origin, values = dfvalues))
}
# Get metadata information about the variables and values present in an operation
get_metadata_variable_values_operation <- function(operation, verbose, validate, lang, progress = FALSE, det = 0, request = NULL){
dfvalues <- NULL
# We obtain the variables from the operation of the series
opevar <- get_metadata_variables(operation = operation, validate = validate, verbose = verbose, lang = lang, page = 0)
# We obtain the values of all the variables
i <- 1
for(var in opevar$Id){
if(progress){
cat(sprintf("- Processing filter: %s%% \r", round(i/nrow(opevar)*50,0)))
i <- i + 1
}
tmp <- get_metadata_values(operation = operation, variable = var, validate = FALSE, verbose = verbose, lang = lang, page = 0, det = det)
selcol <- names(tmp)[grepl("id|nombre|codigo|variable", names(tmp), ignore.case = TRUE)]
tmp <- subset(tmp, select = selcol)
#tmp <- subset(tmp, select = c("Id","Fk_Variable","Nombre","Codigo"))
# create column fk_variable:id
if(det > 0 ){
tmp$varval <- paste(as.character(tmp[, column_names[[API_version]][["variable.id"]][["es"]]]), as.character(tmp[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
}else{
tmp$varval <- paste(as.character(tmp[, column_names[[API_version]][["variable.fk"]][["es"]]]), as.character(tmp[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
}
if (exists("dfvalues") && is.data.frame(get("dfvalues"))){
dfvalues <- rbind(dfvalues,tmp)
}else{
dfvalues <- tmp
}
}
if(!is.null(request)){
dfvalues$varval <- NULL
}
return(list(origin = "series", values = dfvalues))
}
# Get metadata information about the variables and values present in a hierarchy tree
get_metadata_variable_values_hierarchy <- function(variable, hierarchy, verbose, validate, lang, progress = FALSE, det = 0){
dfvalues <- NULL
values <- get_metadata_values(variable = variable, validate = FALSE, verbose = verbose, lang = lang, page = 0, det = det, hierarchy = hierarchy)
# We obtain the values of all the variables
for(i in 0:hierarchy){
if(progress){
cat(sprintf("- Processing filter: %s%% \r", round(i/hierarchy*50,0)))
}
tmp <- subset(values, select = grepl(paste0("_", i, "$"), names(values)))
names(tmp) <- gsub(paste0("_", i, "$"), "", names(tmp))
tmp$level <- i
selcol <- names(tmp)[grepl("id|nombre|codigo|variable|jerarquia|level", names(tmp), ignore.case = TRUE)]
tmp <- unique(subset(tmp, select = selcol))
# create column fk_variable:id
if(det > 0 ){
tmp$varval <- paste(as.character(tmp[, column_names[[API_version]][["variable.id"]][["es"]]]), as.character(tmp[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
valfathers <- if(sum(grepl(column_names[[API_version]][["jerarquia"]][["es"]], names(tmp))) > 0) sapply(tmp[[column_names[[API_version]][["jerarquia"]][["es"]]]],`[[`, column_names[[API_version]][["id"]][["es"]]) else NA
}else{
tmp$varval <- paste(as.character(tmp[, column_names[[API_version]][["variable.fk"]][["es"]]]), as.character(tmp[, column_names[[API_version]][["value.id"]][["es"]]]), sep = ":")
valfathers <- if(sum(grepl(column_names[[API_version]][["jerarquia.fk"]][["es"]], names(tmp))) > 0) tmp[[column_names[[API_version]][["jerarquia.fk"]][["es"]]]] else NA
}
tmp$fathers <- valfathers
if (exists("dfvalues") && is.data.frame(get("dfvalues"))){
dfvalues <- rbind(dfvalues,tmp)
}else{
dfvalues <- tmp
}
}
return(list(origin = "variables", values = dfvalues))
}
# chek if there are negatives values in the filter and remove them
check_negative_values <- function(dfval, variable, values, origin){
# check if there is any negative value
neg <- grepl("^-.*", as.character(values))
if(sum(neg) > 0){
# remove minus sign
neg_values <- gsub("^-", "", as.character(values[neg]))
dfvalues <- NULL
if(!is.null(dfval)){
if(origin == "tablepx"){
# We select only the values of variables present in the filter
dfvalfilter <- subset(dfval,
dfval[[column_names[[API_version]][["variable.code"]][["es"]]]] %in% variable)
# remove negative values
dfvalues <- subset(dfvalfilter[[column_names[[API_version]][["value.code"]][["es"]]]],
!(dfvalfilter[[column_names[[API_version]][["value.code"]][["es"]]]] %in% neg_values))
dfvalues <- paste0(variable, ":", dfvalues)
}else if(origin == "tablepxid"){
check_alias <- grepl("~id$|~cod$", variable)
# variables and values without aliases
variable <- gsub("~id$|~cod$","",as.character(variable))
neg_values <- gsub("~id$|~cod$","",neg_values)
# We select only the values of variables present in the filter
dfvalfilter <- subset(dfval, dfval[[column_names[[API_version]][["variable.code"]][["es"]]]] %in% variable | dfval[[column_names[[API_version]][["variable.id"]][["es"]]]] %in% variable)
if(check_alias){
# remove negative values.
dfvalues <- subset(dfvalfilter[[column_names[[API_version]][["value.id"]][["es"]]]],
!(dfvalfilter[[column_names[[API_version]][["value.id"]][["es"]]]] %in% neg_values))
# include alias ~
dfvalues <- if(length(dfvalues) > 0) paste0(paste0(variable, "~id"), ":", paste0(dfvalues, "~id")) else NULL
# Case with codes
}else{
# remove negative values
dfvalues <- subset(dfvalfilter[[column_names[[API_version]][["value.code"]][["es"]]]],
!(dfvalfilter[[column_names[[API_version]][["value.code"]][["es"]]]] %in% neg_values) & grepl("\\S+", dfvalfilter[[column_names[[API_version]][["value.code"]][["es"]]]]))
dfvalues <- if(length(dfvalues) > 0) paste0(variable, ":", dfvalues) else NULL
}
}else if(origin %in% c("series", "variables")){
# column name depending on det parameter
colname <- if(sum(grepl(column_names[[API_version]][["variable.fk"]][["es"]], names(dfval), ignore.case = TRUE)) > 0) column_names[[API_version]][["variable.fk"]][["es"]] else column_names[[API_version]][["variable.id"]][["es"]]
# We select only the values of variables present in the filter
dfvalfilter <- subset(dfval, dfval[[colname]] %in% variable)
# remove negative values
dfvalues <- subset(dfvalfilter,
!(dfvalfilter[[column_names[[API_version]][["value.id"]][["es"]]]] %in% neg_values), select = "varval")
dfvalues <- unique(unlist(dfvalues))
}else{
# group id of the variables in the filter
fgroup <- subset(dfval, dfval[[column_names[[API_version]][["value.id"]][["es"]]]] %in% neg_values, select = "group")
# We select only the values of variable present in the filter
dfvalfilter <- subset(dfval, dfval$group %in% unique(unlist(fgroup)))
# remove negative values
dfvalues <- subset(dfvalfilter,
!(dfvalfilter[[column_names[[API_version]][["value.id"]][["es"]]]] %in% neg_values), select = "varval")
dfvalues <- unique(unlist(dfvalues))
}
}
}else{
dfvalues <- paste0(variable, ":", values)
}
return(dfvalues)
}
# remove negative sign from filter values
remove_filter_negative_values <- function(filter){
if(is.list(filter)){
# remove minus sign
nfilter <- lapply(filter, function(x) gsub("^-", "", as.character(x)))
}else{
nfilter <- filter
}
return(nfilter)
}
# check if in the filter there are negative values
is_negative_filter_values <- function(filter){
r <- FALSE
if(is.list(filter)){
s <- sum(unlist(lapply(filter, function(x) grepl("^-.*", as.character(x)))))
r <- if(s > 0) TRUE else FALSE
}
return(r)
}
# get values hierarchy tree
get_values_hierarchy <- function(father, request){
# depth of the hierarchy tree
depth <- request$addons$hierarchy
# get the filter
filter <- NULL
dfilter <- NULL
if(!is.null(request$addons$filter)){
filter <- get_addons_filter(request)
# data frame
dfilter <- filter$df
# variables and values to filter
filter <- filter$filter
# dataframe use as father
father <- if(is.null(dfilter)) father else subset(dfilter, dfilter$level == 0, !grepl("varval|level|fathers", names(dfilter), ignore.case = TRUE))
}
# First level column names
names(father) <- paste(names(father), 0, sep = "_")
# copy of input data
data <- father
# column names
cols <- names(father)
# for each level of the tree we get the children
for (l in 1:depth){
children <- get_children(l - 1, father, request$addons$verbose, filter, request$parameters$det, dfilter)
# vector of column names
cols <- append(cols, names(children))
cols <- subset(cols, !grepl("padre", cols))
# join the data by id of the father
if(!is.null(children)){
data <- merge(data, children, by.x = paste("Id", l - 1, sep = "_"), by.y = paste("padre", l, sep = "_"))
data <- data[,cols]
father <- children
}
}
return(data)
}
get_children <- function(depth, df, verbose, filter, det, dfilter = NULL){
data <- NULL
# variables of the filter
varfilter <- if(is.null(filter)) NULL else sapply(strsplit(unlist(filter), ":"), `[`, 1)
# values of the filter
valfilter <- if(is.null(filter)) NULL else sapply(strsplit(unlist(filter), ":"), `[`, 2)
# column name of the variable
varcol <- if(det > 0 ) paste(column_names[[API_version]][["variable.id"]][["es"]], depth, sep = "_") else paste(column_names[[API_version]][["variable.fk"]][["es"]], depth, sep = "_")
# column name of the value
valcol <- paste(column_names[[API_version]][["value.id"]][["es"]], depth, sep = "_")
# filter variables
v <- unique(df[[varcol]])
v <- if(sum(is.element(varfilter, v)) > 0) intersect(varfilter, v) else v
for( var in v){
s <- subset(df, df[[varcol]] == var)
# filter values
va <- unique(s[[valcol]])
va <- if(sum(is.element(valfilter, va)) > 0) intersect(valfilter, va) else va
for(val in va){
if(is.null(dfilter)){
tmp <- get_metadata_values(variable = var, value = val, verbose = verbose, validate = FALSE, det = det)
}else{
# we use the dataframe from the filter
tmp <- subset(dfilter, dfilter$level == depth + 1)
# filter values
rowsel <- sapply(tmp$fathers, function(x) is.element(val, x))
tmp <-subset(tmp, rowsel, !grepl("varval|level|fathers", names(dfilter), ignore.case = TRUE))
}
if(!is.null(tmp)){
# extract the father of the children
if(det > 0){
valfathers <- if(sum(grepl(column_names[[API_version]][["jerarquia"]][["es"]], names(tmp))) > 0) sapply(tmp[[column_names[[API_version]][["jerarquia"]][["es"]]]],`[[`, column_names[[API_version]][["id"]][["es"]]) else NA
}else{
valfathers <- if(sum(grepl(column_names[[API_version]][["jerarquia.fk"]][["es"]], names(tmp))) > 0) tmp[[column_names[[API_version]][["jerarquia.fk"]][["es"]]]] else NA
}
tmp$padre <- unlist(sapply(valfathers , function(x) intersect(val, x)))
# filter variables in the last level
v2 <- if(det > 0) unique(tmp[[column_names[[API_version]][["variable.id"]][["es"]]]]) else unique(tmp[[column_names[[API_version]][["variable.fk"]][["es"]]]])
v2 <- if(sum(is.element(varfilter, v2)) > 0) intersect(varfilter, v2) else v2
if(det > 0){
tmp <-subset(tmp, tmp[[column_names[[API_version]][["variable.id"]][["es"]]]] %in% v2)
}else{
tmp <-subset(tmp, tmp[[column_names[[API_version]][["variable.fk"]][["es"]]]] %in% v2)
}
names(tmp) <- paste(names(tmp), depth + 1, sep = "_")
data <- rbind(data, tmp)
}
}
}
# filter variables in the last level
varcol_new <- if(det > 0) paste(column_names[[API_version]][["variable.id"]][["es"]], depth + 1, sep = "_") else paste(column_names[[API_version]][["variable.fk"]][["es"]], depth + 1, sep = "_")
v3 <- unique(data[[varcol_new]])
v3 <- if(sum(is.element(varfilter, v3)) > 0) intersect(varfilter, v3) else v3
data <-subset(data, data[[varcol_new]] %in% v3)
return(data)
}
# Get url filter
get_addons_filter <- function(request){
val <- request$addons[["filter"]]
lval <- NULL
if(!is.null(val)){
lval <- build_filter(val, request$definition, request$addons, request$check$addons$filter, det = request$parameters$det)
}
return(lval)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.