Merge pull request #139 from mountainMath/v0.4.4

fix problem with metadata parsing and table names and add convenience functions for cache management

Author: mountainMath

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: cansim
 Type: Package
 Title: Accessing Statistics Canada Data Table and Vectors
-Version: 0.4.3
+Version: 0.4.4
 Authors@R: c(
     person("Jens", "von Bergmann", email = "jens@mountainmath.ca", role = c("aut","cre")),
     person("Dmitry", "Shkolnik", email = "shkolnikd@gmail.com", role = c("aut")))

NAMESPACE

@@ -39,6 +39,8 @@ export(remove_cansim_cached_tables)
 export(remove_cansim_sqlite_cached_table)
 export(search_cansim_cubes)
 export(search_cansim_tables)
+export(set_cansim_cache_path)
+export(show_cansim_cache_path)
 export(view_cansim_webpage)
 import(dplyr)
 importFrom(purrr,map)

NEWS.md

@@ -1,9 +1,14 @@
+# cansim 0.4.4
+## Minor changes
+* fix a problem with metadata parsing does not work properly for table names
+* make documentations more consistent wrt default langauge names
+* add convenience functions for setting cache paths for data accessed via get_cansim_connection
+
 # cansim 0.4.3
 ## Minor changes
 * better handling of duplicated levels in metadata, ignore duplication for geography names of census tables but emit warning
 * fix issue with accessing tables without footnotes
 
-
 # cansim 0.4.2
 ## Minor changes
 * ensure proper ordering of levels even if StatCan metadata is not ordered

R/cansim.R

@@ -254,7 +254,7 @@ cansim_old_to_new <- function(oldCansimTableNumber){
     filter(.data$CANSIM_ID == as.integer(cleaned_number)) %>%
     pull(.data$PRODUCT_ID)
   if (identical(new_number, integer(0))) {
-    stop(paste0("Unable to match old CANSIM table number ",cleaned_number))
+    stop(paste0("Unable to match old CANSIM table number ",cleaned_number),call.=FALSE)
   }
   n=as.character(new_number)
   new_table <- paste0(substr(n,1,2),"-",substr(n,3,4),"-",substr(n,5,8))
@@ -746,7 +746,7 @@ get_cansim_column_categories <- function(cansimTableNumber, column, language="en
       dplyr::pull(!!as.name(dimension_id_column))
     data_path <- paste0(base_path_for_table_language(cleaned_number,language),".Rda_column_",column_index)
     if (!file.exists(data_path)){
-      stop(paste0("Unkown column ",column))
+      stop(paste0("Unkown column ",column),call.=FALSE)
     }
     result <- readRDS(file=data_path)
   } else {
@@ -781,7 +781,7 @@ get_cansim_column_categories <- function(cansimTableNumber, column, language="en
                     exceeded_hierarchy_warning_message=exceeded_hierarchy_warning_message)
 
     if (nrow(result)==0){
-      stop(paste0("Unkown column ",column))
+      stop(paste0("Unkown column ",column),call.=FALSE)
     }
   }
 
@@ -930,7 +930,7 @@ get_cansim_table_url <- function(cansimTableNumber, language = "en"){
   url=paste0("https://www150.statcan.gc.ca/t1/wds/rest/getFullTableDownloadCSV/",naked_ndm_table_number(cansimTableNumber),"/",l)
   response <- httr::GET(url)
   if (response$status_code!=200) {
-    stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response))
+    stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response),call.=FALSE)
   }
   httr::content(response)$object
 }
@@ -956,7 +956,7 @@ get_cansim_changed_tables <- function(start_date,end_date=NULL){
     last_available_date = last_available_date  -1
   }
   if (start_date>last_available_date) {
-    stop(paste0("Last available date is ",last_available_date,", please try with a start date on or before that date."))
+    stop(paste0("Last available date is ",last_available_date,", please try with a start date on or before that date."),call.=FALSE)
   }
   if (is.null(end_date)) end_date=start_date
   if (as.Date(end_date) > last_available_date) {
@@ -977,7 +977,7 @@ get_cansim_changed_tables <- function(start_date,end_date=NULL){
       url=paste0("https://www150.statcan.gc.ca/t1/wds/rest/getChangedCubeList/",strftime(date,"%Y-%m-%d"))
       response <- httr::GET(url)
       if (response$status_code!=200) {
-        stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response))
+        stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response),call.=FALSE)
       }
       httr::content(response)$object %>%
         map(function(o)tibble(productId=o$productId,releaseTime=o$releaseTime)) %>%

R/cansim_helpers.R

@@ -41,7 +41,7 @@ table_base_path <- function(cansimTableNumber) {
 
 file_path_for_table_language <- function(cansimTableNumber, language){
   language <- cleaned_ndm_language(language)
-  if (is.na(language)) stop(paste0("Unkown Lanaguage ",language))
+  if (is.na(language)) stop(paste0("Unkown Lanaguage ",language),call.=FALSE)
   base_table <- naked_ndm_table_number(cansimTableNumber)
   file.path(paste0(base_table,"-",language))
 }
@@ -91,7 +91,7 @@ get_with_timeout_retry <- function(url,timeout=200,retry=3,path=NA,warn_only=FAL
            "Statistics Canada has a history of failty SSL certificats on their API,\n",
            "if you are reasonably sure that your connection is not getting hijacked you\n",
            "can disable peer checking for the duration of the R session by typing\n\n",
-           "httr::set_config(httr::config(ssl_verifypeer=0,ssl_verifystatus=0))","\n\n","into the console.")
+           "httr::set_config(httr::config(ssl_verifypeer=0,ssl_verifystatus=0))","\n\n","into the console.",call.=FALSE)
     }
     if (retry>0) {
       message("Got timeout from StatCan, trying again")
@@ -141,7 +141,7 @@ post_with_timeout_retry <- function(url,body,timeout=200,retry=3,warn_only=FALSE
            "Statistics Canada has a history of failty SSL certificats on their API,\n",
            "if you are reasonably sure that your connection is not getting hijacked you\n",
            "can disable peer checking for the duration of the R session by typing\n\n",
-           "httr::set_config(httr::config(ssl_verifypeer=0,ssl_verifystatus=0))","\n\n","into the console.")
+           "httr::set_config(httr::config(ssl_verifypeer=0,ssl_verifystatus=0))","\n\n","into the console.",call.=FALSE)
     }
     if (retry>0) {
       message("Got timeout from StatCan, trying again")
@@ -185,23 +185,6 @@ short_prov.en <- c(
   "Canada"="CAN"
 )
 
-# short_prov.fr <- c(
-#   "Colombie-Britannique"="BC",
-#   "Alberta"="AB",
-#   "Saskatchewan"="SK",
-#   "Manitoba"="MB",
-#   "Ontario"="ON",
-#   "Qu\U00E9bec"="QC",
-#   "Nouveau-Brunswick"="NB",
-#   "\u00CEle-du-Prince-\U00C9douard"="PE",
-#   "Nouvelle-\U00C9cosse"="NS",
-#   "Terre-Neuve-et-Labrador"="NL",
-#   "Yukon"="YT",
-#   "Territoires du Nord-Ouest"="NT",
-#   "Nunavut"="NU",
-#   "Territoires du Nord-Ouest incluant Nunavut"="NTNU",
-#   "Canada"="CAN"
-# )
 
 short_prov.fr <- setNames(c(
   "BC",
@@ -290,7 +273,7 @@ get_cansim_code_set <- function(code_set=c("scalar", "frequency", "symbol", "sta
                                 refresh=FALSE){
   code_sets <- c("scalar", "frequency", "symbol", "status", "uom", "survey",  "subject", "wdsResponseStatus")
   if (length(code_set)!=1 | !(code_set %in% code_sets)) {
-    stop(paste0("Invalid code set, code_set must be one of ",paste0(code_sets,collapse=", ")))
+    stop(paste0("Invalid code set, code_set must be one of ",paste0(code_sets,collapse=", ")),call.=FALSE)
   }
   path=file.path(tempdir(),"cansim_code_sets.Rmd")
   if (refresh | !file.exists(path)) {
@@ -301,7 +284,7 @@ get_cansim_code_set <- function(code_set=c("scalar", "frequency", "symbol", "sta
       saveRDS(content,path)
     } else {
       warning("Problem downloading code sets.")
-      stop(httr::content(r))
+      stop(httr::content(r),call.=FALSE)
     }
   } else {
     content <- readRDS(path)
@@ -410,7 +393,7 @@ format_file_size <- function (x, units = "b", standard = "auto", digits = 1L, ..
       else if (endsWith(units, "b"))
         standard <- "legacy"
       else if (units == "kB")
-        stop("For SI units, specify 'standard = \"SI\"'")
+        stop("For SI units, specify 'standard = \"SI\"'",call.=FALSE)
     }
   }
   base <- known_bases[[standard]]
@@ -426,7 +409,7 @@ format_file_size <- function (x, units = "b", standard = "auto", digits = 1L, ..
       1L
     if (is.na(power))
       stop(gettextf("Unit \"%s\" is not part of standard \"%s\"",
-                    sQuote(units), sQuote(standard)), domain = NA)
+                    sQuote(units), sQuote(standard)), domain = NA,call.=FALSE)
   }
   unit <- units_map[power + 1L]
   if (power == 0 && standard == "legacy")
@@ -579,5 +562,19 @@ normalize_coordinates <- function(coordinates){
 
 }
 
-
+get_robust_cache_path <- function(cache_path) {
+  if (is.null(cache_path) || cache_path=="") {
+    cache_path <- Sys.getenv("CANSIM_CACHE_PATH")
+    if (cache_path=="") cache_path <- getOption("cansim.cache_path",default="")
+    if (cache_path=="") {
+      cache_path <- file.path(tempdir(),"cansim_cache")
+      if (!dir.exists(cache_path)) dir.create(cache_path)
+      message(cansim_no_cache_path_message)
+    }
+  }
+  if (!dir.exists(cache_path)) {
+    stop("Cache path ",cache_path," does not exist, please create it first.",call.=FALSE)
+  }
+  cache_path
+}
 

R/cansim_metadata.R

@@ -39,14 +39,22 @@ parse_metadata <- function(meta,data_path){
       if (length(grep("\u201C|\u201D",meta_part))>0){
         meta_part <- meta_part %>% gsub("\u201C|\u201D",'"',x=.)
       }
-      utils::read.delim(text=meta_part,sep=table_delim,header=TRUE,stringsAsFactors=FALSE,
+      d<-utils::read.delim(text=meta_part,sep=table_delim,header=FALSE,stringsAsFactors=FALSE,
                         quote="\"",na.strings="",
                  colClasses="character",check.names=FALSE) %>%
         as_tibble()
+      if (nrow(d>1)) {
+        nn <- as.character(d[1,])
+        d <- d %>%
+          select(which(!is.na(nn))) %>%
+          setNames(na.omit(nn)) %>%
+          slice(-1)
+      }
     } else {
-      suppressWarnings(readr::read_delim(paste0(meta_part,collapse="\n"),
+      d<- suppressWarnings(readr::read_delim(paste0(meta_part,collapse="\n"),
                                          delim=table_delim, col_types = readr::cols(.default="c")))
     }
+    d
   }
 
   read_notes <- function(meta_part) {
@@ -156,7 +164,7 @@ add_hierarchy <- function(meta_x,parent_member_id_column,member_id_column,hierar
 get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh=FALSE){
   type <- type[1]
   if (!(type %in% c("overview", "members", "notes", "corrections"))) {
-    stop("type must be one of 'overview', 'members', 'notes', or 'corrections'")
+    stop("type must be one of 'overview', 'members', 'notes', or 'corrections'",call.=FALSE)
   }
   tmp_base <- table_base_path(cansimTableNumber)
   if (!dir.exists(tmp_base)) dir.create(tmp_base)
@@ -172,7 +180,7 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh=
                            httr::add_headers("Content-Type"="application/json")
     )
     if (response$status_code!=200) {
-      stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response))
+      stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response),call.=FALSE)
     }
     data <- httr::content(response)
     data1 <- Filter(function(x)x$status=="SUCCESS",data)
@@ -336,7 +344,7 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh=
 #' get_cansim_table_template("34-10-0013")
 #' }
 #' @export
-get_cansim_table_template <- function(cansimTableNumber, language="eng",refresh=FALSE){
+get_cansim_table_template <- function(cansimTableNumber, language="english",refresh=FALSE){
   cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber)
   member_info <- get_cansim_cube_metadata(cansimTableNumber, type="members", refresh=refresh)
 
@@ -430,7 +438,7 @@ get_cansim_series_info_cube_coord <- function(cansimTableNumber,coordinates, tim
                              httr::timeout(timeout)
       )
       if (response$status_code!=200) {
-        stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response))
+        stop("Problem downloading data, status code ",response$status_code,"\n",httr::content(response),call.=FALSE)
       }
       data <- httr::content(response)
       data1 <- Filter(function(x)x$status=="SUCCESS",data)
@@ -477,14 +485,14 @@ get_cansim_series_info_cube_coord <- function(cansimTableNumber,coordinates, tim
 add_cansim_vectors_to_template <- function(template, refresh=FALSE) {
 
   if (!("cansimTableNumber" %in% names(template))) {
-    stop("The template does not have a cansimTableNumber column.")
+    stop("The template does not have a cansimTableNumber column.",call.=FALSE)
   }
   if (!("COORDINATE" %in% names(template))) {
-    stop("The template does not have a COORDINATE column.")
+    stop("The template does not have a COORDINATE column.",call.=FALSE)
   }
 
   if (nrow(template)==0) {
-    stop("No rows in the template.")
+    stop("No rows in the template.",call.=FALSE)
   }
 
   tnr <- unique(template$cansimTableNumber)