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 set the 'dsd' slot of a \code{SDMXData} object
setMethod(f = "setDSD", signature = "SDMXData", function(obj, dsd){
slot(obj, "dsd") <- dsd
return(obj)
})
|
