Merge branch 'master' of github.com:opensdmx/rsdmx

Author: eblondel

R/Class-SDMXDimension.R

@@ -38,6 +38,7 @@ setClass("SDMXDimension",
           conceptVersion = "character", #optional
           conceptAgency = "character", #optional
           conceptSchemeRef = "character", #optional
+          conceptSchemeVersion = "character", #optional
           conceptSchemeAgency = "character", #optional
           codelist = "character", #optional
           codelistVersion = "character", #optional
@@ -63,6 +64,7 @@ setClass("SDMXDimension",
           conceptVersion = "1.0",
           conceptAgency = "ORG",
           conceptSchemeRef = "CONCEPT_SCHEME",
+          conceptSchemeVersion = "1.0",
           conceptSchemeAgency = "ORG",
           codelist = "CODELIST",
           codelistVersion = "1.0",

R/Class-SDMXRequestParams.R

@@ -17,7 +17,8 @@
 #' @slot flowRef an object of class "character" giving the flowRef to be queried
 #' @slot key an object of class "character" giving the key (SDMX url formatted) to be used for the query
 #' @slot start an object of class "character" giving the start time
-#' @slot end an object of class "character" giving the end time
+#' @slot end an object of class "character" giving the end time 
+#' @slot references an object of class "character" giving the instructions to return (or not) the artefacts referenced by the artefact to be returned
 #' @slot compliant an object of class "logical" indicating if the web-service is compliant with the SDMX REST web-service specifications
 #'
 #' @section Warning:
@@ -40,6 +41,7 @@ setClass("SDMXRequestParams",
            key = "character_OR_NULL",
            start = "character_OR_numeric_OR_NULL",
            end = "character_OR_numeric_OR_NULL",
+           references = "character_OR_NULL",
            compliant = "logical"
            ),
          prototype = list(),

R/SDMXCode-methods.R

@@ -39,8 +39,16 @@ SDMXCode <- function(xmlObj, namespaces){
   urn = xmlGetAttr(xmlObj, "urn")
   if(is.null(urn)) urn <- as.character(NA)
 
-  parentCode = xmlGetAttr(xmlObj, "parentCode")
-  if(is.null(parentCode)) parentCode <- as.character(NA)
+  parentCode <- as.character(NA)
+  parentId <- xmlGetAttr(xmlObj, "parentCode")
+  if(!is.null(parentId)) parentCode <- parentId
+  parentNode <- getNodeSet(xmlDoc(xmlObj), "//ns:Parent//Ref", namespaces = strNs)
+  if(length(parentNode) == 1) parentCode <- xmlGetAttr(parentNode[[1]], "id")
+  if(length(parentNode)  > 1) {
+    parentCode <- sapply(parentNode, function(x) { xmlGetAttr(x, "id") })
+    # we collapse the vector of parent codes into a single string as required by the SDMXCode class
+    parentCode <- paste(parentCode, collapse = ",")
+  }
 
   #elements
   #========

R/SDMXConcepts-methods.R

@@ -40,6 +40,11 @@ concepts.SDMXConcepts <- function(xmlObj, namespaces){
                               "//mes:Structures/str:Concepts/str:Concept",
                               namespaces = c(mes = as.character(messageNs),
                                              str = as.character(strNs)))
+    conceptsXML <- c(conceptsXML,
+                    getNodeSet(xmlObj,
+                              "//mes:Structures/str:Concepts/str:ConceptScheme/str:Concept",
+                              namespaces = c(mes = as.character(messageNs),
+                                             str = as.character(strNs))))
   }else{
     conceptsXML <- getNodeSet(xmlObj,
                               "//mes:Concepts/str:Concept",

R/SDMXData-methods.R

@@ -79,9 +79,9 @@ addLabels.SDMXData <- function(data, dsd){
       clName <- components[clMatcher, "codelist"]
       if(is.null(clName) || all(is.na(clName))){
         #try to grab codelist using regexpr on codelist
-        clMatcher <- regexpr(column, components$codelist, ignore.case = TRUE)
-        attr(clMatcher,"match.length")[is.na(clMatcher)] <- -1
-        clName <- components[attr(clMatcher,"match.length")>1, "codelist"]
+        clMatcher2 <- regexpr(column, components$codelist, ignore.case = TRUE)
+        attr(clMatcher2,"match.length")[is.na(clMatcher2)] <- -1
+        clName <- components[attr(clMatcher2,"match.length")>1, "codelist"]
         if(length(clName)>1) clName <- clName[1]
       }
 
@@ -91,6 +91,34 @@ addLabels.SDMXData <- function(data, dsd){
         if(!(clName %in% codelists)){
           clName <- NULL
         }
+        }else if(length(clName)==0){
+          #check if component has a conceptSchemeRef and if so try to resolve
+          #codelist from conceptscheme.
+          conceptSchemeRef <- components[clMatcher, "conceptSchemeRef"]
+          if(length(conceptSchemeRef)>0 && !is.na(conceptSchemeRef)){
+            codelists <- sapply(slot(slot(dsd,"codelists"), "codelists"), slot, "id")
+            conceptSchemeVersion <- components[clMatcher, "conceptSchemeVersion"]
+            conceptSchemeAgency <- components[clMatcher, "conceptSchemeAgency"]
+            conceptSchemes <- slot(slot(dsd, "concepts"), "conceptSchemes")
+            clFound <- FALSE
+            for(conceptScheme in conceptSchemes){
+              if(conceptSchemeRef == conceptScheme@id &&
+              conceptSchemeAgency == conceptScheme@agencyID &&
+              conceptSchemeVersion == conceptScheme@version){
+                for(concept in conceptScheme@Concept){
+                  if(concept@id == column){
+                    coreRepresentation = concept@coreRepresentation
+                    if(coreRepresentation %in% codelists){
+                      clName <- coreRepresentation
+                      clFound <- TRUE
+                      break
+                    } 
+                  }
+                }
+                if(clFound){break}
+              }
+            }
+        }
       }
 
     }else{

R/SDMXDimension-methods.R

@@ -45,6 +45,7 @@ SDMXDimension <- function(xmlObj, namespaces){
   conceptVersion <- NULL
   conceptAgency <- NULL
   conceptSchemeRef <- NULL
+  conceptSchemeVersion <- NULL
   conceptSchemeAgency <- NULL
   codelist <- NULL
   codelistVersion <- NULL
@@ -64,10 +65,16 @@ SDMXDimension <- function(xmlObj, namespaces){
     #concepts
     if(!is.null(conceptRefXML)){
       conceptRef = xmlGetAttr(conceptRefXML, "id")
-      conceptVersion = xmlGetAttr(conceptRefXML, "maintainableParentVersion")
-      conceptAgency = xmlGetAttr(conceptRefXML, "agencyID")
-      #TODO conceptSchemeRef?
-      #TODO conceptSchemeAgency
+      package = xmlGetAttr(conceptRefXML, "package")
+      if(package == "conceptscheme"){
+        conceptSchemeRef = xmlGetAttr(conceptRefXML, "maintainableParentID")
+        conceptSchemeVersion = xmlGetAttr(conceptRefXML, "maintainableParentVersion") 
+        conceptSchemeAgency = xmlGetAttr(conceptRefXML, "agencyID")
+      }else{
+        conceptVersion = xmlGetAttr(conceptRefXML, "maintainableParentVersion")
+        conceptAgency = xmlGetAttr(conceptRefXML, "agencyID")
+      }
+
     }
 
     #codelists
@@ -123,6 +130,7 @@ SDMXDimension <- function(xmlObj, namespaces){
   if(is.null(conceptVersion)) conceptVersion <- as.character(NA)
   if(is.null(conceptAgency)) conceptAgency <- as.character(NA)
   if(is.null(conceptSchemeRef)) conceptSchemeRef <- as.character(NA)
+  if(is.null(conceptSchemeVersion)) conceptSchemeVersion <- as.character(NA)
   if(is.null(conceptSchemeAgency)) conceptSchemeAgency <- as.character(NA)
 
   if(is.null(codelist)) codelist <- as.character(NA)
@@ -201,6 +209,7 @@ SDMXDimension <- function(xmlObj, namespaces){
             conceptVersion = conceptVersion,
             conceptAgency = conceptAgency,
             conceptSchemeRef = conceptSchemeRef,
+            conceptSchemeVersion = conceptSchemeVersion,
             conceptSchemeAgency = conceptSchemeAgency,
             codelist = codelist,
             codelistVersion = codelistVersion,

R/SDMXREST21RequestBuilder-methods.R

@@ -85,7 +85,8 @@ SDMXREST21RequestBuilder <- function(regUrl, repoUrl, accessKey = NULL,
       if(is.null(obj@version)) obj@version = "latest"
       req <- sprintf("%s/datastructure/%s/%s/%s/",obj@regUrl, obj@agencyId, obj@resourceId, obj@version)
       if(forceProviderId) req <- paste(req, obj@providerId, sep = "/")
-      req <- paste0(req, "?references=children") #TODO to see later to have arg for this
+      if(is.null(obj@references)) obj@references = "children"
+      req <- paste0(req, "?references=", obj@references)
 
       #require key
       if(!is.null(accessKey)){

R/SDMXRequestParams-methods.R

@@ -5,7 +5,7 @@
 #' @usage
 #'  SDMXRequestParams(regUrl, repoUrl, accessKey,
 #'                    providerId, agencyId, resource, resourceId, version,
-#'                    flowRef, key, start, end, compliant)
+#'                    flowRef, key, start, end, references = NULL, compliant)
 #'
 #' @param regUrl an object of class "character" giving the base Url of the SDMX service registry
 #' @param repoUrl an object of class "character" giving the base Url of the SDMX service repository
@@ -21,22 +21,23 @@
 #' @param key an object of class "character" giving the key (SDMX url formatted) to be used for the query
 #' @param start an object of class "character" giving the start time
 #' @param end an object of class "character" giving the end time
+#' @param references an object of class "character" giving the instructions to return (or not) the artefacts referenced by the artefact to be returned
 #' @param compliant an object of class "logical" indicating if the web-service is compliant with the SDMX REST web-service specifications
 #'             
 #' @examples
 #'   #how to create a SDMXRequestParams object
 #'   params <- SDMXRequestParams(
 #'    regUrl = "", repoUrl ="", accessKey = NULL,
 #'    providerId = "", agencyId ="", resource = "data", resourceId = "",
-#'    version = "", flowRef = "", key = NULL, start = NULL, end = NULL, compliant = FALSE
+#'    version = "", flowRef = "", key = NULL, start = NULL, end = NULL, references = NULL, compliant = FALSE
 #'   )
 #' @export
 #' 
 SDMXRequestParams <- function(regUrl, repoUrl, accessKey, providerId, agencyId, resource, resourceId, version = NULL,
-                              flowRef, key = NULL, start = NULL, end = NULL, compliant){
+                              flowRef, key = NULL, start = NULL, end = NULL, references = NULL, compliant){
   new("SDMXRequestParams",
       regUrl = regUrl, repoUrl = repoUrl, accessKey = accessKey, providerId = providerId,
        agencyId = agencyId, resource = resource, resourceId = resourceId, version = version,
-       flowRef = flowRef, key = key, start = start, end = end)
+       flowRef = flowRef, key = key, start = start, end = end, references = references)
 }
 

R/SDMXServiceProvider-methods.R

@@ -168,7 +168,14 @@ setSDMXServiceProviders <- function(){ # nocov start
     builder = SDMXREST21RequestBuilder(
       regUrl = "https://api.imf.org/external/sdmx/2.1",
       repoUrl = "https://api.imf.org/external/sdmx/2.1",
-      compliant = TRUE)
+      compliant = TRUE,
+      formatter = list(
+        datastructure = function(obj){
+          if(is.null(obj@references)) obj@references = "descendants"
+          return(obj)
+        }
+      )
+    )
   )
 
   #OECD

R/readSDMX.R

@@ -7,7 +7,7 @@
 #'   provider = NULL, providerId = NULL, providerKey = NULL,
 #'   agencyId = NULL, resource = NULL, resourceId = NULL, version = NULL,
 #'   flowRef = NULL, key = NULL, key.mode = "R", start = NULL, end = NULL, dsd = FALSE,
-#'   headers = list(), validate = FALSE,
+#'   headers = list(), validate = FALSE, references = NULL,
 #'   verbose = !is.null(logger), logger = "INFO", ...)
 #'                 
 #' @param file path to SDMX-ML document that needs to be parsed
@@ -48,6 +48,8 @@
 #'        Recognized if a valid provider or provide id has been specified as argument.
 #' @param end an object of class "integer" or "character" giving the SDMX end time to apply. 
 #'        Recognized if a valid provider or provide id has been specified as argument.
+#' @param references an object of class "character" giving the instructions to return (or not) the
+#'        artefacts referenced by the artefact to be returned.
 #' @param dsd an Object of class "logical" if an attempt to inherit the DSD should be performed.
 #'        Active only if \code{"readSDMX"} is used as helper method (ie if data is fetched using 
 #'        an embedded service provider. Default is FALSE
@@ -138,7 +140,7 @@ readSDMX <- function(file = NULL, isURL = TRUE, isRData = FALSE,
                      provider = NULL, providerId = NULL, providerKey = NULL,
                      agencyId = NULL, resource = NULL, resourceId = NULL, version = NULL,
                      flowRef = NULL, key = NULL, key.mode = "R", start = NULL, end = NULL, dsd = FALSE,
-                     headers = list(), validate = FALSE,
+                     headers = list(), validate = FALSE, references = NULL,
                      verbose = !is.null(logger), logger = "INFO", ...) {
 
   #logger
@@ -203,8 +205,10 @@ readSDMX <- function(file = NULL, isURL = TRUE, isRData = FALSE,
                        key = key,
                        start = start,
                        end = end,
+                       references = references,
                        compliant = provider@builder@compliant
                      )
+
     #formatting requestParams
     requestFormatter <- provider@builder@formatter
     requestParams <- switch(resource,
@@ -451,8 +455,10 @@ readSDMX <- function(file = NULL, isURL = TRUE, isRData = FALSE,
 
       if(resource == "data"){
         dsdObj <- readSDMX(providerId = providerId, providerKey = providerKey,
-                           resource = "datastructure", resourceId = dsdRef, headers = headers,
-                           verbose = verbose, logger = logger, ...)
+                          resource = "datastructure", resourceId = dsdRef, headers = headers,
+                          verbose = verbose, references = references, logger = logger, ...)
+
+
         if(is.null(dsdObj)){
           log$WARN(sprintf("Impossible to fetch DSD for dataset '%s'", flowRef))
         }else{
@@ -463,7 +469,7 @@ readSDMX <- function(file = NULL, isURL = TRUE, isRData = FALSE,
         dsdObj <- lapply(1:length(dsdRef), function(x){
           flowDsd <- readSDMX(providerId = providerId, providerKey = providerKey,
                               resource = "datastructure", resourceId = dsdRef[[x]], headers = headers,
-                              verbose = verbose, logger = logger, ...)
+                              verbose = verbose, references = references, logger = logger, ...)
           if(is.null(flowDsd)){
             log$INFO(sprintf("Impossible to fetch DSD for dataflow '%s'",resourceId))
           }else{