diff --git a/.Rbuildignore b/.Rbuildignore index 1966f505..d4ed2596 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,7 @@ fix_meta.sh ^CRAN-SUBMISSION$ ^\.github$ R-CMD-check-old.yaml +^\.claude$ +^CLAUDE\.md$ +^\.positai$ +^benchmarks$ diff --git a/.gitignore b/.gitignore index 78dc9ea3..186ab78e 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,5 @@ inst/doc .DS_Store CRAN-RELEASE CRAN-SUBMISSION +.claude/settings.local.json +.positai diff --git a/DESCRIPTION b/DESCRIPTION index f6fd0b04..ee2a8dd2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: cansim Type: Package Title: Accessing Statistics Canada Data Table and Vectors -Version: 0.4.4 +Version: 0.5.0 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"))) @@ -21,7 +21,7 @@ LazyData: true Depends: R (>= 4.1) Imports: digest (>= 0.6), dplyr (>= 1.1), - httr (>= 1.0.0), + httr2 (>= 1.1.0), tidyr (>= 1.3), readr (>= 2.1), rlang (>= 1.1), @@ -33,15 +33,16 @@ Imports: digest (>= 0.6), RSQLite (>= 2.3), utils (>= 4.3), dbplyr (>= 2.5) -RoxygenNote: 7.3.2 Suggests: knitr, rmarkdown, ggplot2, scales, - testthat (>= 3.0.0) + testthat (>= 3.0.0), + withr URL: https://github.com/mountainMath/cansim, https://mountainmath.github.io/cansim/, https://www.statcan.gc.ca/ BugReports: https://github.com/mountainMath/cansim/issues VignetteBuilder: knitr Language: en-CA Config/testthat/edition: 3 +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 82ebbf46..4069dd8f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,8 +6,12 @@ export(cansim_old_to_new) export(cansim_repartition_cached_table) export(categories_for_level) export(collect_and_normalize) +export(disconnect_cansim_connection) export(disconnect_cansim_sqlite) export(get_cansim) +export(get_cansim_changed_series_data_for_coordinates) +export(get_cansim_changed_series_data_for_vectors) +export(get_cansim_changed_series_list) export(get_cansim_changed_tables) export(get_cansim_code_set) export(get_cansim_column_categories) diff --git a/NEWS.md b/NEWS.md index b312c8b1..9a2ece7a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,215 @@ +# cansim 0.4.5 +## Major changes +* StatCan being unavailable no longer aborts with an error. Timeouts, connection failures and error + responses are now reported with a loud warning and the function returns `NULL`, so that a script or a + document can decide for itself what to do when the servers are down. This applies to every function + that talks to StatCan, and it also covers the two calls that previously bypassed the retry helper, + `get_cansim_table_last_release_date()` and `get_cansim_series_info_cube_coord()`. Set + `options(cansim.error_on_unavailable=TRUE)` to get the previous behaviour of raising an error +* examples that make a single lightweight API call are now `\donttest{}` rather than `\dontrun{}`, so + they are checked rather than merely displayed. Examples that download a full table or the cube list + stay `\dontrun{}` because of their run time, and `cansim_old_to_new()` needs no network at all so its + example now always runs +* data retrieved by vector or by table/coordinate now carries `UOM` and `UOM_ID` columns, taken from the + cube metadata. StatCan flags a single dimension of each cube as carrying the unit of measure and the unit + varies by member of that dimension, so the unit is resolved per coordinate. Tables that have no unit of + measure, for example census tables, get no unit columns, matching the full table download (#170). + With the unit known, percentage values retrieved by vector or by coordinate are now normalized the + same way as full table downloads: `val_norm` carries the value divided by 100 and the unit of + measure is relabelled to `Rate` (`Taux` in French). Previously the same series normalized + differently depending on whether it was retrieved as a full table or by vector, so scripts that + fetch percentage vectors will see `val_norm` change by a factor of 100 +* non-breaking spaces and control characters in names returned by StatCan are now replaced with regular + spaces. These characters render as an ordinary space or as nothing at all, so a column whose name + contained one could not be reached by typing or copy-pasting what the console displayed. The repair + covers table downloads, vector and coordinate calls, cube metadata, table templates and the cube list, + and emits a warning that shows the offending characters by code point, for example + `Performance strategy`, together with a count of how many names were repaired. Set + `options(cansim.suppress_repair_warnings=TRUE)` to silence the warning. The warning also says that + the characters are in the data StatCan publishes rather than anything the user did, and that it + will disappear on its own once StatCan stops sending them, pointing at the issue where that is + tracked. Column names of tables cached before this release keep the original characters + until the table is downloaded again, `get_cansim_connection()` warns when it finds such a cache (#169) +* the same repair now also covers the member labels in the data itself, not just the names of the + columns holding them. These characters turn out to be more common in member labels than in dimension + names, 53 of 500 sampled tables carry at least one. Repairing only the metadata side would have left + the labels in the data unable to match their own factor levels, so every row carrying an affected + label would have become `NA`. Labels are now also identical whichever way the data is retrieved, so + a table can be joined to template, vector or coordinate data on its dimension columns (#169) + +* an internal `scan_statcan_character_problems()` reads the cube metadata straight off the API, + without the repair applied, and reports every title, dimension name and member name StatCan + publishes with a non-breaking space or a control character in it, by table, level and language. + `summarize_statcan_character_problems()` aggregates that by survey. Neither is exported, they + exist to track whether the upstream problem is shrinking, and both go away along with the repair + once it has (#169) + +* cached tables now record the package version they were parsed under alongside the download + timestamp, in a single `.Rda_info` file that replaces the `.Rda_time` file the timestamp used to + have to itself. The timestamp says whether StatCan has newer data, the version says whether this + release still reads those files the same way. `list_cansim_cached_tables()` reports it in a new + `cansimVersion` column, empty for anything cached before this release. The old timestamp file is + still read, so existing caches keep their download date, and is replaced when a table is + refreshed. `get_cansim_connection()` uses the version to check whether a cache predates the repair + of non-breaking spaces and control characters, and if so reads the metadata cached alongside the + table to see whether its dimension names or member labels actually carry any. Only then does it + warn, naming the offending label and pointing at `refresh=TRUE` (#169) + +* every call that sends StatCan a list of vectors, coordinates or tables is now split into batches of + at most 300 items. StatCan refuses a longer list outright with an HTTP 416, which had gone unnoticed + because most of these calls already batched. `get_cansim_vector_info()` and the cube metadata + download did not, so asking either for more than 300 items at a time failed rather than returning + data + +* a vector or coordinate StatCan cannot answer for is no longer passed off as data. StatCan signals a + bad item two different ways depending on the method, either marking the record `FAILED` or answering + `SUCCESS` and putting the reason in `responseStatusCode`, and the package only checked the first. + That let an invalid vector through `get_cansim_vector_info()` as a row of `NA`s indistinguishable + from real metadata. Both are now checked everywhere, and the items that carry no data are dropped and + reported by reason, naming the vectors or coordinates concerned + +* vector calls that come back with nothing now warn and return an empty table. Previously the empty + answer travelled on to the metadata join and surfaced there as `Column 'cansimTableNumber' doesn't + exist`, which said nothing about what had happened. The warning names all three things that produce + it: vectors that do not exist, vectors with no data in the requested time frame, and the daily window + from midnight to 8:30am Eastern in which StatCan does not serve vector data + +* when StatCan refuses a request it explains why in the response body, and that explanation is now + shown alongside the status code instead of being discarded. An HTTP 409 says whether the product is + simply not released yet, and an HTTP 416 names the limit the request went past. Those two status + codes also got the plain-language translation the other codes already had. The HTTP 504 message now + says that StatCan builds a whole response before sending any of it, so the way past a gateway + timeout is to ask for less at once rather than to retry the same request + +* three new functions expose StatCan's changed series methods, which report what changed at a finer + grain than `get_cansim_changed_tables()` does. `get_cansim_changed_series_list()` lists the series + StatCan changed today as vectors, with the table and coordinate each belongs to, and + `get_cansim_changed_series_data_for_vectors()` and + `get_cansim_changed_series_data_for_coordinates()` retrieve the changed data points themselves, in + the same shape and with the same metadata as the corresponding `get_cansim_vector()` and + coordinate calls. Series that did not change simply contribute no rows, and if none of the ones + asked about changed the answer is an empty table rather than an error. Like the other vector + methods the two data ones batch requests of more than 300 items. + How long the list method takes is entirely a matter of how much StatCan released that morning. It + takes no parameters, so a busy day cannot be asked about in smaller pieces, and on one heavy enough + the request has been seen to outlive StatCan's own gateway and come back as an HTTP 504 after some + nine minutes of silence. Its `timeout` defaults high to let that answer arrive as StatCan's own + rather than as a vaguer local abort, but the limit is at StatCan's end and raising it further will + not help; `get_cansim_changed_tables()` is the question to ask on such a day + +* the package now talks to StatCan through `httr2` rather than `httr`. Requests that fail on a status + StatCan recovers from within seconds, an HTTP 429, 500, 502 or 504, are now retried with + exponential backoff and jitter and honour a `Retry-After` header, where the previous retries went + out back to back and stood a good chance of arriving while the server was still busy. Requests are + also throttled to the 25 per second StatCan documents as its per-IP limit, so a script asking for + many tables or vectors no longer risks being turned away for asking too quickly, and they now + identify themselves with a `cansim/` user agent. Statuses that will not improve on a retry + are deliberately not retried: an HTTP 416 carries more items than StatCan accepts however often it + is sent, an HTTP 409 is the nightly update window, and an HTTP 503 is StatCan being down for + maintenance or an outage, which lasts far longer than any retry budget worth spending. The 503 case + says so, and says to try again later, rather than appearing to hang while retries run down. Users + behind a proxy should note that `httr2` reads the standard `http_proxy` and `https_proxy` + environment variables instead of taking an `httr::set_config()` call + +* the `timeout` argument now bounds how long StatCan may go without sending anything, rather than how + long the whole transfer may take. As a cap on the total it could not tell a connection StatCan had + stopped answering on from a large table that was simply taking a while, and cut both off alike, so a + slow download could fail after two hundred seconds with most of the data already in hand. A transfer + that keeps delivering is now left alone however long it runs, and one that goes quiet for `timeout` + seconds is dropped, which is the distinction the argument was always described as making. Note that + StatCan works out a whole response before sending any of it, taking roughly a tenth of a second per + vector, so a request for a full batch of 300 is silent for something like thirty five seconds before + the first byte arrives; the default of two hundred seconds leaves ample room for that, but a much + smaller value passed by hand will cut off large requests. Establishing the connection is bounded + separately and briefly, so an unreachable host now fails in ten seconds instead of waiting out the + full timeout + +* `get_cansim()` and `get_cansim_connection()` now ask StatCan where a table lives instead of + assembling the download address from the table number. The address the package built was a guess at + a layout StatCan is free to change, and the extra call that replaces it is small next to the table + download it precedes + +## Deprecations +* `get_cansim_sqlite()`, `list_cansim_sqlite_cached_tables()` and `remove_cansim_sqlite_cached_table()` are now + also documented as deprecated, matching the deprecation warnings they already emit. Use + `get_cansim_connection(..., format="sqlite")`, `list_cansim_cached_tables()` and + `remove_cansim_cached_tables(..., format="sqlite")` instead +* `disconnect_cansim_sqlite()` is deprecated in favour of the new `disconnect_cansim_connection()`, + which does the same thing under a name that does not claim a format. It closes a sqlite connection + and leaves parquet and feather connections alone, so a connection can be closed without knowing + which format it came from. It was the last function still named for sqlite that was not itself + deprecated, and its own example demonstrated the deprecated `get_cansim_sqlite()` +* the deprecated `get_cansim_sqlite()`, `list_cansim_sqlite_cached_tables()`, `remove_cansim_sqlite_cached_table()`, + `disconnect_cansim_sqlite()`, `list_cansim_tables()` and `search_cansim_tables()` are scheduled for + removal in a future release + +## Performance +* vector queries now collect their 300-vector API batches in a list and combine them once, instead of + repeatedly copying all previously collected rows into every new batch. In an offline warm-cache + benchmark, combining 100 batches and 150,000 rows improved from 0.424s to 0.227s +* hierarchy building in metadata parsing no longer re-parses the growing hierarchy paths, hierarchies are built + one ancestor level at a time across all members at once +* coordinates are split once into a character matrix when folding in metadata and converting to factors +* factor conversion of dimensions with duplicate member names splits only the unique coordinates instead of + every row, a table repeats each coordinate once per reference period. On 36-10-0580 this is 6,882 unique + coordinates against 996,978 rows, cutting a cached read from 4.5s to 4.0s +* table templates are built with a single cartesian product instead of joining one dimension at a time +* metadata for data retrieved by vector or by table/coordinate is now resolved for all coordinates at once. + The member table of each dimension used to be rebuilt for every single coordinate, which made this step + grow linearly at about 24ms per coordinate. Resolving 200 coordinates of 36-10-0580 went from 5.0s to + 0.02s, and all 10,164 coordinates of that table now take 0.03s. Warnings about members missing from the + cube metadata are reported once per member rather than once per coordinate that uses it + +## Minor changes +* asking `get_cansim_vector_for_latest_periods()` or `get_cansim_data_for_table_coord_periods()` for + all periods no longer sends an arbitrary round number as the period count. StatCan takes `latestN` + as a signed 32-bit integer, rejecting zero or less and anything past 2147483647, and quietly clamps + a count longer than the series to the whole series, so the default is now that bound as the + API itself enforces it, rather than a guess that happened to exceed the longest series. A period count larger than + the bound, or an infinite one, is capped instead of being silently coerced to `NA` and sent to + StatCan as `"latestN":NA`, and a count below one now fails immediately with a message instead of + earning an HTTP 406. This also applies to the per-coordinate `periods` column of a table template +* an unrecognized `language` argument is now an error naming what was passed, instead of an `NA` that + travelled on into a cache directory name or the tail of a StatCan URL and surfaced later as a + download failure or a missing column. Either language can be named in either language, so + `"english"`, `"en"`, `"eng"` and `"anglais"` all select English and `"french"`, `"fr"`, `"fra"` and + `"français"` all select French, along with their longer and shorter forms; case, surrounding + whitespace and accents are ignored. `get_cansim_table_url()` and `get_cansim_table_notes()` now + default to `"english"` like every other function that takes a language, which selects the same + language their previous `"en"` default did (#152) +* drop the unreachable `if (TRUE) ... else ...` in metadata parsing. The else branch held the + `readr::read_delim()` implementation that `utils::read.delim()` replaced in February 2025 and had + since fallen behind the live branch, so it was no longer a working fallback (#151) +* fix a `case_when()` deprecation warning emitted by dplyr 1.2.0 on every table read +* fix `get_cansim_changed_tables()` passing "days" to `difftime()` as a time zone instead of a unit +* `get_cansim_changed_tables()` now takes both the current date and the cutoff after which the day's + changes are available in Eastern time. It used to compare against 9am, half an hour after StatCan + actually closes its nightly update window, and to take "today" from the local clock, so a machine + set west of Eastern could ask StatCan about a day that had not started there yet +* `get_cansim_connection()` no longer fails when the release date of a table cannot be determined, the + staleness check is skipped with a message instead +* the unit of measure columns of French language tables are now ordered with the other value columns, + as they already were in English language tables +* better connection error handling +* fix `get_cansim_cube_metadata()` and `get_cansim_table_template()` for vectors of table numbers, metadata for + all tables is still retrieved in a single API call and cached per table +* `get_cansim_cube_metadata()` adds a `cansimTableNumber` column for the "members", "notes" and "corrections" types +* functions that only operate on a single table now fail with an informative message when given several table numbers +* normalizing percentages now relabels the unit of measure to `Rate`, or `Taux` in French tables, as the + documentation always described; the comparison doing the relabelling could never match before, so the + unit columns used to keep their original `Percent...` labels after the values had been divided by 100 +* `add_cansim_vectors_to_template()` now finds vectors for coordinates whose member ids end in a zero, + trimming of trailing `.0` positions used to eat into member ids like `10` and the affected rows came + back with an `NA` vector +* French connections no longer emit a spurious "Unknown table type" warning on `collect_and_normalize()`, + an internal language comparison never matched the French setting +* when refreshing a cached table fails because StatCan is unavailable, `get_cansim_connection()` now falls + back to the previously cached version with a warning instead of returning `NULL`. Refreshing cube + metadata degrades the same way, so the notes, column, overview and template functions keep working + from previously seen metadata when the servers are down +* the duplicated-column error when caching a table now actually names the offending columns and no longer + blames SQLite for parquet and feather connections + # cansim 0.4.4 ## Minor changes * fix a problem with metadata parsing does not work properly for table names diff --git a/R/cansim.R b/R/cansim.R index fbef3204..f608b78c 100644 --- a/R/cansim.R +++ b/R/cansim.R @@ -2,13 +2,13 @@ #' #' Facilitates working with Statistics Canada data table values retrieved using the package by setting all units to counts/dollars instead of millions, etc. If "replacement_value" is not set, it will replace the \code{VALUE} field with normalized values and drop the \code{scale} column. Otherwise it will keep the scale columns and create a new column named replacement_value with the normalized value. It will attempt to parse the \code{REF_DATE} field and create an R date variable. This is currently experimental. #' -#' @param data A retrieved data table as returned from \code{get_cansim()} pr \code{get_cansim_ndm()} +#' @param data A retrieved data table as returned from \code{get_cansim()} or \code{get_cansim_ndm()} #' @param replacement_value (Optional) the name of the column the manipulated value should be returned in. Defaults to "val_norm" #' @param normalize_percent (Optional) When \code{TRUE} (the default) normalizes percentages by changing them to rates #' @param default_month The default month that should be used when creating Date objects for annual data (default set to "01") #' @param default_day The default day of the month that should be used when creating Date objects for monthly data (default set to "01") #' @param factors (Optional) Logical value indicating if dimensions should be converted to factors. (Default set to \code{TRUE}). -#' @param strip_classification_code (strip_classification_code) Logical value indicating if classification code should be stripped +#' @param strip_classification_code Logical value indicating if classification code should be stripped #' from names. (Default set to \code{FALSE}, if \code{factors=TRUE} this is overridden and set to \code{TRUE}). #' @param cansimTableNumber (Optional) Only needed when operating on results of SQLite connections. #' @param internal (Optional) Flag to indicate that this function is called internally. @@ -47,6 +47,7 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz scale_string2 <- ifelse(language=="fra","FACTEUR SCALAIRE","SCALAR_FACTOR") uom_string=ifelse(language=="fra",paste0("UNIT",intToUtf8(0x00C9)," DE MESURE"),"UOM") percentage_string=ifelse(language=="fra","^Pourcent","^Percent") + rate_string=ifelse(language=="fra","Taux","Rate") classification_prefix <- ifelse(language=="fra","Code de classification pour ","Classification Code for ") hierarchy_prefix <- ifelse(language=="fra",paste0("Hi",intToUtf8(0x00E9),"rarchie pour "),"Hierarchy for ") replacement_value_string = ifelse(is.na(replacement_value),value_string,replacement_value) @@ -61,7 +62,8 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz return (data) } - data <- data %>% as_tibble() + # P10: Avoid unnecessary tibble conversion if data is already a tibble + if (!tibble::is_tibble(data)) data <- as_tibble(data) attr(data,"cansimTableNumber") <- cansimTableNumber attr(data,"language") <- language @@ -79,7 +81,7 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz # divide numbers that are percentages by 100 and convert the unit field to "rate" data <- data %>% mutate(!!as.name(replacement_value_string):=ifelse(grepl(percentage_string,!!as.name(uom_string)),!!as.name(replacement_value_string)/100,!!as.name(replacement_value_string))) %>% - mutate(!!as.name(uom_string):=ifelse(!!as.name(uom_string)==percentage_string,"Rate",!!as.name(uom_string))) + mutate(!!as.name(uom_string):=ifelse(grepl(percentage_string,!!as.name(uom_string)),rate_string,!!as.name(uom_string))) } @@ -87,8 +89,7 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz sample_date <- data[1:10,date_field] %>% pull(date_field) %>% na.omit() %>% first() if (is.na(sample_date)) { - sample_date <- pull(date_field) %>% na.omit() %>% first() - + sample_date <- data %>% pull(date_field) %>% na.omit() %>% first() } # sample_date <- data[[date_field]] %>% # na.omit %>% @@ -98,20 +99,37 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz if (!trad_cansim) { # do nothing } else if (grepl("^\\d{4}$",sample_date)) { - # year - data <- data %>% - mutate(Date=as.Date(paste0(!!as.name(date_field),"-",default_month,"-",default_day))) + # year - use lookup table for efficiency + unique_dates <- unique(data[[date_field]]) + date_lookup <- setNames( + as.Date(paste0(unique_dates, "-", default_month, "-", default_day)), + unique_dates + ) + data$Date <- unname(date_lookup[data[[date_field]]]) } else if (grepl("^\\d{4}/\\d{4}$",sample_date)) { - # year range, use second year as anchor - data <- data %>% - mutate(Date=as.Date(paste0(gsub("^\\d{4}/","",!!as.name(date_field)),"-",default_month,"-",default_day))) + # year range, use second year as anchor - use lookup table for efficiency + unique_dates <- unique(data[[date_field]]) + date_lookup <- setNames( + as.Date(paste0(gsub("^\\d{4}/", "", unique_dates), "-", default_month, "-", default_day)), + unique_dates + ) + data$Date <- unname(date_lookup[data[[date_field]]]) } else if (grepl("^\\d{4}-\\d{2}$",sample_date)) { - # year and month - data <- data %>% mutate(Date=as.Date(paste0(!!as.name(date_field),"-",default_day))) + # year and month - use lookup table for efficiency + unique_dates <- unique(data[[date_field]]) + date_lookup <- setNames( + as.Date(paste0(unique_dates, "-", default_day)), + unique_dates + ) + data$Date <- unname(date_lookup[data[[date_field]]]) } else if (grepl("^\\d{4}-\\d{2}-\\d{2}$",sample_date)) { - # year, month and day - data <- data %>% - mutate(Date=as.Date(!!as.name(date_field))) + # year, month and day - use lookup table for efficiency + unique_dates <- unique(data[[date_field]]) + date_lookup <- setNames( + as.Date(unique_dates), + unique_dates + ) + data$Date <- unname(date_lookup[data[[date_field]]]) } cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) @@ -138,23 +156,34 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz } if (strip_classification_code){ - for (field in fields) { - if (sum(!is.na(data[[paste0(classification_prefix,field)]]))>0) { - data <- data %>% - mutate(!!field:=gsub(" \\[.+\\]$","",!!as.name(field))) - } + # Identify fields that have classification codes to strip (non-NA values in classification column) + fields_to_strip <- fields[vapply(fields, function(field) { + cc_col <- paste0(classification_prefix, field) + cc_col %in% names(data) && sum(!is.na(data[[cc_col]])) > 0 + }, logical(1))] + + if (length(fields_to_strip) > 0) { + # Use across() to strip all classification codes in a single pass + data <- data %>% + mutate(across(all_of(fields_to_strip), ~gsub(" \\[.+\\]$", "", .x))) } } if (factors){ if (!is.null(getOption("cansim.debug"))) message('Converting to factors') + # Coordinates are split once into a character matrix and reused for all dimensions, built + # lazily since only dimensions with duplicate member names need it. Only the unique + # coordinates are split and rows are read back through an index, a table repeats each + # coordinate once per reference period so the unique set is a small fraction of the rows. + coordinate_lookup <- NULL + for (field in fields) { if (!is.null(getOption("cansim.debug"))) message(paste0('Converting ',field,' to factors')) tryCatch({ + # get_deduped_column_level_data now returns pre-sorted data, no need for arrange() level_table <- get_deduped_column_level_data(cansimTableNumber = cansimTableNumber, - language=language,column=field) %>% - arrange(as.integer(.data$`...dim`),as.integer(.data$`...id`)) + language=language,column=field) if (!(field %in% names(data))) { geography_column <- ifelse(cleaned_language=="eng","Geography|Geographic name",paste0("G",intToUtf8(0x00E9),"ographie|Nom g",intToUtf8(0x00E9),"ographique")) data_geography_column <- ifelse(language=="eng","GEO",paste0("G",intToUtf8(0x00C9),"O")) @@ -172,9 +201,18 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz column_position <- which(names(data)==field) column_before <- names(data)[column_position-1] - data$`...id` <- stringr::str_split(data[[coordinate_column]],"\\.") %>% - lapply(\(x)x[dimension_id]) %>% - unlist() + if (is.null(coordinate_lookup)) { + coordinates <- data[[coordinate_column]] + unique_coordinates <- unique(coordinates) + coordinate_parts <- max(c(0,stringr::str_count(unique_coordinates,"\\.")),na.rm=TRUE)+1 + coordinate_lookup <- list(matrix=stringr::str_split_fixed(unique_coordinates,"\\.",coordinate_parts), + index=match(coordinates,unique_coordinates)) + } + if (dimension_id <= ncol(coordinate_lookup$matrix)) { + data$`...id` <- coordinate_lookup$matrix[coordinate_lookup$index,dimension_id] + } else { # coordinates that are shorter than the cube has dimensions carry nothing for this one + data$`...id` <- NA_character_ + } data <- data %>% select(-all_of(field)) %>% @@ -191,8 +229,8 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz "than with StatCan, or if this problem can't be resolved, please flag this as an issue in the\n", "{cansim} repository at https://github.com/mountainMath/cansim/issues.")) } else { - data <- data %>% - mutate(!!field:=factor(!!as.name(field),levels=level_table$...name)) + # Use base R for factor conversion - faster than dplyr's mutate for this operation + data[[field]] <- factor(data[[field]], levels = level_table$...name) } }, @@ -234,9 +272,7 @@ normalize_cansim_values <- function(data, replacement_value="val_norm", normaliz #' @return A character string with the new-format NDM table number #' #' @examples -#' \dontrun{ #' cansim_old_to_new("026-0018") -#' } #' @export cansim_old_to_new <- function(oldCansimTableNumber){ # cache the file as data, old table numbers should not change @@ -299,9 +335,13 @@ fold_in_metadata_for_columns <- function(data,data_path,column_names){ if (!is.null(getOption("cansim.debug"))) message('Generating base hierarchy') - hierarchy_data <- tibble(X=pull(data,coordinate_column) %>% unique) %>% - setNames(coordinate_column) %>% - mutate(...pos=strsplit(!!as.name(coordinate_column),"\\.")) + # the unique coordinates are split once into a character matrix, member ids for each + # dimension are then read off as whole columns rather than element by element + unique_coordinates <- pull(data,coordinate_column) %>% unique() + coordinate_parts <- max(c(0,stringr::str_count(unique_coordinates,"\\.")),na.rm=TRUE)+1 + coordinate_matrix <- stringr::str_split_fixed(unique_coordinates,"\\.",coordinate_parts) + + hierarchy_data <- tibble(!!coordinate_column:=unique_coordinates) for (column_name in column_names) { if (!is.null(getOption("cansim.debug"))) message(paste0("Generating ",column_name," hierarchy")) @@ -325,6 +365,12 @@ fold_in_metadata_for_columns <- function(data,data_path,column_names){ # is_geo_column <- grepl(geography_column,column[[dimension_name_column]]) & !(column[[dimension_name_column]] %in% names(data)) meta_x=readRDS(paste0(data_path,"_column_",column_index)) + if (column_index <= ncol(coordinate_matrix)) { + member_ids_for_column <- coordinate_matrix[,column_index] + } else { # coordinates that are shorter than the cube has dimensions carry nothing for this one + member_ids_for_column <- rep(NA_character_,nrow(coordinate_matrix)) + } + if (is_geo_column) { hierarchy_name <- paste0(hierarchy_prefix," ", data_geography_column) join_column <- meta_x %>% @@ -333,7 +379,7 @@ fold_in_metadata_for_columns <- function(data,data_path,column_names){ select(setdiff(c(member_id_column,"GeoUID",hierarchy_name),names(data))) hierarchy_data <- hierarchy_data %>% - mutate(!!member_id_column:=lapply(.data$...pos,function(d)d[column_index]) %>% unlist) %>% + mutate(!!member_id_column:=member_ids_for_column) %>% dplyr::left_join(join_column,by=member_id_column) %>% dplyr::select(-!!as.name(member_id_column)) } else if (column[[dimension_name_column]] %in% names(data)){ @@ -345,7 +391,7 @@ fold_in_metadata_for_columns <- function(data,data_path,column_names){ select(setdiff(c(member_id_column,classification_name,hierarchy_name),names(data))) hierarchy_data <- hierarchy_data %>% - mutate(!!member_id_column:=lapply(.data$...pos,function(d)d[column_index]) %>% unlist) %>% + mutate(!!member_id_column:=member_ids_for_column) %>% dplyr::left_join(join_column,by=member_id_column) %>% dplyr::select(-!!as.name(member_id_column)) } else { @@ -356,7 +402,7 @@ fold_in_metadata_for_columns <- function(data,data_path,column_names){ } } if (!is.null(getOption("cansim.debug"))) message('Folding in hierarchy') - data %>% dplyr::left_join(hierarchy_data %>% dplyr::select(-"...pos"), by=coordinate_column) + data %>% dplyr::left_join(hierarchy_data, by=coordinate_column) } #' The correspondence file for old to new StatCan table numbers is included in the package @@ -374,9 +420,9 @@ NULL #' Retrieves a data table using an NDM catalogue number as a tidy data frame. Retrieved table data is cached for the duration of the current R session only by default. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. #' @param factors (Optional) Logical value indicating if dimensions should be converted to factors. (Default set to \code{TRUE}). #' @param default_month The default month that should be used when creating Date objects for annual data (default set to "07") #' @param default_day The default day of the month that should be used when creating Date objects for monthly data (default set to "01") @@ -385,6 +431,7 @@ NULL #' @return A tibble with StatCan Table data and added \code{Date} column with inferred date objects and #' added \code{val_norm} column with normalized value from the \code{VALUE} column. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' get_cansim("34-10-0013") @@ -402,7 +449,11 @@ get_cansim <- function(cansimTableNumber, language="english", refresh=FALSE, tim message(paste0("Accessing CANSIM NDM product ", cleaned_number, " from Statistics Canada")) else message(paste0("Acc",intToUtf8(0x00E9),"der au produit ", cleaned_number, " CANSIM NDM de Statistique Canada")) - url=paste0("https://www150.statcan.gc.ca/n1/tbl/csv/",file_path_for_table_language(cleaned_number,language),".zip") + # Asking StatCan where the table lives rather than assembling the address from the table number, + # which is guessing at a layout StatCan is free to change. The extra call is small next to the + # download it precedes. + url <- get_cansim_table_url(cleaned_number, language=language) + if (is.null(url)) return(NULL) response <- get_with_timeout_retry(url,path=path,timeout=timeout) if (is.null(response)) return(response) data <- NA @@ -429,15 +480,20 @@ get_cansim <- function(cansimTableNumber, language="english", refresh=FALSE, tim grouping_mark = "."), col_types = list(.default = "c"), col_names = FALSE) %>% - as.character() + as.character() %>% + repair_statcan_names(context=paste0("column names for table ",cleaned_number)) - symbols <- which(header=="Symbol") + symbols <- which(header=="Symbol" | header=="Symbole") if (length(symbols)==0) { - symbols <- which(header=="Symbols"|header=="Symboles") + symbols <- which(header=="Symbols"| header=="Symboles") } if (length(symbols)>1) { - header[symbols] <- paste0("Symbol ",seq(1,length(symbols))) + if (cleaned_language=="fra") { + header[symbols] <- paste0("Symbole ",seq(1,length(symbols))) + } else { + header[symbols] <- paste0("Symbol ",seq(1,length(symbols))) + } } coordinate_column <- ifelse(cleaned_language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) @@ -475,7 +531,9 @@ get_cansim <- function(cansimTableNumber, language="english", refresh=FALSE, tim parse_metadata(meta_lines,data_path) meta2 <- readRDS(paste0(data_path,"2")) dimension_name_column <- ifelse(cleaned_language=="eng","Dimension name","Nom de la dimension") - data <- fold_in_metadata_for_columns(data,data_path,pull(meta2,dimension_name_column)) + data <- data %>% + repair_statcan_dimension_values(pull(meta2,dimension_name_column),cleaned_language) %>% + fold_in_metadata_for_columns(data_path,pull(meta2,dimension_name_column)) }, error = function(e) { warning("Could not fold in metadata") if (nrow(data)==0) warning(paste0("StatCan returned zero rows of data for table ",cleaned_number, @@ -509,15 +567,16 @@ get_cansim <- function(cansimTableNumber, language="english", refresh=FALSE, tim #' Returns table information given an NDM table catalogue number in English or French. Retrieved table information data is cached for the duration of the R session only. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. # Set to higher values for large tables and slow network connection. (Default is \code{200}). #' #' @return A tibble with the table overview information #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_info("34-10-0013") #' } #' @export @@ -539,6 +598,7 @@ get_cansim_table_info <- function(cansimTableNumber, language="english", refresh archived_column <- "Archive Status" d <- get_cansim_cube_metadata(cansimTableNumber, type="overview",refresh=refresh) + if (is.null(d)) return(NULL) if (cleaned_language=="fra") { result <- d %>% @@ -566,15 +626,16 @@ get_cansim_table_info <- function(cansimTableNumber, language="english", refresh #' Returns table survey detail given an NDM table number in English or French. Retrieved table information data is cached for the duration of the R session only. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. # Set to higher values for large tables and slow network connection. (Default is \code{200}). #' #' @return A tibble with the table survey code and name #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_survey("34-10-0013") #' } #' @export @@ -586,7 +647,9 @@ get_cansim_table_survey <- function(cansimTableNumber, language="english", refre } else { cleaned_language <- cleaned_ndm_language(language) survey_code_grepl_field <- ifelse(cleaned_language=="eng","Survey Code",paste0("Code d'enqu",intToUtf8(0x00EA),"te")) - result<-get_cansim_cube_metadata(cansimTableNumber,type="overview",refresh=refresh) %>% select(!!survey_code_grepl_field:=.data$surveyCode) + d <- get_cansim_cube_metadata(cansimTableNumber,type="overview",refresh=refresh) + if (is.null(d)) return(NULL) + result<-d %>% select(!!survey_code_grepl_field:=.data$surveyCode) } result } @@ -596,15 +659,16 @@ get_cansim_table_survey <- function(cansimTableNumber, language="english", refre #' Returns table subject detail given an NDM table number in English or French. Retrieved table information data is cached for the duration of the R session only. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. # Set to higher values for large tables and slow network connection. (Default is \code{200}). #' #' @return A tibble with the table subject code and name. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_subject("34-10-0013") #' } #' @export @@ -616,7 +680,9 @@ get_cansim_table_subject <- function(cansimTableNumber, language="english", refr } else { cleaned_language <- cleaned_ndm_language(language) subject_code_grepl_field <- ifelse(cleaned_language=="eng","Subject Code","Code du sujet") - result<-get_cansim_cube_metadata(cansimTableNumber,type="overview",refresh=refresh) %>% + d <- get_cansim_cube_metadata(cansimTableNumber,type="overview",refresh=refresh) + if (is.null(d)) return(NULL) + result<-d %>% select(.data$subjectCode) %>% mutate(subjectCode=strsplit(.data$subjectCode,", ")) %>% tidyr::unnest_longer(.data$subjectCode) %>% @@ -630,15 +696,16 @@ get_cansim_table_subject <- function(cansimTableNumber, language="english", refr #' Returns table notes given an NDM table number in English or French. Retrieved table information data is cached for the duration of the R session only. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. # Set to higher values for large tables and slow network connection. (Default is \code{200}). #' #' @return A tibble with the StatCan Notes for the table #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_short_notes("34-10-0013") #' } #' @export @@ -647,11 +714,9 @@ get_cansim_table_short_notes <- function(cansimTableNumber, language="english", data_path <- paste0(base_path_for_table_language(cleaned_number,language),".Rda5") if (!refresh && file.exists(data_path)) { notes <- readRDS(file=data_path) - } else if (!file.exists(data_path)) { - notes <- get_cansim_cube_metadata(cansimTableNumber,refresh=refresh,type="notes") - } - if (refresh || !file.exists(data_path)){ + } else { notes <- get_cansim_cube_metadata(cansimTableNumber,refresh=refresh,type="notes") + if (is.null(notes)) return(NULL) cleaned_language <- cleaned_ndm_language(language) note_id_grepl_field <- ifelse(cleaned_language=="eng","Note ID",paste0("Num",intToUtf8(0x00E9),"ro d'identification de la note")) @@ -676,15 +741,16 @@ get_cansim_table_short_notes <- function(cansimTableNumber, language="english", #' Returns table column details given an NDM table number in English or French. Retrieved table information data is cached for the duration of the R session only. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. # Set to higher values for large tables and slow network connection. (Default is \code{200}). #' #' @return A tibble listing the column names of the StatCan table. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_column_list("34-10-0013") #' } #' @export @@ -698,6 +764,7 @@ get_cansim_column_list <- function(cansimTableNumber, language="english", refres dimension_id_column <- ifelse(cleaned_language=="eng","Dimension ID",paste0("Num",intToUtf8(0x00E9),"ro d'identification de la dimension")) dimension_name_column <- ifelse(cleaned_language=="eng","Dimension name","Nom de la dimension") d <- get_cansim_cube_metadata(cansimTableNumber,type="members",refresh=refresh) + if (is.null(d)) return(NULL) if (cleaned_language=="fra") { result <- d %>% @@ -721,15 +788,16 @@ get_cansim_column_list <- function(cansimTableNumber, language="english", refres #' #' @param cansimTableNumber the NDM table number to load #' @param column the specified column for which to retrieve category information for -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. # Set to higher values for large tables and slow network connection. (Default is \code{200}). #' #' @return A tibble with detailed information on StatCan table categories for the specified field #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_column_categories("34-10-0013", "Geography") #' } #' @export @@ -746,7 +814,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),call.=FALSE) + stop(paste0("Unknown column ",column),call.=FALSE) } result <- readRDS(file=data_path) } else { @@ -761,6 +829,7 @@ get_cansim_column_categories <- function(cansimTableNumber, column, language="en exceeded_hierarchy_warning_message <- ifelse(cleaned_language=="eng","Exceeded max depth for hierarchy, hierarchy information may be faulty.", paste0("Profondeur maximale d",intToUtf8(0x00E9),"pass",intToUtf8(0x00E9),"e pour la hi",intToUtf8(0x00E9),"rarchie, les informations de hi",intToUtf8(0x00E9),"rarchie peuvent ",intToUtf8(0x00EA),"tre erron",intToUtf8(0x00E9),"es.")) d <- get_cansim_cube_metadata(cansimTableNumber,type="members",refresh=refresh) + if (is.null(d)) return(NULL) if (cleaned_language=="fra") { result <- d %>% @@ -781,7 +850,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),call.=FALSE) + stop(paste0("Unknown column ",column),call.=FALSE) } } @@ -793,19 +862,21 @@ get_cansim_column_categories <- function(cansimTableNumber, column, language="en #' Prints table overview information as console output. In order to display table overview information, the selected CANSIM table must be loaded entirely to display overview information. Overview information is printed in console an in English or French, as specified. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) #' #' @return none #' +#' Nothing is printed if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_overview("34-10-0013") #' } #' @export get_cansim_table_overview <- function(cansimTableNumber, language="english", refresh=FALSE){ cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) info <- get_cansim_table_info(cansimTableNumber,language=language,refresh=refresh) + if (is.null(info)) return(invisible(NULL)) #refresh=FALSE cleaned_language <- cleaned_ndm_language(language) cube_title_column <- ifelse(cleaned_language=="eng","Cube Title","Titre du cube") @@ -820,9 +891,11 @@ get_cansim_table_overview <- function(cansimTableNumber, language="english", ref end_period_column,": ",info[[end_period_column]],", ", frequency_column,": ",info[[frequency_column]],"\n") columns <- get_cansim_column_list(cansimTableNumber,language=language,refresh=refresh) + if (is.null(columns)) return(invisible(NULL)) for (column in columns[[dimension_name_column]]) { text <- paste0(text,"\n","Column ",column) categories <- get_cansim_column_categories(cansimTableNumber,column,language=language,refresh=refresh) + if (is.null(categories)) return(invisible(NULL)) text <- paste0(text, " (",nrow(categories),")","\n") text <- paste0(text, paste(utils::head(categories[[member_name_column]],10),collapse=", ")) if (nrow(categories)>10) text <- paste0(text, ", ...") @@ -853,7 +926,7 @@ categories_for_level <- function(data,column_name, level=NA, strict=FALSE, remov hierarchy_name=paste0("Hierarchy for ",column_name) h <- data %>% dplyr::select(column_name,hierarchy_name) %>% unique %>% - dplyr::mutate(hierarchy_level=(strsplit(!!as.name(hierarchy_name),"\\.") %>% lapply(length) %>% unlist)-1) + dplyr::mutate(hierarchy_level=lengths(strsplit(!!as.name(hierarchy_name),"\\."))-1) max_level=max(h$hierarchy_level,na.rm = TRUE) if (is.na(level) | level>max_level) level=max_level h <- h %>% @@ -893,11 +966,12 @@ categories_for_level <- function(data,column_name, level=NA, strict=FALSE, remov #' @export view_cansim_webpage <- function(cansimTableNumber = NULL){ browser <- getOption("browser") + if (!is.null(cansimTableNumber)) validate_single_table_number(cansimTableNumber) cansimTableNumber <- tolower(cansimTableNumber) - if (is.null(cansimTableNumber)) { + if (is.null(cansimTableNumber) || length(cansimTableNumber) == 0) { url <- 'https://www150.statcan.gc.ca/t1/tbl1/en/sbv.action#tables' - } else if (grepl("^v\\d+$",cansimTableNumber)) { + } else if (grepl("^v\\d+$", tolower(cansimTableNumber))) { url <- paste0("https://www150.statcan.gc.ca/t1/tbl1/en/sbv.action?vectorNumbers=",cansimTableNumber) } else { cansimTableNumber <- paste0(gsub("-","",cleaned_ndm_table_number(cansimTableNumber)),"01") @@ -914,25 +988,25 @@ view_cansim_webpage <- function(cansimTableNumber = NULL){ #' Retrieve URL of a table from the API given a table number. Offers a more stable approach than manually guessing the URL of the table. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' #' @return String object containing URL for specified table number #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_url("34-10-0013") #' get_cansim_table_url("34-10-0013", language = "fr") #' } #' @export -get_cansim_table_url <- function(cansimTableNumber, language = "en"){ +get_cansim_table_url <- function(cansimTableNumber, language = "english"){ + validate_single_table_number(cansimTableNumber) cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) l <- cleaned_ndm_language(language) %>% substr(1,2) 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),call.=FALSE) - } - httr::content(response)$object + response <- get_with_timeout_retry(url) + if (is.null(response)) return(NULL) + statcan_response_json(response)$object } #' Retrieve a list of modified tables since a given date @@ -945,15 +1019,19 @@ get_cansim_table_url <- function(cansimTableNumber, language = "en"){ #' #' @return A tibble with Statistics Canada data table product ids and their release times #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_changed_tables("2018-08-01") #' } #' @export get_cansim_changed_tables <- function(start_date,end_date=NULL){ - last_available_date <- Sys.Date() - if (Sys.time()last_available_date) { stop(paste0("Last available date is ",last_available_date,", please try with a start date on or before that date."),call.=FALSE) @@ -969,21 +1047,24 @@ get_cansim_changed_tables <- function(start_date,end_date=NULL){ start_date <- end_date end_date <-d } - if (difftime(end_date,start_date,"days")>31) { + # the third argument of difftime is the time zone, the unit has to be named + if (difftime(end_date,start_date,units="days")>31) { message("Querying for long time intervals may be slow.") } - seq(as.Date(start_date),as.Date(end_date),"days") %>% + changes <- seq(as.Date(start_date),as.Date(end_date),"days") %>% lapply(function(date){ 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),call.=FALSE) - } - httr::content(response)$object %>% + response <- get_with_timeout_retry(url) + if (is.null(response)) return(NULL) + statcan_response_json(response)$object %>% map(function(o)tibble(productId=o$productId,releaseTime=o$releaseTime)) %>% bind_rows - }) %>% - bind_rows + }) + + # a single unavailable day makes the result silently incomplete, which is worse than no result + if (any(vapply(changes,is.null,logical(1)))) return(NULL) + + bind_rows(changes) } @@ -992,18 +1073,19 @@ get_cansim_changed_tables <- function(start_date,end_date=NULL){ #' Returns table notes given an NDM table number in English or French. Retrieved table information data is cached for the duration of the R session only. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (default set to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. # Set to higher values for large tables and slow network connection. (Default is \code{200}). #' @return A tibble with table notes. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_notes("34-10-0013") #' } #' @export -get_cansim_table_notes <- function(cansimTableNumber,language="en",refresh=FALSE, timeout = 200) { +get_cansim_table_notes <- function(cansimTableNumber,language="english",refresh=FALSE, timeout = 200) { cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) cleaned_language <- cleaned_ndm_language(language) dimension_name_column <- ifelse(cleaned_language=="eng","Dimension name","Nom de la dimension") @@ -1012,6 +1094,7 @@ get_cansim_table_notes <- function(cansimTableNumber,language="en",refresh=FALSE member_note_column <- ifelse(cleaned_language=="eng","Member Notes","Notes sur le membre") note_id_column <- ifelse(cleaned_language=="eng","Note ID",paste0("Num",intToUtf8(0x00E9),"ro d'identification de la note")) notes <- get_cansim_table_short_notes(cansimTableNumber,language=language,refresh=refresh,timeout=timeout) + if (is.null(notes)) return(NULL) columns <- get_cansim_column_list(cansimTableNumber,language=language) if (dimenion_note_column %in% names(columns)) { @@ -1034,6 +1117,7 @@ get_cansim_table_notes <- function(cansimTableNumber,language="en",refresh=FALSE } else { full_notes <- get_cansim_cube_metadata(cansimTableNumber,type="notes",refresh=refresh) members <- get_cansim_cube_metadata(cansimTableNumber,type="members",refresh = refresh) + if (is.null(full_notes) || is.null(members)) return(NULL) if (cleaned_language=="fra") { members <- members %>% @@ -1066,33 +1150,30 @@ get_cansim_table_notes <- function(cansimTableNumber,language="en",refresh=FALSE #' @param cansimTableNumber the NDM table number #' @return A datetime object if a release data is available, NULL otherwise. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_last_release_date("34-10-0013") #' } #' @export get_cansim_table_last_release_date <- function(cansimTableNumber){ + validate_single_table_number(cansimTableNumber) cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) pid <- paste0(naked_ndm_table_number(cansimTableNumber),"01") - url <- "https://www150.statcan.gc.ca/n1/en/metadata.json" - response <- purrr::safely(httr::GET)(url,query=list(productid=pid)) - if (!is.null(response$error) || response$result$status_code!=200) { - warning(paste0("Could not access information for table ",cansimTableNumber, - " (productID: ",pid,").\n", - response$error)) - release_date <- NA - } else { - c <- httr::content(response$result) - r<-c$result - if (length(r)>0) { - rd <- unique(unlist(lapply(r,function(rr)rr$releasedate))) - release_date <- strptime(rd,format = STATCAN_TIME_FORMAT,tz="UTC") %>% - max() - } else { - release_date <- NA - } + url <- paste0("https://www150.statcan.gc.ca/n1/en/metadata.json?productid=",pid) + response <- get_with_timeout_retry(url) + if (is.null(response)) return(NULL) + + r <- statcan_response_json(response)$result + if (length(r)==0) { + warning("Could not access release information for table ",cansimTableNumber, + " (productID: ",pid,").",call.=FALSE) + return(NA) } - release_date + + rd <- unique(unlist(lapply(r,function(rr)rr$releasedate))) + strptime(rd,format = STATCAN_TIME_FORMAT,tz="UTC") %>% + max() #get_cansim_cube_metadata(cansimTableNumber) %>% pull(releaseTime) } diff --git a/R/cansim_changed_series.R b/R/cansim_changed_series.R new file mode 100644 index 00000000..37c74a0b --- /dev/null +++ b/R/cansim_changed_series.R @@ -0,0 +1,188 @@ +# StatCan reports a request naming only series that did not change with an HTTP 404 carrying a +# "Not data found" body. Nothing went wrong in that case, the answer is simply that there is nothing, +# so the two methods that name the series they ask about have that status come back as an empty result +# rather than as the failure the shared handling would otherwise make of it. +CHANGED_SERIES_NO_DATA_STATUS <- 404L + +#' Retrieve the series that changed today +#' +#' Retrieve the list of data series Statistics Canada changed today, as vectors together with the +#' table and coordinate they belong to. Where \code{get_cansim_changed_tables()} reports which tables +#' were touched, this reports the individual series inside them, which is the finer grained way to +#' decide what needs re-downloading. +#' +#' StatCan serves this for the current day only and fills it during the daily update window that ends +#' at 8:30am Eastern. Unlike the changed tables method there is no way to ask for an earlier day, +#' StatCan answers a request naming a date with an HTTP 404. +#' +#' How long this takes depends entirely on how much StatCan released that morning. The method takes no +#' parameters, so there is no way to ask for a smaller slice of a busy day, and StatCan works out a +#' whole response before sending any of it. On a quiet day the answer arrives in well under a second; +#' on a heavy one the series changing can number in the hundreds of thousands and the request has been +#' seen to outlive StatCan's own gateway, coming back as an HTTP 504 after some nine minutes of +#' silence. That is a limit at StatCan's end which raising \code{timeout} cannot lift, so on such a day +#' \code{get_cansim_changed_tables()} is the question worth asking instead. +#' +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before +#' the download is abandoned. The default is set high because this method is silent while it works. +#' +#' @return A tibble with one row per changed series, carrying the vector, the table number, the +#' coordinate and the release time +#' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. +#' @examples +#' \dontrun{ +#' get_cansim_changed_series_list() +#' } +#' @export +get_cansim_changed_series_list <- function(timeout=600){ + url <- "https://www150.statcan.gc.ca/t1/wds/rest/getChangedSeriesList" + + # no `empty_status` here, unlike the two data methods below. Their 404 means that none of the series + # asked about changed, but this method names no series, so nothing it could report as absent. A 404 + # from it is StatCan not serving the route, which is worth telling the caller about rather than + # quietly passing off as a day on which nothing changed. + response <- get_with_timeout_retry(url,timeout=timeout) + if (is.null(response)) return(NULL) + + data <- statcan_response_json(response) + if (length(data$object)==0) return(empty_changed_series_list()) + + # this method has been seen to answer both in the wrapped shape the other list methods use, each + # series sitting in the `object` of a record carrying its own status, and with the series themselves + # as the entries of `object`. The presence of that per-record status is what tells the two apart, + # and it has to be settled before asking for the successful records, because putting the unwrapped + # shape through that check would report every series in it as a failure + wrapped <- !is.null(data$object[[1]]$status) + series <- if (wrapped) { + purrr::map(successful_wds_records(data$object,"changed series"),\(x) x$object) + } else { + Filter(\(x) is.list(x) && !is.null(x$vectorId),data$object) + } + + if (length(series)==0) return(empty_changed_series_list()) + changed_series_tibble(series) +} + +empty_changed_series_list <- function(){ + tibble::tibble(VECTOR=character(0),cansimTableNumber=character(0), + COORDINATE=character(0),releaseTime=character(0)) +} + +changed_series_tibble <- function(series){ + field <- function(x,name,default=NA_character_){ + value <- x[[name]] + if (length(value)!=1 || is.null(value)) return(default) + as.character(value) + } + tibble::tibble( + VECTOR=paste0("v",purrr::map_chr(series,field,"vectorId")), + cansimTableNumber=purrr::map_chr(series,\(x){ + product_id <- field(x,"productId") + if (is.na(product_id)) NA_character_ else cleaned_ndm_table_number(product_id) + }), + COORDINATE=gsub("(\\.0)+$","",purrr::map_chr(series,field,"coordinate")), + releaseTime=purrr::map_chr(series,field,"releaseTime")) +} + +# Shared body of the two methods that fetch the data of series that changed. They differ only in the +# endpoint they call and in how the caller names the series it is asking about. +changed_series_data <- function(url,bodies,vectors,language,timeout,factors, + default_month,default_day){ + cleaned_language <- cleaned_ndm_language(language) + + batches <- batch_items(bodies) + batch_results <- vector("list", length(batches)) + for (batch_number in seq_along(batches)) { + addition <- if (length(batches)>1) paste0(" (batch ",batch_number," of ",length(batches),")") else "" + message(paste0("Accessing changed CANSIM NDM series from Statistics Canada",addition)) + + body <- paste0("[",paste(batches[[batch_number]],collapse=", "),"]") + response <- post_with_timeout_retry(url,body=body,timeout=timeout, + empty_status=CHANGED_SERIES_NO_DATA_STATUS) + if (is.null(response)) return(NULL) + # none of the series in this batch changed, which says nothing about the other batches + if (statcan_no_data(response)) next + + records <- successful_wds_records(statcan_response_json(response),"changed series data") + if (length(records)>0) batch_results[[batch_number]] <- extract_vector_data(records) + } + + result <- bind_rows(batch_results) + # an empty answer here means nothing changed, which is an ordinary thing to report rather than the + # sign of a problem the vector methods warn about + finalize_vector_data(result,vectors,cleaned_language,factors,default_month,default_day, + warn_if_empty=FALSE) +} + +#' Retrieve data for series that changed, by vector +#' +#' Retrieve the data points Statistics Canada changed for the given vectors. Series among the ones +#' asked about that did not change contribute no rows, and if none of them changed the result is an +#' empty table rather than an error. The StatCan API can only process 300 vectors at a time, if more +#' than 300 vectors are specified the function will batch the requests to the API. +#' +#' @param vectors The list of vectors to retrieve changed data for +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. +#' @param factors (Optional) Logical value indicating if dimensions should be converted to factors. (Default set to \code{TRUE}). +#' @param default_month The default month that should be used when creating Date objects for annual data (default set to "07") +#' @param default_day The default day of the month that should be used when creating Date objects for monthly data (default set to "01") +#' +#' @return A tibble with the changed data for the specified vector(s) +#' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. +#' @examples +#' \dontrun{ +#' get_cansim_changed_series_data_for_vectors("v41690973") +#' } +#' @export +get_cansim_changed_series_data_for_vectors <- function(vectors, language="english", timeout=200, + factors=TRUE, default_month="07", + default_day="01"){ + naked_vectors <- gsub("^v","",vectors) # allow for leading "v" by conditionally stripping it + bodies <- paste0('{"vectorId":',naked_vectors,'}') + + # the naked vectors, which keep their names through the gsub above, are what rename_vectors() + # further down expects; handing it the prefixed originals would look up "vv..." and label nothing + changed_series_data("https://www150.statcan.gc.ca/t1/wds/rest/getChangedSeriesDataFromVector", + bodies,naked_vectors,language,timeout,factors,default_month,default_day) +} + +#' Retrieve data for series that changed, by table and coordinate +#' +#' Retrieve the data points Statistics Canada changed for the given coordinates of a table. +#' Coordinates among the ones asked about that did not change contribute no rows, and if none of them +#' changed the result is an empty table rather than an error. The StatCan API can only process 300 +#' coordinates at a time, if more than 300 coordinates are specified the function will batch the +#' requests to the API. +#' +#' @param cansimTableNumber The table number the coordinates belong to +#' @param coordinates The coordinates to retrieve changed data for +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. +#' @param factors (Optional) Logical value indicating if dimensions should be converted to factors. (Default set to \code{TRUE}). +#' @param default_month The default month that should be used when creating Date objects for annual data (default set to "07") +#' @param default_day The default day of the month that should be used when creating Date objects for monthly data (default set to "01") +#' +#' @return A tibble with the changed data for the specified coordinates +#' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. +#' @examples +#' \dontrun{ +#' get_cansim_changed_series_data_for_coordinates("34-10-0013","1.1") +#' } +#' @export +get_cansim_changed_series_data_for_coordinates <- function(cansimTableNumber, coordinates, + language="english", timeout=200, + factors=TRUE, default_month="07", + default_day="01"){ + validate_single_table_number(cansimTableNumber) + product_id <- naked_ndm_table_number(cleaned_ndm_table_number(cansimTableNumber)) + # the API wants coordinates spelled out to all ten dimensions + coordinates <- normalize_coordinates(coordinates) + bodies <- paste0('{"productId":',product_id,', "coordinate":"',coordinates,'"}') + + changed_series_data("https://www150.statcan.gc.ca/t1/wds/rest/getChangedSeriesDataFromCubePidCoord", + bodies,NULL,language,timeout,factors,default_month,default_day) +} diff --git a/R/cansim_character_scan.R b/R/cansim_character_scan.R new file mode 100644 index 00000000..63935c7d --- /dev/null +++ b/R/cansim_character_scan.R @@ -0,0 +1,214 @@ +# Instrumentation for #169, meant to be deleted along with its tests once StatCan stops publishing +# non-breaking spaces and control characters in the names it returns. Everything else in the package +# repairs those characters on the way in, which by design hides them, so watching whether the +# upstream problem is shrinking needs a reader that looks at the metadata as StatCan sends it. The +# repair itself, and the warning it emits, become dead weight once a scan comes back empty. + +CUBE_METADATA_SCAN_URL <- "https://www150.statcan.gc.ca/t1/wds/rest/getCubeMetadata" + +# The names of one metadata level for one language, one element per dimension or member, NA where +# StatCan sent nothing at all. Reading them as a vector is what lets the scan grep a whole dimension +# of members at once, there are 2.3 million of them across the catalogue. +scan_names_of <- function(items,key) { + vapply(items, + function(x) { + value <- x[[key]] + if (is.null(value) || length(value)!=1 || is.na(value)) NA_character_ else as.character(value) + }, + character(1)) +} + +# A clean scan finds nothing, so the columns have to come from somewhere other than the hits +empty_character_scan_hits <- function() { + tibble(cansimTableNumber=character(0),level=character(0),language=character(0), + dimension=character(0),value=character(0)) +} + +# One cube as StatCan returned it, no repair applied. Returns the offending names and the number of +# names looked at, the latter is the denominator the hit counts are meaningless without. +scan_cube_object <- function(object) { + problem_characters <- paste0(ZERO_WIDTH_CHARACTERS,"|",SPACE_LIKE_CHARACTERS) + cansimTableNumber <- cleaned_ndm_table_number(as.character(object$productId)) + hits <- list() + + record <- function(level,language,dimension,values) { + if (length(values)==0) return(invisible(NULL)) + bad <- which(!is.na(values) & grepl(problem_characters,values)) + if (length(bad)==0) return(invisible(NULL)) + hits[[length(hits)+1]] <<- tibble(cansimTableNumber=cansimTableNumber, + level=level, + language=language, + dimension=dimension, + value=values[bad]) + invisible(NULL) + } + + for (language in c("eng","fra")) { + suffix <- ifelse(language=="eng","En","Fr") + record("title",language,NA_character_,scan_names_of(list(object),paste0("cubeTitle",suffix))) + } + + dimensions <- object$dimension + members <- 0L + for (dimension in dimensions) { + # the English name identifies the dimension in both languages, a French hit is easier to place + # when it is labelled with the name the rest of the package uses + name <- scan_names_of(list(dimension),"dimensionNameEn") + members <- members + length(dimension$member) + for (language in c("eng","fra")) { + suffix <- ifelse(language=="eng","En","Fr") + record("dimension",language,name,scan_names_of(list(dimension),paste0("dimensionName",suffix))) + record("member",language,name,scan_names_of(dimension$member,paste0("memberName",suffix))) + } + } + + list(hits=hits, + scanned=tibble(cansimTableNumber=cansimTableNumber, + dimensions=length(dimensions), + members=members)) +} + +# Scans the names StatCan publishes for the characters `repair_statcan_strings()` removes, reading +# the metadata straight off the API rather than through `get_cansim_cube_metadata()` so that the +# repair does not hide what is being counted. Defaults to the whole catalogue, which is around 165 +# API calls and takes some twenty minutes, pass table numbers to scan a survey or a single table. +# +# Returns a list of +# `hits`, one row per offending name, holding the name as StatCan sent it and the same name with +# its offending characters written out as `` and friends +# `scanned`, one row per table, carrying the number of dimensions and members looked at and, when +# the whole catalogue was scanned, the survey the table belongs to +# `failed`, the tables StatCan would not return metadata for +# +# Hand the result to `summarize_statcan_character_problems()` for the counts by level, language and +# survey. Returns NULL when StatCan cannot be reached, as the rest of the package does. +scan_statcan_character_problems <- function(cansimTableNumber=NULL,batch_size=50,quiet=FALSE) { + cubes <- NULL + if (is.null(cansimTableNumber)) { + cubes <- suppressWarnings(list_cansim_cubes()) + if (is.null(cubes)) return(NULL) + cansimTableNumber <- cubes$cansim_table_number + } + cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) + + batches <- split(cansimTableNumber,ceiling(seq_along(cansimTableNumber)/batch_size)) + if (!quiet) message("Scanning ",length(cansimTableNumber)," tables in ",length(batches)," calls") + + hits <- list() + scanned <- list() + failed <- character(0) + started <- Sys.time() + + for (i in seq_along(batches)) { + body <- paste0("[",paste(paste0('{"productId":',naked_ndm_table_number(batches[[i]]),'}'), + collapse=", "),"]") + response <- post_with_timeout_retry(CUBE_METADATA_SCAN_URL,body=body) + if (is.null(response)) return(NULL) + + data <- statcan_response_json(response) + succeeded <- Filter(function(x)x$status=="SUCCESS",data) + for (x in succeeded) { + scan <- scan_cube_object(x$object) + hits <- c(hits,scan$hits) + scanned[[length(scanned)+1]] <- scan$scanned + } + failed <- c(failed,setdiff(batches[[i]], + purrr::map_chr(succeeded, + \(x)cleaned_ndm_table_number(as.character(x$object$productId))))) + + if (!quiet && (i %% 10 == 0 || i==length(batches))) { + message(sprintf("%d/%d calls, %d tables, %d affected names, %.1f minutes elapsed", + i,length(batches),length(scanned), + sum(vapply(hits,nrow,integer(1))), + as.numeric(difftime(Sys.time(),started,units="mins")))) + } + } + + hits <- bind_rows(hits,empty_character_scan_hits()) %>% + mutate(escaped=escape_statcan_characters(.data$value)) + + scanned <- bind_rows(scanned,tibble(cansimTableNumber=character(0), + dimensions=integer(0),members=integer(0))) + if (!is.null(cubes)) { + scanned <- scanned %>% + left_join(cubes %>% select("cansim_table_number","surveyCode","surveyEn"), + by=c("cansimTableNumber"="cansim_table_number")) + } + + list(hits=hits,scanned=scanned,failed=failed) +} + +# A cube can list several surveys and is counted under each of them, so the survey rows add up to +# more than the number of tables scanned. Survey names come from the cubes that list a single code, +# the cube list joins the names of several surveys with the same comma it joins their codes with and +# survey names have commas of their own, so a cube listing several cannot be taken apart again. +survey_lookup_from_cubes <- function(scanned) { + scanned %>% + filter(!grepl(",",.data$surveyCode),.data$surveyCode!="") %>% + transmute(surveyCode=trimws(.data$surveyCode),survey=.data$surveyEn) %>% + filter(!is.na(.data$survey)) %>% + distinct(.data$surveyCode,.keep_all=TRUE) +} + +# Counts for a `scan_statcan_character_problems()` result, as a list of +# `overall`, one row per metadata level with the names scanned and the hits in each language +# `tables`, how many tables are affected and on which language side +# `characters`, how often each offending code point occurs, a name can hold several +# `surveys`, the same counts per survey, only present when the whole catalogue was scanned +summarize_statcan_character_problems <- function(scan) { + hits <- scan$hits + scanned <- scan$scanned + levels <- c("title","dimension","member") + count_hits <- function(level,language) sum(hits$level==level & hits$language==language) + + overall <- tibble(level=levels, + scanned=c(nrow(scanned),sum(scanned$dimensions),sum(scanned$members)), + english=unname(vapply(levels,\(l)count_hits(l,"eng"),integer(1))), + french=unname(vapply(levels,\(l)count_hits(l,"fra"),integer(1)))) %>% + mutate(total=.data$english+.data$french) + + per_table <- scanned %>% + select("cansimTableNumber") %>% + left_join(hits %>% + group_by(.data$cansimTableNumber) %>% + summarize(english=sum(.data$language=="eng"), + french=sum(.data$language=="fra"),.groups="drop"), + by="cansimTableNumber") %>% + mutate(across(c("english","french"),\(x)tidyr::replace_na(x,0L)), + total=.data$english+.data$french) + + tables <- tibble(tables=nrow(per_table), + affected=sum(per_table$total>0), + english_only=sum(per_table$english>0 & per_table$french==0), + french_only=sum(per_table$english==0 & per_table$french>0), + both=sum(per_table$english>0 & per_table$french>0)) + + code_points <- unlist(lapply(hits$value,\(v){ + points <- utf8ToInt(v) + points[points %in% c(ZERO_WIDTH_CODE_POINTS,SPACE_LIKE_CODE_POINTS)] + })) + characters <- tibble(code_point=sprintf("U+%04X",code_points)) %>% + count(.data$code_point,name="occurrences",sort=TRUE) + + summary <- list(overall=overall,tables=tables,characters=characters) + + if ("surveyCode" %in% names(scanned)) { + summary$surveys <- scanned %>% + select("cansimTableNumber","surveyCode") %>% + mutate(surveyCode=strsplit(.data$surveyCode,"\\s*,\\s*")) %>% + tidyr::unnest("surveyCode") %>% + filter(.data$surveyCode!="") %>% + left_join(per_table,by="cansimTableNumber") %>% + group_by(.data$surveyCode) %>% + summarize(tables=n(), + affected_tables=sum(.data$total>0), + english=sum(.data$english), + french=sum(.data$french), + total=sum(.data$total),.groups="drop") %>% + left_join(survey_lookup_from_cubes(scanned),by="surveyCode") %>% + select("survey","surveyCode","tables","affected_tables","english","french","total") %>% + arrange(desc(.data$total)) + } + + summary +} diff --git a/R/cansim_helpers.R b/R/cansim_helpers.R index 2a433aa9..f0b8a219 100644 --- a/R/cansim_helpers.R +++ b/R/cansim_helpers.R @@ -1,3 +1,226 @@ +# StatCan returns some names containing characters that are either invisible or that render as an +# ordinary space, most importantly the non-breaking space U+00A0. A name holding one of these cannot +# be reached by typing or copy-pasting what the console displays, which makes the corresponding +# column inaccessible in an R session. Line feeds and other control characters cause the same problem. +ZERO_WIDTH_CODE_POINTS <- c(0x200B,0x200C,0x200D,0xFEFF) +SPACE_LIKE_CODE_POINTS <- c(0x0009,0x000A,0x000B,0x000C,0x000D,0x00A0,0x1680, + 0x2000:0x200A,0x2028,0x2029,0x202F,0x205F,0x3000) +ZERO_WIDTH_CHARACTERS <- paste0("[",intToUtf8(ZERO_WIDTH_CODE_POINTS),"]") +SPACE_LIKE_CHARACTERS <- paste0("[",intToUtf8(SPACE_LIKE_CODE_POINTS),"]") + +# Zero width characters are dropped, everything else that behaves like a space becomes a regular +# space. Strings that contain none of these are returned untouched, so that the squishing and +# trimming below can never alter a name StatCan spelled with ordinary characters. +repair_statcan_strings <- function(x) { + if (length(x)==0 || !is.character(x)) return(x) + needs_repair <- !is.na(x) & grepl(paste0(ZERO_WIDTH_CHARACTERS,"|",SPACE_LIKE_CHARACTERS),x) + if (!any(needs_repair)) return(x) + + x[needs_repair] <- x[needs_repair] %>% + gsub(ZERO_WIDTH_CHARACTERS,"",.) %>% + gsub(SPACE_LIKE_CHARACTERS," ",.) %>% + gsub(" {2,}"," ",.) %>% + trimws() + + x +} + +# Renders the offending characters as their code points. A report that showed the repaired name +# would hide the very thing it is reporting on, since these characters are invisible on screen. +escape_statcan_characters <- function(x) { + for (code_point in c(ZERO_WIDTH_CODE_POINTS,SPACE_LIKE_CODE_POINTS)) { + x <- gsub(intToUtf8(code_point),sprintf("",code_point),x,fixed=TRUE) + } + x +} + +# Keeps the report readable when the offending character sits in the middle of a long table title, +# by showing a window around it rather than the whole string. +abbreviate_around_escape <- function(x,width=60) { + if (is.na(x) || nchar(x)<=width) return(x) + ellipsis <- intToUtf8(0x2026) + at <- regexpr("1) ellipsis else "",substr(x,start,end),if (end% escape_statcan_characters() %>% abbreviate_around_escape() + warning(wrap_warning_text( + "StatCan returned ",context," containing non-breaking spaces or control characters. ", + "These render as an ordinary space or as nothing at all, so the names cannot be typed or ", + "copy-pasted, the package has replaced them with regular spaces. ", + if (length(original_values)==1) paste0("Repaired \"",example,"\".") + else paste0("Repaired ",length(original_values)," names, for example \"",example,"\"."), + " Nothing on your end causes this and nothing on your end can fix it, the characters are ", + "in the data StatCan publishes. This warning will disappear on its own once StatCan stops ", + "sending them, which is tracked at ",ISSUE_169_URL,". ", + "Set options(cansim.suppress_repair_warnings=TRUE) to silence this."), + call.=FALSE) + invisible(NULL) +} + +# repairs a character vector of names and reports once on what changed +repair_statcan_names <- function(x,context=NULL) { + repaired <- repair_statcan_strings(x) + if (!is.null(context)) { + warn_statcan_repairs(unique(x[!is.na(x) & repaired!=x]),context) + } + repaired +} + +# repairs the given columns of a table and reports once across all of them +repair_statcan_columns <- function(data,columns,context=NULL) { + columns <- intersect(columns,names(data)) + changed <- character(0) + for (column in columns) { + original <- data[[column]] + repaired <- repair_statcan_strings(original) + if (!identical(repaired,original)) { + changed <- c(changed,original[!is.na(original) & repaired!=original]) + data[[column]] <- repaired + } + } + if (!is.null(context)) warn_statcan_repairs(unique(changed),context) + data +} + +# The member names in the metadata are repaired, so the labels in the data have to be repaired the +# same way or the two no longer match and every row carrying an affected label turns into NA when the +# dimension is converted to a factor. Dimension columns hold a handful of distinct labels repeated +# across millions of rows, so only the distinct values are scanned and the rows are read back through +# an index. Scanning every row instead costs about seventy times as much on a large table. +repair_statcan_values <- function(x) { + if (length(x)==0 || !is.character(x)) return(x) + values <- unique(x) + repaired <- repair_statcan_strings(values) + if (identical(repaired,values)) return(x) + repaired[match(x,values)] +} + +# The dimension columns are the ones whose labels come from the metadata, and the only ones that need +# repairing. Everything else is either numeric, an identifier, or the coordinate column, which holds +# one distinct value per series and would make the scan above the expensive thing it avoids. +dimension_columns_in_data <- function(data_columns,dimension_names,cleaned_language) { + geography_column <- ifelse(cleaned_language=="eng","Geography|Geographic name", + paste0("G",intToUtf8(0x00E9),"ographie|Nom g",intToUtf8(0x00E9),"ographique")) + data_geography_column <- ifelse(cleaned_language=="eng","GEO",paste0("G",intToUtf8(0x00C9),"O")) + geography_columns <- geography_colum_names(cleaned_language) + + columns <- vapply(dimension_names, function(field) { + if (field %in% data_columns) return(field) + # StatCan names the geography dimension in the metadata but calls the column GEO in the data + if ((grepl(geography_column,field) || field %in% geography_columns) && + data_geography_column %in% data_columns) return(data_geography_column) + NA_character_ + }, character(1), USE.NAMES=FALSE) + + unique(columns[!is.na(columns)]) +} + +# repairs the dimension columns of a table, silently, the caller has already reported on the names +repair_statcan_dimension_values <- function(data,dimension_names,cleaned_language) { + columns <- dimension_columns_in_data(names(data),dimension_names,cleaned_language) + for (column in columns) { + data[[column]] <- repair_statcan_values(data[[column]]) + } + data +} + +# Two things about a cached table are not in the data itself, when it was downloaded and which +# version of the package parsed it. The first says whether StatCan has newer data, the second says +# whether this version of the package would read the same files the same way. They are kept together +# in one file next to the data, `.Rda_info`, as a named list so that further entries can join them. +CACHE_INFO_SUFFIX <- "_info" + +# up to 0.4.4 the timestamp lived on its own in `.Rda_time` and there was no version at all +LEGACY_CACHE_TIME_SUFFIX <- "_time" + +# non-breaking spaces and control characters in column names and member labels are repaired as of +# this version, anything cached before it still carries the characters StatCan sent +VALUE_REPAIR_VERSION <- package_version("0.4.5") + +write_cache_info <- function(meta_base_path,time_cached) { + tryCatch( + saveRDS(list(timeCached=strftime(time_cached,format=TIME_FORMAT), + cansimVersion=as.character(utils::packageVersion("cansim"))), + paste0(meta_base_path,CACHE_INFO_SUFFIX)), + error = function(e) warning("Failed to save cache info: ", e$message) + ) + # a table refreshed into a cache that still has the old timestamp file leaves it behind stale + legacy_file <- paste0(meta_base_path,LEGACY_CACHE_TIME_SUFFIX) + if (file.exists(legacy_file)) unlink(legacy_file) + invisible(NULL) +} + +# Always returns both entries, either of them `NA` when the cache does not say. A cache written +# before 0.4.5 has the timestamp on its own and no version, which is itself the tell that the files +# were parsed by a version that predates everything the version is consulted about. +read_cache_info <- function(cache_dir) { + info_file <- dir(cache_dir,paste0("\\.Rda",CACHE_INFO_SUFFIX,"$")) + if (length(info_file)==1) { + info <- tryCatch(readRDS(file.path(cache_dir,info_file)),error=function(e) NULL) + if (is.list(info)) { + entry <- function(name) if (length(info[[name]])==1) as.character(info[[name]]) else NA_character_ + return(list(timeCached=entry("timeCached"),cansimVersion=entry("cansimVersion"))) + } + } + + time_file <- dir(cache_dir,paste0("\\.Rda",LEGACY_CACHE_TIME_SUFFIX,"$")) + time_cached <- NA_character_ + if (length(time_file)==1) { + time_cached <- tryCatch(as.character(readRDS(file.path(cache_dir,time_file))), + error=function(e) NA_character_) + } + list(timeCached=time_cached,cansimVersion=NA_character_) +} + +# `NULL` when the cache does not record one, the caller decides what an unmarked cache means +read_cache_version <- function(cache_dir) { + version <- read_cache_info(cache_dir)$cansimVersion + if (is.na(version)) return(NULL) + tryCatch(package_version(version),error=function(e) NULL) +} + +cache_predates_value_repair <- function(cache_dir) { + version <- read_cache_version(cache_dir) + is.null(version) || version < VALUE_REPAIR_VERSION +} + +# The dimension names and member labels cached with an old table carry the same unrepaired characters +# as its data, so they are what an old cache can be checked against. The footnotes and the table title +# are not looked at, a line feed inside a footnote is part of the text rather than a defect. +CACHE_METADATA_LABEL_PATTERN <- "\\.Rda2$|\\.Rda_column_" + +# The names and labels the cached metadata holds that the repair would change. Reading them back is +# what tells us whether a cache that predates the repair is actually affected, most tables are not. +stale_cached_labels <- function(cache_dir) { + files <- dir(cache_dir,CACHE_METADATA_LABEL_PATTERN,full.names=TRUE) + labels <- lapply(files, function(file) { + tryCatch({ + meta <- readRDS(file) + values <- c(names(meta),unlist(lapply(meta, function(column) { + if (is.factor(column)) levels(column) else if (is.character(column)) unique(column) else NULL + }),use.names=FALSE)) + values[!is.na(values) & values!=repair_statcan_strings(values)] + }, error=function(e) character(0)) + }) + unique(unlist(labels,use.names=FALSE)) +} + cleaned_ndm_table_number <- function(cansimTableNumber){ if (is.numeric(cansimTableNumber)) { warning(paste0("The cansim table number ",cansimTableNumber," used in this query is numeric,\n", @@ -31,22 +254,60 @@ naked_ndm_table_number <- function(cansimTableNumber){ as.character(gsub("-","",cleaned_ndm_table_number(cansimTableNumber))) } +# StatCan publishes in both languages and so do the people using this package, so a language can be +# named in either one. Everything is folded to lower case and stripped of accents before it is +# matched, which is what lets "Francais", accented or not, and "FRA" all name the same language. +ACCENTED_LETTERS <- intToUtf8(c(0x00E0,0x00E1,0x00E2,0x00E3,0x00E4,0x00E5,0x00E7,0x00E8,0x00E9, + 0x00EA,0x00EB,0x00EE,0x00EF,0x00F4,0x00F6,0x00F9,0x00FB,0x00FC)) +UNACCENTED_LETTERS <- "aaaaaaceeeeiioouuu" + +ENGLISH_LANGUAGE_NAMES <- c("en","eng","engl","english","ang","angl","anglais","anglaise") +FRENCH_LANGUAGE_NAMES <- c("fr","fre","fren","french","fra","fran","franc","francais","francaise") + +# Errors on anything it does not recognize rather than passing an NA on. An unrecognized language used +# to travel as far as the name of a cache directory or the tail of a StatCan URL, where it surfaced as +# a download failure or as a column that could not be found, neither of which points at the argument +# that caused it. Vectors are allowed, `remove_cansim_cached_tables()` asks for both languages at once. cleaned_ndm_language <- function(language){ - ifelse(tolower(language) %in% c("english","eng","en"),"eng",ifelse(tolower(language) %in% c("fra","french","fr"),"fra",NA)) + normalized <- language %>% as.character() %>% trimws() %>% tolower() %>% + chartr(ACCENTED_LETTERS,UNACCENTED_LETTERS,.) + cleaned <- ifelse(normalized %in% ENGLISH_LANGUAGE_NAMES,"eng", + ifelse(normalized %in% FRENCH_LANGUAGE_NAMES,"fra",NA_character_)) + + unknown <- unique(language[is.na(cleaned)]) + if (length(unknown)>0) { + stop("Unknown language ",paste0('"',unknown,'"',collapse=", "), + '. Use "english" (or "en", "eng", "anglais") for English and ', + '"french" (or "fr", "fra", "francais") for French, case and accents are ignored.', + call.=FALSE) + } + + cleaned } table_base_path <- function(cansimTableNumber) { file.path(tempdir(),paste0("cansim_",naked_ndm_table_number(cansimTableNumber))) } +# several functions only operate on a single table, guard against silently +# processing just the first entry when a vector of table numbers is passed +validate_single_table_number <- function(cansimTableNumber){ + if (length(cansimTableNumber)>1) { + stop("This function only accepts a single table number, but ",length(cansimTableNumber), + " table numbers were given.",call.=FALSE) + } + invisible(cansimTableNumber) +} + file_path_for_table_language <- function(cansimTableNumber, language){ + validate_single_table_number(cansimTableNumber) language <- cleaned_ndm_language(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)) } base_path_for_table_language <- function(cansimTableNumber, language,base_dir = NULL){ + validate_single_table_number(cansimTableNumber) if (is.null(base_dir)) { base_dir <- table_base_path(cansimTableNumber) } @@ -56,6 +317,15 @@ base_path_for_table_language <- function(cansimTableNumber, language,base_dir = file.path(base_dir,file_path_for_table_language(cansimTableNumber,language)) } +# StatCan rejects a request that carries more than this many items with an HTTP 416 that names the +# limit, so every method taking a list of vectors, coordinates or tables is sent in batches of at +# most this size. The limit is enforced by the API but is not stated in the WDS user guide. +MAX_BATCH_SIZE <- 300L + +batch_items <- function(items,size=MAX_BATCH_SIZE){ + unname(split(items,ceiling(seq_along(items)/size))) +} + response_status_code_translation <- list( "0"="Success", "1"="Invalid date", @@ -69,102 +339,297 @@ response_status_code_translation <- list( ) response_error_translation <- list( - "503"="StatCan website is currently unavailable" + "409"=paste0("StatCan is publishing this table right now, or the daily update window ", + "(midnight to 8:30am Eastern) has not finished, please try again later"), + "416"="The request asked for more items than StatCan accepts in a single call", + "429"="StatCan is rate limiting requests, please try again later", + "502"="StatCan website is currently unreachable", + "503"=paste0("StatCan website is currently unavailable, either for scheduled maintenance or ", + "because of an outage. This lasts longer than it is worth waiting for, so the ", + "request was not retried, please try again later"), + "504"=paste0("StatCan's own gateway gave up waiting for the servers behind it. StatCan works out a ", + "whole response before sending any of it, so this usually means the request was larger ", + "than it can put together in the time it allows itself, and asking for less at once ", + "may get through where retrying unchanged will not") ) -get_with_timeout_retry <- function(url,timeout=200,retry=3,path=NA,warn_only=FALSE){ - if (!is.na(path)) { - response <- purrr::safely(httr::GET)(url,encode="json", - httr::add_headers("Content-Type"="application/json"), - httr::timeout(timeout), - httr::write_disk(path,overwrite = TRUE)) - } else { - response <- purrr::safely(httr::GET)(url, - encode="json", - httr::add_headers("Content-Type"="application/json"), - httr::timeout(timeout)) - } - if (!is.null(response$error)){ - if ("curl_error_peer_failed_verification" %in% class(response$error)) { - stop(stringr::str_wrap(gsub(".+\\): ","",as.character(response$error),80)),"\n", - "This means that the authenticity of the StatCan API server can't be verified.\n", - "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.",call.=FALSE) - } - if (retry>0) { - message("Got timeout from StatCan, trying again") - response <- get_with_timeout_retry(url,timeout=timeout,retry=retry-1,path=path) - } else { - message("Got timeout from StatCan, giving up") - } - } else if (response$result$status_code %in% names(response_error_translation)){ - if (warn_only) { - warning(sprintf("%s\nReturned status code %s",response_error_translation[[as.character(response$result$status_code)]], response$result$status_code),call.=FALSE) - response=response$result - } else { - stop(sprintf("%s\nReturned status code %s",response_error_translation[[as.character(response$result$status_code)]], response$result$status_code),call.=FALSE) - } - } else if (response$result$status_code != 200){ - if (warn_only) { - warning(sprintf("Problem downloading data, returned status code %s.",response$result$status_code),call.=FALSE) - response=response$result - } else { - stop(sprintf("Problem downloading data, returned status code %s.",response$result$status_code),call.=FALSE) +# A WDS method that takes a list of items answers with one record per item, each carrying its own +# status, and the API does not signal a bad item the same way everywhere. Some methods mark the +# record `"status":"FAILED"`, others answer `"status":"SUCCESS"` and put the reason in +# `responseStatusCode`, where anything other than 0 means the record carries no data. Asking only +# about `status` is what let an invalid vector through `get_cansim_vector_info()` as a row of NAs +# that was indistinguishable from real metadata, so both are checked here. +wds_record_code <- function(record){ + object <- record$object + # a record that failed outright can carry a sentence in place of the object + if (!is.list(object)) return(NA_integer_) + code <- object$responseStatusCode + if (length(code)!=1) return(NA_integer_) + suppressWarnings(as.integer(code)) +} + +wds_record_succeeded <- function(record){ + if (!identical(as.character(record$status),"SUCCESS")) return(FALSE) + code <- wds_record_code(record) + is.na(code) || code==0L +} + +split_wds_records <- function(data){ + if (length(data)==0) return(list(success=list(),failed=list())) + succeeded <- vapply(data,wds_record_succeeded,logical(1)) + list(success=data[succeeded],failed=data[!succeeded]) +} + +wds_record_reason <- function(record){ + object <- record$object + if (is.character(object) && length(object)==1) return(object) + code <- wds_record_code(record) + if (is.na(code)) return("no reason given") + translation <- response_status_code_translation[[as.character(code)]] + # the API emits codes that are not in its own wdsResponseStatus code set, such as the 9 it + # answers with when a request exceeds the item limit + if (is.null(translation)) return(paste0("StatCan response status code ",code)) + translation +} + +# Names the item a failed record answers for, so that a report can say which vector or coordinate +# was dropped rather than only how many. +wds_record_id <- function(record){ + object <- record$object + if (!is.list(object)) return(NA_character_) + present <- function(x) length(x)==1 && !is.na(x) && x!=0 + if (present(object$vectorId)) return(paste0("v",object$vectorId)) + if (present(object$productId)) { + # spelled out rather than routed through cleaned_ndm_table_number(), which warns and messages + # on its own and has no business doing so from inside a failure report + product_id <- as.character(object$productId) + table_number <- paste0(substr(product_id,1,2),"-",substr(product_id,3,4),"-",substr(product_id,5,8)) + if (length(object$coordinate)==1 && !is.na(object$coordinate)) { + return(paste0(table_number," ",gsub("(\\.0)+$","",object$coordinate))) } - } else { - response=response$result + return(table_number) } + NA_character_ +} - if (is.null(response) && retry == 0) { - if (warn_only) { - warning(sprintf("Problem downloading data, multiple timeouts.\nPlease check your network connection. If your connections is fine then StatCan servers might be down."),call.=FALSE) - response=response$result - } else { - stop(sprintf("Problem downloading data, multiple timeouts.\nPlease check your network connection. If your connections is fine then StatCan servers might be down."),call.=FALSE) - } +report_failed_wds_records <- function(failed,context){ + if (length(failed)==0) return(invisible(NULL)) + reasons <- vapply(failed,wds_record_reason,character(1)) + ids <- vapply(failed,wds_record_id,character(1)) + message("Failed to load ",context," for ",length(failed)," of the requested items.") + # a batch of 300 bad vectors is one problem, not 300, so identical reasons are reported together + for (reason in unique(reasons)) { + named <- as.character(na.omit(ids[reasons==reason])) + shown <- head(named,5) + message(" ",reason, + if (length(shown)>0) paste0(" (",paste(shown,collapse=", "), + if (length(named)>length(shown)) ", ..." else "",")") else "") } - response + invisible(NULL) } -post_with_timeout_retry <- function(url,body,timeout=200,retry=3,warn_only=FALSE){ - response <- purrr::safely(httr::POST)(url, - body=body, - encode="json", - httr::add_headers("Content-Type"="application/json"), - httr::timeout(timeout)) - if (!is.null(response$error)){ - if ("curl_error_peer_failed_verification" %in% class(response$error)) { - stop(stringr::str_wrap(gsub(".+\\): ","",as.character(response$error),80)),"\n", - "This means that the authenticity of the StatCan API server can't be verified.\n", - "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.",call.=FALSE) - } - if (retry>0) { - message("Got timeout from StatCan, trying again") - response <- post_with_timeout_retry(url,body=body,timeout=timeout,retry=retry-1) - } else { - message("Got timeout from StatCan, giving up") - response=response$result - } - } else { - response=response$result +# Returns the records that carry data and reports on the rest. `ignore_codes` is for the callers to +# which a given failure is an expected answer rather than a problem worth mentioning. +successful_wds_records <- function(data,context,ignore_codes=integer(0)){ + records <- split_wds_records(data) + if (length(records$failed)>0) { + reported <- Filter(\(record) !(wds_record_code(record) %in% ignore_codes),records$failed) + report_failed_wds_records(reported,context) } + records$success +} - if (is.null(response) && retry == 0) { - if (warn_only) { - warning(sprintf("Problem downloading data, multiple timeouts.\nPlease check your network connection. If your connections is fine then StatCan servers might be down."),call.=FALSE) - response=NULL - } else { - stop(sprintf("Problem downloading data, multiple timeouts.\nPlease check your network connection. If your connections is fine then StatCan servers might be down."),call.=FALSE) +# StatCan servers time out, go down for maintenance, or serve error pages often enough that treating +# it as a fatal error is the wrong default. Every failure to get a usable answer out of StatCan is +# reported through here, which warns loudly and returns NULL so the calling function can return NULL +# in turn. Erroring instead is what repeatedly got the package pulled from CRAN, since a check run +# started while StatCan was down would fail on examples and vignettes that are not at fault. +# Set options(cansim.error_on_unavailable=TRUE) to get an error rather than a warning. +statcan_unavailable <- function(...){ + message <- paste0(...) + if (isTRUE(getOption("cansim.error_on_unavailable"))) stop(message,call.=FALSE) + warning(message,call.=FALSE) + NULL +} + +# The body of every WDS answer is JSON, and this is the only place that is assumed, so that the +# fourteen call sites reading a response do not each have to say so. `check_type=FALSE` because a few +# of the endpoints the package uses, the key release schedule among them, have been seen to label +# their JSON as plain text. +statcan_response_json <- function(response){ + httr2::resp_body_json(response,check_type=FALSE) +} + +# A response StatCan refuses carries a JSON body saying why, which the status code on its own does +# not: the 409 served outside the daily release window explains that the product is not released +# yet, and the 416 served for an oversized request names the item limit it went past. Anything that +# is not JSON with a message in it, an HTML error page or a part-written download, yields NULL. +statcan_response_message <- function(response){ + parsed <- tryCatch(statcan_response_json(response),error=function(e) NULL) + if (!is.list(parsed)) return(NULL) + detail <- parsed$message + if (is.null(detail) && is.character(parsed$object)) detail <- parsed$object + if (length(detail)!=1 || !is.character(detail) || is.na(detail) || detail=="") return(NULL) + detail +} + +# StatCan documents a limit of 25 requests per second per IP address, and 50 across all callers. The +# package makes its requests one after the other so it rarely comes close, but a script looping over +# many tables or vectors can, and being throttled locally is better than being answered with an +# HTTP 429. +STATCAN_REQUESTS_PER_SECOND <- 25 + +# Statuses worth trying again a moment later, being the ones a busy or briefly confused server +# recovers from within seconds. Deliberately not in the list: +# 409, the nightly update window, which lasts until 8:30am Eastern +# 416, a request carrying more items than StatCan accepts, which stays oversized however often it +# is sent +# 503, StatCan being down for maintenance or an outage, which lasts far longer than any retry +# budget worth spending +# Retrying any of these would only fail more slowly, so they are reported to the caller instead, +# with a message saying what to do about it. +STATCAN_TRANSIENT_STATUS <- c(429L,500L,502L,504L) + +# An upper bound on the wall clock time one request may spend being retried, counted from the start of +# the first attempt and so covering the requests themselves as well as the waiting between them. The +# backoff sleeps for somewhere between one and 2^n seconds before the nth retry, which adds up to at +# most 14 seconds across the three retries a request gets by default, so 30 seconds leaves room for +# the full sequence to play out along with the requests it separates. Its purpose is the case that +# sequence does not cover: a request that hangs rather than failing, where the default 200 second +# timeout would otherwise let a single call sit for the better part of quarter of an hour before +# giving up. One attempt that runs to that timeout now uses up the budget on its own, which is the +# intended trade, since a connection StatCan has left hanging rarely comes back on an immediate retry. +STATCAN_MAX_RETRY_SECONDS <- 30 + +# The `timeout` every download function takes used to be a hard cap on the whole transfer, which +# cannot tell a connection StatCan has stopped answering on from a large table that is simply taking a +# while to arrive, and cut both off alike. It is now the length of time StatCan may go without sending +# anything useful, which is the distinction the argument was always described as making. A transfer +# that keeps delivering is left alone however long it runs, and one that goes quiet is dropped. +# +# The floor is set well under any real transfer, an 11.8MB table download runs at about 3MB/s, while +# still being high enough that a connection dribbling a byte at a time to stay alive does not hold the +# session open forever. +STATCAN_MINIMUM_SPEED <- 100 + +# StatCan answers a request by working out the whole response and only then sending it, so the wait +# for the first byte grows with the size of the request: about 0.11 seconds per vector, putting the +# 300 item batches this package sends at roughly 35 seconds of silence before any data arrives. That +# silence counts against the timeout above, which is why the default is left far above it rather than +# tightened to the few seconds a healthy connection needs. Establishing the connection is the one part +# that is quick regardless, and is bounded separately so an unreachable host fails fast. +STATCAN_CONNECT_TIMEOUT <- 10 + +cansim_user_agent <- function(){ + paste0("cansim/",utils::packageVersion("cansim")," (https://github.com/mountainMath/cansim)") +} + +# The shape every request to StatCan has in common. Retry and throttling are handled by httr2 rather +# than by hand: `req_retry()` backs off exponentially with jitter between attempts and honours a +# `Retry-After` header if StatCan sends one, where the package used to retry immediately and only +# ever on a connection failure, never on a status code that says to come back later. +statcan_request <- function(url,timeout=200,retry=3){ + req <- httr2::request(url) %>% + httr2::req_user_agent(cansim_user_agent()) %>% + # sent on GET as well as POST, which is what the package has always done + httr2::req_headers("Content-Type"="application/json") %>% + # `timeout` bounds how long StatCan may go without sending anything, not how long the whole + # transfer may take, see the note on STATCAN_MINIMUM_SPEED above + httr2::req_options(low_speed_limit=STATCAN_MINIMUM_SPEED, + low_speed_time=timeout, + connecttimeout=STATCAN_CONNECT_TIMEOUT) %>% + # every status is translated below rather than thrown, so that a caller only has to check for NULL + httr2::req_error(is_error=function(response) FALSE) %>% + httr2::req_throttle(capacity=STATCAN_REQUESTS_PER_SECOND,fill_time_s=1,realm="statcan") %>% + httr2::req_retry(max_tries=retry+1, + max_seconds=STATCAN_MAX_RETRY_SECONDS, + retry_on_failure=TRUE, + is_transient=function(response) httr2::resp_status(response) %in% STATCAN_TRANSIENT_STATUS) + + if (isTRUE(getOption("cansim.disable_ssl_verification"))) { + req <- httr2::req_options(req,ssl_verifypeer=0,ssl_verifystatus=0) + } + req +} + +# The condition httr2 raises for a request that never got an answer wraps the underlying curl error +# as its parent, so the reason has to be looked for down the chain rather than on the condition +# itself. +condition_classes <- function(cond){ + classes <- character(0) + while (inherits(cond,"condition")) { + classes <- c(classes,class(cond)) + cond <- cond$parent + } + classes +} + +# Distinguishes "StatCan answered, and the answer is that there is nothing" from "StatCan did not +# answer", which is the NULL every failure returns. The changed-series methods need the difference: +# they report that none of the series asked about changed with an HTTP 404, which is an ordinary +# answer for them rather than a sign that anything is wrong. +STATCAN_NO_DATA <- structure(list(),class="statcan_no_data") + +statcan_no_data <- function(x) inherits(x,"statcan_no_data") + +perform_statcan_request <- function(req,path=NA,empty_status=integer(0)){ + response <- tryCatch(if (is.na(path)) httr2::req_perform(req) else httr2::req_perform(req,path=path), + error=function(e) e) + check_statcan_response(response,empty_status=empty_status) +} + +# Shared failure handling for the GET and POST helpers. Takes what performing the request produced, +# either a response or the condition raised when there was none, returns the response on success and +# NULL on any failure, so that callers only ever have to check for NULL rather than inspect statuses. +check_statcan_response <- function(response,empty_status=integer(0)){ + if (inherits(response,"condition")) { + if ("curl_error_peer_failed_verification" %in% condition_classes(response)) { + return(statcan_unavailable( + stringr::str_wrap(gsub(".+\\): ","",conditionMessage(response)),80),"\n", + "This means that the authenticity of the StatCan API server can't be verified.\n", + "Statistics Canada has a history of faulty SSL certificates 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", + "options(cansim.disable_ssl_verification=TRUE)","\n\n","into the console.")) } + return(statcan_unavailable("Problem downloading data, StatCan did not answer.\n", + "Please check your network connection. If your connection is fine then ", + "StatCan servers might be down.\n", + conditionMessage(response))) + } + if (!inherits(response,"httr2_response")) { + return(statcan_unavailable("Problem downloading data, StatCan did not return a response.")) + } + + status_code <- httr2::resp_status(response) + # a status the caller asked for as meaning "nothing to report" rather than "something went wrong" + if (status_code %in% empty_status) return(STATCAN_NO_DATA) + if (status_code!=200) { + translation <- response_error_translation[[as.character(status_code)]] + detail <- statcan_response_message(response) + return(statcan_unavailable(if (is.null(translation)) "" else paste0(translation,"\n"), + "Problem downloading data, StatCan returned status code ",status_code,".", + if (is.null(detail)) "" else paste0("\n","StatCan says: ",detail))) } response } +# `query` is given as a named list rather than pasted onto the url by the caller, because httr2 sends +# a url exactly as handed to it. StatCan's vector-by-reference-period method takes its vector ids +# quoted, and a raw double quote in a query string is answered with an HTTP 400, so the values have +# to be percent-encoded on the way out. +get_with_timeout_retry <- function(url,timeout=200,retry=3,path=NA,query=NULL,empty_status=integer(0)){ + req <- statcan_request(url,timeout=timeout,retry=retry) + if (!is.null(query)) req <- httr2::req_url_query(req,!!!query) + perform_statcan_request(req,path=path,empty_status=empty_status) +} + +post_with_timeout_retry <- function(url,body,timeout=200,retry=3,empty_status=integer(0)){ + req <- statcan_request(url,timeout=timeout,retry=retry) %>% + httr2::req_body_raw(body,type="application/json") + perform_statcan_request(req,empty_status=empty_status) +} + short_prov.en <- c( @@ -265,8 +730,9 @@ add_provincial_abbreviations <- function(data){ #' #' @return A tibble with english and french labels for the given code set #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_code_set("survey") #' } get_cansim_code_set <- function(code_set=c("scalar", "frequency", "symbol", "status", "uom", "survey", "subject", "wdsResponseStatus"), @@ -279,13 +745,9 @@ get_cansim_code_set <- function(code_set=c("scalar", "frequency", "symbol", "sta 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),call.=FALSE) - } + if (is.null(r)) return(NULL) + content <- statcan_response_json(r) + saveRDS(content,path) } else { content <- readRDS(path) } @@ -301,7 +763,7 @@ transform_value_column <- function(data,value_column){ language <- attr(data,"language") cansimTableNumber <- attr(data,"cansimTableNumber") - symbols <- which(grepl("^Symbol( \\d+)*$",names(data))) + symbols <- which(grepl("^Symbol( \\d+)*$|^Symbole( \\d+)*$",names(data))) if (!(value_column %in% names(data)) & length(symbols)>1) { #message("\nTransforming to long form.") dimension_grep_string <- paste0("^.+ \\(",length(symbols),"[A-Za-z]*\\):.+\\[\\d+\\]$") @@ -319,7 +781,7 @@ transform_value_column <- function(data,value_column){ if (length(dimension_name)>1) { warning("Unable to identify dimension name") } else { - symbol_string <- "Symbol" + symbol_string <- ifelse(language=="fra","Symbole","Symbol") renames <- c(setNames(names(data)[dimensions],paste0(member_ids," --- ",value_column)), setNames(names(data)[symbols],paste0(member_ids," --- ",symbol_string))) @@ -359,7 +821,7 @@ transform_value_column <- function(data,value_column){ dplyr::mutate(!!value_column:=as.numeric(!!as.name(value_column))) } } else { - warning("Unkown table type") + warning("Unknown table type") } data } @@ -434,20 +896,24 @@ get_deduped_column_level_data <- function(cansimTableNumber,language,column) { column = column, language = language) - # full level values from metadata + # full level values from metadata - combine mutates for efficiency level_table <- columns %>% select(...dim=!!as.name(dimension_id_column), ...id=!!as.name(member_id_column), ...name=!!as.name(member_name_column), - ...parent_id=!!as.name(parent_member_id_column)) %>% - mutate(...n=as.integer(.data$...id)) %>% - arrange("...n") %>% - select(-"...n") %>% - mutate(...count=n(),.by=c("...dim","...name")) %>% - mutate(...duplicated=.data$...count>1) %>% - mutate(...original=!.data$...duplicated) %>% - mutate(...original_name=.data$...name) %>% - mutate(...last_parent_id=.data$...parent_id) + ...parent_id=!!as.name(parent_member_id_column)) + + # Sort once using base R for efficiency + level_table <- level_table[order(as.integer(level_table$...id)), ] + + # Compute duplicates in one pass + level_table <- level_table %>% + mutate(...count=n(), + ...duplicated=.data$...count>1, + ...original=.data$...count==1, + ...original_name=.data$...name, + ...last_parent_id=.data$...parent_id, + .by=c("...dim","...name")) fixed_level_table <- NULL # don't try to dedup census geographies, too messy @@ -459,27 +925,26 @@ get_deduped_column_level_data <- function(cansimTableNumber,language,column) { filter(.data$...dim!="1") } - # try to dedup + # try to dedup - only if there are duplicates max_run <- 30 while (sum(level_table$...duplicated)>0 && max_run>0) { # deals with 36-10-0580 max_run <- max_run - 1 + # Use join-based approach for deduplication as it handles dynamic parent chains efficiently level_table <- level_table %>% left_join(level_table %>% select("...id","...dim",...parent_name="...original_name",...new_parent_id="...last_parent_id"), by=c("...last_parent_id"="...id","...dim"="...dim")) %>% mutate(...name=case_when(.data$...duplicated & is.na(.data$...parent_name) ~ paste0(.data$...name," [",.data$...id,"]"), .data$...duplicated & !is.na(.data$...parent_name) ~ paste0(.data$...name," ==> ",.data$...parent_name), - TRUE ~ .data$...name)) %>% - mutate(...last_parent_id=ifelse(.data$...duplicated, - .data$...new_parent_id, - .data$...last_parent_id)) %>% - mutate(...count=n(),.by=c("...dim","...name")) %>% - mutate(...duplicated=.data$...count>1) %>% + TRUE ~ .data$...name), + ...last_parent_id=ifelse(.data$...duplicated, .data$...new_parent_id, .data$...last_parent_id)) %>% + mutate(...count=n(), ...duplicated=.data$...count>1, .by=c("...dim","...name")) %>% select(-any_of(c("...parent_name","...new_parent_id"))) - } - bind_rows(fixed_level_table,level_table) %>% - arrange("...dim") %>% + result <- bind_rows(fixed_level_table,level_table) + # Sort by dim and id for final output + result <- result[order(as.integer(result$...dim), as.integer(result$...id)), ] + result %>% select("...dim","...id","...name","...original","...original_name") } @@ -496,6 +961,7 @@ standardize_cansim_column_order <- function(data) { scale_string <- ifelse(language=="fra","IDENTIFICATEUR SCALAIRE","SCALAR_ID") scale_string2 <- ifelse(language=="fra","FACTEUR SCALAIRE","SCALAR_FACTOR") uom_string=ifelse(language=="fra",paste0("UNIT",intToUtf8(0x00C9)," DE MESURE"),"UOM") + uom_id_string=ifelse(language=="fra",paste0("IDENTIFICATEUR D'UNIT",intToUtf8(0x00C9)," DE MESURE"),"UOM_ID") classification_prefix <- ifelse(language=="fra","Code de classification pour ","Classification Code for ") hierarchy_prefix <- ifelse(language=="fra",paste0("Hi",intToUtf8(0x00E9),"rarchie pour "),"Hierarchy for ") coordinate_column <- ifelse(language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) @@ -504,7 +970,7 @@ standardize_cansim_column_order <- function(data) { standard_order1 <- intersect(c("REF_DATE",date_field,"Date","REF_DATE2",data_geography_column,"DGUID","GeoUID") %>% unique(),names(data)) - standard_order2 <- intersect(c(value_string,"val_norm","UOM","UOM_ID",scale_string2,scale_string,"VECTOR","cansimTableNumber",coordinate_column, + standard_order2 <- intersect(c(value_string,"val_norm",uom_string,uom_id_string,scale_string2,scale_string,"VECTOR","cansimTableNumber",coordinate_column, "STATUS","SYMBOL","releaseTime","frequencyCode", "TERMINATED","DECIMALS"), names(data)) standard_order3 <- names(data)[grepl(paste0("^",hierarchy_prefix,"|^",classification_prefix),names(data))] @@ -523,10 +989,11 @@ column_names_for_language <- function(language) { scale_string <- ifelse(language=="fra","IDENTIFICATEUR SCALAIRE","SCALAR_ID") scale_string2 <- ifelse(language=="fra","FACTEUR SCALAIRE","SCALAR_FACTOR") uom_string=ifelse(language=="fra",paste0("UNIT",intToUtf8(0x00C9)," DE MESURE"),"UOM") + uom_id_string=ifelse(language=="fra",paste0("IDENTIFICATEUR D'UNIT",intToUtf8(0x00C9)," DE MESURE"),"UOM_ID") coordinate_column <- ifelse(language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) data_geography_column <- ifelse(language=="eng","GEO",paste0("G",intToUtf8(0x00C9),"O")) column_names <- c(date_field,classification_code_column,value_string,scale_string,scale_string2, - uom_string,coordinate_column,data_geography_column) + uom_string,uom_id_string,coordinate_column,data_geography_column) column_names } @@ -543,11 +1010,14 @@ rename_columns_for_language <- function(data,from_language,to_language) { } geography_colum_names <- function(language) { - geography_columns <- case_when(language=="eng" ~ - c("Geography","Geographic name","Geography of origin"), - TRUE ~ c(paste0("G",intToUtf8(0x00E9),"ographie"), - paste0("Nom g",intToUtf8(0x00E9),"ographique"), - paste0("G",intToUtf8(0x00E9),"ographie d'origine"))) + # `language` is a single value, an unrecognized (NA) language falls back to the French names + if (isTRUE(language=="eng")) { + c("Geography","Geographic name","Geography of origin") + } else { + c(paste0("G",intToUtf8(0x00E9),"ographie"), + paste0("Nom g",intToUtf8(0x00E9),"ographique"), + paste0("G",intToUtf8(0x00E9),"ographie d'origine")) + } } diff --git a/R/cansim_members.R b/R/cansim_members.R deleted file mode 100644 index aac23600..00000000 --- a/R/cansim_members.R +++ /dev/null @@ -1,43 +0,0 @@ - - -get_cansim_members <- function(cansimTableNumber, language="english", - latestN=NULL, - members=list(), - refresh=FALSE, - timeout=1000, - cache_path=getOption("cansim.cache_path")){ - - language <- cleaned_ndm_language(language) - cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) - naked_table_number <- naked_ndm_table_number(cansimTableNumber) - - base_url <- "https://www150.statcan.gc.ca/t1/tbl1/en/dtl!downloadDbLoadingData-nonTraduit.action" - - "startDate=&endDate=&csvLocale=en&selectedMembers=[[],[2,3,4],[],[],[],[1,2]]&checkedLevels=0D1,1D1,2D1,3D1,3D2,4D1" - - - if (is.null(latestN)) {latestN=100000} - - cl <- get_cansim_column_list(cansimTableNumber, language=language, refresh=refresh, timeout=timeout) - - selectedMembers <- cl %>% - arrange(as.integer(1)) %>% - pull(1) %>% - lapply(\(did){ - - }) - - members %>% - #seq_along() %>% - lapply(\(i,el,n){ - - }) - - url <- paste0(base_url, - "?","pid=",naked_table_number,"01", - "&","latestN=",latestN, - "&","csvLocale=",substr(language,1,2)) - - readr::read_csv() - -} diff --git a/R/cansim_metadata.R b/R/cansim_metadata.R index 2745e9b3..cbc72240 100644 --- a/R/cansim_metadata.R +++ b/R/cansim_metadata.R @@ -34,25 +34,22 @@ parse_metadata <- function(meta,data_path){ while (meta_part[length(meta_part)]=="") { meta_part <- meta_part[-length(meta_part)] } - if (TRUE) { - # This is a workaround for problems with StatCan Metadata found in Table 17-10-0016 - if (length(grep("\u201C|\u201D",meta_part))>0){ - meta_part <- meta_part %>% gsub("\u201C|\u201D",'"',x=.) - } - 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 { - d<- suppressWarnings(readr::read_delim(paste0(meta_part,collapse="\n"), - delim=table_delim, col_types = readr::cols(.default="c"))) + # This is a workaround for problems with StatCan Metadata found in Table 17-10-0016 + if (length(grep("\u201C|\u201D",meta_part))>0){ + meta_part <- meta_part %>% gsub("\u201C|\u201D",'"',x=.) + } + d<-utils::read.delim(text=meta_part,sep=table_delim,header=FALSE,stringsAsFactors=FALSE, + quote="\"",na.strings="", + colClasses="character",check.names=FALSE) %>% + as_tibble() + # the section is read without a header so that its first line can be taken as the column names + # here, which is what lets the unnamed trailing columns StatCan pads its metadata with be dropped + if (nrow(d)>0) { + nn <- as.character(d[1,]) + d <- d %>% + select(which(!is.na(nn))) %>% + setNames(na.omit(nn)) %>% + slice(-1) } d } @@ -68,18 +65,24 @@ parse_metadata <- function(meta,data_path){ quote="\"",na.strings="", colClasses="character",check.names=FALSE) %>% names() - notes <- tibble(!!h[1]:=meta_part[-1] %>% lapply(\(x)gsub(",.+","",x)) %>% unlist(), - !!h[2]:=meta_part[-1] %>% lapply(\(x)gsub("^\\d+,","",x) %>% gsub("^\"|\"$","",.)) %>% unlist()) + notes <- tibble(!!h[1]:=gsub(",.+", "", meta_part[-1]), + !!h[2]:=gsub("^\"|\"$", "", gsub("^\\d+,", "", meta_part[-1]))) } cut_indices <- setdiff(which(grepl(paste0('^"',dimension_id_column,'"|^',symbol_legend_grepl_field,''),meta)),length(meta)) - meta1 <- read_meta(meta[seq(1,cut_indices[1]-1)]) + # Dimension and member names have to be repaired the same way as the column names of the data + # itself, otherwise the two no longer match and metadata stops folding in. The repair is silent + # here, the caller has already reported on the column names of this table. + meta1 <- read_meta(meta[seq(1,cut_indices[1]-1)]) %>% + repair_statcan_columns(cube_title_column) saveRDS(meta1,file=paste0(data_path,"1")) - meta2 <- read_meta(meta[seq(cut_indices[1],cut_indices[2]-1)]) + meta2 <- read_meta(meta[seq(cut_indices[1],cut_indices[2]-1)]) %>% + repair_statcan_columns(dimension_name_column) saveRDS(meta2,file=paste0(data_path,"2")) - meta3 <- read_meta(meta[seq(cut_indices[2],cut_indices[3]-1)]) + meta3 <- read_meta(meta[seq(cut_indices[2],cut_indices[3]-1)]) %>% + repair_statcan_columns(member_name_column) saveRDS(meta3,file=paste0(data_path,"2m")) correction_index <- grep(paste0('^"',correction_id_grepl_field,'"'),meta) if (length(correction_index)==0) correction_index=length(meta) @@ -95,11 +98,19 @@ parse_metadata <- function(meta,data_path){ column_ids <- dplyr::pull(meta2,dimension_id_column) column_names <- dplyr::pull(meta2,dimension_name_column) + + # P2: Pre-split meta3 by dimension_id for O(1) lookup instead of O(n) filter per column + meta3_split <- split(meta3, meta3[[dimension_id_column]]) + meta2_split <- split(meta2, meta2[[dimension_id_column]]) + for (column_index in column_ids) { # iterate through columns for which we have meta data - column <- meta2 %>% dplyr::filter(.data[[dimension_id_column]]==column_index) + column_key <- as.character(column_index) + column <- meta2_split[[column_key]] is_geo_column <- grepl(geography_column,column[[dimension_name_column]]) & !(column[[dimension_name_column]] %in% column_names) - meta_x <- meta3 %>% - dplyr::filter(.data[[dimension_id_column]]==column_index) %>% + # a dimension without any member rows has no entry in the split, it still needs its file + meta_x <- meta3_split[[column_key]] + if (is.null(meta_x)) meta_x <- meta3[0,] + meta_x <- meta_x %>% add_hierarchy(parent_member_id_column=parent_member_id_column, member_id_column=member_id_column, hierarchy_column=hierarchy_column, @@ -115,32 +126,37 @@ parse_metadata <- function(meta,data_path){ add_hierarchy <- function(meta_x,parent_member_id_column,member_id_column,hierarchy_column,exceeded_hierarchy_warning_message){ meta_x <- meta_x %>% mutate(across(all_of(c(member_id_column,parent_member_id_column)),as.character)) - parent_lookup <- rlang::set_names(meta_x[[parent_member_id_column]],meta_x[[member_id_column]]) - current_top <- function(c){ - strsplit(c,"\\.") %>% - purrr::map(dplyr::first) %>% - unlist - } - parent_for_current_top <- function(c){ - as.character(parent_lookup[current_top(c)]) - } - meta_x <- meta_x %>% - dplyr::mutate(!!as.name(hierarchy_column):=.data[[member_id_column]]) - added=TRUE - max_depth=100 - count=0 - while (added & count% - dplyr::mutate(p=parent_for_current_top(.data[[hierarchy_column]])) %>% - dplyr::mutate(!!as.name(hierarchy_column):=ifelse(is.na(.data$p),.data[[hierarchy_column]],paste0(.data$p,".",.data[[hierarchy_column]]))) %>% - dplyr::select(-"p") - added <- sum(old != meta_x[[hierarchy_column]])>0 - count=count+1 + member_ids <- meta_x[[member_id_column]] + parent_lookup <- rlang::set_names(meta_x[[parent_member_id_column]],member_ids) + + # all hierarchies are grown one ancestor level at a time, so the number of passes is the + # depth of the tree rather than the number of members. The topmost id of each path is + # carried in its own vector, which avoids re-splitting the growing paths to find it. + hierarchy_paths <- member_ids + tops <- member_ids + max_depth <- 100 + depth <- 0 + exceeded <- FALSE + + repeat { + # single bracket so that a parent that is not itself a member yields NA rather than an error + parents <- unname(parent_lookup[tops]) + growing <- !is.na(parents) + if (!any(growing)) break + if (depth>=max_depth) { + exceeded <- TRUE + break + } + hierarchy_paths[growing] <- paste0(parents[growing],".",hierarchy_paths[growing]) + tops <- parents + depth <- depth+1 } - if (added) { + + if (exceeded) { warning(exceeded_hierarchy_warning_message) } + + meta_x[[hierarchy_column]] <- hierarchy_paths meta_x } @@ -154,10 +170,13 @@ add_hierarchy <- function(meta_x,parent_member_id_column,member_id_column,hierar #' @param type Which type of metadata to get, options are "overview", "members", "notes", or "corrections". #' @param refresh Refresh the data from the Statistics Canada API #' -#' @return a tibble containing the table metadata +#' @return a tibble containing the table metadata. When several table numbers are given, the metadata for +#' all tables is retrieved in a single API call and the results are stacked. Types other than "overview" carry +#' no table identifier of their own, for those a `cansimTableNumber` column is added to identify the table. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_cube_metadata("34-10-0013") #' } #' @export @@ -166,37 +185,77 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh= if (!(type %in% c("overview", "members", "notes", "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) cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) - tmp <- file.path(tmp_base, paste0(cansimTableNumber,"_metadata", ".Rda")) - if (!file.exists(tmp) || refresh) { - table_id <- naked_ndm_table_number(cansimTableNumber) - url <- "https://www150.statcan.gc.ca/t1/wds/rest/getCubeMetadata" - response <- httr::POST(url, - #body=jsonlite::toJSON(list("productId"=table_id),auto_unbox =TRUE), - body=paste0("[",paste(paste0('{"productId":',table_id,'}'),collapse = ", "),"]"), - encode="json", - 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),call.=FALSE) - } - data <- httr::content(response) - data1 <- Filter(function(x)x$status=="SUCCESS",data) - data2 <- Filter(function(x)x$status!="SUCCESS",data) - if (length(data2)>0) { - message(paste0("Failed to load metadata for ",length(data2)," tables ")) - data2 %>% purrr::map(function(x){ - message(x$object) - }) - } - d <- data[[1]]$object - saveRDS(data1, tmp) + + # metadata for all tables not yet cached is downloaded in a single API call + if (!download_cube_metadata(cansimTableNumber, refresh=refresh)) return(NULL) + + result <- cansimTableNumber %>% + rlang::set_names() %>% + purrr::map(\(t)cube_metadata_for_table(t, type=type, refresh=refresh)) + + if (type=="overview") { + dplyr::bind_rows(result) } else { - data1 <- readRDS(tmp) + # member, footnote and correction metadata carry no table identifier of their own + dplyr::bind_rows(result, .id="cansimTableNumber") + } +} + +cube_metadata_path <- function(cansimTableNumber){ + file.path(table_base_path(cansimTableNumber), + paste0(cleaned_ndm_table_number(cansimTableNumber),"_metadata",".Rda")) +} + +# Downloads cube metadata for one or several tables in a single API call, caching the +# response for each table separately so that later calls can reuse individual tables. +# Returns TRUE when the metadata for every requested table is cached and ready to be read, and +# FALSE when StatCan could not be reached, so callers can hand back NULL rather than fail. +# When a refresh download fails but every requested table still has a previously cached copy, +# that copy is served with a warning instead, matching what get_cansim_connection() does for +# the table data itself. +download_cube_metadata <- function(cansimTableNumber, refresh=FALSE){ + needed <- cansimTableNumber[refresh | !file.exists(cube_metadata_path(cansimTableNumber))] + if (length(needed)==0) return(invisible(TRUE)) + + purrr::walk(table_base_path(needed),\(p)if (!dir.exists(p)) dir.create(p,recursive=TRUE)) + + table_ids <- naked_ndm_table_number(needed) + url <- "https://www150.statcan.gc.ca/t1/wds/rest/getCubeMetadata" + + # StatCan refuses a request carrying more tables than it accepts at once with an HTTP 416, so a + # call asking for many tables at a time has to be split the way the vector methods are + downloaded <- character(0) + for (batch in batch_items(table_ids)) { + body <- paste0("[",paste(paste0('{"productId":',batch,'}'),collapse = ", "),"]") + response <- post_with_timeout_retry(url, body=body) + if (is.null(response)) { + if (!all(file.exists(cube_metadata_path(needed)))) return(invisible(FALSE)) + warning(paste0("Failed to download metadata for table",ifelse(length(needed)>1,"s ", " "), + paste0(needed,collapse=", "), + ", proceeding with the previously cached version."),call.=FALSE) + return(invisible(TRUE)) + } + + data1 <- successful_wds_records(statcan_response_json(response),"cube metadata") + + batch_downloaded <- purrr::map_chr(data1,\(x)cleaned_ndm_table_number(as.character(x$object$productId))) + purrr::walk2(data1,batch_downloaded,\(d,tn)saveRDS(list(d), cube_metadata_path(tn))) + downloaded <- c(downloaded,batch_downloaded) + } + + failed <- setdiff(needed,downloaded) + if (length(failed)>0) { + stop("Could not retrieve metadata for table",ifelse(length(failed)>1,"s ", " "), + paste0(failed,collapse=", "),call.=FALSE) } - d <- data1[[1]]$object + + invisible(TRUE) +} + +cube_metadata_for_table <- function(cansimTableNumber, type="overview", refresh=FALSE){ + tmp_base <- table_base_path(cansimTableNumber) + d <- readRDS(cube_metadata_path(cansimTableNumber))[[1]]$object meta1_path <- file.path(tmp_base, paste0(cansimTableNumber, "_cubemeta1.Rda")) @@ -208,11 +267,13 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh= if (!file.exists(meta1_path)||refresh) { m1 <- d %>% tibble::enframe() %>% - mutate(l=lapply(.data$value,class) %>% unlist()) %>% + mutate(l=vapply(.data$value, function(x) class(x)[1], character(1))) %>% filter(.data$l!="list" | .data$name %in% c("surveyCode","subjectCode")) %>% select(-"l") %>% tidyr::pivot_wider() %>% - mutate_all(\(x)paste0(unlist(x), collapse=", ")) + mutate_all(\(x)paste0(unlist(x), collapse=", ")) %>% + repair_statcan_columns(c("cubeTitleEn","cubeTitleFr"), + context=paste0("the title of table ",cansimTableNumber)) saveRDS(m1, meta1_path) } else { m1 <- readRDS(meta1_path) @@ -226,7 +287,9 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh= tidyr::unnest_wider("member") %>% mutate(across(where(is.integer),as.character)) }) %>% - arrange(as.integer(.data$dimensionPositionId),as.integer(.data$memberId)) + arrange(as.integer(.data$dimensionPositionId),as.integer(.data$memberId)) %>% + repair_statcan_columns(c("dimensionNameEn","dimensionNameFr","memberNameEn","memberNameFr"), + context=paste0("dimension or member names for table ",cansimTableNumber)) saveRDS(m2, meta2_path) } else { m2 <- readRDS(meta2_path) @@ -255,7 +318,7 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh= m4 <- d$correctionFootnote %>% purrr::map_df(\(x){ tibble::as_tibble(x) %>% - mutate(across(is.integer,as.character)) + mutate(across(where(is.integer),as.character)) }) saveRDS(m4, meta4_path) } else { @@ -263,60 +326,14 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh= } - if (FALSE) { - short_language <- c("eng"="En","fra"="Fr")[[language]] - - m1_renames <- c( - "Cube Title"=paste0("cubeTitle",short_language), - "Product Id"="productId", - "CANSIM Id"="cansimId", - "URL"="URL", - "Cube Notes"="cubeNotes", - "Archive Status"=paste0("archiveStatus",short_language), - "Frequency"=paste0("frequencyDesc",short_language), - "Start Reference Period"="cubeStartDate", - "End Reference Period"="cubeEndDate", - "Total number of dimensions"="nbDatapointsCube" - ) - - frequency_codes <- get_cansim_code_set("frequency") - - meta1 <- m1 %>% - left_join(frequency_codes,by="frequencyCode") %>% - mutate(URL=paste0("https://www150.statcan.gc.ca/t1/tbl1/en/tv.action?pid=",productId)) %>% - mutate(cubeNotes=m3 %>% filter(dimensionPositionId==0,memberId==0) %>% pull(footnoteId) %>% paste0(collapse=", ")) %>% - rename(!!!m1_renames) %>% - relocate(names(m1_renames)) - - writeRDS(meta1, paste0(base_path_for_table_language(cansimTableNumber, language), ".Rda1")) - } if (type=="overview") { - if (FALSE) { # experimental code - fields <- c("productId", "cansimId", "cubeTitleEn", "cubeTitleFr", "cubeStartDate", "cubeEndDate", "nbSeriesCube", - "nbDatapointsCube", "archiveStatusCode", "archiveStatusEn", "archiveStatusFr", "subjectCode", - "surveyCode", "dimension","releaseTime") - result <- lapply(fields, function(field){ - purrr::map(data1,function(d){ - dd<-d$object[[field]] - if (typeof(dd)=="list") dd <- dd %>% unlist %>% as.character() %>% paste(collapse = ",") - dd - }) %>% as.character() - }) %>% - purrr::set_names(fields) %>% - tibble::as_tibble() %>% - dplyr::mutate(productId=cleaned_ndm_table_number(.data$productId)) %>% - dplyr::mutate(releaseTime=readr::parse_datetime(.data$releaseTime, - format=STATCAN_TIME_FORMAT, - locale=readr::locale(tz=STATCAN_TIMEZONE))) - } else { result <- m1 %>% dplyr::mutate(productId=cleaned_ndm_table_number(.data$productId)) %>% dplyr::mutate(releaseTime=readr::parse_datetime(.data$releaseTime, format=STATCAN_TIME_FORMAT, locale=readr::locale(tz=STATCAN_TIMEZONE))) - } } else if (type=="notes") { result <- m3 } else if (type=="members") { @@ -334,22 +351,40 @@ get_cansim_cube_metadata <- function(cansimTableNumber, type="overview",refresh= #' the `add_cansim_vectors_to_template` function can be used. #' #' @param cansimTableNumber A new or old CANSIM/NDM table number or a vector of table numbers -#' @param language Language for the dimension and member names, either "eng" or "fra" +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh Refresh the data from the Statistics Canada API #' -#' @return a tibble containing the table template +#' @return a tibble containing the table template, with a `cansimTableNumber` column identifying the table. +#' When several table numbers are given, the templates are stacked and columns for dimensions that only appear +#' in some of the tables are filled with `NA` for the other tables. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_table_template("34-10-0013") #' } #' @export get_cansim_table_template <- function(cansimTableNumber, language="english",refresh=FALSE){ cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) + language <- cleaned_ndm_language(language) + + # member metadata for all tables is retrieved in a single API call member_info <- get_cansim_cube_metadata(cansimTableNumber, type="members", refresh=refresh) + if (is.null(member_info)) return(NULL) - language <- cleaned_ndm_language(language) + result <- cansimTableNumber %>% + purrr::map(\(tn)table_template_for_members(member_info %>% filter(.data$cansimTableNumber==tn), + tn, language)) %>% + dplyr::bind_rows() + + attr(result, "cansimTableNumber") <- cansimTableNumber + attr(result, "language") <- language + result +} + +# builds the template for a single table from its member metadata +table_template_for_members <- function(member_info, cansimTableNumber, language){ if (language=="fra") { member_info <- member_info %>% select("dimensionPositionId",dimensionName="dimensionNameFr","memberId",memberName="memberNameFr", @@ -363,36 +398,33 @@ get_cansim_table_template <- function(cansimTableNumber, language="english",refr dimensions <- member_info %>% select("dimensionPositionId", "dimensionName") %>% unique() %>% - arrange("dimensionPositionId") - - result <- tibble(...link="link",COORDINATE="") - - for (i in seq_len(nrow(dimensions))) { - dim <- dimensions[i,] - dim_name <- dim$dimensionName - member <- member_info %>% - filter(.data$dimensionPositionId==dim$dimensionPositionId) %>% - select("memberId", "memberName") %>% - unique() %>% - arrange("memberId") %>% - rename(!!dim_name:="memberName") %>% - mutate(...link="link") - - result <- result %>% - full_join(member, by="...link", - relationship = "many-to-many") %>% - mutate(COORDINATE=ifelse(.data$COORDINATE=="", .data$memberId, paste0(.data$COORDINATE, ".", .data$memberId))) %>% - select(-any_of("memberId")) - } - - result <- result %>% - select(-any_of("...link")) %>% - mutate(cansimTableNumber=!!cansimTableNumber,.before="COORDINATE") - - attr(result, "cansimTableNumber") <- cansimTableNumber - attr(result, "langauge") <- language - - result + arrange(as.integer(.data$dimensionPositionId)) + + # StatCan cubes can carry two dimensions with the same name, expand_grid below needs unique names + dimension_names <- make.unique(dimensions$dimensionName) + + # member names and ids per dimension, in dimension position order + dim_data <- seq_len(nrow(dimensions)) %>% + lapply(function(i) { + dim_name <- dimension_names[i] + member_info %>% + filter(.data$dimensionPositionId==dimensions$dimensionPositionId[i]) %>% + select("memberId", "memberName") %>% + unique() %>% + rename(!!dim_name:="memberName") %>% + select(!!dim_name, !!paste0("...mid",i):="memberId") + }) + + # the cartesian product over all dimensions in one step, last dimension varying fastest + result <- do.call(tidyr::expand_grid, dim_data) + + member_id_columns <- paste0("...mid",seq_len(nrow(dimensions))) + + result %>% + mutate(cansimTableNumber=!!cansimTableNumber, + COORDINATE=do.call(paste, c(unname(as.list(result[member_id_columns])), sep=".")), + .before=1) %>% + select(-any_of(member_id_columns)) } @@ -400,28 +432,32 @@ get_cansim_table_template <- function(cansimTableNumber, language="english",refr #' #' Retrieves series information by coordinates #' -#' @param cansimTableNumber A new or old CANSIM/NDM table number or a vector of table numbers +#' @param cansimTableNumber A new or old CANSIM/NDM table number, coordinates are specific to a single table #' @param coordinates A vector of coordinates -#' @param timeout Timeout for the API call +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the call is abandoned. This does not limit how long the call may take overall, a response that keeps arriving is left alone. #' @param refresh Refresh the data from the Statistics Canada API #' -#' @return a tibble containing the table template +#' @return a tibble containing the series information for the given coordinates #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ -#' get_cansim_table_template("34-10-0013") +#' \donttest{ +#' get_cansim_series_info_cube_coord("34-10-0013", c("1.1.1.1.1.1", "2.1.1.1.1.1")) #' } #' @export get_cansim_series_info_cube_coord <- function(cansimTableNumber,coordinates, timeout=1000, refresh=FALSE){ + if (length(cansimTableNumber)!=1) { + stop("Coordinates are specific to a single table, `cansimTableNumber` needs to be a single table number.", + call.=FALSE) + } productId <- naked_ndm_table_number(cansimTableNumber) coordinates <- sort(normalize_coordinates(coordinates)) - chuncksize <- 300 - batches = split(coordinates, cumsum((1:length(coordinates)-1)%%chuncksize==0)) + batches <- batch_items(coordinates) - info <- purrr::map_dfr(batches, \(coordinates){ + info <- purrr::map(batches, \(coordinates){ body <- paste0("{\"productId\": ",productId,", \"coordinate\": \"",coordinates,"\"}") %>% paste0(.,collapse=", ") %>% paste0("[",.,"]") @@ -431,18 +467,14 @@ get_cansim_series_info_cube_coord <- function(cansimTableNumber,coordinates, tim if (!file.exists(tmp) || refresh) { url <- "https://www150.statcan.gc.ca/t1/wds/rest/getSeriesInfoFromCubePidCoord" - response <- httr::POST(url, - body=body, - encode="json", - httr::add_headers("Content-Type"="application/json"), - httr::timeout(timeout) - ) - if (response$status_code!=200) { - 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) - data2 <- Filter(function(x)x$status!="SUCCESS",data) + response <- post_with_timeout_retry(url, body=body, timeout=timeout) + if (is.null(response)) return(NULL) + + # A coordinate that names no series in the cube comes back as SUCCESS with a + # responseStatusCode of 2. That is the expected answer here rather than a problem worth + # reporting, since callers such as add_cansim_vectors_to_template() use this method precisely + # to find out which of the coordinates they hold are real. + data1 <- successful_wds_records(statcan_response_json(response),"series information",ignore_codes=2) info <- data1 %>% purrr::map_df(\(x){ @@ -457,9 +489,13 @@ get_cansim_series_info_cube_coord <- function(cansimTableNumber,coordinates, tim info }) - info %>% - filter(.data$responseStatusCode!=2) %>% # filter out invalid combinations - select(-"responseStatusCode") + # a batch that could not be retrieved would quietly drop those coordinates from the result + if (any(vapply(info,is.null,logical(1)))) return(NULL) + + # invalid combinations were dropped above, `any_of` because every batch coming back empty leaves + # a table with no columns to name + dplyr::bind_rows(info) %>% + select(-any_of("responseStatusCode")) } #' Retrieve series info for given table id and coordinates @@ -473,6 +509,7 @@ get_cansim_series_info_cube_coord <- function(cansimTableNumber,coordinates, tim #' #' @return a tibble containing the table template with added vector information #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' template <- get_cansim_table_template("34-10-0013") @@ -503,10 +540,13 @@ add_cansim_vectors_to_template <- function(template, refresh=FALSE) { working_template <- template %>% filter(.data$cansimTableNumber==tn) - new_vector_info <- get_cansim_series_info_cube_coord(tn, working_template$COORDINATE, refresh=refresh) %>% + series_info <- get_cansim_series_info_cube_coord(tn, working_template$COORDINATE, refresh=refresh) + if (is.null(series_info)) return(NULL) + + new_vector_info <- series_info %>% select(COORDINATE="coordinate", VECTOR=.data$vectorId) %>% mutate(VECTOR=paste0("v",.data$VECTOR)) %>% - mutate(COORDINATE=gsub("(.0)+$","",.data$COORDINATE)) + mutate(COORDINATE=gsub("(\\.0)+$","",.data$COORDINATE)) vector_info <- bind_rows(vector_info, new_vector_info) } diff --git a/R/cansim_parquet.R b/R/cansim_parquet.R index fa70ce0b..a51049e6 100644 --- a/R/cansim_parquet.R +++ b/R/cansim_parquet.R @@ -6,14 +6,14 @@ #' and emit a warning message if the cached table is out of date. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param format (Optional) The format of the data table to retrieve. Either \code{"parquet"}, \code{"feather"}, or \code{sqlite} (default is \code{"parquet"}). #' @param partitioning (Optional) Partition columns to use for parquet or feather formats. #' @param refresh (Optional) Valid options are \code{FALSE} (the default), \code{TRUE}, and \code{"auto"}. When set #' to \code{TRUE}, forces a reload of data table, when set to \code{"auto"} it will refresh the table by downloading #' the newest version from StatCan if the table is out of date. If set to \code{FALSE} and the table is out of date #' a warning will be emitted to alert the user that the data is outdated. -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. #' @param cache_path (Optional) Path to where to cache the table permanently. By default, the data is cached #' in the path specified by `Sys.getenv('CANSIM_CACHE_PATH')`, if this is set. Otherwise it will use `tempdir()`. # Set to higher values for large tables and slow network connection. (Default is \code{1000}). @@ -21,6 +21,7 @@ #' @return A database connection to a local parquet, feather, or sqlite database with the StatCan Table data. The data #' frames after calling `collect()` or `collect_and_normalize()` are identical up to possibly different row order. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' con <- get_cansim_connection("34-10-0013") @@ -52,6 +53,7 @@ get_cansim_connection <- function(cansimTableNumber, cansimTableNumber <- cleaned_ndm_table_number(cansimTableNumber) have_custom_path <- !is.null(cache_path) if (!have_custom_path) cache_path <- tempdir() + base_cache_path <- cache_path # Save base cache path before it's overwritten cleaned_number <- cansimTableNumber cleaned_language <- cleaned_ndm_language(language) base_table <- naked_ndm_table_number(cansimTableNumber) @@ -64,36 +66,47 @@ get_cansim_connection <- function(cansimTableNumber, db_path <- paste0(base_path_for_table_language(cansimTableNumber,language,cache_path),".",file_extension) last_updated <- tryCatch(get_cansim_table_last_release_date(cleaned_number), error=function(cond)return(NA)) - - if (is.na(last_updated)) { - warning("Could not determine if existing table is out of date.") - } else { - last_downloaded <- list_cansim_cached_tables() %>% - filter(.data$cansimTableNumber==cleaned_number, .data$dataFormat==format) %>% - pull(.data$timeCached) - - if (file.exists(db_path) && auto_refresh && !is.na(last_downloaded) && !is.null(last_updated) && - as.numeric(last_downloaded)% + filter(.data$cansimTableNumber==cleaned_number, .data$dataFormat==format, .data$language==cleaned_language) %>% + pull(.data$timeCached) + # no matching cache entry gives a zero length vector, an unreadable one gives NA + has_last_downloaded <- length(last_downloaded)==1 && !is.na(last_downloaded) + cache_is_stale <- has_last_updated && has_last_downloaded && + as.numeric(last_downloaded)",NA,"NA","","F") exdir=file.path(tempdir(),file_path_for_table_language(cansimTableNumber,language)) @@ -120,21 +133,18 @@ get_cansim_connection <- function(cansimTableNumber, parse_metadata(meta_lines,data_path = meta_base_path) - scale_string <- ifelse(language=="fr","IDENTIFICATEUR SCALAIRE","SCALAR_ID") - value_string <- ifelse(language=="fr","VALEUR","VALUE") + scale_string <- ifelse(cleaned_language=="fra","IDENTIFICATEUR SCALAIRE","SCALAR_ID") + value_string <- ifelse(cleaned_language=="fra","VALEUR","VALUE") dimension_name_column <- ifelse(cleaned_language=="eng","Dimension name","Nom de la dimension") geography_column <- ifelse(cleaned_language=="eng","Geography",paste0("G",intToUtf8(0x00E9),"ographie")) - geography_columns <- case_when(cleaned_language=="eng" ~ - c("Geography","Geographic name","Geography of origin"), - TRUE ~ c(paste0("G",intToUtf8(0x00E9),"ographie"), - paste0("Nom g",intToUtf8(0x00E9),"ographique"), - paste0("G",intToUtf8(0x00E9),"ographie d'origine"))) + geography_columns <- geography_colum_names(cleaned_language) data_geography_column <- ifelse(cleaned_language=="eng","GEO",paste0("G",intToUtf8(0x00C9),"O")) coordinate_column <- ifelse(cleaned_language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) meta2 <- readRDS(paste0(meta_base_path,"2")) - geo_column_pos <- which(pull(meta2,dimension_name_column) %in% geography_columns) + dimension_names <- pull(meta2,dimension_name_column) + geo_column_pos <- which(dimension_names %in% geography_columns) if (length(geo_column_pos)>1) geo_column_pos <- geo_column_pos[1] @@ -152,21 +162,26 @@ get_cansim_connection <- function(cansimTableNumber, locale=readr::locale(encoding="UTF-8"), col_types = list(.default = "c"), col_names = FALSE) %>% - as.character() + as.character() %>% + # repaired before the duplicate check below, since the repair itself can turn two names that + # differed only by a non-breaking space into the same name + repair_statcan_names(context=paste0("column names for table ",cansimTableNumber)) - symbols <- which(header=="Symbol") + symbols <- which(header=="Symbol" | header=="Symbole") if (length(symbols)==0) { - symbols <- which(header=="Symbols"|header=="Symboles") + symbols <- which(header=="Symbols"| header=="Symboles") } - sl <- length(symbols) if (sl>1) { - header[symbols] <- paste0("Symbol ",seq(1,sl)) + if (cleaned_language=="fra") { + header[symbols] <- paste0("Symbole ",seq(1,sl)) + } else { + header[symbols] <- paste0("Symbol ",seq(1,sl)) + } } - if (!(coordinate_column %in% header)) { ci <- which(grepl(coordinate_column,header,ignore.case = TRUE)) if (length(ci)==0 && (paste0("Coordonn",intToUtf8(0x00E9),"es") %in% header | paste0("Coordonn",intToUtf8(0x00E9),"e") %in% header)) { @@ -179,13 +194,13 @@ get_cansim_connection <- function(cansimTableNumber, } - hd <- header[duplicated(toupper(header))] + hd <- header[duplicated(toupper(header)) | duplicated(toupper(header), fromLast = TRUE)] if (length(hd)>0) { - dupes <- header[toupper(header) %in% hd] + dupes <- header[toupper(header) %in% toupper(hd)] unlink(exdir, recursive=TRUE) - stop(paste0("This table has duplicated columns names: ",paste0(dupes,collapse = ", "), - ".\nThis is not allowed for SQLite databases, please use the 'get_cansim' method for this table."),call.=FALSE) + stop(paste0("This table has duplicated columns names: ",paste0(unique(dupes),collapse = ", "), + ".\nThis is not supported for cached ",format," connections, please use the 'get_cansim' method for this table."),call.=FALSE) } if (format=="sqlite") { @@ -203,7 +218,9 @@ get_cansim_connection <- function(cansimTableNumber, transform=function(data){ attr(data,"language") <- cleaned_language attr(data,"cansimTableNumber") <- cleaned_number - data <- data %>% transform_value_column(value_string) + data <- data %>% + transform_value_column(value_string) %>% + repair_statcan_dimension_values(dimension_names,cleaned_language) if (length(geo_column_pos)==1) { data <- data %>% fold_in_metadata_for_columns(meta_base_path,geography_column) %>% @@ -222,6 +239,7 @@ get_cansim_connection <- function(cansimTableNumber, partitioning = partitioning, na = na_strings, value_column = value_string, + repair_columns = dimension_columns_in_data(header,dimension_names,cleaned_language), delim = delim) } @@ -255,28 +273,28 @@ get_cansim_connection <- function(cansimTableNumber, DBI::dbDisconnect(con) } - # saving timestamp - saveRDS(strftime(time_check,format=TIME_FORMAT),paste0(meta_base_path,"_time")) + # when the data was downloaded, and which version of the package parsed it + write_cache_info(meta_base_path,time_check) } else { - if (!is.na(last_updated)) { - if (is.na(last_downloaded)) message(paste0("Could not accesses date table ",cleaned_number," was cached.")) - if (is.null(last_updated)) message(paste0("Could not accesses date table ",cleaned_number," was last updated.")) - if (!is.na(last_downloaded) && !is.null(last_updated) && - as.numeric(last_downloaded)0) { - meta2 <- readRDS(file.path(meta_dir_name,meta_files[grepl("\\.Rda2$",meta_files)])) - for (f in column_files) { - nn <- gsub(".+_column_","",f) - id <- meta2[meta2[,2]==nn,1] %>% as.character() - if (length(id)==1) { - new_name <- f %>% gsub("_column_.+$",paste0("_column_",id),x=.) - file.rename(file.path(meta_dir_name,f),file.path(meta_dir_name,new_name)) - } + # the metadata sits next to the cached table and gets copied into the session cache where the + # metadata helpers look for it, this is needed whether or not a custom cache path is set + meta_base_path <- paste0(base_path_for_table_language(cansimTableNumber,language,cache_path),".Rda") + meta_grep_string <- basename(meta_base_path) + meta_dir_name <- dirname(meta_base_path) + meta_files <- dir(meta_dir_name,pattern=meta_grep_string) + + column_files <- meta_files[grepl("_column_",meta_files) & !grepl("_\\d+$",meta_files)] + + # legacy support for old column files + if (length(column_files)>0) { + meta2 <- readRDS(file.path(meta_dir_name,meta_files[grepl("\\.Rda2$",meta_files)])) + # Use column names instead of hardcoded indices + dimension_id_col <- names(meta2)[1] # "Dimension ID" or French equivalent + dimension_name_col <- names(meta2)[2] # "Dimension name" or French equivalent + for (f in column_files) { + nn <- gsub(".+_column_","",f) + id <- meta2[meta2[[dimension_name_col]]==nn, dimension_id_col] %>% as.character() + if (length(id)==1) { + new_name <- f %>% gsub("_column_.+$",paste0("_column_",id),x=.) + file.rename(file.path(meta_dir_name,f),file.path(meta_dir_name,new_name)) } - meta_files <- dir(meta_dir_name,pattern=meta_grep_string) } + meta_files <- dir(meta_dir_name,pattern=meta_grep_string) + } - meta_base_path <- table_base_path(cansimTableNumber) - for (f in meta_files) file.copy(file.path(meta_dir_name,f),file.path(meta_base_path,f)) - } + # the version marker sits next to the metadata, a cache that has none was built before 0.4.5 + stale_cache <- cache_predates_value_repair(meta_dir_name) + stale_labels <- if (stale_cache) stale_cached_labels(meta_dir_name) else character(0) + + meta_base_path <- table_base_path(cansimTableNumber) + for (f in meta_files) file.copy(file.path(meta_dir_name,f),file.path(meta_base_path,f)) if (format %in% c("parquet","feather")) { partitioning_path <- file.path(dirname(db_path),paste0(basename(db_path),".partitioning")) @@ -344,6 +369,32 @@ get_cansim_connection <- function(cansimTableNumber, attr(con,"language") <- cleaned_language attr(con,"cansimTableNumber") <- cansimTableNumber + # Names and labels are baked into the cached files, so a table cached before these characters were + # repaired keeps them until it is downloaded again. The cached metadata says whether this table is + # one of the affected ones, most are not, and it carries the same characters as the data next to it. + cached_names <- tryCatch(if (inherits(con,"tbl_lazy")) colnames(con) else names(con), + error=function(e) character(0)) + stale_names <- cached_names[cached_names!=repair_statcan_strings(cached_names)] + stale_labels <- setdiff(stale_labels,stale_names) + if (stale_cache && (length(stale_names)>0 || length(stale_labels)>0) && + !isTRUE(getOption("cansim.suppress_repair_warnings"))) { + cached_version <- read_cache_version(dirname(db_path)) + example <- c(stale_names,stale_labels)[1] %>% escape_statcan_characters() %>% abbreviate_around_escape() + warning(wrap_warning_text( + "The cached copy of table ",cleaned_number," was built by cansim ", + ifelse(is.null(cached_version),"0.4.4 or earlier",as.character(cached_version)), + ", before non-breaking spaces and control characters were repaired, and it has ", + ifelse(length(stale_names)>0,paste0(length(stale_names)," column name", + ifelse(length(stale_names)==1,"","s"), + ifelse(length(stale_labels)>0," and ","")),""), + ifelse(length(stale_labels)>0,paste0(length(stale_labels)," member label", + ifelse(length(stale_labels)==1,"","s")),""), + " containing them, for example \"",example,"\". These cannot be typed or copy-pasted, ", + "and they do not match the same table retrieved by vector, coordinate or table template, ", + "which are repaired. Pass `refresh=TRUE` to download the table again and fix the cache."), + call.=FALSE) + } + con } @@ -357,6 +408,8 @@ get_cansim_connection <- function(cansimTableNumber, #' @param value_column name of the value column with numeric data #' @param partitioning optional partition columns #' @param na na character strings +#' @param repair_columns columns whose values should be repaired of non-breaking spaces and control +#' characters before writing, usually the dimension columns #' @param text_encoding encoding of csv file (default UTF-8) #' @param delim (Optional) csv deliminator, default is "," #' @@ -366,6 +419,7 @@ csv2arrow <- function(csv_file, arrow_file, format="parquet", col_names, value_column = "VALUE", partitioning = c(), na=c(NA,"..","","...","F"), + repair_columns = c(), text_encoding="UTF-8",delim = ",") { if (file.exists(arrow_file)) unlink(arrow_file,recursive=TRUE) @@ -393,6 +447,15 @@ csv2arrow <- function(csv_file, arrow_file, format="parquet", skip_rows=1, column_names=col_names)) + # arrow has no binding for the string squishing the repair does, an arrow side mutate would silently + # pull the whole table into R and take seven times as long. The columns are pulled over one at a + # time instead, and only the distinct values of each are actually scanned. + for (column in intersect(repair_columns,names(input))) { + values <- as.vector(input[[column]]) + repaired <- repair_statcan_values(values) + if (!identical(repaired,values)) input[[column]] <- arrow::Array$create(repaired) + } + if ("DGUID" %in% names(input)) { input <- input %>% mutate(GeoUID=stringr::str_sub(.data$DGUID,10,-1) %>% as.character()) # ,.before=.data$DGUID) @@ -413,7 +476,10 @@ csv2arrow <- function(csv_file, arrow_file, format="parquet", schema_path <- file.path(dirname(arrow_file),paste0(basename(arrow_file),".schema")) partitioning_path <- file.path(dirname(arrow_file),paste0(basename(arrow_file),".partitioning")) arrow::write_dataset(input %>% dplyr::slice_head(n=1), format=format, schema_path) - saveRDS(partitioning,partitioning_path) + tryCatch( + saveRDS(partitioning,partitioning_path), + error = function(e) warning("Failed to save partitioning metadata: ", e$message) + ) } @@ -422,7 +488,7 @@ csv2arrow <- function(csv_file, arrow_file, format="parquet", #' Repartitions and already downloaded and cached parquet or feather dataset #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param format (Optional) The format of the data table to retrieve. Either \code{"parquet"}, \code{"feather"}, or \code{sqlite} (default is \code{"parquet"}). #' @param new_partitioning (Optional) Partition columns to use for parquet or feather formats. #' @param cache_path (Optional) Path to where to cache the table permanently. By default, the data is cached @@ -485,7 +551,33 @@ cansim_repartition_cached_table <- function(cansimTableNumber, unlink(old_path,recursive=TRUE) - saveRDS(new_partitioning,partitioning_path) + tryCatch( + saveRDS(new_partitioning,partitioning_path), + error = function(e) warning("Failed to save partitioning metadata: ", e$message) + ) + invisible() +} + +#' Disconnect from a cansim connection +#' +#' Closes the database connection behind a table retrieved with +#' \code{get_cansim_connection(..., format="sqlite")}. Parquet and feather connections hold no +#' connection to close and are left alone, so code that does not know which format it was handed +#' can close it either way. +#' +#' @param connection A connection to a cansim table as returned by \code{get_cansim_connection} +#' @return `NULL` +#' +#' @examples +#' \dontrun{ +#' con <- get_cansim_connection("34-10-0013", format="sqlite") +#' disconnect_cansim_connection(con) +#' } +#' @export +disconnect_cansim_connection <- function(connection){ + if ("tbl_sql" %in% class(connection)) { + DBI::dbDisconnect(connection$src$con) + } invisible() } @@ -532,7 +624,7 @@ collect_and_normalize <- function(connection, } } - value_string <- ifelse(language=="fr","VALEUR","VALUE") + value_string <- ifelse(language=="fra","VALEUR","VALUE") data <- NULL if ("tbl_sql" %in% class(connection)) { @@ -540,7 +632,7 @@ collect_and_normalize <- function(connection, attr(data,"language") <- language attr(data,"cansimTableNumber") <- cansimTableNumber - if (disconnect) disconnect_cansim_sqlite(connection) + if (disconnect) disconnect_cansim_connection(connection) } else if ("arrow_dplyr_query" %in% class(connection) || "ArrowObject" %in% class(connection)){ data <- connection %>% dplyr::as_tibble() @@ -616,7 +708,7 @@ list_cansim_cached_tables <- function(cache_path=Sys.getenv('CANSIM_CACHE_PATH') } result <- dplyr::tibble(path=dir(cache_path,"cansim_\\d+_parquet_eng|cansim_\\d+_parquet_fra|cansim_\\d+_feather_eng|cansim_\\d+_feather_fra|cansim_\\d+_sqlite_eng|cansim_\\d+_sqlite_fra")) %>% - dplyr::mutate(cansimTableNumber=gsub("^cansim_|_eng$|_fra$|_parquet_eng$|_parquet_fra|_feather_eng$|_feather_fra|_sqlite_eng$|_sqlte_fra$","",.data$path) %>% cleaned_ndm_table_number()) %>% + dplyr::mutate(cansimTableNumber=gsub("^cansim_|_eng$|_fra$|_parquet_eng$|_parquet_fra|_feather_eng$|_feather_fra|_sqlite_eng$|_sqlite_fra$","",.data$path) %>% cleaned_ndm_table_number()) %>% dplyr::mutate(dataFormat=case_when(grepl("_parquet",.data$path)~"parquet", grepl("_feather",.data$path)~"feather", grepl("_sqlite",.data$path)~"sqlite", @@ -624,56 +716,59 @@ list_cansim_cached_tables <- function(cache_path=Sys.getenv('CANSIM_CACHE_PATH') dplyr::mutate(language=gsub("^cansim_\\d+_sqlite_|^cansim_\\d+_parquet_|^cansim_\\d+_feather_","",.data$path)) %>% dplyr::mutate(title=NA_character_, timeCached=NA_character_, + cansimVersion=NA_character_, rawSize=NA_real_, niceSize=NA_character_) if (nrow(result)>0) { result <- result %>% - dplyr::select("cansimTableNumber","language","dataFormat","timeCached","niceSize","rawSize", - "title","path") + dplyr::select("cansimTableNumber","language","dataFormat","timeCached","cansimVersion", + "niceSize","rawSize","title","path") } if (nrow(result)>0) { - result$timeCached <- do.call("c", - lapply(result$path,function(p){ - pp <- dir(file.path(cache_path,p),"\\.Rda_time") - if (length(pp)==1) { - d<-readRDS(file.path(cache_path,p,pp)) - dd<- strptime(d,format=TIME_FORMAT) - } else { - dd <- strptime("1900-01-01 01:00:00",format=TIME_FORMAT) - } - })) - result$rawSize <- do.call("c", - lapply(result$path,function(p){ - pp <- dir(file.path(cache_path,p),"\\.sqlite$|\\.arrow$|\\.parquet$") - if (length(pp)==1) { - file_path <- file.path(cache_path,p,pp) - if (dir.exists(file_path)) { - d<-list.files(file.path(cache_path,p,pp),full.names = TRUE,recursive = TRUE) %>% - lapply(file.size) %>% - unlist() %>% - sum() - } else { - d<-file.size(file.path(cache_path,p,pp)) - } - } else { - d <- NA_real_ - } - d - })) - result$niceSize <- do.call("c",lapply(result$rawSize,\(x)ifelse(is.na(x),NA_real_,format_file_size(x,"auto")))) - result$title <- do.call("c", - lapply(result$path,function(p){ - pp <- dir(file.path(cache_path,p),"\\.Rda1") - if (length(pp)==1) { - d <- readRDS(file.path(cache_path,p,pp)) - dd <- as.character(d[1,1]) - } else { - dd <- NA_character_ - } - dd - })) + # P3: Single pass to collect all metadata instead of three separate lapply calls + cache_metadata <- lapply(result$path, function(p) { + full_path <- file.path(cache_path, p) + + # when the table was downloaded and which version of the package parsed it, the version is + # absent for anything cached before 0.4.5 + info <- read_cache_info(full_path) + time_cached <- strptime(ifelse(is.na(info$timeCached),"1900-01-01 01:00:00",info$timeCached), + format = TIME_FORMAT) + + # Get rawSize + data_file <- dir(full_path, "\\.sqlite$|\\.arrow$|\\.parquet$") + if (length(data_file) == 1) { + data_path <- file.path(full_path, data_file) + if (dir.exists(data_path)) { + raw_size <- sum(file.size(list.files(data_path, full.names = TRUE, recursive = TRUE))) + } else { + raw_size <- file.size(data_path) + } + } else { + raw_size <- NA_real_ + } + + # Get title + title_file <- dir(full_path, "\\.Rda1") + if (length(title_file) == 1) { + title <- as.character(readRDS(file.path(full_path, title_file))[1, 1]) + } else { + title <- NA_character_ + } + + list(timeCached = time_cached, rawSize = raw_size, title = title, + cansimVersion = info$cansimVersion) + }) + + result$timeCached <- do.call("c", lapply(cache_metadata, `[[`, "timeCached")) + result$cansimVersion <- vapply(cache_metadata, `[[`, character(1), "cansimVersion") + result$rawSize <- vapply(cache_metadata, `[[`, numeric(1), "rawSize") + result$niceSize <- vapply(result$rawSize, function(x) { + if (is.na(x)) NA_character_ else format_file_size(x, "auto") + }, character(1)) + result$title <- vapply(cache_metadata, `[[`, character(1), "title") } cube_info <- list_cansim_cubes(lite=TRUE,refresh = refresh,quiet=TRUE) @@ -699,7 +794,7 @@ list_cansim_cached_tables <- function(cache_path=Sys.getenv('CANSIM_CACHE_PATH') #' @param cansimTableNumber Vector of the table(s) to be removed, or a (filtered) table as returned by `list_cansim_cached_tables` #' with the list of tables to be removed. #' @param format Format of cache to remove, possible values are `"parquet"`, `"feather"` or `"sqlite"` or a subset of these (the default is all of these) -#' @param language Language for which to remove the cached data. If unspecified (`NULL`) tables for all languages will be removed. +#' @param language Language for which to remove the cached data, named as in \code{get_cansim()}. If unspecified (`NULL`) tables for all languages will be removed. #' @param cache_path Optional, default value is `Sys.getenv('CANSIM_CACHE_PATH')` #' @return `NULL`` #' @@ -714,7 +809,7 @@ remove_cansim_cached_tables <- function(cansimTableNumber, format=c("parquet","f cache_path <- get_robust_cache_path(cache_path) format=tolower(format) if (length(setdiff(format,c("parquet","sqlite","feather")))>0) { - stop("Invalid format, must be a subset of 'parquet' (recommended), 'sqlite', or 'sqlite'.",call.=FALSE) + stop("Invalid format, must be a subset of 'parquet' (recommended), 'sqlite', or 'feather'.",call.=FALSE) } if (is.null(language)) language <- c("eng","fra") cleaned_language <- cleaned_ndm_language(language) @@ -723,7 +818,7 @@ remove_cansim_cached_tables <- function(cansimTableNumber, format=c("parquet","f if (!have_custom_path) cache_path <- tempdir() if (is.data.frame(cansimTableNumber)) { - if (!sum(c("cansimTableNumber","language","dataFormat") %in% colnames(cansimTableNumber))) { + if (!all(c("cansimTableNumber","language","dataFormat") %in% colnames(cansimTableNumber))) { stop("cansimTableNumber must be a character vector or a (filtered) data frame as returned by list_cansim_cached_tables.",call.=FALSE) } # ensure that tables actually exist diff --git a/R/cansim_sql.R b/R/cansim_sql.R index 5871df8a..5b754243 100644 --- a/R/cansim_sql.R +++ b/R/cansim_sql.R @@ -2,32 +2,35 @@ TIME_FORMAT <- "%Y-%m-%d %H:%M:%S" -#' Retrieve a Statistics Canada data table using NDM catalogue number as SQLite database connection +#' Retrieve a Statistics Canada data table using NDM catalogue number as SQLite database connection (deprecated) #' +#' This method is deprecated and will be removed in a future version, please use +#' `get_cansim_connection(..., format="sqlite")` instead. #' Retrieves a data table using an NDM catalogue number as an SQLite table. Retrieved table data is #' cached permanently if a cache path is supplied or for duration of the current R session. #' The function will check against the latest release data for the table and emit a warning message #' if the cached table is out of date. #' #' @param cansimTableNumber the NDM table number to load -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) #' @param auto_refresh (Optional) When set to \code{TRUE}, it will reload of data table if a new version is available (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. #' @param cache_path (Optional) Path to where to cache the table permanently. By default, the data is cached #' in the path specified by `Sys.getenv('CANSIM_CACHE_PATH')`, if this is set. Otherwise it will use `tempdir()`. # Set to higher values for large tables and slow network connection. (Default is \code{1000}). #' #' @return A database connection to a local SQLite database with the StatCan Table data. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' con <- get_cansim_connection("34-10-0013", format="sqlite") #' #' # Work with the data connection -#' gplimpse(con) +#' glimpse(con) #' -#' disconnect_cansim_sqlite(con) +#' disconnect_cansim_connection(con) #' } #' @keywords internal #' @export @@ -36,7 +39,7 @@ get_cansim_sqlite <- function(cansimTableNumber, language="english", refresh=FAL cache_path=Sys.getenv('CANSIM_CACHE_PATH')){ .Deprecated("get_cansim_connection", package="cansim", - msg="This function has been deprecated, it will be removed in future versions. Please use get_cansim_connection(..., format='sqlite'') instead.") + msg="This function has been deprecated, it will be removed in future versions. Please use get_cansim_connection(..., format='sqlite') instead.") if (auto_refresh){ refresh <- "auto" @@ -50,28 +53,36 @@ get_cansim_sqlite <- function(cansimTableNumber, language="english", refresh=FAL cache_path=cache_path) } -#' Disconnect from a cansim database connection +#' Disconnect from a cansim database connection (deprecated) +#' +#' This method is deprecated and will be removed in a future version, please use +#' `disconnect_cansim_connection()` instead. #' #' @param connection connection to database #' @return `NULL`` #' #' @examples #' \dontrun{ -#' con <- get_cansim_sqlite("34-10-0013") -#' disconnect_cansim_sqlite(con) +#' con <- get_cansim_connection("34-10-0013", format="sqlite") +#' disconnect_cansim_connection(con) #' } +#' @keywords internal #' @export disconnect_cansim_sqlite <- function(connection){ - if ("tbl_sql" %in% class(connection)) { - DBI::dbDisconnect(connection$src$con) - } - invisible() + .Deprecated("disconnect_cansim_connection", + package="cansim", + msg="This function has been deprecated, it will be removed in future versions. Please use disconnect_cansim_connection(...) instead.") + + disconnect_cansim_connection(connection) } -#' List cached cansim SQLite database +#' List cached cansim SQLite database (deprecated) +#' +#' This method is deprecated and will be removed in a future version, please use +#' `list_cansim_cached_tables()` instead. #' #' @param cache_path Optional, default value is `Sys.getenv('CANSIM_CACHE_PATH')`. #' @param refresh Optional, refresh the last updated date of cached cansim tables @@ -91,18 +102,21 @@ list_cansim_sqlite_cached_tables <- function(cache_path=Sys.getenv('CANSIM_CACHE filter(.data$dataFormat=="sqlite") } -#' Remove cached cansim SQLite database +#' Remove cached cansim SQLite database (deprecated) +#' +#' This method is deprecated and will be removed in a future version, please use +#' `remove_cansim_cached_tables(..., format="sqlite")` instead. #' #' @param cansimTableNumber Number of the table to be removed -#' @param language Language for which to remove the cached data. If unspecified (`NULL`) tables for all languages -#' will be removed +#' @param language Language for which to remove the cached data, named as in \code{get_cansim()}. If +#' unspecified (`NULL`) tables for all languages will be removed #' @param cache_path Optional, default value is `Sys.getenv('CANSIM_CACHE_PATH')` #' @return `NULL`` #' #' @examples #' \dontrun{ #' con <- get_cansim_connection("34-10-0013", format="sqlite") -#' disconnect_cansim_sqlite(con) +#' disconnect_cansim_connection(con) #' remove_cansim_cached_tables("34-10-0013", format="sqlite") #' } #' @keywords internal @@ -110,7 +124,7 @@ list_cansim_sqlite_cached_tables <- function(cache_path=Sys.getenv('CANSIM_CACHE remove_cansim_sqlite_cached_table <- function(cansimTableNumber,language=NULL,cache_path=Sys.getenv('CANSIM_CACHE_PATH')){ .Deprecated("remove_cansim_cached_tables", package="cansim", - msg="This function has been deprecated, it will be removed in future versions. Please use remove_cansim_cached_tables(..., format='sqlite'') instead.") + msg="This function has been deprecated, it will be removed in future versions. Please use remove_cansim_cached_tables(..., format='sqlite') instead.") remove_cansim_cached_tables(cansimTableNumber=cansimTableNumber,language=language,format="sqlite",cache_path=cache_path) } diff --git a/R/cansim_tables_list.R b/R/cansim_tables_list.R index 9c184a82..f570b1a2 100644 --- a/R/cansim_tables_list.R +++ b/R/cansim_tables_list.R @@ -7,6 +7,7 @@ #' #' @return A tibble with available Statistics Canada data tables, listing title, Statistics Canada data table catalogue number, deprecated CANSIM table number, description, and geography #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' list_cansim_tables() @@ -19,14 +20,17 @@ list_cansim_tables <- function(refresh=FALSE){ package="cansim", msg="This function has been deprecated, it will be removed in future versions. Please use list_cansim_cubes(...) instead.") - list_cansim_cubes(lite=FALSE,refresh=refresh) %>% + cube_list <- list_cansim_cubes(lite=FALSE,refresh=refresh) + if (is.null(cube_list)) return(NULL) + + cube_list %>% mutate(title=.data$cubeTitleEn, subject=.data$subjectEn, date_published=as.Date(.data$releaseTime)) %>% - rename(title_en=.data$cubeTitleEn, - title_fr=.data$cubeTitleFr, - time_period_coverage_start=.data$cubeStartDate, - time_period_coverage_end=.data$cubeEndDate) + rename(title_en="cubeTitleEn", + title_fr="cubeTitleFr", + time_period_coverage_start="cubeStartDate", + time_period_coverage_end="cubeEndDate") } #' Search through Statistics Canada data tables (deprecated) @@ -40,6 +44,7 @@ list_cansim_tables <- function(refresh=FALSE){ #' #' @return A tibble with available Statistics Canada data tables, listing title, Statistics Canada data table catalogue number, deprecated CANSIM table number, description and geography that match the search term. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' search_cansim_tables("Labour force") @@ -52,14 +57,17 @@ search_cansim_tables <- function(search_term, search_fields = "both", refresh=FA package="cansim", msg="This function has been deprecated, it will be removed in future versions. Please use search_cansim_cubes(...) instead.") - search_cansim_cubes(search_term = search_term, refresh=refresh) %>% + cube_list <- search_cansim_cubes(search_term = search_term, refresh=refresh) + if (is.null(cube_list)) return(NULL) + + cube_list %>% mutate(title=.data$cubeTitleEn, subject=.data$subjectEn, date_published=as.Date(.data$releaseTime)) %>% - rename(title_en=.data$cubeTitleEn, - title_fr=.data$cubeTitleFr, - time_period_coverage_start=.data$cubeStartDate, - time_period_coverage_end=.data$cubeEndDate) + rename(title_en="cubeTitleEn", + title_fr="cubeTitleFr", + time_period_coverage_start="cubeStartDate", + time_period_coverage_end="cubeEndDate") } @@ -75,6 +83,7 @@ search_cansim_tables <- function(search_term, search_fields = "both", refresh=FA #' @return A tibble with available Statistics Canada data cubes, including NDM table number, cube title, #' start and end dates, achieve status, subject and survey codes, frequency codes and a list of cube dimensions. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' list_cansim_cubes() @@ -88,67 +97,70 @@ list_cansim_cubes <- function(lite=FALSE,refresh=FALSE,quiet=FALSE){ if (refresh | !file.exists(path)) { if (!quiet) message("Retrieving cube information from StatCan servers...") url=ifelse(lite,"https://www150.statcan.gc.ca/t1/wds/rest/getAllCubesListLite","https://www150.statcan.gc.ca/t1/wds/rest/getAllCubesList") - r<-get_with_timeout_retry(url,retry=0,warn_only=TRUE) - if (r$status_code==200) { - content <- httr::content(r) - - header <- content[[1]] %>% - tibble::enframe() %>% - t() %>% - as.data.frame() %>% - slice(1) %>% - unlist() %>% - as.character() - - # if ("dimesions" %in% header) - # header <- c(setdiff(header,"dimensions"),"dimensionNameEn","dimensionNameFr") - - h1 <- setdiff(header,"dimensions") - - surveys <- get_cansim_code_set("survey") - surveys_en <- setNames(surveys$surveyEn,surveys$surveyCode) - surveys_fr <- setNames(surveys$surveyFr,surveys$surveyCode) - subjects <- get_cansim_code_set("subject") - subjects_en <- setNames(subjects$subjectEn,subjects$subjectCode) - subjects_fr <- setNames(subjects$subjectEn,subjects$subjectCode) - - if (lite) { - r<-content %>% - lapply(function(l){ - lapply(l,function(d)paste0(unlist(d),collapse=", ")) %>% - as_tibble() - }) %>% - bind_rows() - } else { - r<-content %>% - lapply(function(l){ - lapply(l[h1],function(d)paste0(unlist(d),collapse=", ")) %>% - as_tibble() %>% - bind_cols(tibble( - dimensionNameEn=lapply(l[["dimensions"]],function(d)d["dimensionNameEn"]) %>% unlist %>% paste0(.,collapse = ", "), - dimensionNameFr=lapply(l[["dimensions"]],function(d)d["dimensionNameFr"]) %>% unlist %>% paste0(.,collapse = ", "))) - }) %>% - bind_rows() - } - - data <- r %>% - mutate_at(vars(ends_with("Date")),as.Date) %>% - mutate_at(vars(matches("releaseTime")),function(d)readr::parse_datetime(d, - #format=STATCAN_TIME_FORMAT, - locale=readr::locale(tz=STATCAN_TIMEZONE))) %>% - 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"))) %>% - mutate(surveyEn=lapply(.data$surveyCode,function(d)surveys_en[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) %>% - mutate(surveyFr=lapply(.data$surveyCode,function(d)surveys_fr[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) %>% - mutate(subjectEn=lapply(.data$subjectCode,function(d)subjects_en[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) %>% - mutate(subjectFr=lapply(.data$subjectCode,function(d)subjects_fr[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) - - saveRDS(data,path) + r<-get_with_timeout_retry(url,retry=0) + if (is.null(r)) return(NULL) + + content <- statcan_response_json(r) + + header <- content[[1]] %>% + tibble::enframe() %>% + t() %>% + as.data.frame() %>% + slice(1) %>% + unlist() %>% + as.character() + + # if ("dimesions" %in% header) + # header <- c(setdiff(header,"dimensions"),"dimensionNameEn","dimensionNameFr") + + h1 <- setdiff(header,"dimensions") + + surveys <- get_cansim_code_set("survey") + subjects <- get_cansim_code_set("subject") + if (is.null(surveys) || is.null(subjects)) return(NULL) + surveys_en <- setNames(surveys$surveyEn,surveys$surveyCode) + surveys_fr <- setNames(surveys$surveyFr,surveys$surveyCode) + subjects_en <- setNames(subjects$subjectEn,subjects$subjectCode) + subjects_fr <- setNames(subjects$subjectFr,subjects$subjectCode) + + if (lite) { + r<-content %>% + lapply(function(l){ + lapply(l,function(d)paste0(unlist(d),collapse=", ")) %>% + as_tibble() + }) %>% + bind_rows() } else { - warning("Could not retrieve cube list from StatCan servers.") + r<-content %>% + lapply(function(l){ + lapply(l[h1],function(d)paste0(unlist(d),collapse=", ")) %>% + as_tibble() %>% + bind_cols(tibble( + dimensionNameEn=lapply(l[["dimensions"]],function(d)d["dimensionNameEn"]) %>% unlist %>% paste0(.,collapse = ", "), + dimensionNameFr=lapply(l[["dimensions"]],function(d)d["dimensionNameFr"]) %>% unlist %>% paste0(.,collapse = ", "))) + }) %>% + bind_rows() } + + data <- r %>% + # M11: Replace deprecated mutate_at/vars with across() + mutate(across(ends_with("Date"), as.Date)) %>% + mutate(across(matches("releaseTime"), \(d) readr::parse_datetime(d, + locale=readr::locale(tz=STATCAN_TIMEZONE)))) %>% + 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"))) %>% + mutate(surveyEn=lapply(.data$surveyCode,function(d)surveys_en[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) %>% + mutate(surveyFr=lapply(.data$surveyCode,function(d)surveys_fr[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) %>% + mutate(subjectEn=lapply(.data$subjectCode,function(d)subjects_en[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) %>% + mutate(subjectFr=lapply(.data$subjectCode,function(d)subjects_fr[unlist(strsplit(d,", "))] %>% paste0(collapse="; ")) %>% unlist) %>% + # the cube list doubles as an internal lookup, for example when checking whether a cached + # table is out of date, so it only reports on repairs when called on the user's behalf + repair_statcan_columns(c("cubeTitleEn","cubeTitleFr","dimensionNameEn","dimensionNameFr"), + context=if (quiet) NULL else "table titles or dimension names") + + saveRDS(data,path) } else { if (!quiet) message("Retrieving cube information from temporary cache.") data <- readRDS(path) @@ -166,6 +178,7 @@ list_cansim_cubes <- function(lite=FALSE,refresh=FALSE,quiet=FALSE){ #' #' @return A tibble with available Statistics Canada data cubes, listing title, Statistics Canada data cube catalogue number, deprecated CANSIM table number, survey and subject. #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples #' \dontrun{ #' search_cansim_cubes("Labour force") @@ -173,7 +186,9 @@ list_cansim_cubes <- function(lite=FALSE,refresh=FALSE,quiet=FALSE){ #' #' @export search_cansim_cubes <- function(search_term, refresh=FALSE){ - list_cansim_cubes(refresh = refresh) %>% + cube_list <- list_cansim_cubes(refresh = refresh) + if (is.null(cube_list)) return(NULL) + cube_list %>% 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) | @@ -193,8 +208,9 @@ search_cansim_cubes <- function(search_term, refresh=FALSE){ #' #' @return a tibble with data, and details for major economic indicator release #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_key_release_schedule() #' } #' @@ -202,12 +218,9 @@ search_cansim_cubes <- function(search_term, refresh=FALSE){ get_cansim_key_release_schedule <- function(){ url <- "https://www150.statcan.gc.ca/n1/dai-quo/ssi/homepage/schedule-key_indicators-eng.json" response <- get_with_timeout_retry(url) + if (is.null(response)) return(NULL) - if (response$status_code!=200){ - stop("Problem accessing release schedule.",call.=FALSE) - } - - httr::content(response) %>% + statcan_response_json(response) %>% lapply(dplyr::as_tibble) %>% dplyr::bind_rows() %>% mutate(date=strftime(date,STATCAN_TIME_FORMAT_S,tz="UTC") %>% as.Date) diff --git a/R/cansim_vectors.R b/R/cansim_vectors.R index 4945d21c..c72de3e4 100644 --- a/R/cansim_vectors.R +++ b/R/cansim_vectors.R @@ -1,4 +1,23 @@ -MAX_PERIODS = 1000000L +# The latestN methods take the period count as a signed 32-bit integer. The API rejects zero or less +# with "vector id or latest N is negative or zero" and anything above 2147483647 with a JSON syntax +# error, while a count longer than the series is silently clamped to the whole series at no extra cost. +# Asking for every period is therefore best expressed as the largest value the API will accept, which +# is also the largest value R can hold in an integer, so as.integer() can never overshoot it. Neither +# the bound nor the clamping is stated in the WDS user guide, which only requires latestN to be > 0. +MAX_PERIODS <- .Machine$integer.max + +# Coerce a user supplied period count to something the latestN methods accept. Missing, infinite and +# over-long counts all mean "every period there is"; a count below one has no reading that the API +# would honour, so it is refused here rather than sent off to earn an HTTP 406. +clean_periods <- function(periods) { + if (is.null(periods) || length(periods) == 0) return(MAX_PERIODS) + periods <- suppressWarnings(as.numeric(periods)) + if (any(!is.na(periods) & periods < 1)) { + stop("The number of periods to retrieve must be at least 1.") + } + periods[is.na(periods) | periods > MAX_PERIODS] <- MAX_PERIODS + as.integer(periods) +} STATCAN_TIMEZONE = "America/Toronto" STATCAN_TIME_FORMAT="%Y-%m-%dT%H:%M" STATCAN_TIME_FORMAT_S="%Y-%m-%dT%H:%M:%S" @@ -19,7 +38,8 @@ extract_vector_data <- function(data1){ if (length(vdp)==0) {return(NULL)} value_data <- lapply(vf,function(f){ x=purrr::map(vdp,function(cc)cc[[f]]) - x[sapply(x, is.null)] <- NA + # P8: Use vapply instead of sapply for type-safe, faster null check + x[vapply(x, is.null, logical(1))] <- NA unlist(x) }) %>% tibble::as_tibble() %>% @@ -40,67 +60,131 @@ extract_vector_data <- function(data1){ } +# The member table of a dimension, and with it the disambiguation of duplicated member names and the +# resulting factor levels, is the same for every coordinate of a table. It is therefore built once per +# dimension and all coordinates are looked up against it in a single pass, rather than rebuilding it +# for every coordinate in turn. metadata_for_coordinates <- function(cansimTableNumber,coordinates,language) { - unique(coordinates) %>% - purrr::map_dfr(\(coord)metadata_for_coordinate(cansimTableNumber,coord,language)) -} - -metadata_for_coordinate <- function(cansimTableNumber,coordinate,language) { cleaned_language <- cleaned_ndm_language(language) - coordinate_column <- ifelse(language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) + coordinate_column <- ifelse(cleaned_language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) + coordinates <- unique(coordinates) + members <- get_cansim_cube_metadata(cansimTableNumber,type="members") - coordinates <- coordinate %>% strsplit("\\.") %>% unlist() - dimensions <- members %>% pull(.data$dimensionPositionId) %>% unique() - result <- tibble::tibble(cansimTableNumber=cansimTableNumber, !!coordinate_column:=coordinate) + result <- tibble::tibble(cansimTableNumber=cansimTableNumber, !!coordinate_column:=coordinates) - if (cleaned_language=="fra") { - members <- members %>% - select("dimensionPositionId","memberId",dimensionName="dimensionNameFr",memberName="memberNameFr") - } else { - members <- members %>% - select("dimensionPositionId","memberId",dimensionName="dimensionNameEn",memberName="memberNameEn") - } + # without cube metadata the data still stands on its own, it just carries no dimension names + if (!is.null(members)) { + dimensions <- members %>% pull(.data$dimensionPositionId) %>% unique() - for (dimension in dimensions) { - member_pos <- coordinates[as.integer(dimension)] - dm<-members %>% - filter(.data$dimensionPositionId==dimension) %>% - mutate(n=n(),.by = "memberName") %>% - mutate(nn=row_number(),.by="memberName") %>% - mutate(memberLevel=if_else(.data$n==1,.data$memberName,paste0(.data$memberName," (",.data$nn,")"))) + if (cleaned_language=="fra") { + members <- members %>% + select("dimensionPositionId","memberId",dimensionName="dimensionNameFr",memberName="memberNameFr") + } else { + members <- members %>% + select("dimensionPositionId","memberId",dimensionName="dimensionNameEn",memberName="memberNameEn") + } data_geography_column <- ifelse(cleaned_language=="eng","GEO",paste0("G",intToUtf8(0x00C9),"O")) - geography_columns <- case_when(cleaned_language=="eng" ~ - c("Geography","Geographic name","Geography of origin"), - TRUE ~ c(paste0("G",intToUtf8(0x00E9),"ographie"), - paste0("Nom g",intToUtf8(0x00E9),"ographique"), - paste0("G",intToUtf8(0x00E9),"ographie d'origine"))) - - m<-dm %>% - filter(.data$memberId==member_pos) - - if (nrow(m)==0) { - warning("Could not find metadata for dimension ",unique(dm$dimensionName)," member ",member_pos," in table ",cansimTableNumber) - next - } - if (dimension==1 && (m$dimensionName %in% geography_columns)) { - m$dimensionName <- data_geography_column - } + geography_columns <- geography_colum_names(cleaned_language) + + # split the coordinates once, the member ids of a dimension are then a column of this matrix + coordinate_parts <- max(c(0,stringr::str_count(coordinates,"\\.")),na.rm=TRUE)+1 + coordinate_matrix <- stringr::str_split_fixed(coordinates,"\\.",coordinate_parts) + + dimension_columns <- lapply(dimensions, function(dimension) { + dm <- members %>% + filter(.data$dimensionPositionId==dimension) %>% + mutate(n=n(),.by="memberName") %>% + mutate(nn=row_number(),.by="memberName") %>% + mutate(memberLevel=if_else(.data$n==1,.data$memberName,paste0(.data$memberName," (",.data$nn,")"))) + + position <- as.integer(dimension) + if (position<=ncol(coordinate_matrix)) { + member_ids <- coordinate_matrix[,position] + member_ids[is.na(member_ids) | member_ids==""] <- NA_character_ + } else { # coordinates that are shorter than the cube has dimensions carry nothing for this one + member_ids <- rep(NA_character_,length(coordinates)) + } - dn <- m$dimensionName + index <- match(member_ids,as.character(dm$memberId)) + # NA member ids come from coordinates that do not reach this dimension, only real ids are worth a warning + for (missing_id in setdiff(unique(member_ids[is.na(index)]),NA_character_)) { + warning("Could not find metadata for dimension ",unique(dm$dimensionName)," member ",missing_id, + " in table ",cansimTableNumber) + } + # a dimension no coordinate resolves against adds a column of nothing but NA + if (all(is.na(index))) return(NULL) - result_new <- m %>% - select("dimensionName","memberLevel") %>% - tidyr::pivot_wider(names_from="dimensionName",values_from="memberLevel") %>% - mutate(!!dn:=factor(!!as.name(dn),levels=dm$memberLevel)) + dn <- dm$dimensionName[1] + if (position==1 && (dn %in% geography_columns)) dn <- data_geography_column - result <- result %>% - bind_cols(result_new) + tibble::tibble(!!dn:=factor(dm$memberLevel[index],levels=dm$memberLevel)) + }) + + dimension_columns <- Filter(Negate(is.null),dimension_columns) + if (length(dimension_columns)>0) result <- bind_cols(c(list(result),dimension_columns)) } - result + + result %>% + add_uom_for_coordinates(cansimTableNumber,language) +} + +# StatCan flags a single dimension of each cube as carrying the unit of measure, the unit itself +# varies by member of that dimension. The member id at the matching position of the coordinate +# therefore determines the unit, and the "uom" code set resolves that code to a name. This is done +# for all coordinates of a table at once so the cube metadata and the code set are only consulted once. +add_uom_for_coordinates <- function(data,cansimTableNumber,language) { + cleaned_language <- cleaned_ndm_language(language) + coordinate_column <- ifelse(cleaned_language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) + uom_column <- ifelse(cleaned_language=="fra",paste0("UNIT",intToUtf8(0x00C9)," DE MESURE"),"UOM") + uom_id_column <- ifelse(cleaned_language=="fra",paste0("IDENTIFICATEUR D'UNIT",intToUtf8(0x00C9)," DE MESURE"),"UOM_ID") + + # never overwrite a unit of measure that is already present, including a dimension that happens + # to carry the same name as the unit columns + if (nrow(data)==0 || !(coordinate_column %in% names(data)) || + uom_column %in% names(data) || uom_id_column %in% names(data)) return(data) + + members <- tryCatch(get_cansim_cube_metadata(cansimTableNumber,type="members"), + error=function(e) NULL, warning=function(w) NULL) + if (is.null(members) || !all(c("hasUom","memberUomCode","dimensionPositionId","memberId") %in% names(members))) { + return(data) + } + + uom_members <- members %>% filter(.data$hasUom) + uom_position <- unique(as.integer(uom_members$dimensionPositionId)) + if (nrow(uom_members)==0 || length(uom_position)!=1 || is.na(uom_position)) return(data) + + coordinates <- pull(data,coordinate_column) + coordinate_parts <- max(c(0,stringr::str_count(coordinates,"\\.")),na.rm=TRUE)+1 + # coordinates that do not reach the unit dimension carry no unit information + if (coordinate_parts% + mutate(!!uom_column:=uom_names, + !!uom_id_column:=uom_ids) } extract_vector_metadata <- function(data1){ + # every vector of the request can be rejected, and the mutates below need columns to work on + if (length(data1)==0) return(tibble::tibble()) vf=list("DECIMALS"="decimals", "VECTOR"="vectorId", "table"="productId", @@ -128,6 +212,60 @@ extract_vector_metadata <- function(data1){ result } +# Every vector method answers with the same shape, so everything between the rows StatCan sent and +# the table handed back is shared: the metadata each coordinate needs, the vector names as the caller +# spelled them, and the value normalization. `warn_if_empty` is for the methods to which an empty +# answer is expected rather than a sign that something went wrong. +finalize_vector_data <- function(result,vectors,cleaned_language,factors, + default_month,default_day,warn_if_empty=TRUE){ + # An empty result used to travel on to the metadata join below and surface there as a missing + # `cansimTableNumber` column, an error that says nothing about what actually happened. + if (nrow(result)==0) { + if (warn_if_empty) warn_no_vector_data() + attr(result,"language") <- cleaned_language + return(result) + } + + attr(result,"language") <- cleaned_language + coordinate_column <- ifelse(cleaned_language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) + + if (cleaned_language=="fra") { # need to rename columns + result <- result %>% + rename_columns_for_language("eng",cleaned_language) + } + + metadata <- result %>% + select("cansimTableNumber",all_of(coordinate_column)) %>% + unique() %>% + group_by(.data$cansimTableNumber) %>% + group_map(~ metadata_for_coordinates(cansimTableNumber=.y$cansimTableNumber, + coordinates=.x[[coordinate_column]], + language=cleaned_language)) %>% + bind_rows() + + result <- result %>% + left_join(metadata,by=c("cansimTableNumber",coordinate_column)) %>% + rename_vectors(vectors) %>% + normalize_cansim_values(replacement_value = "val_norm", factors = factors, + default_month = default_month, default_day = default_day, internal=TRUE) + + result %>% + mutate(across(all_of(coordinate_column),~gsub("(\\.0)+$","",.x))) +} + +# The vector methods answer a request they have no data for with an empty list rather than with an +# error, and `getDataFromVectorByReferencePeriodRange` does so for every vector at once during the +# nightly window from midnight to 8:30am Eastern, where the other methods refuse with an HTTP 409. +# There is nothing in that answer to tell the three cases apart, so the warning names all of them. +warn_no_vector_data <- function(){ + warning(wrap_warning_text( + "StatCan returned no data for any of the requested vectors. This happens when none of the ", + "vectors exist, when none of them carry data in the requested time frame, and during the daily ", + "window from midnight to 8:30am Eastern in which StatCan does not serve vector data."), + call.=FALSE) + invisible(NULL) +} + rename_vectors <- function(data,vectors){ if (!is.null(names(vectors))) { vectors2 <- rlang::set_names(names(vectors),paste0("v",as.character(vectors))) @@ -152,17 +290,18 @@ rename_vectors <- function(data,vectors){ #' @param start_time Starting date in \code{YYYY-MM-DD} format, applies to \code{REF_DATE} or \code{releaseTime}, depending on \code{use_ref_date} parameter #' @param end_time Set an optional end time filter in \code{YYYY-MM-DD} format (defaults to current system time) #' @param use_ref_date Optional, \code{TRUE} by default. When set to \code{TRUE}, uses \code{REF_DATE} of vector data to filter, otherwise it uses StatisticsCanada's \code{releaseDate} value for filtering the specified vectors. -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. #' @param factors (Optional) Logical value indicating if dimensions should be converted to factors. (Default set to \code{TRUE}). #' @param default_month The default month that should be used when creating Date objects for annual data (default set to "07") #' @param default_day The default day of the month that should be used when creating Date objects for monthly data (default set to "01") #' #' @return A tibble with data for vectors released between start and end time #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_vector("v41690973","2015-01-01") #' } #' @export @@ -175,8 +314,9 @@ get_cansim_vector<-function(vectors, start_time = as.Date("1800-01-01"), end_tim original_end_time=as.Date(end_time) vectors=gsub("^v","",vectors) # allow for leading "v" by conditionally stripping it - batches <- split(vectors, ceiling(seq_along(vectors)/300)) - result <- NULL + batches <- batch_items(vectors) + # Keep batches separate so the accumulated rows are copied only once. + batch_results <- vector("list", length(batches)) for (batch_number in seq_along(batches)) { addition="" if (length(batches)>1) { @@ -185,10 +325,13 @@ get_cansim_vector<-function(vectors, start_time = as.Date("1800-01-01"), end_tim vecs <- batches[[batch_number]] if (use_ref_date){ url = "https://www150.statcan.gc.ca/t1/wds/rest/getDataFromVectorByReferencePeriodRange" - vectors_string=paste0('vectorIds=',paste(lapply(as.character(vecs),function(x)paste0('"',x,'"')),collapse = ","),"") - time_string=paste0('startRefPeriod=',strftime(start_time,"%Y-%m-%d",tz=STATCAN_TIMEZONE), - '&endReferencePeriod=',strftime(end_time,"%Y-%m-%d",tz=STATCAN_TIMEZONE),'') - body=paste0(vectors_string,"&",time_string) + vector_ids=paste(lapply(as.character(vecs),function(x)paste0('"',x,'"')),collapse = ",") + start_period=strftime(start_time,"%Y-%m-%d",tz=STATCAN_TIMEZONE) + end_period=strftime(end_time,"%Y-%m-%d",tz=STATCAN_TIMEZONE) + # kept in the shape they had when they were pasted onto the url, they key the cache below + vectors_string=paste0('vectorIds=',vector_ids,"") + time_string=paste0('startRefPeriod=',start_period,'&endReferencePeriod=',end_period,'') + query=list(vectorIds=vector_ids,startRefPeriod=start_period,endReferencePeriod=end_period) } else { url="https://www150.statcan.gc.ca/t1/wds/rest/getBulkVectorDataByRange" vectors_string=paste0('"vectorIds":[',paste(purrr::map(as.character(vecs),function(x)paste0('"',x,'"')),collapse = ", "),"]") @@ -200,69 +343,33 @@ get_cansim_vector<-function(vectors, start_time = as.Date("1800-01-01"), end_tim if (!file.exists(cache_path)||refresh) { message(paste0("Accessing CANSIM NDM vectors from Statistics Canada",addition)) if (use_ref_date){ - response <- get_with_timeout_retry(paste0(url,"?",body), + response <- get_with_timeout_retry(url, query=query, timeout = timeout) } else { response <- post_with_timeout_retry(url, body=body, timeout = timeout) } if (is.null(response)) return(response) - if (response$status_code!=200) { - 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) - data2 <- Filter(function(x)x$status!="SUCCESS",data) - if (length(data2)>0) { - message(paste0("Failed to load data for ",length(data2)," vector(s).")) - data2 %>% purrr::map(function(x){ - message(paste0("Problem downloading data: ",response_status_code_translation[as.character(x$object$responseStatusCode)])) - }) - } + data1 <- successful_wds_records(statcan_response_json(response),"vector data") - if (length(data1)>0) + if (length(data1)>0) { result_new <- extract_vector_data(data1) - else + saveRDS(result_new,cache_path) + } else { + # Nothing came back at all, which during the nightly window is true of every vector at + # once. Caching that would keep serving the empty answer for the rest of the session. result_new <- tibble::tibble() - saveRDS(result_new,cache_path) + } } else { message(paste0("Reading CANSIM NDM vectors from temporary cache",addition)) result_new <- readRDS(cache_path) } - result <- bind_rows(result,result_new) + batch_results[[batch_number]] <- result_new } + result <- bind_rows(batch_results) - attr(result,"language") <- cleaned_language - coordinate_column <- ifelse(cleaned_language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) - - if (cleaned_language=="fra") { # need to rename columns - result <- result %>% - rename_columns_for_language("eng",cleaned_language) - } - - metadata <- result %>% - select("cansimTableNumber",all_of(coordinate_column)) %>% - unique() %>% - group_by(.data$cansimTableNumber) %>% - group_map(~ metadata_for_coordinates(cansimTableNumber=.y$cansimTableNumber, - coordinates=.x[[coordinate_column]], - language=cleaned_language)) %>% - bind_rows() - - #metadata_for_coordinates(attr(result,"cansimTableNumber"),coordinates=unique(result$COORDINATE),language=language) - - - if (nrow(result)>0) { - result <- result %>% - left_join(metadata,by=c("cansimTableNumber",coordinate_column)) %>% - rename_vectors(vectors) %>% - normalize_cansim_values(replacement_value = "val_norm", factors = factors, - default_month = default_month, default_day = default_day, internal=TRUE) - } - - result %>% - mutate(across(all_of(coordinate_column),~gsub("(\\.0)+$","",.x))) + finalize_vector_data(result,vectors,cleaned_language,factors,default_month,default_day) } #' Retrieve data for specified Statistics Canada data vector(s) for last N periods @@ -277,17 +384,18 @@ get_cansim_vector<-function(vectors, start_time = as.Date("1800-01-01"), end_tim #' #' @param vectors The list of vectors to retrieve #' @param periods Numeric value for number of latest periods to retrieve data for, but default all data is retrieved. -#' @param language \code{"en"} or \code{"english"} for English and \code{"fr"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. #' @param factors (Optional) Logical value indicating if dimensions should be converted to factors. (Default set to \code{TRUE}). #' @param default_month The default month that should be used when creating Date objects for annual data (default set to "07") #' @param default_day The default day of the month that should be used when creating Date objects for monthly data (default set to "01") #' #' @return A tibble with data for specified vector(s) for the last N periods #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_vector_for_latest_periods("v41690973",10) #' } #' @export @@ -295,15 +403,15 @@ get_cansim_vector_for_latest_periods<-function(vectors, periods=NULL, language="english", refresh = FALSE, timeout = 200, factors = TRUE, default_month = "07", default_day = "01"){ - if (is.null(periods) || is.na(periods)) {periods <- MAX_PERIODS} - periods <- as.integer(periods) + periods <- clean_periods(periods) cleaned_language <- cleaned_ndm_language(language) vectors=gsub("^v","",vectors) # allow for leading "v" by conditionally stripping it url="https://www150.statcan.gc.ca/t1/wds/rest/getDataFromVectorsAndLatestNPeriods" - batches <- split(vectors, ceiling(seq_along(vectors)/300)) - result <- NULL + batches <- batch_items(vectors) + # Keep batches separate so the accumulated rows are copied only once. + batch_results <- vector("list", length(batches)) for (batch_number in seq_along(batches)) { addition="" if (length(batches)>1) { @@ -317,58 +425,25 @@ get_cansim_vector_for_latest_periods<-function(vectors, periods=NULL, message(paste0("Accessing CANSIM NDM vectors from Statistics Canada",addition)) response <- post_with_timeout_retry(url, body=vectors_string, timeout = timeout) if (is.null(response)) return(response) - if (response$status_code!=200) { - 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) - data2 <- Filter(function(x)x$status!="SUCCESS",data) - if (length(data2)>0) { - message(paste0("Failed to load data for ",length(data2)," vector(s).")) - data2 %>% purrr::map(function(x){ - message(paste0("Problem downloading data: ",response_status_code_translation[as.character(x$object$responseStatusCode)])) - }) - } - if (length(data1)>0) + data1 <- successful_wds_records(statcan_response_json(response),"vector data") + + if (length(data1)>0) { result_new <- extract_vector_data(data1) - else + saveRDS(result_new,cache_path) + } else { + # see the note in get_cansim_vector(), an empty answer is not worth caching result_new <- tibble::tibble() - saveRDS(result_new,cache_path) + } } else { message(paste0("Reading CANSIM NDM vectors from temporary cache",addition)) result_new <- readRDS(cache_path) } - result <- bind_rows(result,result_new) + batch_results[[batch_number]] <- result_new } + result <- bind_rows(batch_results) - attr(result,"language") <- cleaned_language - coordinate_column <- ifelse(cleaned_language=="eng","COORDINATE",paste0("COORDONN",intToUtf8(0x00C9),"ES")) - - if (cleaned_language=="fra") { # need to rename columns - result <- result %>% - rename_columns_for_language("eng",cleaned_language) - } - - metadata <- result %>% - select("cansimTableNumber",all_of(coordinate_column)) %>% - unique() %>% - group_by(.data$cansimTableNumber) %>% - group_map(~ metadata_for_coordinates(cansimTableNumber=.y$cansimTableNumber, - coordinates=.x[[coordinate_column]], - language=cleaned_language)) %>% - bind_rows() - - if (nrow(result)>0) { - result <- result %>% - left_join(metadata,by=c("cansimTableNumber",coordinate_column)) %>% - rename_vectors(vectors) %>% - normalize_cansim_values(replacement_value = "val_norm", factors = factors, - default_month = default_month, default_day = default_day, internal=TRUE) - } - - result %>% - mutate(across(all_of(coordinate_column),~gsub("(\\.0)+$","",.x))) + finalize_vector_data(result,vectors,cleaned_language,factors,default_month,default_day) } @@ -385,17 +460,18 @@ get_cansim_vector_for_latest_periods<-function(vectors, periods=NULL, #' @param periods Optional numeric value for number of latest periods to retrieve data for, default is \code{NULL} in which case data for all periods is downloaded. #' Alternatively this can be specified by #' coordinate if tableCoordinates is a data frame, this argument will be ignored if that data frame as a "periods" column. -#' @param language \code{"eng"} or \code{"english"} for English and \code{"fra"} or \code{"french"} for French language versions (defaults to English) +#' @param language \code{"english"} (the default) or \code{"french"}. Short forms such as \code{"en"}, \code{"eng"}, \code{"fr"} or \code{"fra"} are accepted, as are the French names \code{"anglais"} and \code{"francais"}; case and accents are ignored #' @param refresh (Optional) When set to \code{TRUE}, forces a reload of data table (default is \code{FALSE}) -#' @param timeout (Optional) Timeout in seconds for downloading cansim table to work around scenarios where StatCan servers drop the network connection. +#' @param timeout (Optional) Number of seconds StatCan is allowed to go without sending data before the download is abandoned, to work around scenarios where StatCan servers drop the network connection. This does not limit how long a download may take overall, a transfer that keeps delivering data is left alone. StatCan prepares a whole response before sending any of it, which for large requests can take the better part of a minute, so values much below the default of 200 risk cutting off legitimate requests. #' @param factors (Optional) Logical value indicating if dimensions should be converted to factors. (Default set to \code{TRUE}). #' @param default_month The default month that should be used when creating Date objects for annual data (default set to "07") #' @param default_day The default day of the month that should be used when creating Date objects for monthly data (default set to "01") #' #' @return A tibble with data matching specified coordinate and period input arguments #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_data_for_table_coord_periods(list("35-10-0003"=c("1.1","1.12")),periods=3) #' } #' @export @@ -404,14 +480,13 @@ get_cansim_data_for_table_coord_periods<-function(tableCoordinates, periods=NULL refresh = FALSE, timeout = 200, factors=TRUE, default_month="07", default_day="01"){ CENSUS_TABLE_STARTING_STRING <- "9810" - if (is.null(periods) || is.na(periods)) {periods <- MAX_PERIODS} - periods <- as.integer(periods) + periods <- clean_periods(periods) # pad coordinate if needed if ("list" %in% class(tableCoordinates)) { tableCoordinates <- tibble::enframe(tableCoordinates) %>% setNames(c("cansimTableNumber","COORDINATE")) %>% - tidyr::unnest_longer(.data$COORDINATE) + tidyr::unnest_longer("COORDINATE") } tableCoordinates <- tableCoordinates %>% mutate(cansimTableNumber=naked_ndm_table_number(.data$cansimTableNumber)) %>% @@ -419,7 +494,7 @@ get_cansim_data_for_table_coord_periods<-function(tableCoordinates, periods=NULL mutate(is_census_table=substr(.data$cansimTableNumber,1,4)==CENSUS_TABLE_STARTING_STRING) %>% mutate(batch=paste0(.data$is_census_table,"_",.data$cansimTableNumber)) %>% mutate(n=row_number(),.by="batch") %>% - mutate(b=(n-1) %% 300 == 0) %>% + mutate(b=(n-1) %% MAX_BATCH_SIZE == 0) %>% mutate(batch=paste0(.data$batch,"_",cumsum(.data$b)),.by="batch") if (!("periods") %in% names(tableCoordinates)) { @@ -427,7 +502,7 @@ get_cansim_data_for_table_coord_periods<-function(tableCoordinates, periods=NULL mutate(periods = !!periods) } else { tableCoordinates <- tableCoordinates %>% - mutate(periods = coalesce(.data$periods, MAX_PERIODS)) + mutate(periods = clean_periods(.data$periods)) } tableCoordinates <- tableCoordinates %>% @@ -457,18 +532,19 @@ get_cansim_data_for_table_coord_periods<-function(tableCoordinates, periods=NULL } message(paste0("Accessing CANSIM NDM coordinates from Statistics Canada",addition)) response <- post_with_timeout_retry(url, body=body_string, timeout = timeout) - if (response$status_code!=200) { - 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) - data2 <- Filter(function(x)x$status!="SUCCESS",data) + if (is.null(response)) {return(response)} + # this function reports the coordinates it could not get below, with a note of its own for the + # census tables, so the failed records are kept rather than handed to the shared reporting + records <- split_wds_records(statcan_response_json(response)) + data1 <- records$success new_failed_coordinates <- NULL - if (length(data2)>0) { - # message(paste0("Failed to load for ",length(data2)," coordinates ")) - new_failed_coordinates <- data2 %>% purrr::map(function(x){x$object$coordinate}) %>% unlist() + if (length(records$failed)>0) { + # message(paste0("Failed to load for ",length(records$failed)," coordinates ")) + # a record can carry a sentence in place of the object, and that has no coordinate in it + new_failed_coordinates <- purrr::map_chr(records$failed,\(x) + if (is.list(x$object) && length(x$object$coordinate)==1) x$object$coordinate else NA_character_) new_failed_coordinates <- tibble::tibble(cansimTableNumber=unique(working_data$cansimTableNumber), - COORDINATE=new_failed_coordinates) + COORDINATE=as.character(na.omit(new_failed_coordinates))) # if (substr(batch,7,10) == CENSUS_TABLE_STARTING_STRING) { # warning(paste0("Table ",.data$cansimTableNumber, @@ -519,7 +595,7 @@ get_cansim_data_for_table_coord_periods<-function(tableCoordinates, periods=NULL } attr(result,"language") <- cleaned_language - if (!is.null(failed_coordinates) && nrow(failed_coordinates > 0)) { + if (!is.null(failed_coordinates) && nrow(failed_coordinates) > 0) { regular_fails <- failed_coordinates %>% filter(substr(.data$cansimTableNumber,1,4) != CENSUS_TABLE_STARTING_STRING) census_fails <- failed_coordinates %>% @@ -554,30 +630,28 @@ get_cansim_data_for_table_coord_periods<-function(tableCoordinates, periods=NULL #' #' @return A tibble with metadata for selected vectors #' +#' Returns \code{NULL} if the data could not be retrieved because StatCan is unavailable. #' @examples -#' \dontrun{ +#' \donttest{ #' get_cansim_vector_info("v41690973") #' } #' @export get_cansim_vector_info <- function(vectors){ vectors=gsub("^v","",vectors) # allow for leading "v" by conditionally stripping it url="https://www150.statcan.gc.ca/t1/wds/rest/getSeriesInfoFromVector" - vectors_string=paste0("[",paste(purrr::map(as.character(vectors),function(x)paste0('{"vectorId":',x,'}')),collapse = ", "),"]") - response <- post_with_timeout_retry(url, body=vectors_string) - if (response$status_code!=200) { - 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) - data2 <- Filter(function(x)x$status!="SUCCESS",data) - if (length(data2)>0) { - message(paste0("Failed to load metadata for ",length(data2)," tables ")) - data2 %>% purrr::map(function(x){ - message(x$object) - }) + + batches <- batch_items(vectors) + batch_results <- vector("list", length(batches)) + for (batch_number in seq_along(batches)) { + vecs <- batches[[batch_number]] + vectors_string=paste0("[",paste(purrr::map(as.character(vecs),function(x)paste0('{"vectorId":',x,'}')),collapse = ", "),"]") + response <- post_with_timeout_retry(url, body=vectors_string) + if (is.null(response)){return(response)} + # this method answers an invalid vector with SUCCESS and a responseStatusCode of 4, which used + # to reach extract_vector_metadata() and come back as a row of NAs that looked like metadata + data1 <- successful_wds_records(statcan_response_json(response),"vector metadata") + batch_results[[batch_number]] <- extract_vector_metadata(data1) } - extract_vector_metadata(data1) + bind_rows(batch_results) } - - diff --git a/R/hex_sticker.R b/R/hex_sticker.R index ac716383..5c554008 100644 --- a/R/hex_sticker.R +++ b/R/hex_sticker.R @@ -1,14 +1,13 @@ #' Internal function to generate hex sticker #' @keywords internal generate_cansim_hex_sticker <- function (){ - income_data <- cansim::get_cansim("11-10-0239") %>% - cansim::normalize_cansim_values() income_age_groups <- c("16 to 24 years", "25 to 34 years" , "35 to 44 years" , "45 to 54 years" ,"55 to 64 years", "65 years and over") - income_plot_data <- income_data %>% + income_plot_data <- cansim::get_cansim_connection("11-10-0239") %>% dplyr::filter(Sex=="Both sexes", Statistics=="Median income (excluding zeros)", `Income source`=="Total income", `Age group` %in% income_age_groups) %>% + cansim::collect_and_normalize() %>% dplyr::mutate(`Age group`=factor(`Age group`,levels=income_age_groups)) %>% dplyr::group_by(GEO,`Age group`) %>% dplyr::left_join(dplyr::filter(.,Date==min(Date)) %>% @@ -19,7 +18,31 @@ generate_cansim_hex_sticker <- function (){ pd <- income_plot_data %>% dplyr::filter(GEO=="Canada") ed <- pd %>% dplyr::filter(Date==max(Date)) - ca_data <- cancensus::get_census("CA16",regions=list(C="01"),geo_format='sf') %>% sf::st_transform(102002) + crs <- 'PROJCS["Canada_Lambert_Conformal_Conic", + GEOGCS["NAD83", + DATUM["North_American_Datum_1983", + SPHEROID["GRS 1980",6378137,298.257222101, + AUTHORITY["EPSG","7019"]], + AUTHORITY["EPSG","6269"]], + PRIMEM["Greenwich",0, + AUTHORITY["EPSG","8901"]], + UNIT["degree",0.0174532925199433, + AUTHORITY["EPSG","9122"]], + AUTHORITY["EPSG","4269"]], + PROJECTION["Lambert_Conformal_Conic_2SP"], + PARAMETER["latitude_of_origin",40], + PARAMETER["central_meridian",-96], + PARAMETER["standard_parallel_1",50], + PARAMETER["standard_parallel_2",70], + PARAMETER["false_easting",0], + PARAMETER["false_northing",0], + UNIT["metre",1, + AUTHORITY["EPSG","9001"]], + AXIS["Easting",EAST], + AXIS["Northing",NORTH], + AUTHORITY["ESRI","102002"]]' + + ca_data <- cancensus::get_census("CA16",regions=list(C="01"),geo_format='sf') %>% sf::st_transform(crs) q <- ggplot2::ggplot(ca_data) + ggplot2::geom_sf(fill="grey20",size=0.01) + ggplot2::theme_void() + @@ -27,7 +50,7 @@ generate_cansim_hex_sticker <- function (){ bbox=sf::st_bbox(ca_data) p<-ggplot2::ggplot(pd,ggplot2::aes(x=Date,y=VALUE,color=`Age group`)) + ggplot2::geom_line() + - ggplot2::scale_color_brewer(palette="Dark2",guide=FALSE) + + ggplot2::scale_color_brewer(palette="Dark2",guide='none') + ggplot2::labs(x="",y="") + ggplot2::theme_void() + hexSticker::theme_transparent() @@ -45,6 +68,16 @@ generate_cansim_hex_sticker <- function (){ p_color="white", filename=here::here("images/cansim-sticker.png")) + if (FALSE) { + hexSticker::sticker(pp, package="CanViz", + p_size=8, p_y=1.5, + s_x=1, s_y=0.78, s_width=1.5, s_height=1.5, + h_color="#FF0000", + h_fill= "grey40", + p_color="white", + filename=here::here("~/Downloads/canviz-sticker.svg")) + } + } #' Internal function to update table list diff --git a/README.md b/README.md index 0e73634b..0c2173b8 100644 --- a/README.md +++ b/README.md @@ -4,10 +4,10 @@ [![CRAN status](https://www.r-pkg.org/badges/version/cansim)](https://CRAN.R-project.org/package=cansim) [![CRAN_Downloads_Badge](https://cranlogs.r-pkg.org/badges/cansim)](https://cranlogs.r-pkg.org/badges/cansim) [![R-CMD-check](https://github.com/mountainMath/cansim/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/mountainMath/cansim/actions/workflows/R-CMD-check.yaml) -[![DOI](https://img.shields.io/badge/doi-10.32614/CRAN.package.cansim-#d2b24a.svg)](https://doi.org/10.32614/CRAN.package.cansim) +[![DOI](https://img.shields.io/badge/DOI-10.32614/CRAN.package.cansim-d2b24a.svg)](https://doi.org/10.32614/CRAN.package.cansim) -cansim logo + An R package to retrieve and work with public Statistics Canada data tables. @@ -208,10 +208,12 @@ CANSIM was the name of Statistics Canada's legacy socio-economic data repository ### Proxy issues -Some users have reported issues accessing and downloading Statistics Canada tables while behind a proxy as is sometimes the case in office environments. A quick fix for this requires specifying a proxy configuration for the `httr` package. +Some users have reported issues accessing and downloading Statistics Canada tables while behind a proxy as is sometimes the case in office environments. The package uses `httr2`, which picks up the standard proxy environment variables, so pointing it at a proxy is a matter of setting them before making requests. ```r -httr::set_config(use_proxy(url=http_proxy, port=selected_port, username=your_username,password=your_pass)) +Sys.setenv(https_proxy="http://your_username:your_pass@proxy.example.com:8080") +Sys.setenv(http_proxy="http://your_username:your_pass@proxy.example.com:8080") ``` +Setting these in your `.Renviron` file makes the configuration stick across sessions. ### Contributing @@ -231,7 +233,7 @@ If you want to get in touch, we are pretty good at responding via email or via t If you wish to cite the `cansim` package in your work: - von Bergmann, J., Dmitry Shkolnik (2024). cansim: functions and convenience tools for accessing Statistics Canada data tables. v0.4.4. DOI: 10.32614/CRAN.package.cansim + von Bergmann, J., Dmitry Shkolnik (2024). cansim: functions and convenience tools for accessing Statistics Canada data tables. v0.5.0. DOI: 10.32614/CRAN.package.cansim A BibTeX entry for LaTeX users is @@ -241,7 +243,7 @@ A BibTeX entry for LaTeX users is title = {cansim: functions and convenience tools for accessing Statistics Canada data tables}, year = {2025}, doi = {10.32614/CRAN.package.cansim}, - note = {R package version 0.4.4}, + note = {R package version 0.5.0}, url = {https://mountainmath.github.io/cansim/} } ``` diff --git a/benchmarks/README.md b/benchmarks/README.md new file mode 100644 index 00000000..416a5e75 --- /dev/null +++ b/benchmarks/README.md @@ -0,0 +1,33 @@ +# Performance benchmarks + +## Vector batch materialization + +`vector_batching.R` measures the warm-cache path of +`get_cansim_vector_for_latest_periods()`. It uses deterministic cached batch +fixtures and mocks only metadata retrieval and value normalization, keeping the +network outside the benchmark while exercising the public batching workflow. + +Run it against isolated package installs: + +```sh +R CMD INSTALL -l /tmp/cansim-baseline-lib /path/to/cansim-0.4.5 +Rscript benchmarks/vector_batching.R /tmp/cansim-baseline-lib /tmp/baseline.rds + +R CMD INSTALL -l /tmp/cansim-candidate-lib . +Rscript benchmarks/vector_batching.R /tmp/cansim-candidate-lib /tmp/candidate.rds +``` + +Results from five randomized repetitions on R 4.5.0, macOS arm64, dplyr 1.1.4: + +| Vectors | Rows | Batches | 0.4.5 median | Candidate median | Saving | Speedup | +|---:|---:|---:|---:|---:|---:|---:| +| 3,000 | 15,000 | 10 | 0.026 s | 0.024 s | 0.002 s | 1.08x | +| 15,000 | 75,000 | 50 | 0.154 s | 0.116 s | 0.038 s | 1.33x | +| 30,000 | 150,000 | 100 | 0.424 s | 0.227 s | 0.197 s | 1.87x | + +Speedup is baseline elapsed time divided by candidate elapsed time. Absolute +timings vary by machine. The output SHA-256 digests matched between the +independently installed 0.4.5 baseline and candidate at all three scales. + +The mechanism is avoiding repeated copies of the complete accumulated tibble: +each API batch is stored in a preallocated list and all batches are bound once. diff --git a/benchmarks/vector_batching.R b/benchmarks/vector_batching.R new file mode 100644 index 00000000..3b960145 --- /dev/null +++ b/benchmarks/vector_batching.R @@ -0,0 +1,134 @@ +# Benchmark the warm-cache batching path in get_cansim_vector_for_latest_periods(). +# Network, metadata retrieval, and normalization are kept outside the claim so +# the benchmark measures how downloaded batches are materialized into one result. +# +# Usage: +# Rscript benchmarks/vector_batching.R /path/to/library /tmp/results.rds +# +# Install the baseline or candidate into the supplied isolated library first. + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) != 2L) { + stop("Usage: vector_batching.R LIBRARY OUTPUT_RDS", call. = FALSE) +} + +library_path <- normalizePath(args[[1L]], mustWork = TRUE) +output_path <- args[[2L]] +namespace <- loadNamespace("cansim", lib.loc = library_path) +get_vectors <- get("get_cansim_vector_for_latest_periods", envir = namespace) + +periods <- 5L +workloads <- data.frame( + vectors = c(3000L, 15000L, 30000L), + batches = c(10L, 50L, 100L) +) +repetitions <- 5L + +make_cache <- function(vectors) { + batches <- split(vectors, ceiling(seq_along(vectors) / 300L)) + paths <- character(length(batches)) + for (batch_number in seq_along(batches)) { + vecs <- batches[[batch_number]] + vectors_string <- paste0( + "[", + paste( + purrr::map(as.character(vecs), function(x) { + paste0('{"vectorId":', x, ',"latestN":', periods, "}") + }), + collapse = ", " + ), + "]" + ) + paths[[batch_number]] <- file.path( + tempdir(), + paste0("cansim_cache_", digest::digest(vectors_string, algo = "md5"), ".rda") + ) + + vector_rows <- rep(vecs, each = periods) + result <- tibble::tibble( + REF_DATE = rep(sprintf("202%d", seq_len(periods) - 1L), times = length(vecs)), + VALUE = as.numeric(vector_rows %% 1000L), + COORDINATE = paste0((vector_rows %% 97L) + 1L, ".", (vector_rows %% 31L) + 1L), + VECTOR = paste0("v", vector_rows), + cansimTableNumber = "34-10-0001" + ) + saveRDS(result, paths[[batch_number]]) + } + paths +} + +metadata_stub <- function(cansimTableNumber, coordinates, language) { + tibble::tibble(cansimTableNumber = cansimTableNumber, COORDINATE = coordinates) +} +normalization_stub <- function(data, ...) data + +run_order <- sample(rep(seq_len(nrow(workloads)), each = repetitions)) +timings <- vector("list", length(run_order)) +digests <- character(nrow(workloads)) + +for (workload_id in seq_len(nrow(workloads))) { + vectors <- seq_len(workloads$vectors[[workload_id]]) + cache_paths <- make_cache(vectors) + on.exit(unlink(cache_paths), add = TRUE) +} + +for (i in seq_along(run_order)) { + workload_id <- run_order[[i]] + vectors <- seq_len(workloads$vectors[[workload_id]]) + + gc() + elapsed <- system.time({ + result <- suppressMessages(testthat::with_mocked_bindings( + get_vectors(vectors, periods = periods, factors = FALSE), + metadata_for_coordinates = metadata_stub, + normalize_cansim_values = normalization_stub, + .package = "cansim" + )) + })[["elapsed"]] + + stopifnot( + nrow(result) == length(vectors) * periods, + identical(unique(result$VECTOR), paste0("v", vectors)), + identical(names(result), c("REF_DATE", "VALUE", "COORDINATE", "VECTOR", + "cansimTableNumber")) + ) + + result_digest <- digest::digest(result, algo = "sha256", serialize = TRUE) + if (digests[[workload_id]] == "") { + digests[[workload_id]] <- result_digest + } else { + stopifnot(identical(digests[[workload_id]], result_digest)) + } + + timings[[i]] <- data.frame( + vectors = workloads$vectors[[workload_id]], + rows = nrow(result), + batches = workloads$batches[[workload_id]], + repetition = sum(run_order[seq_len(i)] == workload_id), + elapsed_seconds = elapsed + ) +} + +timings <- do.call(rbind, timings) +summary <- aggregate( + elapsed_seconds ~ vectors + rows + batches, + timings, + function(x) c(min = min(x), median = median(x), max = max(x)) +) +summary <- cbind(summary[seq_len(3L)], as.data.frame(summary$elapsed_seconds)) + +result <- list( + package_version = as.character(utils::packageVersion("cansim", lib.loc = library_path)), + package_library = library_path, + r_version = R.version.string, + platform = R.version$platform, + dplyr_version = as.character(utils::packageVersion("dplyr")), + periods = periods, + repetitions = repetitions, + output_digests = digests, + timings = timings, + summary = summary +) + +saveRDS(result, output_path) +print(summary, row.names = FALSE) diff --git a/cran-comments.md b/cran-comments.md index 56481467..fe0df921 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,9 +1,23 @@ ## Test environments -* local OS X install, R 4.3.2 -* GitHub Action macOS-latest, windows-lastest (3.6), ubuntu-20.04 (devel, release) +* local macOS install, R 4.6.0 +* GitHub Actions macOS-latest (release), windows-latest (release), ubuntu-latest (devel, release, oldrel-1) ## R CMD check results -There were no ERRORs or WARNINGs or NOTEs. +There were no ERRORs or WARNINGs or NOTEs, with `--as-cran --run-donttest`. + +## Notes on examples + +This package retrieves data from Statistics Canada web services. Their servers +time out or go down for maintenance from time to time, which has caused checks +of this package to fail in the past through no fault of the package. As of +version 0.4.5 no function aborts when Statistics Canada cannot be reached, it +emits a warning and returns `NULL` instead. Examples that make a single +lightweight API call are therefore wrapped in `\donttest{}` and complete without +error whether or not Statistics Canada is reachable, which we verified by +running them with all requests to Statistics Canada blocked. The remaining +`\dontrun{}` examples are the ones that download an entire data table or the +full table catalogue, they are excluded because of their run time, not because +they might fail. ## Changes from version 0.2.1 @@ -151,3 +165,18 @@ There were no ERRORs or WARNINGs or NOTEs. * 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.5 +## Major changes +* Statistics Canada being unavailable no longer aborts with an error, timeouts, connection failures and + error responses are reported with a warning and the function returns `NULL` +* examples that make a single lightweight API call are now `\donttest{}` rather than `\dontrun{}` +* data retrieved by vector or by table/coordinate now carries unit of measure columns +* non-breaking spaces and control characters in names returned by Statistics Canada are replaced with + regular spaces so that the resulting column names can be typed +## Minor changes +* fix a `case_when()` deprecation warning emitted by dplyr 1.2.0 +* fix `get_cansim_changed_tables()` passing "days" to `difftime()` as a time zone instead of a unit +* `get_cansim_connection()` no longer fails when the release date of a table cannot be determined +* performance improvements in metadata parsing and table template generation + diff --git a/docs/404.html b/docs/404.html index c73f2820..ea9d4aa4 100644 --- a/docs/404.html +++ b/docs/404.html @@ -11,9 +11,9 @@ - - - + + + @@ -34,11 +34,11 @@ Skip to contents -