From b92d3afd0efcf09d6890ebb171a3b287a7e421b6 Mon Sep 17 00:00:00 2001 From: byron Date: Wed, 20 Mar 2024 12:46:31 +0200 Subject: [PATCH] Added agency ID / URL mapping Also refactored to make LSP happy --- R/econdata_credentials.R | 11 +- R/get_metadata.R | 43 ++- R/login_helper.R | 2 +- R/read_database.R | 110 +++---- R/read_dataset.R | 135 +++++---- R/read_registry.R | 620 ++++++++++++++++++++++++--------------- R/read_release.R | 24 +- R/tidy_data.R | 101 ++++--- R/write_database.R | 3 +- R/write_dataset.R | 8 +- R/write_registry.R | 395 +++++++++++++++---------- R/write_release.R | 16 +- inst/settings.json | 24 +- 13 files changed, 899 insertions(+), 593 deletions(-) diff --git a/R/econdata_credentials.R b/R/econdata_credentials.R index ded87d6..88567c0 100644 --- a/R/econdata_credentials.R +++ b/R/econdata_credentials.R @@ -1,6 +1,6 @@ econdata_credentials <- function() { if (!requireNamespace("tcltk", quietly = TRUE)) { - stop("Package \"tcltk\" needed for this function to work. Please install it.", + stop("Package \"tcltk\" needed for this function to work.", call. = FALSE) } user <- pswd <- NULL # Need to add global bindings for variables @@ -28,9 +28,12 @@ econdata_credentials <- function() { } submit.but <- tcltk::tkbutton(tt, text = "submit", command = submit) - tcltk::tkgrid(tcltk::tklabel(tt, text = "Enter User Details"), columnspan = 2) - tcltk::tkgrid(tcltk::tklabel(tt, text = "Username"), user.entry, pady = 10, padx = 10) - tcltk::tkgrid(tcltk::tklabel(tt, text = "Password"), pswd.entry, pady = 10, padx = 10) + tcltk::tkgrid(tcltk::tklabel(tt, text = "Enter User Details"), + columnspan = 2) + tcltk::tkgrid(tcltk::tklabel(tt, text = "Username"), + user.entry, pady = 10, padx = 10) + tcltk::tkgrid(tcltk::tklabel(tt, text = "Password"), + pswd.entry, pady = 10, padx = 10) tcltk::tkgrid(submit.but, reset.but, pady = 10, padx = 50) tcltk::tkwait.window(tt) diff --git a/R/get_metadata.R b/R/get_metadata.R index a9ba8ae..9094475 100644 --- a/R/get_metadata.R +++ b/R/get_metadata.R @@ -1,7 +1,8 @@ get_metadata <- function(x) { env <- fromJSON(system.file("settings.json", package = "econdatar")) - # Fetch data structure definition (metadata) --- + + # Fetch data structure definition (metadata) ---- attrs <- attr(x, "metadata") provision_agreement_ref <- paste(attrs[["provision-agreement"]][[2]]$agencyid, @@ -12,49 +13,59 @@ get_metadata <- function(x) { path = paste(c(env$registry$path, "provisionagreements", provision_agreement_ref), collapse = "/"), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, type = "application/json", encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") - provision_agreement <- data_message[[2]]$structures[["provision-agreements"]][[1]] + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") + provision_agreement <- + data_message[[2]]$structures[["provision-agreements"]][[1]] dataflow_ref <- paste(provision_agreement[[2]][["dataflow"]][[2]]$agencyid, provision_agreement[[2]][["dataflow"]][[2]]$id, provision_agreement[[2]][["dataflow"]][[2]]$version, - sep = "-") + sep = "-") response <- GET(env$registry$url, path = paste(c(env$registry$path, "dataflows", dataflow_ref), collapse = "/"), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, type = "application/json", encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") dataflow <- data_message[[2]]$structures[["dataflows"]][[1]] data_structure_ref <- paste(dataflow[[2]][["data-structure"]][[2]]$agencyid, dataflow[[2]][["data-structure"]][[2]]$id, dataflow[[2]][["data-structure"]][[2]]$version, - sep = "-") + sep = "-") response <- GET(env$registry$url, path = paste(c(env$registry$path, "datastructures", data_structure_ref), collapse = "/"), query = list(relations = "references"), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, type = "application/json", encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") data_structure <- data_message[[2]]$structures[["data-structures"]][[1]][[2]] concept_schemes <- data_message[[2]]$structures[["concept-schemes"]] codelists <- data_message[[2]]$structures[["codelists"]] - # Compile metadata --- + # Compile metadata ---- concepts <- list() for (component in data_structure$components) { @@ -65,8 +76,8 @@ get_metadata <- function(x) { codelist = NULL) for (concept_scheme in concept_schemes) { if (id$agencyid == concept_scheme[[2]]$agencyid && - id$parentid == concept_scheme[[2]]$id && - id$parentversion == concept_scheme[[2]]$version) { + id$parentid == concept_scheme[[2]]$id && + id$parentversion == concept_scheme[[2]]$version) { for (concept in concept_scheme[[2]]$concepts) { if (id$id == concept[[2]]$id) { concepts[[id$id]]$concept <- concept[[2]] @@ -77,8 +88,8 @@ get_metadata <- function(x) { if (is.list(repr)) { for (codelist in codelists) { if (repr[[2]]$agencyid == codelist[[2]]$agencyid && - repr[[2]]$id == codelist[[2]]$id && - repr[[2]]$version == codelist[[2]]$version) { + repr[[2]]$id == codelist[[2]]$id && + repr[[2]]$version == codelist[[2]]$version) { concepts[[id$id]]$codelist <- codelist[[2]] } } @@ -91,7 +102,7 @@ get_metadata <- function(x) { data_structure_ref <- dataflow[[2]][["data-structure"]][[2]] |> (function(x) do.call(sprintf, c("%s:%s(%s)", x)))(x = _) metadata <- list(data_provider_ref = data_provider_ref, - dataflow_ref= dataflow_ref, + dataflow_ref = dataflow_ref, data_structure_ref = data_structure_ref, concepts = concepts) return(metadata) diff --git a/R/login_helper.R b/R/login_helper.R index 476416b..07512ef 100644 --- a/R/login_helper.R +++ b/R/login_helper.R @@ -21,7 +21,7 @@ login_helper <- function(credentials, login_url) { cookie_jar <- cookies(response) domain <- substr(login_url, 9, nchar(login_url)) session <- cookie_jar[which(cookie_jar[, 1] == paste0("#HttpOnly_", domain) & - cookie_jar[, 6] == "ring-session"), ] + cookie_jar[, 6] == "ring-session"), ] assign("econdata_session", as.character(session), envir = .pkgenv) lockBinding("econdata_session", .pkgenv) } diff --git a/R/read_database.R b/R/read_database.R index 7a19220..a8516d6 100644 --- a/R/read_database.R +++ b/R/read_database.R @@ -1,9 +1,8 @@ read_database <- function(id, include_series = FALSE, tidy = FALSE, ...) { - # Parameters --- + # Parameters ---- - env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) if (!is.null(params$username) && !is.null(params$password)) { credentials <- paste(params$username, params$password, sep = ";") @@ -21,8 +20,11 @@ read_database <- function(id, include_series = FALSE, tidy = FALSE, ...) { version <- "latest" } + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[agencyid]] - # Fetch data set(s) --- + + # Fetch data set(s) ---- message(paste("\nFetching data set(s) -", id, "\n")) if (!is.null(params$file)) { @@ -39,66 +41,72 @@ read_database <- function(id, include_series = FALSE, tidy = FALSE, ...) { response <- GET(env$repository$url, path = c(env$repository$path, "/datasets"), query = query_params, - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = get("econdata_session", + envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") } - # Process data set(s) --- + # Process data set(s) ---- database <- lapply(data_message[[2]][["data-sets"]], function(raw_data_set) { - if (!is.null(params$file)) { - tmp_data_set <- raw_data_set[[2]] - } else { - if(include_series) { - data_set_ref <- paste(raw_data_set[[2]]$agencyid, - raw_data_set[[2]]$id, - raw_data_set[[2]]$version, - sep = "-") - query_params <- list() - if (!is.null(params$series_key)) { - query_params[["series-key"]] <- params$series_key - } - response <- GET(env$repository$url, - path = paste(env$repository$path, - "datasets", - data_set_ref, - "series", sep = "/"), - query = query_params, - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), - accept("application/vnd.sdmx-codera.data+json")) - if (response$status_code == 200) { - message("Processing data set: ", data_set_ref, "\n") - } else { - stop(content(response, type = "application/json", encoding = "UTF-8")) - } - data_message <- content(response, type = "application/json", encoding = "UTF-8") - tmp_data_set <- data_message[[2]][["data-sets"]][[1]][[2]] + if (!is.null(params$file)) { + tmp_data_set <- raw_data_set[[2]] + } else { + if (include_series) { + data_set_ref <- paste(raw_data_set[[2]]$agencyid, + raw_data_set[[2]]$id, + raw_data_set[[2]]$version, + sep = "-") + query_params <- list() + if (!is.null(params$series_key)) { + query_params[["series-key"]] <- params$series_key + } + response <- GET(env$repository$url, + path = paste(env$repository$path, + "datasets", + data_set_ref, + "series", sep = "/"), + query = query_params, + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), + accept("application/vnd.sdmx-codera.data+json")) + if (response$status_code == 200) { + message("Processing data set: ", data_set_ref, "\n") } else { - tmp_data_set <- raw_data_set[[2]] + stop(content(response, type = "application/json", encoding = "UTF-8")) } - } - data_set <- list() - series_names <- sapply(tmp_data_set$series, function(raw_series) { - return(raw_series[["series-key"]]) - }) - data_set$series <- lapply(tmp_data_set$series, function(raw_series) { - raw_series[["series-key"]] <- NULL - raw_series[["obs"]] <- NULL - series <- data.frame() - attr(series, "metadata") <- raw_series - return(series) - }) - names(data_set$series) <- series_names - tmp_data_set$series <- NULL - attr(data_set, "metadata") <- tmp_data_set - class(data_set) <- "eds_dataset" - return(data_set) + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") + tmp_data_set <- data_message[[2]][["data-sets"]][[1]][[2]] + } else { + tmp_data_set <- raw_data_set[[2]] + } + } + data_set <- list() + series_names <- sapply(tmp_data_set$series, function(raw_series) { + return(raw_series[["series-key"]]) + }) + data_set$series <- lapply(tmp_data_set$series, function(raw_series) { + raw_series[["series-key"]] <- NULL + raw_series[["obs"]] <- NULL + series <- data.frame() + attr(series, "metadata") <- raw_series + return(series) }) + names(data_set$series) <- series_names + tmp_data_set$series <- NULL + attr(data_set, "metadata") <- tmp_data_set + class(data_set) <- "eds_dataset" + return(data_set) + }) class(database) <- "eds_database" if (tidy) { tidy_data(database, ...) diff --git a/R/read_dataset.R b/R/read_dataset.R index 3ca76cd..de9acb0 100644 --- a/R/read_dataset.R +++ b/R/read_dataset.R @@ -1,9 +1,8 @@ read_dataset <- function(id, tidy = FALSE, ...) { - # Parameters --- + # Parameters ---- - env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) if (!is.null(params$username) && !is.null(params$password)) { credentials <- paste(params$username, params$password, sep = ";") @@ -21,8 +20,11 @@ read_dataset <- function(id, tidy = FALSE, ...) { version <- "latest" } + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[agencyid]] - # Fetch data set(s) --- + + # Fetch data set(s) ---- message(paste("\nFetching data set(s) -", id, "\n")) if (!is.null(params$file)) { @@ -39,16 +41,19 @@ read_dataset <- function(id, tidy = FALSE, ...) { response <- GET(env$repository$url, path = c(env$repository$path, "/datasets"), query = query_params, - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") } - # Process data sets --- + # Process data sets ---- database <- lapply(data_message[[2]][["data-sets"]], function(raw_data_set) { if (!is.null(params$file)) { @@ -66,32 +71,32 @@ read_dataset <- function(id, tidy = FALSE, ...) { tmp_data_set <- get_data(env, data_set_ref, query_params) } series_names <- sapply(tmp_data_set$series, function(raw_series) { - return(raw_series[["series-key"]]) - }) + return(raw_series[["series-key"]]) + }) data_set <- lapply(tmp_data_set$series, function(raw_series) { - obs <- raw_series$obs - raw_series[["series-key"]] <- NULL - raw_series[["obs"]] <- NULL - if (length(obs) == 0) { - series <- data.frame() - attr(series, "metadata") <- raw_series - return(series) - } else { - fields <- lapply(obs, function(x) names(x)) |> - unlist() |> - unique() - series <- lapply(fields, function(n) { - sapply(obs, function(x) { - ifelse(is.null(x[[n]]), NA, x[[n]]) - }) - }) |> - as.data.frame(col.names = fields) - rownames(series) <- series$TIME_PERIOD - series$TIME_PERIOD <- NULL - attr(series, "metadata") <- raw_series - return(series) - } - }) + obs <- raw_series$obs + raw_series[["series-key"]] <- NULL + raw_series[["obs"]] <- NULL + if (length(obs) == 0) { + series <- data.frame() + attr(series, "metadata") <- raw_series + return(series) + } else { + fields <- lapply(obs, function(x) names(x)) |> + unlist() |> + unique() + series <- lapply(fields, function(n) { + sapply(obs, function(x) { + ifelse(is.null(x[[n]]), NA, x[[n]]) + }) + }) |> + as.data.frame(col.names = fields) + rownames(series) <- series$TIME_PERIOD + series$TIME_PERIOD <- NULL + attr(series, "metadata") <- raw_series + return(series) + } + }) names(data_set) <- series_names tmp_data_set$series <- NULL attr(data_set, "metadata") <- tmp_data_set @@ -122,46 +127,51 @@ read_econdata <- function(id, tidy = FALSE, ...) { get_release <- function(env, ref, candidate_release) { if (is.null(candidate_release)) { - candidate_release = "latest" + candidate_release <- "latest" } if (candidate_release != "unreleased") { final_release <- tryCatch({ - strftime(cadidate_release, "%Y-%m-%dT%H:%M:%S") + strftime(candidate_release, "%Y-%m-%dT%H:%M:%S") }, error = function(e) { response <- GET(env$repository$url, path = paste(env$repository$path, "datasets", ref, "release", sep = "/"), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept_json()) if (response$status_code != 200) { stop(content(response, type = "application/json", encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") if (candidate_release == "latest") { release <- head(data_message$releases, n = 1)[[1]]$release |> - as.POSIXct(x, tz = "UTC", format = "%Y-%m-%dT%H:%M:%SZ") + as.POSIXct(tz = "UTC", format = "%Y-%m-%dT%H:%M:%SZ") attr(release, "tzone") <- "Africa/Johannesburg" return(strftime(release, "%Y-%m-%dT%H:%M:%S")) } else { release <- sapply(data_message$releases, function(release) { - if(candidate_release == release$description) { - release$release - } else { - NA - } - }) |> - na.omit() |> - head(n = 1) + if (candidate_release == release$description) { + release$release + } else { + NA + } + }) |> + na.omit() |> + head(n = 1) if (length(release) != 0) { - release <- as.POSIXct(release, tz = "UTC", format = "%Y-%m-%dT%H:%M:%SZ") + release <- as.POSIXct(release, + tz = "UTC", + format = "%Y-%m-%dT%H:%M:%SZ") attr(release, "tzone") <- "Africa/Johannesburg" return(strftime(release, "%Y-%m-%dT%H:%M:%S")) } else { message("Release not found, returning latest release instead.") release <- tail(data_message$releases, n = 1)[[1]]$release |> - as.POSIXct(x, tz = "UTC", format = "%Y-%m-%dT%H:%M:%SZ") + as.POSIXct(tz = "UTC", format = "%Y-%m-%dT%H:%M:%SZ") attr(release, "tzone") <- "Africa/Johannesburg" return(strftime(release, "%Y-%m-%dT%H:%M:%S")) } @@ -180,7 +190,8 @@ get_data <- function(env, ref, params, links = NULL, data_set = NULL) { "datasets", ref, sep = "/"), query = params, - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code == 200) { message("Processing data set: ", ref, "\n") @@ -188,7 +199,9 @@ get_data <- function(env, ref, params, links = NULL, data_set = NULL) { stop(content(response, type = "application/json", encoding = "UTF-8")) } links <- unlist(strsplit(response$headers$link, ",")) - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") data_set <- data_message[[2]][["data-sets"]][[1]][[2]] if (!any(grepl("rel=next", links))) { return(data_set) @@ -202,19 +215,27 @@ get_data <- function(env, ref, params, links = NULL, data_set = NULL) { URLdecode() |> strsplit("\\?") |> unlist() - response <- GET(env$repository$url, - path = link_parts[1], - query = strsplit(unlist(strsplit(link_parts[2], "&")), "=") |> - lapply(function(x) { y <- list(); y[[x[1]]] <- x[2]; return(y) }) |> - unlist(recursive = FALSE), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), - accept("application/vnd.sdmx-codera.data+json")) + response <- + GET(env$repository$url, + path = link_parts[1], + query = strsplit(unlist(strsplit(link_parts[2], "&")), "=") |> + lapply(function(x) { + y <- list() + y[[x[1]]] <- x[2] + return(y) + }) |> + unlist(recursive = FALSE), + set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, type = "application/json", encoding = "UTF-8")) } links <- unlist(strsplit(response$headers$link, ",")) - data_message <- content(response, type = "application/json", encoding = "UTF-8") - data_set$series <- c(data_set$series, data_message[[2]][["data-sets"]][[1]][[2]]$series) + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") + data_set$series <- c(data_set$series, + data_message[[2]][["data-sets"]][[1]][[2]]$series) if (!any(grepl("rel=next", links))) { return(data_set) } else { diff --git a/R/read_registry.R b/R/read_registry.R index 30d3333..30a03ad 100644 --- a/R/read_registry.R +++ b/R/read_registry.R @@ -1,11 +1,9 @@ read_registry <- function(structure, tidy = FALSE, ...) { - # Parameters --- + # Parameters ---- - env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) - params$env <- env if (is.null(params$id) && is.null(params$file)) { stop("At least one of either: 'id' or 'file' parameter required.") } @@ -30,8 +28,12 @@ read_registry <- function(structure, tidy = FALSE, ...) { version <- "latest" } + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[agencyid]] + params$env <- env + - # Fetch structure(s) --- + # Fetch structure(s) ---- if (!exists("econdata_session", envir = .pkgenv)) { login_helper(credentials, env$repository$url) @@ -41,18 +43,26 @@ read_registry <- function(structure, tidy = FALSE, ...) { versions <- paste(version, collapse = ",") structure_data <- switch(structure, - "category-scheme" = read_category_schemes(agencyids, ids, versions, params), - "codelist" = read_codelists(agencyids, ids, versions, params), - "concept-scheme" = read_concept_schemes(agencyids, ids, versions, params), - "dataflow" = read_dataflow(agencyids, ids, versions, params), - "data-structure" = read_data_structures(agencyids, ids, versions, params), - "memberlist" = read_memberlist(agencyids, ids, versions, params), - "consumption-agreement" = read_cons_agreement(agencyids, ids, versions, params), - "provision-agreement" = read_prov_agreement(agencyids, ids, versions, params), + "category-scheme" = + read_category_schemes(agencyids, ids, versions, params), + "codelist" = + read_codelists(agencyids, ids, versions, params), + "concept-scheme" = + read_concept_schemes(agencyids, ids, versions, params), + "dataflow" = + read_dataflow(agencyids, ids, versions, params), + "data-structure" = + read_data_structures(agencyids, ids, versions, params), + "memberlist" = + read_memberlist(agencyids, ids, versions, params), + "consumption-agreement" = + read_cons_agreement(agencyids, ids, versions, params), + "provision-agreement" = + read_prov_agreement(agencyids, ids, versions, params), stop("Specified structure, ", structure, ", is not supported.")) - # Process structures --- + # Process structures ---- structures <- lapply(structure_data, function(x) { switch(structure, @@ -75,28 +85,41 @@ read_registry <- function(structure, tidy = FALSE, ...) { -# Category schemes --- +# Category schemes ---- read_category_schemes <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching category scheme(s) -", paste(ids, collapse = ", "), "\n")) + message(paste("\nFetching category scheme(s) -", + paste(ids, collapse = ", "), "\n")) response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "categoryschemes"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + path = paste(c(params$env$registry$path, "categoryschemes"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") category_schemes <- data_message[[2]][["structures"]][["category-schemes"]] return(category_schemes) } else { message(paste("\nFetching category scheme(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - categories <- read_ods(path = params$file, sheet = "categories", na = na, as_tibble = FALSE) - category_scheme <- as.list(read_ods(path = params$file, sheet = "category_scheme", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + categories <- read_ods(path = params$file, + sheet = "categories", + na = na, + as_tibble = FALSE) + category_scheme <- as.list(read_ods(path = params$file, + sheet = "category_scheme", + na = na, + as_tibble = FALSE)) category_scheme$categories <- categories return(list(category_scheme)) } @@ -104,7 +127,7 @@ read_category_schemes <- function(agencyids, ids, versions, params) { process_category_scheme <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -120,21 +143,21 @@ process_category_scheme <- function(structure, params) { name = structure[[2]]$name[[2]], description = description) categories <- lapply(structure[[2]]$categories, function(category) { - description <- if (is.null(category[[2]]$description[[2]])) { - NA - } else { - category[[2]]$description[[2]] - } - lapply(category[[2]]$references, function(reference) { - list(id = category[[2]]$id, - name = category[[2]]$name[[2]], - description = description, - reference_agencyid = reference[[2]]$agencyid, - reference_id = reference[[2]]$id, - reference_version = reference[[2]]$version) - }) |> - do.call(rbind.data.frame, args = _) + description <- if (is.null(category[[2]]$description[[2]])) { + NA + } else { + category[[2]]$description[[2]] + } + lapply(category[[2]]$references, function(reference) { + list(id = category[[2]]$id, + name = category[[2]]$name[[2]], + description = description, + reference_agencyid = reference[[2]]$agencyid, + reference_id = reference[[2]]$id, + reference_version = reference[[2]]$version) }) |> + do.call(rbind.data.frame, args = _) + }) |> do.call(rbind.data.frame, args = _) category_scheme$categories <- categories class(category_scheme) <- c(class(category_scheme), "eds_category_scheme") @@ -148,29 +171,42 @@ process_category_scheme <- function(structure, params) { -# Codelists --- +# Codelists ---- read_codelists <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching codelist(s) -", paste(ids, collapse = ", "), "\n")) + message(paste("\nFetching codelist(s) -", + paste(ids, collapse = ", "), "\n")) response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "codelists"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + path = paste(c(params$env$registry$path, "codelists"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") codelists <- data_message[[2]][["structures"]][["codelists"]] return(codelists) } else { message(paste("\nFetching codelist(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - codes <- read_ods(path = params$file, sheet = "codes", na = na, as_tibble = FALSE) - codelist <- as.list(read_ods(path = params$file, sheet = "codelist", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + codes <- read_ods(path = params$file, + sheet = "codes", + na = na, + as_tibble = FALSE) + codelist <- as.list(read_ods(path = params$file, + sheet = "codelist", + na = na, + as_tibble = FALSE)) codelist$codes <- codes return(list(codelist)) } @@ -178,7 +214,7 @@ read_codelists <- function(agencyids, ids, versions, params) { process_codelist <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -194,15 +230,15 @@ process_codelist <- function(structure, params) { name = structure[[2]]$name[[2]], description = description) codes <- lapply(structure[[2]]$codes, function(code) { - description <- if (is.null(code[[2]]$description[[2]])) { - NA - } else { - code[[2]]$description[[2]] - } - list(id = code[[2]]$id, - name = code[[2]]$name[[2]], - description = description) - }) |> + description <- if (is.null(code[[2]]$description[[2]])) { + NA + } else { + code[[2]]$description[[2]] + } + list(id = code[[2]]$id, + name = code[[2]]$name[[2]], + description = description) + }) |> do.call(rbind.data.frame, args = _) codelist$codes <- codes class(codelist) <- c(class(codelist), "eds_codelist") @@ -216,28 +252,41 @@ process_codelist <- function(structure, params) { -# Concept schemes --- +# Concept schemes ---- read_concept_schemes <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching concept scheme(s) -", paste(ids, collapse = ", "), "\n")) + message(paste("\nFetching concept scheme(s) -", + paste(ids, collapse = ", "), "\n")) response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "conceptschemes"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + path = paste(c(params$env$registry$path, "conceptschemes"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") concept_schemes <- data_message[[2]][["structures"]][["concept-schemes"]] return(concept_schemes) } else { message(paste("\nFetching concept scheme(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - concepts <- read_ods(path = params$file, sheet = "concepts", na = na, as_tibble = FALSE) - concept_scheme <- as.list(read_ods(path = params$file, sheet = "concept_scheme", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + concepts <- read_ods(path = params$file, + sheet = "concepts", + na = na, + as_tibble = FALSE) + concept_scheme <- as.list(read_ods(path = params$file, + sheet = "concept_scheme", + na = na, + as_tibble = FALSE)) concept_scheme$concepts <- concepts return(list(concept_scheme)) } @@ -245,7 +294,7 @@ read_concept_schemes <- function(agencyids, ids, versions, params) { process_concept_scheme <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -261,28 +310,28 @@ process_concept_scheme <- function(structure, params) { name = structure[[2]]$name[[2]], description = description) concepts <- lapply(structure[[2]]$concepts, function(concept) { - description <- if (is.null(concept[[2]]$description[[2]])) { - NA - } else { - concept[[2]]$description[[2]] - } - representation <- if (is.list(concept[[2]][["core-representation"]])) { - codelist_ref <- concept[[2]][["core-representation"]][[2]] - list(representation = "codelist", - codelist_agencyid = codelist_ref$agencyid, - codelist_id = codelist_ref$id, - codelist_version = codelist_ref$version) - } else { - list(representation = concept[[2]][["core-representation"]], - codelist_agencyid = NA, - codelist_id = NA, - codelist_version = NA) - } - c(list(id = concept[[2]]$id, - name = concept[[2]]$name[[2]], - description = description), - representation) - }) |> + description <- if (is.null(concept[[2]]$description[[2]])) { + NA + } else { + concept[[2]]$description[[2]] + } + representation <- if (is.list(concept[[2]][["core-representation"]])) { + codelist_ref <- concept[[2]][["core-representation"]][[2]] + list(representation = "codelist", + codelist_agencyid = codelist_ref$agencyid, + codelist_id = codelist_ref$id, + codelist_version = codelist_ref$version) + } else { + list(representation = concept[[2]][["core-representation"]], + codelist_agencyid = NA, + codelist_id = NA, + codelist_version = NA) + } + c(list(id = concept[[2]]$id, + name = concept[[2]]$name[[2]], + description = description), + representation) + }) |> do.call(rbind.data.frame, args = _) concept_scheme$concepts <- concepts class(concept_scheme) <- c(class(concept_scheme), "eds_concept_scheme") @@ -296,29 +345,42 @@ process_concept_scheme <- function(structure, params) { -# Dataflow --- +# Dataflow ---- read_dataflow <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching dataflow(s) -", paste(ids, collapse = ", "), "\n")) + message(paste("\nFetching dataflow(s) -", + paste(ids, collapse = ", "), "\n")) response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "dataflows"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + path = paste(c(params$env$registry$path, "dataflows"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") dataflows <- data_message[[2]][["structures"]][["dataflows"]] return(dataflows) } else { message(paste("\nFetching dataflow(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - data_structure <- as.list(read_ods(path = params$file, sheet = "data_structure", na = na, as_tibble = FALSE)) - dataflow <- as.list(read_ods(path = params$file, sheet = "dataflow", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + data_structure <- as.list(read_ods(path = params$file, + sheet = "data_structure", + na = na, + as_tibble = FALSE)) + dataflow <- as.list(read_ods(path = params$file, + sheet = "dataflow", + na = na, + as_tibble = FALSE)) dataflow$data_structure <- data_structure return(list(dataflow)) } @@ -326,7 +388,7 @@ read_dataflow <- function(agencyids, ids, versions, params) { process_dataflow <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -341,9 +403,10 @@ process_dataflow <- function(structure, params) { version = structure[[2]]$version, name = structure[[2]]$name[[2]], description = description) - data_structure <- list(agencyid = structure[[2]][["data-structure"]][[2]]$agencyid, - id = structure[[2]][["data-structure"]][[2]]$id, - version = structure[[2]][["data-structure"]][[2]]$version) + data_structure <- + list(agencyid = structure[[2]][["data-structure"]][[2]]$agencyid, + id = structure[[2]][["data-structure"]][[2]]$id, + version = structure[[2]][["data-structure"]][[2]]$version) dataflow$data_structure <- data_structure class(dataflow) <- c(class(dataflow), "eds_dataflow") return(dataflow) @@ -355,31 +418,53 @@ process_dataflow <- function(structure, params) { } -# Data structures --- +# Data structures ---- read_data_structures <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching data structure(s) -", paste(ids, collapse = ", "), "\n")) + message(paste("\nFetching data structure(s) -", + paste(ids, collapse = ", "), "\n")) response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "datastructures"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + path = paste(c(params$env$registry$path, "datastructures"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") data_structures <- data_message[[2]][["structures"]][["data-structures"]] return(data_structures) } else { message(paste("\nFetching codelist(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - dimensions <- read_ods(path = params$file, sheet = "dimensions", na = na, as_tibble = FALSE) - attrs <- read_ods(path = params$file, sheet = "attributes", na = na, as_tibble = FALSE) - time_dimension <- read_ods(path = params$file, sheet = "time_dimension", na = na, as_tibble = FALSE) - primary_measure <- read_ods(path = params$file, sheet = "primary_measure", na = na, as_tibble = FALSE) - data_structure <- as.list(read_ods(path = params$file, sheet = "data_structure", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + dimensions <- read_ods(path = params$file, + sheet = "dimensions", + na = na, + as_tibble = FALSE) + attrs <- read_ods(path = params$file, + sheet = "attributes", + na = na, + as_tibble = FALSE) + time_dimension <- read_ods(path = params$file, + sheet = "time_dimension", + na = na, + as_tibble = FALSE) + primary_measure <- read_ods(path = params$file, + sheet = "primary_measure", + na = na, + as_tibble = FALSE) + data_structure <- as.list(read_ods(path = params$file, + sheet = "data_structure", + na = na, + as_tibble = FALSE)) data_structure$dimensions <- dimensions data_structure$attributes <- attrs data_structure$time_dimension <- time_dimension @@ -390,7 +475,7 @@ read_data_structures <- function(agencyids, ids, versions, params) { process_data_structure <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -406,13 +491,14 @@ process_data_structure <- function(structure, params) { name = structure[[2]]$name[[2]], description = description) dimensions <- lapply(structure[[2]]$components, function(component) { - if (component[[1]] == "#sdmx.infomodel.datastructure.Dimension") { - concept_ref <- component[[2]][["concept-identity"]][[2]] - concept <- list(concept_agencyid = concept_ref$agencyid, - concept_parentid = concept_ref$parentid, - concept_parentversion = concept_ref$parentversion, - concept_id = concept_ref$id) - representation <- if (is.list(component[[2]][["local-representation"]])) { + if (component[[1]] == "#sdmx.infomodel.datastructure.Dimension") { + concept_ref <- component[[2]][["concept-identity"]][[2]] + concept <- list(concept_agencyid = concept_ref$agencyid, + concept_parentid = concept_ref$parentid, + concept_parentversion = concept_ref$parentversion, + concept_id = concept_ref$id) + representation <- + if (is.list(component[[2]][["local-representation"]])) { codelist_ref <- component[[2]][["local-representation"]][[2]] list(representation = "codelist", codelist_agencyid = codelist_ref$agencyid, @@ -424,23 +510,24 @@ process_data_structure <- function(structure, params) { codelist_id = NA, codelist_version = NA) } - c(list(id = component[[2]]$id, - position = component[[2]]$position), - concept, - representation) - } - }) |> + c(list(id = component[[2]]$id, + position = component[[2]]$position), + concept, + representation) + } + }) |> do.call(rbind.data.frame, args = _) - dimensions_ordered <- dimensions[order(dimensions$position),] + dimensions_ordered <- dimensions[order(dimensions$position), ] rownames(dimensions_ordered) <- NULL attrs <- lapply(structure[[2]]$components, function(component) { - if (component[[1]] == "#sdmx.infomodel.datastructure.Attribute") { - concept_ref <- component[[2]][["concept-identity"]][[2]] - concept <- list(concept_agencyid = concept_ref$agencyid, - concept_parentid = concept_ref$parentid, - concept_parentversion = concept_ref$parentversion, - concept_id = concept_ref$id) - representation <- if (is.list(component[[2]][["local-representation"]])) { + if (component[[1]] == "#sdmx.infomodel.datastructure.Attribute") { + concept_ref <- component[[2]][["concept-identity"]][[2]] + concept <- list(concept_agencyid = concept_ref$agencyid, + concept_parentid = concept_ref$parentid, + concept_parentversion = concept_ref$parentversion, + concept_id = concept_ref$id) + representation <- + if (is.list(component[[2]][["local-representation"]])) { codelist_ref <- component[[2]][["local-representation"]][[2]] list(representation = "codelist", codelist_agencyid = codelist_ref$agencyid, @@ -452,44 +539,45 @@ process_data_structure <- function(structure, params) { codelist_id = NA, codelist_version = NA) } - - c(list(id = component[[2]]$id, - level = component[[2]][["attachment-level"]], - mandatory = component[[2]][["assignment-mandatory"]]), - concept, - representation) - } - }) |> + c(list(id = component[[2]]$id, + level = component[[2]][["attachment-level"]], + mandatory = component[[2]][["assignment-mandatory"]]), + concept, + representation) + } + }) |> do.call(rbind.data.frame, args = _) - attrs_ordered <- attrs[order(attrs$level),] + attrs_ordered <- attrs[order(attrs$level), ] rownames(attrs_ordered) <- NULL time_dimension <- lapply(structure[[2]]$components, function(component) { - if (component[[1]] == "#sdmx.infomodel.datastructure.TimeDimension") { - concept_ref <- component[[2]][["concept-identity"]][[2]] - concept <- list(concept_agencyid = concept_ref$agencyid, - concept_parentid = concept_ref$parentid, - concept_parentversion = concept_ref$parentversion, - concept_id = concept_ref$id) - representation <- list(representation = component[[2]][["local-representation"]]) - c(list(id = component[[2]]$id), - concept, - representation) - } - }) |> + if (component[[1]] == "#sdmx.infomodel.datastructure.TimeDimension") { + concept_ref <- component[[2]][["concept-identity"]][[2]] + concept <- list(concept_agencyid = concept_ref$agencyid, + concept_parentid = concept_ref$parentid, + concept_parentversion = concept_ref$parentversion, + concept_id = concept_ref$id) + representation <- + list(representation = component[[2]][["local-representation"]]) + c(list(id = component[[2]]$id), + concept, + representation) + } + }) |> do.call(rbind.data.frame, args = _) primary_measure <- lapply(structure[[2]]$components, function(component) { - if (component[[1]] == "#sdmx.infomodel.datastructure.PrimaryMeasure") { - concept_ref <- component[[2]][["concept-identity"]][[2]] - concept <- list(concept_agencyid = concept_ref$agencyid, - concept_parentid = concept_ref$parentid, - concept_parentversion = concept_ref$parentversion, - concept_id = concept_ref$id) - representation <- list(representation = component[[2]][["local-representation"]]) - c(list(id = component[[2]]$id), - concept, - representation) - } - }) |> + if (component[[1]] == "#sdmx.infomodel.datastructure.PrimaryMeasure") { + concept_ref <- component[[2]][["concept-identity"]][[2]] + concept <- list(concept_agencyid = concept_ref$agencyid, + concept_parentid = concept_ref$parentid, + concept_parentversion = concept_ref$parentversion, + concept_id = concept_ref$id) + representation <- + list(representation = component[[2]][["local-representation"]]) + c(list(id = component[[2]]$id), + concept, + representation) + } + }) |> do.call(rbind.data.frame, args = _) data_structure$dimensions <- dimensions_ordered data_structure$attributes <- attrs_ordered @@ -506,28 +594,41 @@ process_data_structure <- function(structure, params) { -# Memberlist --- +# Memberlist ---- read_memberlist <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching memberlist(s) -", paste(ids, collapse = ", "), "\n")) + message(paste("\nFetching memberlist(s) -", + paste(ids, collapse = ", "), "\n")) response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "memberlists"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + path = paste(c(params$env$registry$path, "memberlists"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") + data_message <- content(response, + type = "application/json", + encoding = "UTF-8") memberlists <- data_message[[2]][["structures"]][["memberlists"]] return(memberlists) } else { message(paste("\nFetching memberlist(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - members <- read_ods(path = params$file, sheet = "members", na = na, as_tibble = FALSE) - memberlist <- as.list(read_ods(path = params$file, sheet = "memberlist", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + members <- read_ods(path = params$file, + sheet = "members", + na = na, + as_tibble = FALSE) + memberlist <- as.list(read_ods(path = params$file, + sheet = "memberlist", + na = na, + as_tibble = FALSE)) memberlist$members <- members return(list(memberlist)) } @@ -535,7 +636,7 @@ read_memberlist <- function(agencyids, ids, versions, params) { process_memberlist <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -551,32 +652,32 @@ process_memberlist <- function(structure, params) { name = structure[[2]]$name[[2]], description = description) members <- lapply(structure[[2]]$members, function(member) { - lapply(member[[2]]$memberships, function(membership) { - m <- list(id = member[[2]]$id, - email = member[[2]]$email, - firstname = member[[2]]$firstname, - lastname = member[[2]]$lastname, - annotations = toJSON(lapply(member[[2]]$annotations, unbox))) - if (membership[[1]] == "#sdmx.infomodel.base.DataConsumerRef") { - c(m, - list(membership_type = "data consumer", - membership_agencyid = membership[[2]]$agencyid, - membership_parentid = membership[[2]]$parentid, - membership_parentversion = membership[[2]]$parentversion, - membership_id = membership[[2]]$id)) - } else if (membership[[1]] == "#sdmx.infomodel.base.DataProviderRef") { - c(m, - list(membership_type = "data provider", - membership_agencyid = membership[[2]]$agencyid, - membership_parentid = membership[[2]]$parentid, - membership_parentversion = membership[[2]]$parentversion, - membership_id = membership[[2]]$id)) - } else { - stop("Unable to parse reference type: ", membership[[1]]) - } - }) |> - do.call(rbind.data.frame, args = _) + lapply(member[[2]]$memberships, function(membership) { + m <- list(id = member[[2]]$id, + email = member[[2]]$email, + firstname = member[[2]]$firstname, + lastname = member[[2]]$lastname, + annotations = toJSON(lapply(member[[2]]$annotations, unbox))) + if (membership[[1]] == "#sdmx.infomodel.base.DataConsumerRef") { + c(m, + list(membership_type = "data consumer", + membership_agencyid = membership[[2]]$agencyid, + membership_parentid = membership[[2]]$parentid, + membership_parentversion = membership[[2]]$parentversion, + membership_id = membership[[2]]$id)) + } else if (membership[[1]] == "#sdmx.infomodel.base.DataProviderRef") { + c(m, + list(membership_type = "data provider", + membership_agencyid = membership[[2]]$agencyid, + membership_parentid = membership[[2]]$parentid, + membership_parentversion = membership[[2]]$parentversion, + membership_id = membership[[2]]$id)) + } else { + stop("Unable to parse reference type: ", membership[[1]]) + } }) |> + do.call(rbind.data.frame, args = _) + }) |> do.call(rbind.data.frame, args = _) memberlist$members <- members class(memberlist) <- c(class(memberlist), "memberlist") @@ -590,30 +691,46 @@ process_memberlist <- function(structure, params) { -# Consumption agreement --- +# Consumption agreement ---- read_cons_agreement <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching consumption agreement(s) -", paste(ids, collapse = ", "), "\n")) - response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "consumptionagreements"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), - accept("application/vnd.sdmx-codera.data+json")) + message(paste("\nFetching consumption agreement(s) -", + paste(ids, collapse = ", "), "\n")) + response <- + GET(params$env$registry$url, + path = paste(c(params$env$registry$path, "consumptionagreements"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") - cons_agreements <- data_message[[2]][["structures"]][["consumption-agreements"]] + data_message <- + content(response, type = "application/json", encoding = "UTF-8") + cons_agreements <- + data_message[[2]][["structures"]][["consumption-agreements"]] return(cons_agreements) } else { message(paste("\nFetching consumption agreement(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - dataflow <- as.list(read_ods(path = params$file, sheet = "dataflow", na = na, as_tibble = FALSE)) - data_consumer <- as.list(read_ods(path = params$file, sheet = "data_consumer", na = na, as_tibble = FALSE)) - cons_agreement <- as.list(read_ods(path = params$file, sheet = "consumption_agreement", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + dataflow <- as.list(read_ods(path = params$file, + sheet = "dataflow", + na = na, + as_tibble = FALSE)) + data_consumer <- as.list(read_ods(path = params$file, + sheet = "data_consumer", + na = na, + as_tibble = FALSE)) + cons_agreement <- as.list(read_ods(path = params$file, + sheet = "consumption_agreement", + na = na, + as_tibble = FALSE)) cons_agreement$dataflow <- dataflow cons_agreement$data_consumer <- data_consumer return(list(cons_agreement)) @@ -622,7 +739,7 @@ read_cons_agreement <- function(agencyids, ids, versions, params) { process_cons_agreement <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -639,14 +756,16 @@ process_cons_agreement <- function(structure, params) { description = description) dataflow <- list(agencyid = structure[[2]][["dataflow"]][[2]]$agencyid, id = structure[[2]][["dataflow"]][[2]]$id, - version = structure[[2]][["dataflow"]][[2]]$version) - data_consumer <- list(agencyid = structure[[2]][["data-consumer"]][[2]]$agencyid, - parentid = structure[[2]][["data-consumer"]][[2]]$parentid, - parentversion = structure[[2]][["data-consumer"]][[2]]$parentversion, - id = structure[[2]][["data-consumer"]][[2]]$id) + version = structure[[2]][["dataflow"]][[2]]$version) + data_consumer <- + list(agencyid = structure[[2]][["data-consumer"]][[2]]$agencyid, + parentid = structure[[2]][["data-consumer"]][[2]]$parentid, + parentversion = structure[[2]][["data-consumer"]][[2]]$parentversion, + id = structure[[2]][["data-consumer"]][[2]]$id) cons_agreement$dataflow <- dataflow cons_agreement$data_consumer <- data_consumer - class(cons_agreement) <- c(class(cons_agreement), "eds_consumption_agreement") + class(cons_agreement) <- c(class(cons_agreement), + "eds_consumption_agreement") return(cons_agreement) } else { message("Processing consumption agreement: ", params$file, "\n") @@ -657,30 +776,46 @@ process_cons_agreement <- function(structure, params) { -# Provision agreement --- +# Provision agreement ---- read_prov_agreement <- function(agencyids, ids, versions, params) { if (is.null(params$file)) { - message(paste("\nFetching provision agreement(s) -", paste(ids, collapse = ", "), "\n")) - response <- GET(params$env$registry$url, - path = paste(c(params$env$registry$path, "provisionagreements"), collapse = "/"), - query = list(agencyids = agencyids, ids = ids, versions = versions), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), - accept("application/vnd.sdmx-codera.data+json")) + message(paste("\nFetching provision agreement(s) -", + paste(ids, collapse = ", "), "\n")) + response <- + GET(params$env$registry$url, + path = paste(c(params$env$registry$path, "provisionagreements"), + collapse = "/"), + query = list(agencyids = agencyids, + ids = ids, + versions = versions), + set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + accept("application/vnd.sdmx-codera.data+json")) if (response$status_code != 200) { stop(content(response, encoding = "UTF-8")) } - data_message <- content(response, type = "application/json", encoding = "UTF-8") - prov_agreements <- data_message[[2]][["structures"]][["provision-agreements"]] + data_message <- + content(response, type = "application/json", encoding = "UTF-8") + prov_agreements <- + data_message[[2]][["structures"]][["provision-agreements"]] return(prov_agreements) } else { message(paste("\nFetching provision agreement(s) -", params$file, "\n")) - na <- c("","NA", "#N/A") - dataflow <- as.list(read_ods(path = params$file, sheet = "dataflow", na = na, as_tibble = FALSE)) - data_provider <- as.list(read_ods(path = params$file, sheet = "data_provider", na = na, as_tibble = FALSE)) - prov_agreement <- as.list(read_ods(path = params$file, sheet = "provision_agreement", na = na, as_tibble = FALSE)) + na <- c("", "NA", "#N/A") + dataflow <- as.list(read_ods(path = params$file, + sheet = "dataflow", + na = na, + as_tibble = FALSE)) + data_provider <- as.list(read_ods(path = params$file, + sheet = "data_provider", + na = na, + as_tibble = FALSE)) + prov_agreement <- as.list(read_ods(path = params$file, + sheet = "provision_agreement", + na = na, + as_tibble = FALSE)) prov_agreement$dataflow <- dataflow prov_agreement$data_provider <- data_provider return(list(prov_agreement)) @@ -689,7 +824,7 @@ read_prov_agreement <- function(agencyids, ids, versions, params) { process_prov_agreement <- function(structure, params) { if (is.null(params$file)) { - structure_ref <- paste(structure[[2]]$agencyid, + structure_ref <- paste(structure[[2]]$agencyid, structure[[2]]$id, structure[[2]]$version, sep = "-") @@ -706,11 +841,12 @@ process_prov_agreement <- function(structure, params) { description = description) dataflow <- list(agencyid = structure[[2]][["dataflow"]][[2]]$agencyid, id = structure[[2]][["dataflow"]][[2]]$id, - version = structure[[2]][["dataflow"]][[2]]$version) - data_provider <- list(agencyid = structure[[2]][["data-provider"]][[2]]$agencyid, - parentid = structure[[2]][["data-provider"]][[2]]$parentid, - parentversion = structure[[2]][["data-provider"]][[2]]$parentversion, - id = structure[[2]][["data-provider"]][[2]]$id) + version = structure[[2]][["dataflow"]][[2]]$version) + data_provider <- + list(agencyid = structure[[2]][["data-provider"]][[2]]$agencyid, + parentid = structure[[2]][["data-provider"]][[2]]$parentid, + parentversion = structure[[2]][["data-provider"]][[2]]$parentversion, + id = structure[[2]][["data-provider"]][[2]]$id) prov_agreement$dataflow <- dataflow prov_agreement$data_provider <- data_provider class(prov_agreement) <- c(class(prov_agreement), "eds_provsion_agreement") diff --git a/R/read_release.R b/R/read_release.R index 46d69f1..5a16bb1 100644 --- a/R/read_release.R +++ b/R/read_release.R @@ -1,9 +1,8 @@ read_release <- function(id, tidy = FALSE, ...) { - # Parameters --- + # Parameters ---- - env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) if (!is.null(params$username) && !is.null(params$password)) { credentials <- paste(params$username, params$password, sep = ";") @@ -30,20 +29,22 @@ read_release <- function(id, tidy = FALSE, ...) { if (!is.null(params$description)) { query_params$description <- params$description } + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[agencyid]] - # Fetch release --- + # Fetch release ---- if (!exists("econdata_session", envir = .pkgenv)) { login_helper(credentials, env$repository$url) } - dataset_ref <- paste(agencyid, id, version, sep = "-") response <- GET(env$repository$url, path = c(env$repository$path, "/datasets"), query = list(agencyids = paste(agencyid, collapse = ","), ids = paste(id, collapse = ","), versions = paste(version, collapse = ",")), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept_json()) if (response$status_code != 200) stop(content(response, encoding = "UTF-8")) @@ -57,7 +58,8 @@ read_release <- function(id, tidy = FALSE, ...) { "datasets", dataset_ref, "release", sep = "/"), query = query_params, - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept("application/vnd.sdmx-codera.data+json")) if (response$status_code == 200) { message("Fetching releases for: ", dataset_ref, "\n") @@ -66,11 +68,11 @@ read_release <- function(id, tidy = FALSE, ...) { } release <- content(response, type = "application/json", encoding = "UTF-8") release$releases <- lapply(release$releases, function(r) { - list("release" = strptime(r$release, "%Y-%m-%dT%H:%M:%S%z"), - "start-period" = strptime(r[["start-period"]], "%Y-%m-%d"), - "end-period" = strptime(r[["end-period"]], "%Y-%m-%d"), - "description" = r[["description"]]) - }) + list("release" = strptime(r$release, "%Y-%m-%dT%H:%M:%S%z"), + "start-period" = strptime(r[["start-period"]], "%Y-%m-%d"), + "end-period" = strptime(r[["end-period"]], "%Y-%m-%d"), + "description" = r[["description"]]) + }) class(release) <- "eds_release" if (tidy) { tidy_data(release, ...) diff --git a/R/tidy_data.R b/R/tidy_data.R index ed1ce2f..745284c 100644 --- a/R/tidy_data.R +++ b/R/tidy_data.R @@ -1,11 +1,11 @@ -null2NA <- function(x) if(is.null(x)) NA_character_ else x +null2NA <- function(x) if (is.null(x)) NA_character_ else x make_label <- function(x, codelabel, meta) { m <- attr(x, "metadata") if (codelabel && !is.null(meta)) { lab <- NULL for (l in names(m)) { - if(meta[[l]]$type == "#sdmx.infomodel.datastructure.Dimension") { + if (meta[[l]]$type == "#sdmx.infomodel.datastructure.Dimension") { cl <- sapply(meta[[l]]$codelist$codes, function(x) c(x[[2]]$id, x[[2]]$name[[2]])) lab <- c(lab, cl[2L, which(cl[1L, ] == m[[l]])]) @@ -27,13 +27,18 @@ add_version_names <- function(x, is_release = FALSE) { } else { versions <- sapply(x, function(z) attr(z, "metadata")[[2]]$version) } - if(length(versions) == length(x) && !anyDuplicated(versions)) names(x) <- paste0("v", versions) + if (length(versions) == length(x) && !anyDuplicated(versions)) { + names(x) <- paste0("v", versions) + } return(x) } tidy_wide <- function(x, codelabel = FALSE, prettymeta = TRUE, ...) { - if(is.null(names(x))) return(lapply(add_version_names(x), tidy_wide, codelabel, prettymeta)) - metadata <- if(prettymeta) get_metadata(x) else NULL + if (is.null(names(x))) return(lapply(add_version_names(x), + tidy_wide, + codelabel, + prettymeta)) + metadata <- if (prettymeta) get_metadata(x) else NULL d <- unlist2d(x, "series_key", row.names = "time_period", DT = TRUE) |> dcast(time_period ~ series_key, value.var = "OBS_VALUE") |> fmutate(time_period = as.Date(time_period)) @@ -47,19 +52,20 @@ tidy_wide <- function(x, codelabel = FALSE, prettymeta = TRUE, ...) { extract_metadata <- function(x, meta, allmeta = FALSE, origmeta = FALSE) { - if(!allmeta && length(x) == 0L) return(NULL) # Omits non-observed series. + if (!allmeta && length(x) == 0L) return(NULL) # Omits non-observed series. m <- attr(x, "metadata") - if(origmeta) return(m) + if (origmeta) return(m) if (!is.null(meta)) { out <- list() for (p in names(m)) { if (!is.null(meta[[p]])) { cc_nam <- meta[[p]]$concept$name[[2]] cl <- meta[[p]]$codelist - if(!is.null(cl)) { + if (!is.null(cl)) { cl <- sapply(meta[[p]]$codelist$codes, function(x) c(x[[2]]$id, x[[2]]$name[[2]])) - out[[gsub(" ", "_", tolower(cc_nam))]] <- cl[2L, which(cl[1L, ] == m[[p]])] + out[[gsub(" ", "_", tolower(cc_nam))]] <- + cl[2L, which(cl[1L, ] == m[[p]])] } else { out[[gsub(" ", "_", tolower(cc_nam))]] <- m[[p]] } @@ -67,44 +73,68 @@ extract_metadata <- function(x, meta, allmeta = FALSE, origmeta = FALSE) { } return(out) } - return(m) + return(m) } tidy_long <- function(x, combine = FALSE, allmeta = FALSE, origmeta = FALSE, prettymeta = TRUE, ...) { if (is.null(names(x))) { - res <- lapply(add_version_names(x), tidy_long, combine, allmeta, origmeta, prettymeta) - return(if(combine) rbindlist(res, use.names = TRUE, fill = TRUE) else res) + res <- lapply(add_version_names(x), + tidy_long, + combine, + allmeta, + origmeta, + prettymeta) + return(if (combine) rbindlist(res, use.names = TRUE, fill = TRUE) else res) } - metadata <- if(prettymeta) get_metadata(x) else NULL + metadata <- if (prettymeta) get_metadata(x) else NULL d <- unlist2d(x, "series_key", row.names = "time_period", DT = TRUE) |> - fmutate(time_period = as.Date(time_period), series_key = qF(series_key)) |> - frename(OBS_VALUE = "obs_value") + fmutate(time_period = as.Date(time_period), + series_key = qF(series_key)) |> + frename(OBS_VALUE = "obs_value") M <- attr(x, "metadata") - meta4dataset <- extract_metadata(x, metadata$concepts, allmeta && !combine, origmeta) - meta <- lapply(x, extract_metadata, metadata$concepts, allmeta && !combine, origmeta) |> + meta4dataset <- extract_metadata(x, + metadata$concepts, + allmeta && !combine, + origmeta) + meta <- lapply(x, + extract_metadata, + metadata$concepts, + allmeta && !combine, + origmeta) |> rbindlist(use.names = TRUE, fill = TRUE) if (origmeta) names(meta) <- tolower(names(meta)) if (allmeta && !combine) { meta <- c(meta4dataset, meta) - meta$data_set_name <- M$name[[2]] + meta$data_set_name <- M$name[[2]] meta$data_set_ref <- sprintf("%s:%s(%s)", M$agencyid, M$id, M$version) meta$data_provider_ref <- metadata$data_provider_ref meta$series_key <- names(x) } else { nseries <- length(levels(d$series_key)) - meta <- c(lapply(meta4dataset, function(x) if (length(x) == 1) rep(x, nseries) else x), meta) + meta <- c(lapply(meta4dataset, + function(x) if (length(x) == 1) rep(x, nseries) else x), + meta) meta$data_set_name <- rep(M$name[[2]], nseries) - meta$data_set_ref <- rep(sprintf("%s:%s(%s)", M$agencyid, M$id, M$version), nseries) - meta$data_provider_ref <- rep(metadata$data_provider_ref, nseries) + meta$data_set_ref <- rep(sprintf("%s:%s(%s)", + M$agencyid, + M$id, M$version), + nseries) + meta$data_provider_ref <- rep(metadata$data_provider_ref, nseries) meta$series_key <- names(x)[names(x) %in% levels(d$series_key)] } - setcolorder(meta, c("data_set_name", "data_set_ref", "data_provider_ref", "series_key")) + setcolorder(meta, + c("data_set_name", + "data_set_ref", + "data_provider_ref", + "series_key")) if (!allmeta) get_vars(meta, fnobs(meta) == 0L) <- NULL if (combine) { meta_fct <- dapply(meta, qF, drop = FALSE) # Factors for efficient storage series_key <- d$series_key d$series_key <- NULL - add_vars(d, "front") <- ss(meta_fct, ckmatch(series_key, meta_fct$series_key), check = FALSE) + add_vars(d, "front") <- ss(meta_fct, + ckmatch(series_key, meta_fct$series_key), + check = FALSE) return(d) } return(list(data = d, metadata = meta)) @@ -113,17 +143,18 @@ tidy_long <- function(x, combine = FALSE, allmeta = FALSE, origmeta = FALSE, pre # Tidying the output of read_release() tidy_data.eds_release <- function(x) { axnull <- is.null(attributes(x)) - if(axnull && length(x) > 1L) { + if (axnull && length(x) > 1L) { res <- lapply(x, tidy_data.eds_release) return(add_version_names(res, is_release = TRUE)) } - res <- rbindlist(lapply(x$releases, function(x) { - list("release" = as.POSIXct(x[["release"]]), - "start-period" = as.POSIXct(x[["start-period"]]), - "end-period" = as.POSIXct(x[["end-period"]]), - "description" = x[["description"]]) - } - )) + res <- + rbindlist(lapply(x$releases, function(x) { + list("release" = as.POSIXct(x[["release"]]), + "start-period" = as.POSIXct(x[["start-period"]]), + "end-period" = as.POSIXct(x[["end-period"]]), + "description" = x[["description"]]) + } + )) attr(res, "metadata") <- x[["data-set"]] return(qDT(res, keep.attr = TRUE)) } @@ -132,20 +163,20 @@ tidy_data.eds_release <- function(x) { # together with read_econdata() tidy_data.eds_dataset <- function(x, wide = TRUE, ...) { if (wide) { - tidy_wide(x, ...) + tidy_wide(x, ...) } else { - tidy_long(x, ...) + tidy_long(x, ...) } } tidy_data.eds_database <- function(x, ...) { lapply(x, function(y) { - m <- attr(y, "metadata") + m <- attr(y, "metadata") m$name <- m$name[[2]] m$description <- m$description[[2]] return(m[c("agencyid", "id", "version", "name")]) }) |> - rbindlist() + rbindlist() } tidy_data <- function(x, ...) UseMethod("tidy_data", x) diff --git a/R/write_database.R b/R/write_database.R index dfc550d..a0ce959 100644 --- a/R/write_database.R +++ b/R/write_database.R @@ -3,7 +3,6 @@ write_database <- function(x, method = "update", ...) { # Parameters --- - env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) if (!is.null(params$username) && !is.null(params$password)) { credentials <- paste(params$username, params$password, sep = ";") @@ -12,6 +11,8 @@ write_database <- function(x, method = "update", ...) { } stopifnot(length(method) == 1) stopifnot(method %in% c("create", "update")) + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[x$agencyid]] # Push data message --- diff --git a/R/write_dataset.R b/R/write_dataset.R index b907865..e224f9e 100644 --- a/R/write_dataset.R +++ b/R/write_dataset.R @@ -1,7 +1,7 @@ write_dataset <- function(x, method = "stage", ...) { - # Parameters --- + # Parameters ---- env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) @@ -12,9 +12,11 @@ write_dataset <- function(x, method = "stage", ...) { } stopifnot(length(method) == 1) stopifnot(method %in% c("stage", "validate")) + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[x$agencyid]] - # Push data message --- + # Push data message ---- if (is.null(params$file) && !exists("econdata_session", envir = .pkgenv)) { login_helper(credentials, env$repository$url) @@ -32,7 +34,7 @@ write_dataset <- function(x, method = "stage", ...) { } - # Push each data set individually --- + # Push each data set individually ---- lapply(data_sets, function(data_set) { metadata <- attr(data_set, "metadata") diff --git a/R/write_registry.R b/R/write_registry.R index c6a2c60..defc740 100644 --- a/R/write_registry.R +++ b/R/write_registry.R @@ -1,11 +1,9 @@ write_registry <- function(structure, x, method = "update", ...) { - # Parameters --- + # Parameters ---- - env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) - params$env <- env if (!is.null(params$username) && !is.null(params$password)) { credentials <- paste(params$username, params$password, sep = ";") } else { @@ -13,15 +11,18 @@ write_registry <- function(structure, x, method = "update", ...) { } stopifnot(length(method) == 1) stopifnot(method %in% c("create", "update")) + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[x$agencyid]] + params$env <- env - # Fetch structure(s) --- + # Fetch structure(s) ---- if (!exists("econdata_session", envir = .pkgenv)) { login_helper(credentials, env$repository$url) } header <- list() - if(is.null(params$file)) { + if (is.null(params$file)) { header$id <- unbox("ECONDATAR") header$prepared <- unbox(format(Sys.time(), format = "%Y-%m-%dT%T")) header$sender <- tryCatch(unbox(Sys.getenv()[["USER"]]), @@ -29,26 +30,26 @@ write_registry <- function(structure, x, method = "update", ...) { header$receiver <- unbox("EconData web application") } params$header <- header - structure_data <- - switch(structure, - "category-scheme" = write_category_scheme(x, method, params), - "codelist" = write_codelist(x, method, params), - "concept-scheme" = write_concept_scheme(x, method, params), - "dataflow" = write_dataflow(x, method, params), - "data-structure" = write_data_structure(x, method, params), - "memberlist" = write_memberlist(x, method, params), - "consumption-agreement" = write_cons_agreement(x, method, params), - "provision-agreement" = write_prov_agreement(x, method, params), - stop("Specified structure, ", structure, ", is not supported.")) + switch(structure, + "category-scheme" = write_category_scheme(x, method, params), + "codelist" = write_codelist(x, method, params), + "concept-scheme" = write_concept_scheme(x, method, params), + "dataflow" = write_dataflow(x, method, params), + "data-structure" = write_data_structure(x, method, params), + "memberlist" = write_memberlist(x, method, params), + "consumption-agreement" = write_cons_agreement(x, method, params), + "provision-agreement" = write_prov_agreement(x, method, params), + stop("Specified structure, ", structure, ", is not supported.")) + return(invisible(NULL)) } -# Category scheme --- +# Category scheme ---- write_category_scheme <- function(category_scheme, method, params) { - if(is.null(params$file)) { + if (is.null(params$file)) { category_scheme_ref <- paste(category_scheme$agencyid, category_scheme$id, category_scheme$version, @@ -58,13 +59,13 @@ write_category_scheme <- function(category_scheme, method, params) { list(header = params$header, structures = list("category-schemes" = - list( - list(unbox("#sdmx.infomodel.categoryscheme.CategoryScheme"), - list(agencyid = unbox(category_scheme$agencyid), - id = unbox(category_scheme$id), - version = unbox(category_scheme$version), - name = c("en", category_scheme$name), - categories = list())))))) + list( + list(unbox("#sdmx.infomodel.categoryscheme.CategoryScheme"), + list(agencyid = unbox(category_scheme$agencyid), + id = unbox(category_scheme$id), + version = unbox(category_scheme$version), + name = c("en", category_scheme$name), + categories = list())))))) if (!is.na(category_scheme$description)) { data_message[[2]]$structures[["category-schemes"]][[1]][[2]]$description <- c("en", category_scheme$description) @@ -82,15 +83,16 @@ write_category_scheme <- function(category_scheme, method, params) { category[[2]]$description <- c("en", tmp$description) } references <- apply(category_scheme$categories[index, ], 1, function(reference) { - tmp <- as.list(reference) - list(unbox("#sdmx.infomodel.registry.ProvisionAgreementRef"), - list(agencyid = unbox(tmp$reference_agencyid), - id = unbox(tmp$reference_id), - version = unbox(tmp$reference_version))) - }) + tmp <- as.list(reference) + list(unbox("#sdmx.infomodel.registry.ProvisionAgreementRef"), + list(agencyid = unbox(tmp$reference_agencyid), + id = unbox(tmp$reference_id), + version = unbox(tmp$reference_version))) + }) names(references) <- NULL category[[2]]$references <- references - data_message[[2]]$structures[["category-schemes"]][[1]][[2]]$categories[[i]] <- category + data_message[[2]]$structures[["category-schemes"]][[1]][[2]]$categories[[i]] <- + category } } if (method == "create") { @@ -98,7 +100,9 @@ write_category_scheme <- function(category_scheme, method, params) { response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "categoryschemes", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -114,7 +118,9 @@ write_category_scheme <- function(category_scheme, method, params) { path = paste(params$env$repository$path, "categoryschemes", category_scheme_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -130,19 +136,24 @@ write_category_scheme <- function(category_scheme, method, params) { } else { categories <- category_scheme$categories category_scheme$categories <- NULL - write_ods(as.data.frame(category_scheme), path = params$file, sheet = "category_scheme") - write_ods(categories, path = params$file, sheet = "categories", append = TRUE) + write_ods(as.data.frame(category_scheme), + path = params$file, + sheet = "category_scheme") + write_ods(categories, + path = params$file, + sheet = "categories", + append = TRUE) message("Concept scheme successfully written to: ", params$file, "\n") } } -# Codelist --- +# Codelist ---- write_codelist <- function(codelist, method, params) { - if(is.null(params$file)) { + if (is.null(params$file)) { codelist_ref <- paste(codelist$agencyid, codelist$id, codelist$version, @@ -152,19 +163,19 @@ write_codelist <- function(codelist, method, params) { list(header = params$header, structures = list(codelists = - list( - list(unbox("#sdmx.infomodel.codelist.Codelist"), - list(agencyid = unbox(codelist$agencyid), - id = unbox(codelist$id), - version = unbox(codelist$version), - name = c("en", codelist$name), - codes = list())))))) + list( + list(unbox("#sdmx.infomodel.codelist.Codelist"), + list(agencyid = unbox(codelist$agencyid), + id = unbox(codelist$id), + version = unbox(codelist$version), + name = c("en", codelist$name), + codes = list())))))) if (!is.na(codelist$description)) { data_message[[2]]$structures$codelists[[1]][[2]]$description <- c("en", codelist$description) } for (i in seq_len(NROW(codelist$codes))) { - tmp <- as.list(codelist$codes[i,]) + tmp <- as.list(codelist$codes[i, ]) code <- list(unbox("#sdmx.infomodel.codelist.Code"), list(id = unbox(tmp$id), name = c("en", tmp$name))) @@ -178,7 +189,9 @@ write_codelist <- function(codelist, method, params) { response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "codelists", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -194,7 +207,9 @@ write_codelist <- function(codelist, method, params) { path = paste(params$env$repository$path, "codelists", codelist_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -218,11 +233,11 @@ write_codelist <- function(codelist, method, params) { -# Concept scheme --- +# Concept scheme ---- write_concept_scheme <- function(concept_scheme, method, params) { - if(is.null(params$file)) { + if (is.null(params$file)) { concept_scheme_ref <- paste(concept_scheme$agencyid, concept_scheme$id, concept_scheme$version, @@ -232,19 +247,19 @@ write_concept_scheme <- function(concept_scheme, method, params) { list(header = params$header, structures = list("concept-schemes" = - list( - list(unbox("#sdmx.infomodel.conceptscheme.ConceptScheme"), - list(agencyid = unbox(concept_scheme$agencyid), - id = unbox(concept_scheme$id), - version = unbox(concept_scheme$version), - name = c("en", concept_scheme$name), - concepts = list())))))) + list( + list(unbox("#sdmx.infomodel.conceptscheme.ConceptScheme"), + list(agencyid = unbox(concept_scheme$agencyid), + id = unbox(concept_scheme$id), + version = unbox(concept_scheme$version), + name = c("en", concept_scheme$name), + concepts = list())))))) if (!is.na(concept_scheme$description)) { data_message[[2]]$structures[["concept-schemes"]][[1]][[2]]$description <- c("en", concept_scheme$description) } for (i in seq_len(NROW(concept_scheme$concepts))) { - tmp <- as.list(concept_scheme$concepts[i,]) + tmp <- as.list(concept_scheme$concepts[i, ]) concept <- list(unbox("#sdmx.infomodel.conceptscheme.Concept"), list(id = unbox(tmp$id), name = c("en", tmp$name))) @@ -267,7 +282,9 @@ write_concept_scheme <- function(concept_scheme, method, params) { response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "conceptschemes", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -283,7 +300,9 @@ write_concept_scheme <- function(concept_scheme, method, params) { path = paste(params$env$repository$path, "conceptschemes", concept_scheme_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -299,7 +318,9 @@ write_concept_scheme <- function(concept_scheme, method, params) { } else { concepts <- concept_scheme$concepts concept_scheme$concepts <- NULL - write_ods(as.data.frame(concept_scheme), path = params$file, sheet = "concept_scheme") + write_ods(as.data.frame(concept_scheme), + path = params$file, + sheet = "concept_scheme") write_ods(concepts, path = params$file, sheet = "concepts", append = TRUE) message("Concept scheme successfully written to: ", params$file, "\n") } @@ -307,11 +328,11 @@ write_concept_scheme <- function(concept_scheme, method, params) { -# Dataflow --- +# Dataflow ---- write_dataflow <- function(dataflow, method, params) { - if(is.null(params$file)) { + if (is.null(params$file)) { dataflow_ref <- paste(dataflow$agencyid, dataflow$id, dataflow$version, @@ -321,12 +342,12 @@ write_dataflow <- function(dataflow, method, params) { list(header = params$header, structures = list(dataflows = - list( - list(unbox("#sdmx.infomodel.datastructure.Dataflow"), - list(agencyid = unbox(dataflow$agencyid), - id = unbox(dataflow$id), - version = unbox(dataflow$version), - name = c("en", dataflow$name))))))) + list( + list(unbox("#sdmx.infomodel.datastructure.Dataflow"), + list(agencyid = unbox(dataflow$agencyid), + id = unbox(dataflow$id), + version = unbox(dataflow$version), + name = c("en", dataflow$name))))))) if (!is.na(dataflow$description)) { data_message[[2]]$structures$dataflows[[1]][[2]]$description <- c("en", dataflow$description) @@ -341,7 +362,9 @@ write_dataflow <- function(dataflow, method, params) { response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "dataflows", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -357,7 +380,8 @@ write_dataflow <- function(dataflow, method, params) { path = paste(params$env$repository$path, "dataflows", dataflow_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -374,18 +398,20 @@ write_dataflow <- function(dataflow, method, params) { data_structure <- dataflow$data_structure dataflow$data_structure <- NULL write_ods(as.data.frame(dataflow), path = params$file, sheet = "dataflow") - write_ods(as.data.frame(data_structure), path = params$file, sheet = "data_structure", append = TRUE) + write_ods(as.data.frame(data_structure), + path = params$file, + sheet = "data_structure", append = TRUE) message("Dataflow successfully written to: ", params$file, "\n") } } -# Data structure --- +# Data structure ---- write_data_structure <- function(data_structure, method, params) { - if(is.null(params$file)) { + if (is.null(params$file)) { data_structure_ref <- paste(data_structure$agencyid, data_structure$id, data_structure$version, @@ -395,23 +421,23 @@ write_data_structure <- function(data_structure, method, params) { list(header = params$header, structures = list("data-structures" = - list( - list(unbox("#sdmx.infomodel.datastructure.DataStructure"), - list(agencyid = unbox(data_structure$agencyid), - id = unbox(data_structure$id), - version = unbox(data_structure$version), - name = c("en", data_structure$name), - components = list())))))) + list( + list(unbox("#sdmx.infomodel.datastructure.DataStructure"), + list(agencyid = unbox(data_structure$agencyid), + id = unbox(data_structure$id), + version = unbox(data_structure$version), + name = c("en", data_structure$name), + components = list())))))) if (!is.na(data_structure$description)) { data_message[[2]]$structures[["data-structures"]][[1]][[2]]$description <- c("en", data_structure$description) } - # Dimensions --- + # Dimensions ---- for (i in seq_len(NROW(data_structure$dimensions))) { - tmp <- as.list(data_structure$dimensions[i,]) + tmp <- as.list(data_structure$dimensions[i, ]) dimension <- list(unbox("#sdmx.infomodel.datastructure.Dimension"), list(id = unbox(tmp$id), position = unbox(tmp$position))) @@ -435,10 +461,10 @@ write_data_structure <- function(data_structure, method, params) { } - # Attributes --- + # Attributes ---- for (i in seq_len(NROW(data_structure$attributes))) { - tmp <- as.list(data_structure$attributes[i,]) + tmp <- as.list(data_structure$attributes[i, ]) attribute <- list(unbox("#sdmx.infomodel.datastructure.Attribute"), list(id = unbox(tmp$id), "attachment-level" = unbox(tmp$level), @@ -464,11 +490,11 @@ write_data_structure <- function(data_structure, method, params) { } - # Time dimension --- + # Time dimension ---- - tmp <- as.list(data_structure$time_dimension[1,]) + tmp <- as.list(data_structure$time_dimension[1, ]) time_dimension <- list(unbox("#sdmx.infomodel.datastructure.TimeDimension"), - list(id = unbox(tmp$id))) + list(id = unbox(tmp$id))) concept_ref <- list(unbox("#sdmx.infomodel.conceptscheme.ConceptRef"), list(agencyid = unbox(tmp$concept_agencyid), parentid = unbox(tmp$concept_parentid), @@ -489,11 +515,12 @@ write_data_structure <- function(data_structure, method, params) { time_dimension - # Primary measure --- + # Primary measure ---- tmp <- as.list(data_structure$primary_measure[1,]) - primary_measure <- list(unbox("#sdmx.infomodel.datastructure.PrimaryMeasure"), - list(id = unbox(tmp$id))) + primary_measure <- + list(unbox("#sdmx.infomodel.datastructure.PrimaryMeasure"), + list(id = unbox(tmp$id))) concept_ref <- list(unbox("#sdmx.infomodel.conceptscheme.ConceptRef"), list(agencyid = unbox(tmp$concept_agencyid), parentid = unbox(tmp$concept_parentid), @@ -507,21 +534,24 @@ write_data_structure <- function(data_structure, method, params) { version = unbox(tmp$codelist_version))) primary_measure[[2]][["local-representation"]] <- codelist_ref } else { - primary_measure[[2]][["local-representation"]] <- unbox(tmp$representation) + primary_measure[[2]][["local-representation"]] <- + unbox(tmp$representation) } i <- NROW(data_structure$dimensions) + NROW(data_structure$attributes) + 2 data_message[[2]]$structures[["data-structures"]][[1]][[2]]$components[[i]] <- primary_measure - # Push data message --- + # Push data message ---- - if (method == "create") { + if (method == "create") { message("Creating data structure: ", data_structure_ref, "\n") response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "datastructures", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -537,7 +567,9 @@ write_data_structure <- function(data_structure, method, params) { path = paste(params$env$repository$path, "datastructures", data_structure_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -555,22 +587,36 @@ write_data_structure <- function(data_structure, method, params) { attrs <- data_structure$attributes time_dimension <- data_structure$time_dimension primary_measure <- data_structure$primary_measure - write_ods(as.data.frame(data_structure), path = params$file, sheet = "data_structure") - write_ods(dimensions, path = params$file, sheet = "dimensions", append = TRUE) - write_ods(attrs, path = params$file, sheet = "attributes", append = TRUE) - write_ods(time_dimension, path = params$file, sheet = "time_dimension", append = TRUE) - write_ods(primary_measure, path = params$file, sheet = "primary_measure", append = TRUE) + write_ods(as.data.frame(data_structure), + path = params$file, + sheet = "data_structure") + write_ods(dimensions, + path = params$file, + sheet = "dimensions", + append = TRUE) + write_ods(attrs, + path = params$file, + sheet = "attributes", + append = TRUE) + write_ods(time_dimension, + path = params$file, + sheet = "time_dimension", + append = TRUE) + write_ods(primary_measure, + path = params$file, + sheet = "primary_measure", + append = TRUE) message("Data structure successfully written to: ", params$file, "\n") } } -# Memberlist --- +# Memberlist ---- write_memberlist <- function(memberlist, method, params) { - if(is.null(params$file)) { + if (is.null(params$file)) { memberlist_ref <- paste(memberlist$agencyid, memberlist$id, memberlist$version, @@ -580,13 +626,13 @@ write_memberlist <- function(memberlist, method, params) { list(header = params$header, structures = list("memberlists" = - list( - list(unbox("#sdmx.infomodel.memberlist.Memberlist"), - list(agencyid = unbox(memberlist$agencyid), - id = unbox(memberlist$id), - version = unbox(memberlist$version), - name = c("en", memberlist$name), - members = list())))))) + list( + list(unbox("#sdmx.infomodel.memberlist.Memberlist"), + list(agencyid = unbox(memberlist$agencyid), + id = unbox(memberlist$id), + version = unbox(memberlist$version), + name = c("en", memberlist$name), + members = list())))))) if (!is.na(memberlist$description)) { data_message[[2]]$structures[["memberlists"]][[1]][[2]]$description <- c("en", memberlist$description) @@ -596,28 +642,29 @@ write_memberlist <- function(memberlist, method, params) { for (i in seq_len(length(ids))) { id <- ids[i] index <- memberlist$members$id == id - tmp <- as.list(memberlist$members[which(index)[1],]) + tmp <- as.list(memberlist$members[which(index)[1], ]) member <- list(unbox("#sdmx.infomodel.memberlist.Member"), - list(id = unbox(tmp$id), - email = unbox(tmp$email), - firstname = unbox(tmp$firstname), - lastname = unbox(tmp$lastname), - annotations = lapply(fromJSON(tmp$annotations), unbox))) + list(id = unbox(tmp$id), + email = unbox(tmp$email), + firstname = unbox(tmp$firstname), + lastname = unbox(tmp$lastname), + annotations = lapply(fromJSON(tmp$annotations), + unbox))) memberships <- apply(memberlist$members[index, ], 1, function(membership) { - tmp <- as.list(membership) - if (tmp$membership_type == "data consumer") { - type <- "#sdmx.infomodel.base.DataConsumerRef" - } else if (tmp$membership_type == "data provider") { - type <- "#sdmx.infomodel.base.DataProviderRef" - } else { - stop("Unable to parse membership type: ", tmp$membership_type) - } - list(unbox(type), - list(agencyid = unbox(tmp$membership_agencyid), - parentid = unbox(tmp$membership_parentid), - parentversion = unbox(tmp$membership_parentversion), - id = unbox(tmp$membership_id))) - }) + tmp <- as.list(membership) + if (tmp$membership_type == "data consumer") { + type <- "#sdmx.infomodel.base.DataConsumerRef" + } else if (tmp$membership_type == "data provider") { + type <- "#sdmx.infomodel.base.DataProviderRef" + } else { + stop("Unable to parse membership type: ", tmp$membership_type) + } + list(unbox(type), + list(agencyid = unbox(tmp$membership_agencyid), + parentid = unbox(tmp$membership_parentid), + parentversion = unbox(tmp$membership_parentversion), + id = unbox(tmp$membership_id))) + }) names(memberships) <- NULL member[[2]]$memberships <- memberships data_message[[2]]$structures[["memberlists"]][[1]][[2]]$members[[i]] <- member @@ -628,7 +675,9 @@ write_memberlist <- function(memberlist, method, params) { response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "memberlists", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -644,7 +693,9 @@ write_memberlist <- function(memberlist, method, params) { path = paste(params$env$repository$path, "memberlists", memberlist_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -658,7 +709,9 @@ write_memberlist <- function(memberlist, method, params) { } else { members <- memberlist$members memberlist$members <- NULL - write_ods(as.data.frame(memberlist), path = params$file, sheet = "memberlist") + write_ods(as.data.frame(memberlist), + path = params$file, + sheet = "memberlist") write_ods(members, path = params$file, sheet = "members", append = TRUE) message("Memberlist successfully written to: ", params$file, "\n") } @@ -666,7 +719,7 @@ write_memberlist <- function(memberlist, method, params) { -# Consumption agreement --- +# Consumption agreement ---- write_cons_agreement <- function(cons_agreement, method, params) { @@ -680,12 +733,12 @@ write_cons_agreement <- function(cons_agreement, method, params) { list(header = params$header, structures = list("consumption-agreements" = - list( - list(unbox("#sdmx.infomodel.registry.ConsumptionAgreement"), - list(agencyid = unbox(cons_agreement$agencyid), - id = unbox(cons_agreement$id), - version = unbox(cons_agreement$version), - name = c("en", cons_agreement$name))))))) + list( + list(unbox("#sdmx.infomodel.registry.ConsumptionAgreement"), + list(agencyid = unbox(cons_agreement$agencyid), + id = unbox(cons_agreement$id), + version = unbox(cons_agreement$version), + name = c("en", cons_agreement$name))))))) if (!is.na(cons_agreement$description)) { data_message[[2]]$structures[["consumption-agreements"]][[1]][[2]]$description <- c("en", cons_agreement$description) @@ -706,7 +759,9 @@ write_cons_agreement <- function(cons_agreement, method, params) { response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "consumptionagreements", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -722,7 +777,9 @@ write_cons_agreement <- function(cons_agreement, method, params) { path = paste(params$env$repository$path, "consumptionagreements", cons_agreement_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -740,20 +797,27 @@ write_cons_agreement <- function(cons_agreement, method, params) { data_consumer <- cons_agreement$data_consumer cons_agreement$dataflow <- NULL cons_agreement$data_consumer <- NULL - write_ods(as.data.frame(cons_agreement), path = params$file, sheet = "consumption_agreement") - write_ods(as.data.frame(dataflow), path = params$file, sheet = "dataflow", append = TRUE) - write_ods(as.data.frame(data_consumer), path = params$file, sheet = "data_consumer", append = TRUE) - message("Consumption agreement successfully written to: ", params$file, "\n") + write_ods(as.data.frame(cons_agreement), + path = params$file, + sheet = "consumption_agreement") + write_ods(as.data.frame(dataflow), + path = params$file, + sheet = "dataflow", append = TRUE) + write_ods(as.data.frame(data_consumer), + path = params$file, + sheet = "data_consumer", append = TRUE) + message("Consumption agreement successfully written to: ", + params$file, "\n") } } -# Provision agreement --- +# Provision agreement ---- write_prov_agreement <- function(prov_agreement, method, params) { - if(is.null(params$file)) { + if (is.null(params$file)) { prov_agreement_ref <- paste(prov_agreement$agencyid, prov_agreement$id, prov_agreement$version, @@ -763,12 +827,12 @@ write_prov_agreement <- function(prov_agreement, method, params) { list(header = params$header, structures = list("provision-agreements" = - list( - list(unbox("#sdmx.infomodel.registry.ProvisionAgreement"), - list(agencyid = unbox(prov_agreement$agencyid), - id = unbox(prov_agreement$id), - version = unbox(prov_agreement$version), - name = c("en", prov_agreement$name))))))) + list( + list(unbox("#sdmx.infomodel.registry.ProvisionAgreement"), + list(agencyid = unbox(prov_agreement$agencyid), + id = unbox(prov_agreement$id), + version = unbox(prov_agreement$version), + name = c("en", prov_agreement$name))))))) if (!is.na(prov_agreement$description)) { data_message[[2]]$structures[["provision-agreements"]][[1]][[2]]$description <- c("en", prov_agreement$description) @@ -789,7 +853,9 @@ write_prov_agreement <- function(prov_agreement, method, params) { response <- POST(params$env$repository$url, path = paste(params$env$repository$path, "provisionagreements", sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -805,7 +871,9 @@ write_prov_agreement <- function(prov_agreement, method, params) { path = paste(params$env$repository$path, "provisionagreements", prov_agreement_ref, sep = "/"), - body = toJSON(data_message, na = "null", always_decimal = TRUE), + body = toJSON(data_message, + na = "null", + always_decimal = TRUE), set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), content_type("application/vnd.sdmx-codera.data+json"), @@ -823,9 +891,16 @@ write_prov_agreement <- function(prov_agreement, method, params) { data_provider <- prov_agreement$data_provider prov_agreement$dataflow <- NULL prov_agreement$data_provider <- NULL - write_ods(as.data.frame(prov_agreement), path = params$file, sheet = "provision_agreement") - write_ods(as.data.frame(dataflow), path = params$file, sheet = "dataflow", append = TRUE) - write_ods(as.data.frame(data_provider), path = params$file, sheet = "data_provider", append = TRUE) - message("Consumption agreement successfully written to: ", params$file, "\n") + write_ods(as.data.frame(prov_agreement), + path = params$file, + sheet = "provision_agreement") + write_ods(as.data.frame(dataflow), + path = params$file, + sheet = "dataflow", append = TRUE) + write_ods(as.data.frame(data_provider), + path = params$file, + sheet = "data_provider", append = TRUE) + message("Consumption agreement successfully written to: ", + params$file, "\n") } } diff --git a/R/write_release.R b/R/write_release.R index fc03304..db9e74f 100644 --- a/R/write_release.R +++ b/R/write_release.R @@ -1,9 +1,8 @@ write_release <- function(id, version, providerid, description, method = "release", ...) { - # Parameters --- + # Parameters ---- - env <- fromJSON(system.file("settings.json", package = "econdatar")) params <- list(...) if (!is.null(params$username) && !is.null(params$password)) { credentials <- paste(params$username, params$password, sep = ";") @@ -26,9 +25,11 @@ write_release <- function(id, version, providerid, description, method = "releas } stopifnot(length(method) == 1) stopifnot(method %in% c("release", "reset", "rollback")) + env <- fromJSON(system.file("settings.json", + package = "econdatar"))[[agencyid]] - # Commit data set release --- + # Commit data set release ---- if (!exists("econdata_session", envir = .pkgenv)) { login_helper(credentials, env$repository$url) @@ -42,7 +43,8 @@ write_release <- function(id, version, providerid, description, method = "releas dataset_ref, "commit", sep = "/"), query = query_params, - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept_json()) if (response$status_code == 200) { message(content(response, encoding = "UTF-8")$success) @@ -56,7 +58,8 @@ write_release <- function(id, version, providerid, description, method = "releas "datasets", dataset_ref, "reset", sep = "/"), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept_json()) if (response$status_code == 200) { message(content(response, encoding = "UTF-8")$success) @@ -70,7 +73,8 @@ write_release <- function(id, version, providerid, description, method = "releas "datasets", dataset_ref, "rollback", sep = "/"), - set_cookies(.cookies = get("econdata_session", envir = .pkgenv)), + set_cookies(.cookies = + get("econdata_session", envir = .pkgenv)), accept_json()) if (response$status_code == 200) { message(content(response, encoding = "UTF-8")$success) diff --git a/inst/settings.json b/inst/settings.json index 2cc62af..08d4447 100644 --- a/inst/settings.json +++ b/inst/settings.json @@ -1,10 +1,22 @@ { - "repository" : { - "url" : "https://www.econdata.co.za", - "path" : "sdmx-codera/v1" + "ECONDATA" : { + "repository" : { + "url" : "https://www.econdata.co.za", + "path" : "sdmx-codera/v1" + }, + "registry" : { + "url" : "https://www.econdata.co.za", + "path" : "sdmx-codera/v1" + } }, - "registry" : { - "url" : "https://www.econdata.co.za", - "path" : "sdmx-codera/v1" + "FIRSTRAND" : { + "repository" : { + "url" : "https://firstrand.econdata.co.za", + "path" : "sdmx-codera/v1" + }, + "registry" : { + "url" : "https://firstrand.econdata.co.za", + "path" : "sdmx-codera/v1" + } } }