File: SDMXCodelists-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 (111 lines) | stat: -rw-r--r-- 3,837 bytes parent folder | download | duplicates (3)
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));