Skip to content

Commit

Permalink
Added agency ID / URL mapping
Browse files Browse the repository at this point in the history 
Also refactored to make LSP happy
  • Loading branch information
@byrongibby
byrongibby committed Mar 20, 2024
1 parent aa73d5c commit b92d3af
Show file tree
Hide file tree
Showing 13 changed files with 899 additions and 593 deletions.
11 changes: 7 additions & 4 deletions R/econdata_credentials.R
View file
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -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)
Expand Down
43 changes: 27 additions & 16 deletions R/get_metadata.R
View file
Original file line number Diff line number Diff line change
@@ -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,
Expand All @@ -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) {
Expand All @@ -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]]
Expand All @@ -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]]
}
}
Expand All @@ -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)
Expand Down
2 changes: 1 addition & 1 deletion R/login_helper.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
}
110 changes: 59 additions & 51 deletions R/read_database.R
View file
Original file line number Diff line number Diff line change
@@ -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 = ";")
Expand All @@ -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)) {
Expand All @@ -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, ...)
Expand Down
Loading

0 comments on commit b92d3af

Please sign in to comment.