File: SDMXData-methods.R

package info (click to toggle)
r-cran-rsdmx 1%3A0.5-13%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 984 kB
  • sloc: makefile: 2
file content (147 lines) | stat: -rw-r--r-- 4,621 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
#' @name SDMXData
#' @rdname SDMXData
#' @aliases SDMXData,SDMXData-method
#' 
#' @usage
#' SDMXData(xmlObj, namespaces)
#' 
#' @param xmlObj object of class "XMLInternalDocument derived from XML package
#' @param namespaces object of class "data.frame" given the list of namespace URIs
#' 
#' @return an object of class "SDMXData"
#' 
#' @seealso \link{readSDMX}
#'
SDMXData <- function(xmlObj, namespaces){
  
  sdmxObj <- SDMX(xmlObj, namespaces)
  dsdRef <- dsdRef.SDMXData(xmlObj, namespaces)
  dsd <- NULL
  if(!is.null(dsdRef)){
    dsd <- NULL
  }
  
  new("SDMXData",
      sdmxObj,
      dsdRef = dsdRef,
      dsd = dsd
  )  	
}

#get DSD REF
#===========
dsdRef.SDMXData <- function(xmlObj, namespaces){
  
  sdmxVersion <- version.SDMXSchema(xmlObj, namespaces)
  
  dsXML <- xmlChildren(xmlChildren(xmlObj)[[1]])$DataSet
  dsdRef <- switch(sdmxVersion,
    "1.0" = NULL, #TODO
    "2.0" = {
      ref <- NULL
      xml <- xmlChildren(dsXML)
      xmlNames <- names(xml)
      if("KeyFamilyRef" %in% xmlNames){
        keyFamilyRef <- xml$KeyFamilyRef
        ref <- xmlValue(keyFamilyRef)
      }
      ref
    },
    "2.1" = xmlGetAttr(dsXML,"structureRef")
  )
  return(dsdRef)
}

#ENRICH DATA WITH LABELS
#=======================
addLabels.SDMXData <- function(data, dsd){
  
  #try to inherit datastructure components
  components <- NULL
  datastructures <- slot(slot(dsd,"datastructures"), "datastructures")
  if(length(datastructures)>0){
    ds <- datastructures[[1]]
    components <- slot(ds, "Components")
    components <- as.data.frame(components)
  }
    
  #function to enrich a column with its labels
  enrichColumnWithLabels <- function(column, data, dsd, components){
    datac <- as.data.frame(data[,column], stringsAsFactors = FALSE)
    colnames(datac) <- column
    
    #grab codelist name
    clName <- NULL
    if(!is.null(components)){
      #try to grab codelist using concepts
      clMatcher <- components$conceptRef == column
      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"]
        if(length(clName)>1) clName <- clName[1]
      }
      
      if(length(clName)>0 && !is.na(clName)){
        #additional check in case codelist would not be specified in DSD
        codelists <- sapply(slot(slot(dsd,"codelists"), "codelists"), slot, "id")
        if(!(clName %in% codelists)){
          clName <- NULL
        }
      }

    }else{
      #no components, take the column name as codelistId
      codelists <- sapply(slot(slot(dsd,"codelists"), "codelists"), slot, "id")
      if(column %in% codelists){
        clName <- column
      }
    }
    
    if(length(clName) != 0 && !is.na(clName) && !is.null(clName)){
      cl <- as.data.frame(slot(dsd, "codelists"), codelistId = clName)
      datac$order <- seq(len=nrow(datac))
      datac = merge(x = datac, y = cl, by.x = column, by.y = "id",
                    all.x = TRUE, all.y = FALSE, sort = FALSE)
      datac <- datac[sort.list(datac$order),]
      datac$order <- NULL
      datac <- datac[,((regexpr("label", colnames(datac)) != -1) + 
                         (colnames(datac) == column) == 1)]
      colnames(datac)[regexpr("label",colnames(datac)) != -1] <- paste0(column,
      "_",colnames(datac)[regexpr("label",colnames(datac)) != -1])
    }

    return(datac)  
  }
  
  fulldata <- do.call("cbind" ,lapply(colnames(data), enrichColumnWithLabels,
                                      data, dsd, components))
  return(fulldata)
}


#' @name setDSD
#' @docType methods
#' @aliases setDSD,SDMXData-method
#' @title setDSD
#' @description set the 'dsd' slot of a \code{SDMXData} object
#' @usage setDSD(obj, dsd)
#' 
#' @param obj An object deriving from class "SDMXData"
#' @param dsd An object of class "SDMXDataStructureDefinition"
#' @return the 'obj' object of class "SDMXData" enriched with the dsd
#'
#' @seealso \link{SDMXData-class}
#'
#' @author Emmanuel Blondel, \email{emmanuel.blondel1@@gmail.com}

if (!isGeneric("setDSD"))
  setGeneric("setDSD", function(obj, dsd) standardGeneric("setDSD"));

#' @describeIn setDSD
setMethod(f = "setDSD", signature = "SDMXData", function(obj, dsd){
  slot(obj, "dsd") <- dsd
  return(obj)
})