working on local implementation

.Rbuildignore

@@ -8,3 +8,4 @@
 ^CRAN-RELEASE$
 ^dev_notes$
 ^\.github$
+^data-raw$

DESCRIPTION

@@ -19,6 +19,8 @@ Imports:
         tools,
         utils
 Suggests:
+    countrycode,
+    cshapes,
     DBI,
     RSQLite,
     sf,

R/GNRS_local.R

@@ -25,10 +25,44 @@
 #'   downloaded silently: the function reports what is missing and the call that
 #'   would fix it.  Set it to TRUE to allow an unattended build.
 #' @param quiet Suppress progress messages?
+#' @param history Historical political divisions: \code{"all"} (the default;
+#'   also matches former countries such as the USSR, Yugoslavia or
+#'   Czechoslovakia, flagging such matches, so a record named with a political
+#'   division that was ever accurate resolves), \code{"current"} (today's
+#'   divisions only, as the web service does), or \code{"at_date"} (as "all",
+#'   but a former country is accepted only if it existed at the record's date,
+#'   taken from an optional \code{date} column of years or ISO dates; a name
+#'   marked as former, such as "Former USSR", is accepted for any later date,
+#'   and a state or county that resolves within a successor is kept and flagged
+#'   whatever the date).  Needs the \code{"history"} component, built from
+#'   tables shipped with the package plus the CShapes historical boundaries,
+#'   which are read from the \code{cshapes} package when it is installed and
+#'   otherwise downloaded from the publisher (about 60 MB) when
+#'   \code{build_missing} allows building; with \code{history = "current"}
+#'   nothing beyond the ordinary components is needed.  When the component
+#'   cannot be prepared (a package not installed, a download declined), the
+#'   call says so and resolves current divisions only.
+#' @param tolerance_years With \code{history = "at_date"}, how many years
+#'   either side of a former country's existence a record date may fall.  A
+#'   single non-negative number.
 #' @return A data.frame with the same columns as \code{GNRS()}, one row per
-#'   input row in input order.  Scores are numeric rather than the character
-#'   strings the web service returns; identifiers are character, as the web
-#'   service returns them; empty values are "".
+#'   input row in input order.  With \code{history} other than "current",
+#'   further columns: \code{entity_key}, \code{is_historical},
+#'   \code{entity_valid_from}, \code{entity_valid_to}, \code{successors} (the
+#'   current countries descending from a matched former country),
+#'   \code{subnational_resolved_in} and \code{subnational_status} (a state or
+#'   county given under a former country is looked up within its successors;
+#'   "unverifiable" if none contains it), and \code{date_check}.  Whatever
+#'   \code{history} is, four further columns report a state or county that is
+#'   an alternative or superseded division rather than one the service knows
+#'   (a Swedish landskap, a Watsonian vice-county, a Norwegian county from
+#'   before the 2020 reform): \code{alt_division} (its name),
+#'   \code{alt_division_system}, \code{alt_division_level} and
+#'   \code{alt_division_extent_known} (whether the GADM units it covers are
+#'   recorded, so that a coordinate could be checked against it); "" or NA
+#'   for a row that resolved ordinarily.  Scores are numeric rather than the
+#'   character strings the web service returns; identifiers are character, as
+#'   the web service returns them; empty values are "".
 #' @note \strong{This is a new implementation and should be treated as beta.}
 #'   It is a port of the SQL the web service runs, resolving against the
 #'   service's own reference tables, so identifiers, standard names and codes
@@ -67,7 +101,10 @@ GNRS_local <- function(political_division_dataframe,
                        alternate_names = TRUE,
                        dir = gnrs_cache_dir(),
                        build_missing = interactive(),
-                       quiet = FALSE) {
+                       quiet = FALSE,
+                       history = c("all", "current", "at_date"),
+                       tolerance_years = 1) {
+  history <- match.arg(history)
   if (!inherits(political_division_dataframe, "data.frame")) {
     stop("political_division_dataframe should be a data.frame", call. = FALSE)
   }
@@ -78,13 +115,68 @@ GNRS_local <- function(political_division_dataframe,
   if (!is.logical(alternate_names) || length(alternate_names) != 1L || is.na(alternate_names)) {
     stop("alternate_names should be TRUE or FALSE", call. = FALSE)
   }
+  if (!is.numeric(tolerance_years) || length(tolerance_years) != 1L ||
+    !is.finite(tolerance_years) || tolerance_years < 0) {
+    stop("tolerance_years should be a single non-negative number", call. = FALSE)
+  }
 
   input <- gnrs_check_input(political_division_dataframe)
 
+  dates <- if (history == "at_date") {
+    if (!"date" %in% names(political_division_dataframe)) {
+      message("history = \"at_date\" but no date column: former countries are matched without a date check.")
+      NULL
+    } else {
+      gnrs_parse_record_date(political_division_dataframe$date)
+    }
+  } else {
+    NULL
+  }
+
+  # Alternative and superseded sub-national divisions (Swedish landskap, Watsonian
+  # vice-counties, Norwegian counties after the 2018 and 2020 reforms): shipped
+  # curation, nothing downloaded, so it is built on first use.
+  if (!gnrs_is_built("altdiv", dir)) {
+    if (!quiet) message("Building the alternative-division component (no download) ...")
+    gnrs_build_altdiv(dir = dir, quiet = TRUE)
+  }
+
   sources <- if (alternate_names) c("gnrs", "geonames") else "gnrs"
   if (!gnrs_require_sources(sources, dir = dir, build_missing = build_missing, quiet = quiet)) {
     return(invisible(NULL))
   }
+  # The history component is assembled from the curation shipped with the package and
+  # the user's own copy of CShapes (nothing derived from CShapes ships: it is CC BY-NC-SA
+  # 4.0 and the package is MIT). With the cshapes package installed that downloads
+  # nothing, so it happens on first use as it always did; without it CShapes has to be
+  # downloaded, which follows build_missing like every other download.
+  # When it cannot be prepared (a package missing, or a download declined), the
+  # call goes on with current divisions only, and says so, rather than returning
+  # nothing: the default build prepares the ordinary components only.
+  if (history != "current" && !gnrs_is_built("history", dir)) {
+    ready <- FALSE
+    need <- c("sf", "countrycode")[!vapply(c("sf", "countrycode"), requireNamespace, logical(1), quietly = TRUE)]
+    if (length(need)) {
+      message("history = \"", history, "\" needs the ", paste(need, collapse = " and "),
+              " package", if (length(need) > 1) "s" else "", ", which ",
+              if (length(need) > 1) "are" else "is", " not installed.")
+    } else if (!gnrs_is_built("cshapes", dir) && !requireNamespace("cshapes", quietly = TRUE) &&
+               !gnrs_require_sources("cshapes", dir = dir, build_missing = build_missing, quiet = quiet)) {
+      message("The CShapes data that history = \"", history, "\" needs was not built.")
+    } else {
+      if (!gnrs_is_built("cshapes", dir)) {
+        if (!quiet) message("Building the CShapes component from the cshapes package (no download) ...")
+        gnrs_build_cshapes(dir = dir, quiet = TRUE)
+      }
+      if (!quiet) message("Building the history component (no download) ...")
+      gnrs_build_history(dir = dir, quiet = TRUE)
+      ready <- TRUE
+    }
+    if (!ready) {
+      message("Resolving against current political divisions only (history = \"current\").")
+      history <- "current"
+    }
+  }
   if (!alternate_names && gnrs_is_built("geonames", dir)) {
     # Built but not wanted: the name table on disk includes the GeoNames
     # names, so they are set aside when loading
@@ -113,10 +205,26 @@ GNRS_local <- function(political_division_dataframe,
   if (!quiet && nrow(u) > 0) {
     message("Resolving ", nrow(u), " distinct political division", if (nrow(u) == 1) "" else "s", " ...")
   }
-  resolved <- gnrs_resolve(u, bb, threshold = threshold)
-
   m <- match(key, key[distinct])
-  gnrs_build_output(resolved[m, , drop = FALSE], input, threshold)
+  if (history == "current") {
+    resolved <- gnrs_resolve(u, bb, threshold = threshold)
+    return(gnrs_build_output(resolved[m, , drop = FALSE], input, threshold))
+  }
+
+  r <- gnrs_resolve_history(u, m, dates, bb, dir = dir, threshold = threshold,
+                            history = history, tolerance_years = tolerance_years,
+                            alternate_names = alternate_names)
+  out <- gnrs_build_output(r, input, threshold)
+  chr <- function(x) { x <- as.character(x); x[is.na(x)] <- ""; x }
+  out$entity_key <- chr(r$entity_key)
+  out$is_historical <- r$is_historical
+  out$entity_valid_from <- chr(r$entity_valid_from)
+  out$entity_valid_to <- chr(r$entity_valid_to)
+  out$successors <- chr(r$successors)
+  out$subnational_resolved_in <- chr(r$subnational_resolved_in)
+  out$subnational_status <- chr(r$subnational_status)
+  out$date_check <- chr(r$date_check)
+  out
 }
 
 #' Check the submitted data.frame and put it in a standard form
@@ -250,6 +358,14 @@ gnrs_build_output <- function(r, input, threshold) {
     user_id = input$user_id,
     stringsAsFactors = FALSE
   )
+  # A declared division belonging to another division system, recognised as itself
+  # rather than forced onto the nearest GADM unit. Appended after the service's own
+  # columns, as the history component's are: extent_known says whether the GADM units
+  # it covers are known, and so whether a coordinate can be checked against it.
+  out$alt_division <- chr(r$alt_division)
+  out$alt_division_system <- chr(r$alt_division_system)
+  out$alt_division_level <- chr(r$alt_division_level)
+  out$alt_division_extent_known <- r$alt_division_extent_known
   rownames(out) <- NULL
   out
 }

R/GNRS_local_citations.R

@@ -108,11 +108,16 @@ GNRS_local_citations <- function(dir = gnrs_cache_dir(), bibtex_file = NULL, qui
         "GeoNames. Gazetteer (allCountries), file dated ", version,
         ". https://www.geonames.org/ (CC BY 4.0). Accessed ", accessed, "."
       )
-    } else {
+    } else if (source %in% c("history", "cshapes")) {
+      # the registry carries the full citation for these components
+      paste0(spec$citation, if (!is.na(accessed)) paste0(" Built ", accessed, ".") else "")
+    } else if (source == "geonames") {
       paste0(
         "GeoNames. Alternate names (alternateNamesV2), file dated ", version,
         ". https://www.geonames.org/ (CC BY 4.0). Accessed ", accessed, "."
       )
+    } else {
+      paste0(spec$full_name, ". ", spec$citation %||% spec$url)
     }
     rows[[length(rows) + 1]] <- data.frame(
       what = "source", name = spec$full_name, version = version,

R/local_altdiv.R

@@ -0,0 +1,178 @@
+# ===========================================================================
+# Alternative and superseded sub-national divisions
+#
+# A large part of the record stream declares a state or county that is not a GADM
+# division: Swedish landskap and lappmarker, British Watsonian vice-counties,
+# Norwegian counties from after the 2018 and 2020 reforms. Matching those names
+# onto the nearest-looking GADM unit is worse than not matching them at all,
+# because the coordinate then falls in a different unit and a correctly
+# georeferenced, correctly labelled record looks geo-invalid.
+#
+# This component recognises such names as units in their own right. A unit with a
+# known EXTENT - the set of GADM units it covers - can be validated properly: the
+# coordinate must fall inside one of them. A unit whose extent has not been sourced
+# yet is UNVERIFIABLE: recognised, and never called invalid.
+#
+# Curation: data-raw/altdiv.R -> inst/extdata/altdiv_{units,names,extent}.csv.
+# ===========================================================================
+
+#' @keywords internal
+#' @noRd
+gnrs_altdiv_path <- function(table, dir = gnrs_cache_dir()) {
+  file.path(dir, paste0("altdiv-", table, ".gz.parquet"))
+}
+
+#' Build the alternative-division component
+#'
+#' Internal.  Reads the shipped curation and writes it to the cache.  No
+#' download.  When the GADM layer is present the extents are checked against it,
+#' so a unit can never claim a GADM division that does not exist.
+#' @keywords internal
+#' @noRd
+gnrs_build_altdiv <- function(dir = gnrs_cache_dir(create = TRUE), quiet = FALSE) {
+  if (!dir.exists(dir)) dir.create(dir, recursive = TRUE, showWarnings = FALSE)
+  rd <- function(f) utils::read.csv(gnrs_extdata(f), stringsAsFactors = FALSE,
+                                    encoding = "UTF-8", na.strings = "")
+  units <- rd("altdiv_units.csv")
+  names_ <- rd("altdiv_names.csv")
+  extent <- rd("altdiv_extent.csv")
+  units$valid_from <- as.Date(units$valid_from)
+  units$valid_to <- as.Date(units$valid_to)
+  if (anyDuplicated(units$entity_key)) stop("Alternative-division keys are not unique.", call. = FALSE)
+  stopifnot(all(names_$entity_key %in% units$entity_key),
+            all(extent$entity_key %in% units$entity_key))
+
+  known <- unique(extent$entity_key)
+  units$extent_known <- units$entity_key %in% known
+  if (nrow(extent) && gnrs_is_built("gadm", dir) && file.exists(gnrs_gadm_path(dir))) {
+    g <- as.data.frame(nanoparquet::read_parquet(gnrs_gadm_path(dir)))
+    have <- unique(c(g$gid_1, g$gid_2))
+    have <- have[!is.na(have)]
+    # only where the layer covers that country at all: a layer may be partial (and in
+    # the tests is synthetic), and an extent naming a country it does not carry is not
+    # an error. Within a country the layer does carry, an unknown unit is a typo.
+    country <- function(x) sub("[.].*", "", x)
+    covered <- unique(country(have))
+    check <- extent$gid[country(extent$gid) %in% covered]
+    bad <- setdiff(check, have)
+    if (length(bad)) {
+      stop("Alternative-division extents name GADM units that are not in the layer: ",
+           paste(utils::head(bad, 5), collapse = ", "), call. = FALSE)
+    }
+  }
+
+  w <- function(x, table) nanoparquet::write_parquet(x, gnrs_altdiv_path(table, dir), compression = "gzip")
+  w(units, "units"); w(names_, "names"); w(extent, "extent")
+  provenance <- list(
+    source = "altdiv", full_name = "Alternative and superseded sub-national divisions",
+    version = "1", downloaded = as.character(Sys.Date()),
+    n_units = nrow(units), n_with_extent = length(known), n_names = nrow(names_),
+    systems = paste(sort(unique(units$system)), collapse = ", "),
+    sources = "Curated for GNRS; Norwegian county reforms of 2018 and 2020; Swedish landskap, lappmarker and lan name forms; Watsonian vice-counties"
+  )
+  saveRDS(provenance, gnrs_provenance_path("altdiv", dir))
+  gnrs_env$altdiv <- NULL
+  if (!quiet) {
+    message("  ", nrow(units), " alternative or superseded divisions (", length(known),
+            " with a known extent), ", nrow(names_), " names")
+  }
+  invisible(provenance)
+}
+
+#' The alternative-division tables, cached for the session
+#' @keywords internal
+#' @noRd
+gnrs_altdiv <- function(dir = gnrs_cache_dir()) {
+  paths <- gnrs_altdiv_path(c("units", "names", "extent"), dir)
+  if (!all(file.exists(paths))) return(NULL)
+  # the cache is for this directory and these files: a call with another dir,
+  # or after a rebuild, reads afresh
+  stamp <- paste(normalizePath(dir, winslash = "/"), paste(file.mtime(paths), collapse = "|"))
+  if (!is.null(gnrs_env$altdiv) && identical(gnrs_env$altdiv_stamp, stamp)) return(gnrs_env$altdiv)
+  rd <- function(p) as.data.frame(nanoparquet::read_parquet(p))
+  a <- list(units = rd(paths[1]), names = rd(paths[2]), extent = rd(paths[3]))
+  a$units$valid_from <- as.Date(a$units$valid_from)
+  a$units$valid_to <- as.Date(a$units$valid_to)
+  a$names$lower <- gnrs_lower(a$names$name)
+  a$country_of <- a$units$country_iso[match(a$names$entity_key, a$units$entity_key)]
+  a$exact <- a$names$match == "exact"
+  # A name can belong to two units of different systems: "Skane" is a lan and a
+  # landskap, "Norrbotten" likewise. Prefer the one whose extent is known, so a
+  # coordinate can still be checked; the order here is what match() picks up.
+  ord <- order(!a$units$extent_known[match(a$names$entity_key, a$units$entity_key)])
+  a$names <- a$names[ord, , drop = FALSE]
+  a$country_of <- a$country_of[ord]
+  a$exact <- a$names$match == "exact"
+  a$key_exact <- paste(a$country_of[a$exact], a$names$lower[a$exact], sep = "\u001f")
+  gnrs_env$altdiv <- a
+  gnrs_env$altdiv_stamp <- stamp
+  a
+}
+
+#' Match declared division names against the alternative divisions
+#'
+#' Internal.  Vectorised.  \code{country_iso} and \code{name} are the declared
+#' country and the declared state or county; \code{dates} are the record dates,
+#' used only for units that existed over a period.
+#'
+#' @return data.frame with one row per input: \code{entity_key}, \code{system},
+#'   \code{kind}, \code{extent_known}, and \code{in_period} - NA when the unit has
+#'   no dates or the record has none, so that a caller can tell "outside its
+#'   period" from "no date to check".
+#' @keywords internal
+#' @noRd
+gnrs_altdiv_match <- function(country_iso, name, dates = NULL, dir = gnrs_cache_dir(),
+                              altdiv = NULL) {
+  n <- length(name)
+  out <- data.frame(entity_key = rep(NA_character_, n), system = NA_character_,
+                    kind = NA_character_, extent_known = NA, in_period = NA,
+                    stringsAsFactors = FALSE)
+  # `altdiv` lets a caller that already holds the tables (the resolver, through the
+  # backbone) skip the cache lookup
+  a <- if (!is.null(altdiv)) altdiv else gnrs_altdiv(dir)
+  if (is.null(a) || !n) return(out)
+  nm <- gnrs_lower(trimws(ifelse(is.na(name), "", name)))
+  cc <- toupper(ifelse(is.na(country_iso), "", country_iso))
+  hit <- match(paste(cc, nm, sep = "\u001f"), a$key_exact)
+  key <- ifelse(is.na(hit), NA_character_, a$names$entity_key[a$exact][hit])
+
+  # the regex systems (vice-counties are written "VC57 Derbyshire"), tried only where
+  # no exact name matched, and only against patterns registered for that country
+  rx <- which(!a$exact)
+  todo <- which(is.na(key) & nzchar(nm))
+  for (r in rx) {
+    if (!length(todo)) break
+    cand <- todo[cc[todo] == a$country_of[r]]
+    if (!length(cand)) next
+    ok <- grepl(a$names$name[r], name[cand], perl = TRUE)
+    key[cand[ok]] <- a$names$entity_key[r]
+    todo <- setdiff(todo, cand[ok])
+  }
+
+  i <- match(key, a$units$entity_key)
+  out$entity_key <- key
+  out$system <- a$units$system[i]
+  out$kind <- a$units$kind[i]
+  out$extent_known <- a$units$extent_known[i]
+  if (!is.null(dates)) {
+    from <- a$units$valid_from[i]
+    to <- a$units$valid_to[i]
+    d <- as.Date(dates)
+    # NA where there is nothing to check: no dates on the unit, or none on the record
+    out$in_period <- ifelse(is.na(d) | (is.na(from) & is.na(to)), NA,
+                            (is.na(from) | d >= from) & (is.na(to) | d <= to))
+  }
+  out
+}
+
+#' The GADM units an alternative division covers
+#'
+#' Internal.  Returns a character vector of GADM ids, empty when the extent of
+#' that unit has not been sourced.
+#' @keywords internal
+#' @noRd
+gnrs_altdiv_extent <- function(entity_key, dir = gnrs_cache_dir()) {
+  a <- gnrs_altdiv(dir)
+  if (is.null(a) || is.na(entity_key)) return(character(0))
+  a$extent$gid[a$extent$entity_key == entity_key]
+}