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
|
#' @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){
ds <- slot(slot(dsd,"datastructures"), "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
#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) && !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)
})
|
