fix bug with language

R/api_call.R

 #' Get a codelist based on an identifier
 #'
-#' @param identifier  the codelist's identifier
+#' @param identifier the codelist's identifier
+#' @param server server on which to query API
+#' Available are 'i14y' and 'abn'.
 #' @param language string for language(s) to return.
 #' Available are 'all', 'fr', 'de', 'it', 'en'.
 #' If 'all' (default), all languages are returned.
@@ -13,12 +15,14 @@
 #' @return response based on the export format
 #' @export
 get_codelist <- function(identifier,
+                         server = 'I14Y',
                          language = "all",
                          export_format = "SDMX-ML",
                          version_format = 2.1,
                          annotations = FALSE) {
   api <- api_class(
     api_type = "codelist",
+    server = server,
     id = identifier,
     language = language,
     export_format = export_format,
@@ -31,6 +35,8 @@ get_codelist <- function(identifier,
 #' Get one level of a nomenclature
 #'
 #' @param identifier nomenclature's identifier
+#' @param server server on which to query API
+#' Available are 'i14y' and 'abn'.
 #' @param filters additionnal filters
 #' @param level_number level to export
 #' @param language  the language of the response data
@@ -41,6 +47,7 @@ get_codelist <- function(identifier,
 #' (Code, Parent and Name in the selected language)
 #' @export
 get_nomenclature_one_level <- function(identifier,
+                                       server = 'I14Y',
                                        filters = list(),
                                        level_number = 1,
                                        language = "all",
@@ -52,6 +59,7 @@ get_nomenclature_one_level <- function(identifier,
   )
   api <- api_class(
     api_type = "nomenclature_one_level",
+    server = server,
     id = identifier,
     language = language,
     parameters = parameters,
@@ -64,6 +72,8 @@ get_nomenclature_one_level <- function(identifier,
 #' Get multiple levels of a nomenclature (from `level_from` to `level_to`)
 #'
 #' @param identifier nomenclature's identifier
+#' @param server server on which to query API
+#' Available are 'i14y' and 'abn'.
 #' @param filters additionnal filters
 #' @param level_from the 1st level to include
 #' @param level_to the last level to include
@@ -75,6 +85,7 @@ get_nomenclature_one_level <- function(identifier,
 #' from `level_from` to `level_to` codes
 #' @export
 get_nomenclature_multiple_levels <- function(identifier,
+                                             server = 'I14Y',
                                              filters = list(),
                                              level_from = 1,
                                              level_to = 2,
@@ -89,6 +100,7 @@ get_nomenclature_multiple_levels <- function(identifier,
   )
   api <- api_class(
     api_type = "nomenclature_multiple_levels",
+    server = server,
     id = identifier,
     parameters = parameters,
     export_format = "CSV"

R/api_class.R

@@ -2,6 +2,8 @@
 #' Api class to make appropriate request based on parameters
 #'
 #' @field api_type character. The name of the api to call (see url_mapping)
+#' @field server server on which to query API
+#' Available are 'I14Y' and 'ABN'
 #' @field export_format character (default = "JSON"). The export's format
 #' Available are CSV, XLSX, SDMX-ML and JSON
 #' @field parameters character. Additional request parameters
@@ -18,6 +20,7 @@ api_class <- setRefClass(
   "Api",
   fields = list(
     api_type = "character",
+    server = "character",
     export_format = "character",
     parameters = "character",
     id = "character",
@@ -27,6 +30,7 @@ api_class <- setRefClass(
   ),
   methods = list(
     initialize = function(...,
+                          server = 'I14Y',
                           export_format = "JSON",
                           parameters = "",
                           id = "",
@@ -34,6 +38,7 @@ api_class <- setRefClass(
                           version_format = 2.1) {
       callSuper(
         ...,
+        server = server,
         export_format = export_format,
         parameters = parameters,
         id = id,
@@ -42,39 +47,41 @@ api_class <- setRefClass(
       )
       get_url(id, export_format, version_format, language)
     },
-    get_response = function() {
-      # Select type of call to API
-      request_function <- REQUEST_FUNCTION_MAPPING[[export_format]]
-      if (parameters == "") {
-        url <- glue::glue("{BASE_URL}/api/{api_url}")
-      } else {
-        url <- glue::glue("{BASE_URL}/api/{api_url}?{parameters}")
-      }
-      
-      # API call
-      res <- request_function(url)
-      
-      # If specified language, keep only language specific columns
-      if(language != "all") {
-        res <- dplyr::select(
-          res, dplyr::contains(language) | dplyr::matches("id")
-        )
-      }
-      res
-    },
     get_url = function(id, export_format, version_format, language) {
       # Map function names to specific API URL
       url_mapping <- list(
         "codelist" =
           glue::glue("CodeLists/{id}/exports/{export_format}/{version_format}"),
-        "dcat_data_structure" =
-          glue::glue("DataStructures/{id}/{language}"),
         "nomenclature_one_level" =
           glue::glue("Nomenclatures/{id}/levelexport/CSV"),
         "nomenclature_multiple_levels" =
           glue::glue("Nomenclatures/{id}/multiplelevels/CSV")
       )
       api_url <<- url_mapping[[api_type]]
+    },
+    get_response = function() {
+      # API call to url
+      url <- glue::glue("{SERVERS[[server]]}/api/{api_url}?{parameters}")
+      res <- REQUEST_FUNCTION_MAPPING[[export_format]](url)
+      
+      # If specified language, keep only language specific columns
+      if(language != "all") { res <- remove_other_languages(res, language) }
+      
+      res
     }
   )
 )
+
+
+#' Remove columns that belong to other languages than the selected one
+#'
+#' @param df data.frame returned from API with columns for all languages
+#' @param language language to keep
+#'
+#' @return dataframe with columns relevant to selected language only
+remove_other_languages <- function(df, language) {
+  to_remove <- glue::glue(
+    "[.|_]+({paste(LANGUAGES[LANGUAGES != language], collapse = '|')})$"
+  )
+  df[, ! names(df) %in% names(df)[stringr::str_detect(names(df), to_remove)]]
+}
\ No newline at end of file

R/constants.R

-# Root URL constants
-BASE_URL <- "https://www.i14y.admin.ch"
+# Root URL constants¨
+SERVERS <- list(
+  "I14Y" = "https://www.i14y.admin.ch",
+  "ABN" = "iop-a.app.cfap02.atlantica.admin.ch"
+)
+
+LANGUAGES <- c('en', 'de', 'fr', 'it')

R/format_request.R

@@ -55,3 +55,4 @@ list_to_string <- function(filters) {
   }
   string
 }
+

demo.R

@@ -6,46 +6,57 @@ devtools::install_url("https://renkulab.io/gitlab/dscc/metadata-auto-r-library/-
 library("fso.metadata")
 
 
-# Get a codelist 
-# In german
-codelist <- get_codelist(identifier='CL_NOGA_SECTION', language='de')
-head(codelist$label.de)
-head(codelist$id)
+## Get a codelist
+# All languages
+codelist <- get_codelist(identifier='CL_NOGA_SECTION')
+names(codelist)
+head(codelist)
 
 # In french
 codelist <- get_codelist(identifier='CL_NOGA_SECTION', language='fr')
+names(codelist)
+
 head(codelist$label.fr)
 head(codelist$id)
 
+
 ## Get a nomenclature of one level
-# French 2 levels
+# All language: Level 1
+nomenclature <- get_nomenclature_one_level(
+  identifier='HCL_CH_ISCO_19_PROF', level_number=2
+)
+names(nomenclature)
+head(nomenclature, 5)
+
+# French: Level 2
 nomenclature_fr <- get_nomenclature_one_level(
-  identifier='HCL_CH_ISCO_19_PROF', level_number=2, language='fr'
+  identifier='HCL_CH_ISCO_19_PROF', level_number=1, language='fr'
 )
-head(nomenclature_fr, 10)
+names(nomenclature_fr)
+head(nomenclature_fr, 5)
 
-# German 3 levels
 nomenclature_de <- get_nomenclature_one_level(
-  identifier='HCL_CH_ISCO_19_PROF', level_number=3, language='de'
+  identifier='HCL_CH_ISCO_19_PROF', level_number=1, language='de'
 )
-head(nomenclature_de, 10)
-
+names(nomenclature_de)
+head(nomenclature_de, 5)
 
 ## Get a nomenclature of multiple levels
 # French
 multi_nomenclature_fr <- get_nomenclature_multiple_levels(
   identifier='HCL_CH_ISCO_19_PROF', 
-  level_from=2, 
+  level_from=1, 
   level_to=5, 
   language='fr'
 )
-head(multi_nomenclature_fr, 10)
+head(multi_nomenclature_fr, 5)
 
 # German
 multi_nomenclature_de <- get_nomenclature_multiple_levels(
   identifier='HCL_CH_ISCO_19_PROF', 
-  level_from=1, 
+  level_from=2, 
   level_to=3, 
   language='de'
 )
-head(multi_nomenclature_de, 10)
+head(multi_nomenclature_de, 5)
+

install.R

@@ -5,7 +5,7 @@ install.packages(c(
 devtools::install_github("opensdmx/rsdmx")
 
 ## Load and test library
-# pkgload::load_all('.')
+# pkgload::load_all('.', TRUE)
 # styler::style_pkg('.')
 # devtools::check('.')
 # testthat::test_file("tests/testthat.R")