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
|
#' @name SDMXCodelists
#' @rdname SDMXCodelists
#' @aliases SDMXCodelists,SDMXCodelists-method
#'
#' @usage
#' SDMXCodelists(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 "SDMXCodelists"
#'
#' @seealso \link{readSDMX}
#'
SDMXCodelists <- function(xmlObj, namespaces){
new("SDMXCodelists",
SDMX(xmlObj, namespaces),
codelists = codelists.SDMXCodelists(xmlObj, namespaces)
)
}
#get list of SDMXCodelist
#=======================
codelists.SDMXCodelists <- function(xmlObj, namespaces){
codelists <- NULL
messageNsString <- "message"
if(isRegistryInterfaceEnvelope(xmlObj, FALSE)) messageNsString <- "registry"
messageNs <- findNamespace(namespaces, messageNsString)
strNs <- findNamespace(namespaces, "structure")
sdmxVersion <- version.SDMXSchema(xmlObj, namespaces)
VERSION.21 <- sdmxVersion == "2.1"
codelistsXML <- NULL
if(VERSION.21){
codelistsXML <- getNodeSet(xmlObj,
"//mes:Structures/str:Codelists/str:Codelist",
namespaces = c(mes = as.character(messageNs),
str = as.character(strNs)))
}else{
codelistsXML <- getNodeSet(xmlObj,
"//mes:CodeLists/str:CodeList",
namespaces = c(mes = as.character(messageNs),
str = as.character(strNs)))
}
if(!is.null(codelistsXML)){
codelists <- lapply(codelistsXML, SDMXCodelist, namespaces)
}
return(codelists)
}
#as.data.frame
#=============
as.data.frame.SDMXCodelists <- function(x, ...,
codelistId = NULL,
ignore.empty.slots = TRUE){
xmlObj <- x@xmlObj;
codes <- NULL
if(length(x@codelists) == 0) return(codes)
codelist <- NULL
if(length(x@codelists) > 1){
if(is.null(codelistId)){
warning("Using first codelist referenced in SDMXCodelists object: \n
Specify 'codelistId' argument for a specific codelist")
codelist <- x@codelists[[1]]
}else{
selectedCodelist <- NULL
for(i in 1:length(x@codelists)){
cl <- x@codelists[[i]]
if(cl@id == codelistId){
selectedCodelist <- cl
}
}
codelist <- selectedCodelist
}
}else{
codelist <- x@codelists[[1]]
}
codesList <- codelist@Code
if(!is.null(codesList)){
codes <- do.call("rbind.fill",
lapply(codesList, function(code){
fields <- sapply(slotNames(code), function(x){
obj <- slot(code,x)
if(length(obj)>0) return(obj)
})
fields <- fields[!sapply(fields, is.null)]
fnames <- names(fields)
fields <- as.data.frame(fields, stringsAsFactors = FALSE)
if(length(fnames)==length(colnames(fields))){
colnames(fields)[4:length(fnames)] <- paste(fnames[4:length(fnames)],
sapply(strsplit(colnames(fields)[4:length(fnames)], ".", fixed=T), function(x){x[[1]]}), sep=".")
}
return(fields)
})
)
}
if(ignore.empty.slots){
codes <- codes[,colSums(is.na(codes))<nrow(codes)]
}
return(encodeSDMXOutput(codes))
}
setAs("SDMXCodelists", "data.frame",
function(from) as.data.frame.SDMXCodelists(from));
|
