odata.rmd

## Functions related to OData
### Libraries and constants
```{r eval=F}
library(magrittr)
library(dplyr)
library(curl)
library(XML)

std_namespaces = c(ns="http://www.w3.org/2005/Atom",
  m="http://schemas.microsoft.com/ado/2007/08/dataservices/metadata",
  d="http://schemas.microsoft.com/ado/2007/08/dataservices") 
```

### **get_cbs_data** 
This function passes a request for data to the CBS OData server
```{r eval=F}
get_cbs_data <- function (url, query=NULL, save_file_name = NULL) {
  # query  = "?$format=atom&$filter=GeneesmiddelengroepATC eq '100000'"
  if (!is.null(url)) {
    f  = paste0(url,query)
  } else{
    f  = url
  }
  f  = URLencode(f)
  r  = curl_fetch_memory(f)
  x  = rawToChar(r$content)
  doc = xmlParse(x,asText =T)
  if (!is.null(save_file_name)) {
    saveXML(doc, save_file_name)
  }
  return(doc)
}

```
### **get_cbs_table_info** 
This function returns a named character vector with the urls of the sub tables. When it is e.g used as  
 *table_list = get_cbs_table_info(get_cbs_data("http://opendata.cbs.nl/ODataFeed/OData/82935NED"))*  
one can use *table_list['DataProperties']* and *table_list['TableInfos']* as references to two of its sub tables.
```{r eval=F}
get_cbs_table_info <- function(doc) {
  m1    = xpathSApply(doc,"//@href/..", 
    function(x) c(xmlValue(x), xmlAttrs(x)[["href"]]))
  hrefs = m1[2,]
  names(hrefs) =m1[1,]
  return(hrefs)
}
```
### Get information from the XML structure
The function **copy_table** calls the **get_cbs_data** function to get the data from the CBS server and extracts the information from the XML structure. How the information is to be extracted is specified by the *mt* parameter. It can point to the **prop_table_fun** function (for the *DataProperties* sub table) or to the **data_table_fun** function for the other (rectangular) sub tables. In the default case the full XML structure is returned. \newline 
When the data needs to be read in more than one call of **get_cbs_data** later parts are not written to an xml file and when no value was given for *mt* the later parts are skipped because there is no obvious way to concatenate xml structures.
```{r eval=F}
copy_table <- function (dsn,  mt = NULL, query= NULL, save_XML = NULL) {
  n1 = paste0('temp_', names(dsn))
  if (is.null(save_XML)) {
    save_file_name = NULL
  } else if (nchar(save_XML) == 0) {
    save_file_name = paste0(n1, '.xml')
  } else {
    save_file_name = save_XML
  }
  t1    = get_cbs_data(dsn, query, save_file_name = save_file_name)
  if (is.null(mt))
    return(t1)
  t1d = mt(t1)
  next1 = xpathSApply(t1,"//ns:link[@rel='next']",
    function(x) xmlAttrs(x)[["href"]],
    namespaces = std_namespaces)
  while (length(next1)> 0 ) {
    t1    = get_cbs_data(next1) # no save for part2 and later
    t1d   = rbind(t1d,t1d = mt(t1))
    next1 = xpathSApply(t1,"//ns:link[@rel='next']",
      function(x) xmlAttrs(x)[["href"]],
      namespaces = std_namespaces)
  }
  return(t1d)
}

data_table_fun <- function(doc) {
  t1n <- xpathApply(doc,
    '//ns:entry[1]//m:properties[1]/d:*',
    xmlName,
    namespaces = std_namespaces)
  t1d  = xpathSApply(doc, '//m:properties/d:*',xmlValue)
  t1d  = as.data.frame(matrix(t1d, ncol = length(t1n), byrow = T),
    stringsAsFactors =F)
  names(t1d) = t1n
  return(t1d)
}

prop_table_fun <- function(doc) {
  m     = xpathSApply(doc, '//m:properties/d:*',
    function(x)
      c(
        xpathSApply(xmlParent(x), './d:ID', xmlValue, namespaces = std_namespaces),
        xmlName(x),
        xmlValue(x)
      ))
  # m matrix: r1 number; r2 field ; r3 value
  uf    = unique(m[2, ])
  # "ID" "Position" "ParentID" "Type" "Key" "Title" "Description" "ReleasePolicy"
  # "Datatype" "Unit" "Decimals" "Default"
  nc    = length(uf)
  nr    = 1+max(as.numeric(m[1, ]))
  m2 = matrix(rep('', nr * nc), nrow = nr, ncol = nc)
  for (i in 1:nr) {
    m3 = m[, m[1, ] == paste(i-1)] # counting origin=0
    ix = match(m3[2, ], uf)
    m2[i, ix] = m3[3, ]
  }
  colnames(m2) = uf
  rownames(m2) = 1:nr
  as.data.frame(m2,stringsAsFactors =F)
}
```
### **couple_data**
The **couple_data** function takes a coded data.frame, converts all topic variables to numeric and decodes all dimensions with the aid of **couple_data_dim**. The coded *RegionS* dimension is allways kept under the name  *RegionS_coded*.
```{r eval=F}
couple_data <- function(
  df,        # data.frame with coded dimensions (e.g. read by copy_table)
  dv,        # character vector with the names of the dimensions
  tv,        # character vector with the names of the topics
  table_list # named vector with urls of sub tables 
             # (e.g. read by get_cbs_table_info)
  ) {
  tt = df %>% 
    mutate_each_(funs(as.numeric),tv$Key)  #topics -> numeric
  for (dim in dv$Key)  {
    if (dim == c('RegioS') ) {
      tt = couple_data_dim(tt, table_list['RegioS'],keep_code=T) # link RegioS
    } else {
      tt = couple_data_dim(tt, table_list[dim],keep_code=F) # link other dimensions
    }
  }
  return(tt)
}

couple_data_dim <- function(tt, dsn, keep_code=F) {
  dim  = names(dsn)
  tab1 = copy_table(dsn, data_table_fun) %>%
    select(Key, Title) %>%
    rename_(.dots = setNames('Title', paste0(dim, '_decode')))
  by1  = c('Key') ; names(by1) = dim
  tt = tt %>%
    inner_join(tab1, by = by1) %>%
    rename_(.dots = setNames(dim, paste0(dim, '_coded'))) %>%
    rename_(.dots = setNames(paste0(dim, '_decode'), dim))
  if (keep_code == F) {
    tt = tt %>%
      select_(.dots = setdiff(names(.), paste0(dim, '_coded')))
  }
  return(tt)
}
```
### Functions to produce the topics and dimensions
The **topic_vars** and **dim_vars** functions return a data.frame with resp. the names of the topics and the dimensions.
```{r eval=F}
topic_vars <- function(props) 
  props %>%
  filter(Type=='Topic') %>%
  select(Key)

dim_vars <- function(props) {
  props %>%
    filter(Type %in% c('Dimension','TimeDimension','GeoDimension')) %>%
    select(Key)
}
```