add support for sdmx parsing

this is the first step to resolving
#27 by adding a function that creates
sc_table() like objects based on sdmx
archives

The sdmx format contains all metadata
that is necessary for STATcubeR to reuse
the existing $tabulate() workflow and this
first version already provides support for
various features via the base class (sc_data)

- $tabulate() to aggregate data
- $total_codes() to set/unset total codes
- $recoder to recode datasets (change labels)
  change codes, toggle visibility of
  elements, reorder elements, etc.
- importing german and english labels
  simultaniously (both languages are included
  in a zip download) and allowing to swhitch
  between them using $language<-().

New features
- sdmx arcives provide a $parent column
  in the $fields() table which are used
  to represent hierarchical classifications.
  Previously, this was only possible with
  od_table()

There are still some improvements. See
the issue #27 for more details

- properly parse time variables -
  currently they are treated as generic
  categories.
- parse element annotations (detailed
  descriptions for classification
  elements) and add them to
  $field()$de_desc just like with
  OGD dataset
- parse value annotations (see #39)
- provide a print/fromat method
- add a reasonable logic for total
  codes that takes the parent codes into
  account
- fill meta$measures$fun and
  $meta$measures$precision based on
  the sdmx metadata
- modify very long codes which use
  the @-symbol (probably for escapes)
- extend documentation
- possibly check SuperCROSS compability

NAMESPACE

@@ -74,6 +74,7 @@ export(sc_table_custom)
 export(sc_table_saved)
 export(sc_table_saved_list)
 export(sc_tabulate)
+export(sdmx_table)
 importFrom(magrittr,"%<>%")
 importFrom(magrittr,"%>%")
 importFrom(magrittr,"%T>%")

R/sdmx_table.R

@@ -0,0 +1,133 @@
+#' Import data from SDMX
+#'
+#' Function that reads STATcube data from an sdmx archive - a zip file
+#' consisting of `structure.xml` with metadata and `dataset.xml` for the
+#' values.
+#'
+#' @param file a "sdmx archive" file that was downloaded from STATcube.
+#' @return An object of class `sc_data`
+#' @keywords experimental
+#' @export
+sdmx_table <- function(file) {
+  sdmx_read_zip(file) %>%
+    sdmx_as_data_object()
+}
+
+sdmx_read <- function(folder = ".") {
+  list(
+    meta = folder %>% sprintf('%s/structure.xml', .) %>% xml2::read_xml() %>%
+      xml2::xml_ns_strip(),
+    data = folder %>% sprintf('%s/dataset.xml', .) %>% xml2::read_xml() %>%
+      xml2::xml_ns_strip()
+  )
+}
+
+sdmx_read_zip <- function(zip_file) {
+  exdir <- tempfile()
+  dir.create(exdir)
+  on.exit(unlink(exdir, recursive = TRUE))
+  unzip(zipfile = zip_file, exdir = exdir)
+  sdmx_read(exdir)
+}
+
+sdmx_as_raw_df <- function(x) {
+  obs <- x$data %>% xml2::xml_find_all(".//ObsValue") %>%
+    xml2::xml_attr("value") %>% as.numeric()
+  val <- x$data %>% xml2::xml_find_all(".//SeriesKey//Value") %>%
+    xml2::xml_attr("value")
+  # assume that entries of SeriesKey always use the same order
+  val_lab <- x$data %>% xml2::xml_find_first(".//SeriesKey") %>%
+    xml2::xml_find_all(".//Value") %>% xml2::xml_attr("concept")
+  val_split <- split(val, rep(
+    seq_len(length(val)/length(obs)), length(obs)
+  ))
+  names(val_split) <- val_lab
+  n <- which(val_lab == "MEASURES_DIMENSION")
+  obs_split <- split(obs, val_split[[n]])
+  res <- c(
+    lapply(val_split[-n], function(x) {
+      u <- head(x, length(obs_split[[1]]))
+      factor(u, unique(u))
+    }),
+    obs_split
+  ) %>% vctrs::new_data_frame()
+  names(res) <- gsub("F-DATA_", "", names(res))
+  res
+}
+
+sdmx_fields <- function(x) {
+  fields <- x$meta %>%
+    xml2::xml_find_all(".//CodeList[(@id and starts-with(@id, 'C-'))]")
+  lapply(fields, function(field) {
+    names <- xml2::xml_find_all(field, ".//Name") %>%
+      xml2::xml_text()
+    codes <- xml2::xml_find_all(field, "Code")
+    values <- xml2::xml_attr(codes, "value")
+    desc <- codes %>% xml2::xml_find_all("Description") %>%
+      xml2::xml_text()
+    ind_de <- seq(1, length(desc), 2)
+    ind_en <- seq(2, length(desc), 2)
+    parent <- xml2::xml_attr(codes, "parentCode")
+    list(
+      id = field %>% xml2::xml_attr("id"),
+      label_en = names[2],
+      label_de = names[1],
+      elements = vctrs::new_data_frame(list(
+        label = desc[ind_en],
+        code = values,
+        parsed = desc[ind_en],
+        label_de = desc[ind_de],
+        label_en = desc[ind_en],
+        parent = factor(parent, levels = values),
+        de_desc = rep(NA_character_, length(values)),
+        en_desc = rep(NA_character_, length(values))
+      ))
+    )
+  })
+}
+
+sdmx_meta <- function(x) {
+  code_measure <- x$meta %>% xml2::xml_find_all(
+    ".//*[(@id = 'CL_MEASURES_DIMENSION')]/Code") %>% xml2::xml_attr("value")
+  label_measure <- x$meta %>% xml2::xml_find_all(
+    ".//*[(@id = 'CL_MEASURES_DIMENSION')]/Code/Description") %>%
+    xml2::xml_text()
+  code_db <- xml2::xml_find_all(x$meta, ".//ConceptScheme") %>%
+    xml2::xml_attr("id")
+  label_dataset <- x$meta %>% xml2::xml_find_all(".//ConceptScheme/Name") %>%
+    xml2::xml_text()
+  ind_de <- seq(1, length(label_measure), 2)
+  ind_en <- seq(2, length(label_measure), 2)
+  list(
+    source = data_frame(label = label_dataset[2], code = code_db,
+                          lang = "en", label_de = label_dataset[1],
+                          label_en = label_dataset[2]),
+    measures = data_frame(
+      label = label_measure[ind_en],
+      code = code_measure,
+      label_de = label_measure[ind_de],
+      label_en = label_measure[ind_en],
+      NAs = rep(0, length(code_measure))
+    )
+  )
+}
+
+sdmx_as_data_object <- function(x) {
+  df <- sdmx_as_raw_df(x)
+  fields <- sdmx_fields(x)
+  meta <- sdmx_meta(x)
+  meta$fields <- data_frame(
+    code = vapply(fields, function(x) x$id, ""),
+    label = vapply(fields, function(x) x$label_en, "") ,
+    label_de = vapply(fields, function(x) x$label_de, ""),
+    label_en = vapply(fields, function(x) x$label_en, ""),
+    total_code = rep(NA, length(fields)),
+    nitems = sapply(fields, function(x) {nrow(x$elements)}),
+    type = rep("Category", length(fields))
+  )
+  fields2 <- lapply(fields, function(x) x$elements)
+  names(df) <- c(meta$fields$code, meta$measures$code)
+  y <- sc_data$new(df, meta, fields2)
+  y$language <- "en"
+  y
+}