add ability to get code sets and fold into cansim cube list

Author: mountainMath

NAMESPACE

@@ -6,6 +6,7 @@ export(cansim_old_to_new)
 export(categories_for_level)
 export(get_cansim)
 export(get_cansim_changed_tables)
+export(get_cansim_code_set)
 export(get_cansim_column_categories)
 export(get_cansim_column_list)
 export(get_cansim_cube_metadata)

R/cansim_helpers.R

@@ -175,6 +175,11 @@ short_prov.fr <- purrr::set_names(c(
 #' @export
 #' @param data code{cansim} package data frame with provincial level data
 #' @return a code{cansim} package data frame with additional factor GEO.abb that contains language-specific provincial abbreviations
+#'
+#' @examples
+#' df <- get_cansim("17-10-0005")
+#' df <- add_provincial_abbreviations(df)
+#'
 add_provincial_abbreviations <- function(data){
   cleaned_language <- ifelse("VALEUR" %in% names(data),"fra","eng")
   if (cleaned_language=="eng") {
@@ -187,3 +192,42 @@ add_provincial_abbreviations <- function(data){
   data <- data %>%
     mutate(GEO.abb=factor(as.character(short_prov[!!as.name(data_geography_column)]), levels=c("CAN","BC","AB","SK","MB","ON","QC","NB","PE","NS","NL","YT","NT","NU","NTNU")))
 }
+
+
+#' Get NDM code sets
+#'
+#' Useful to get a list of surveys  or subjects and used internally
+#' @export
+#' @param code_set the code set to retrieve.
+#' @param refresh Default is \code{FALSE}, repeated calls during the same session will hit the cached data.
+#' To refresh the code list during a running R session set to \code{TRUE}
+#' @return a tibble with english and french labels for the given code set
+#'
+#' @examples
+#' get_cansim_code_set("survey")
+#'
+get_cansim_code_set <- function(code_set=c("scalar", "frequency", "symbol", "status", "uom", "survey",  "subject", "wdsResponseStatus"),
+                                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=", ")))
+  }
+  path=file.path(tempdir(),"cansim_code_sets.Rmd")
+  if (refresh | !file.exists(path)) {
+    url='https://www150.statcan.gc.ca/t1/wds/rest/getCodeSets'
+    r<-get_with_timeout_retry(url)
+    if (r$status_code==200) {
+      content <- httr::content(r)
+      saveRDS(content,path)
+    } else {
+      warning("Problem downloading code sets.")
+      stop(httr::content(r))
+    }
+  } else {
+    content <- readRDS(path)
+  }
+  m<-do.call(rbind, content$object[[code_set]])
+  m[m=="NULL"] <- NA
+  as_tibble(m) %>%
+    mutate_all(unlist)
+}

R/cansim_tables_list.R

@@ -225,6 +225,8 @@ list_cansim_cubes <- function(lite=FALSE,refresh=FALSE){
             purrr::map(dimensions[[1]],function(a)a$dimensionNameFr) %>% paste0(collapse=", "))
         })
       }
+      surveys <- get_cansim_code_set("survey")
+      subjects <- get_cansim_code_set("subject")
       data <- lapply(dd,function(d)d$value) %>%
         do.call(rbind,.) %>%
         as_tibble() %>%
@@ -233,27 +235,10 @@ list_cansim_cubes <- function(lite=FALSE,refresh=FALSE){
         mutate(archived=.data$archived==1) %>%
         mutate(cansim_table_number=cleaned_ndm_table_number(.data$productId)) %>%
         select(c("cansim_table_number","cubeTitleEn","cubeTitleFr"),
-               setdiff(names(.),c("cansim_table_number","cubeTitleEn","cubeTitleFr")))
-      # data <- content %>% purrr::map_df(function(l){
-      #   tibble::enframe(l) %>%
-      #     t() %>%
-      #     as_tibble() %>%
-      #     setNames(unlist((.)[1,])) %>%
-      #     slice(-1)
-      #   if ("dimensions" %in% names(data)) {
-      #     data <- data %>%
-      #       mutate(dimensionsEn=purrr::map(dimensions[[1]],function(a)a$dimensionNameEn) %>% paste0(collapse=", ")) %>%
-      #       mutate(dimensionsFR=purrr::map(dimensions[[1]],function(a)a$dimensionNameFr) %>% paste0(collapse=", ")) %>%
-      #       select(-dimensions)
-      #   }
-      #   data <- data %>%
-      #     mutate_if(is.list,function(d)unlist(d) %>% paste0(collapse=", "))
-      # }) %>%
-      #   mutate_at(vars(ends_with("Date")),as.Date) %>%
-      #   mutate(archived=archived==1) %>%
-      #   mutate(cansim_table_number=cleaned_ndm_table_number(productId)) %>%
-      #   select(c("cansim_table_number","cubeTitleEn","cubeTitleFr"),
-      #          setdiff(names(.),c("cansim_table_number","cubeTitleEn","cubeTitleFr")))
+               setdiff(names(.),c("cansim_table_number","cubeTitleEn","cubeTitleFr"))) %>%
+        left_join(surveys,by="surveyCode") %>%
+        left_join(subjects,by="subjectCode")
+
       saveRDS(data,path)
     }
   } else {
@@ -270,7 +255,7 @@ list_cansim_cubes <- function(lite=FALSE,refresh=FALSE){
 #' @param search_term User-supplied search term used to find Statistics Canada data cubes with matching titles, table numbers, subject and survey codes.
 #' @param refresh Default is \code{FALSE}. The underlying cube list is cached for the duration of the R sessions and will regenerate the cube list if set to \code{TRUE}
 #'
-#' @return A tibble with available Statistics Canada data cubes, listing title, Statistics Canada data cube catalogue number, deprecated CANSIM table number, description and geography that match the search term.
+#' @return A tibble with available Statistics Canada data cubes, listing title, Statistics Canada data cube catalogue number, deprecated CANSIM table number, survey and subject.
 #'
 #' @examples
 #' search_cansim_cubes("Labour force")
@@ -280,6 +265,12 @@ search_cansim_cubes <- function(search_term, refresh=FALSE){
   list_cansim_cubes(refresh = refresh) %>%
     filter(grepl(search_term,.data$cubeTitleEn,ignore.case = TRUE) |
              grepl(search_term,.data$cubeTitleFr,ignore.case = TRUE) |
+             grepl(search_term,.data$surveyEn,ignore.case = TRUE) |
+             grepl(search_term,.data$surveyFr,ignore.case = TRUE) |
+             grepl(search_term,.data$subjectEn,ignore.case = TRUE) |
+             grepl(search_term,.data$subjectFr,ignore.case = TRUE) |
+             grepl(search_term,.data$subjectCode,ignore.case = TRUE) |
+             grepl(search_term,.data$surveyCode,ignore.case = TRUE) |
              grepl(search_term,.data$cansim_table_number,ignore.case = TRUE) |
              grepl(search_term,.data$productId,ignore.case = TRUE))
 }